From 34cbb93d72c40ec9ab91466e6cf492515761a48e Mon Sep 17 00:00:00 2001
From: Lucie Bakels <lucie.bakels@univie.ac.at>
Date: Wed, 24 May 2023 12:38:23 +0000
Subject: [PATCH] Merging FLEXPART version 11
---
.gitlab-ci.yml | 19 +-
README_PARALLEL.md | 16 +-
documentation/docs/configuration.md | 1 +
documentation/docs/evolution.md | 9 +
documentation/docs/examples.md | 1 +
documentation/docs/index.md | 5 +
documentation/docs/installation.md | 52 +
documentation/docs/output.md | 1 +
documentation/docs/running.md | 151 +
documentation/docs/transport.md | 7 +
documentation/flexpart8.pdf | Bin 255327 -> 0 bytes
documentation/flexpart9.2.tex | 2835 ----------
documentation/fluxdiagram.txt | 120 -
documentation/memo_verttr.ps.gz | Bin 18850 -> 0 bytes
documentation/mkdocs.yml | 30 +
documentation/program_list.txt | 160 -
documentation/release_notes_9.2.rtf | 133 -
options.reference/COMMAND.reference | 2 +-
options.reference/OUTGRID | 100 +-
options.reference/SPECIES/SPECIES.README | 106 +-
options.reference/surfdata.t | 34 +-
options/COMMAND | 13 +-
options/PARTOPTIONS | 42 +
options/SPECIES/SPECIES.README | 69 +-
options/SPECIES/SPECIES_002 | 1 +
options/SPECIES/SPECIES_003 | 1 +
options/SPECIES/SPECIES_004 | 1 +
options/SPECIES/SPECIES_005 | 1 +
options/SPECIES/SPECIES_006 | 1 +
options/SPECIES/SPECIES_007 | 1 +
options/SPECIES/SPECIES_008 | 1 +
options/SPECIES/SPECIES_009 | 1 +
options/SPECIES/SPECIES_010 | 1 +
options/SPECIES/SPECIES_011 | 1 +
options/SPECIES/SPECIES_012 | 1 +
options/SPECIES/SPECIES_013 | 1 +
options/SPECIES/SPECIES_014 | 1 +
options/SPECIES/SPECIES_015 | 1 +
options/SPECIES/SPECIES_016 | 1 +
options/SPECIES/SPECIES_017 | 2 +
options/SPECIES/SPECIES_018 | 1 +
options/SPECIES/SPECIES_019 | 1 +
options/SPECIES/SPECIES_020 | 1 +
options/SPECIES/SPECIES_021 | 1 +
options/SPECIES/SPECIES_022 | 1 +
options/SPECIES/SPECIES_023 | 1 +
options/SPECIES/SPECIES_024 | 1 +
options/SPECIES/SPECIES_025 | 1 +
options/SPECIES/SPECIES_026 | 1 +
options/SPECIES/SPECIES_027 | 1 +
options/SPECIES/SPECIES_031 | 1 +
options/SPECIES/SPECIES_034 | 1 +
options/SPECIES/SPECIES_040 | 11 +-
options/surfdata.t | 34 +-
src/FLEXPART.f90 | 567 +-
src/advance_mod.f90 | 802 +++
src/binary_output_mod.f90 | 4538 +++++++++++++++++
src/calcpar.f90 | 269 -
src/calcpv.f90 | 315 --
src/{cbl.f90 => cbl_mod.f90} | 262 +-
src/{gributils => }/class_gribfile_mod.f90 | 0
src/com_mod.f90 | 437 +-
src/conv_mod.f90 | 2187 +++++++-
src/coordinates_ecmwf_mod.f90 | 475 ++
src/date_mod.f90 | 154 +
src/drydepo_mod.f90 | 1525 ++++++
src/{erf.f90 => erf_mod.f90} | 20 +-
src/ew.f90 | 29 -
src/flux_mod.f90 | 524 +-
src/get_settling.f90 | 129 -
src/getfields_mod.f90 | 1685 ++++++
src/initialise_mod.f90 | 1853 +++++++
src/interpol_mod.f90 | 1555 +++++-
src/interpol_wind_short.f90 | 142 -
src/list-of-modules.txt | 39 +
src/makefile | 417 --
src/makefile_gfortran | 194 +
src/makefile_intel | 191 +
src/netcdf_output_mod.f90 | 1784 ++++++-
src/oh_mod.f90 | 434 +-
src/outg_mod.f90 | 853 +++-
src/output_mod.f90 | 1369 +++++
src/output_mod_old.f90 | 952 ++++
src/par_mod.f90 | 141 +-
src/particle_mod.f90 | 746 +++
src/partoutput.f90 | 197 -
src/partpos_average.f90 | 188 -
src/pathnames | 6 +-
src/pbl_profile_mod.f90 | 200 +
src/plume_mod.f90 | 687 +++
src/plumetraj.f90 | 233 -
src/point_mod.f90 | 112 +
src/{qvsat.f90 => qvsat_mod.f90} | 81 +-
src/random_mod.f90 | 133 +-
src/readoptions_mod.f90 | 3334 ++++++++++++
src/redist.f90 | 238 -
src/{ => redundant}/FLEXPART_MPI.f90 | 16 +-
src/{ => redundant}/advance.f90 | 545 +-
src/{ => redundant}/assignland.f90 | 1 +
src/{ => redundant}/boundcond_domainfill.f90 | 388 +-
.../boundcond_domainfill_mpi.f90 | 0
src/{ => redundant}/calcfluxes.f90 | 50 +-
src/{ => redundant}/calcmatrix.f90 | 101 +-
src/{ => redundant}/calcpar_nests.f90 | 0
src/redundant/calcpv.f90 | 579 +++
src/{ => redundant}/calcpv_nests.f90 | 0
src/{ => redundant}/caldate.f90 | 0
src/{ => redundant}/centerofmass.f90 | 0
src/{ => redundant}/clustering.f90 | 37 +-
src/{ => redundant}/conccalc.f90 | 241 +-
src/{ => redundant}/conccalc_mpi.f90 | 0
src/{ => redundant}/concoutput.f90 | 0
src/{ => redundant}/concoutput_inversion.f90 | 0
.../concoutput_inversion_nest.f90 | 0
src/{ => redundant}/concoutput_mpi.f90 | 0
src/{ => redundant}/concoutput_nest.f90 | 0
src/{ => redundant}/concoutput_nest_mpi.f90 | 0
src/{ => redundant}/concoutput_surf.f90 | 0
src/{ => redundant}/concoutput_surf_mpi.f90 | 0
src/{ => redundant}/concoutput_surf_nest.f90 | 0
.../concoutput_surf_nest_mpi.f90 | 0
src/{ => redundant}/convect43c.f90 | 958 ++--
src/{ => redundant}/convmix.f90 | 192 +-
src/{ => redundant}/coordtrafo.f90 | 0
src/{ => redundant}/detectformat.f90 | 0
src/{ => redundant}/distance.f90 | 0
src/{ => redundant}/distance2.f90 | 0
src/redundant/domainfill.f90 | 931 ++++
src/{ => redundant}/drydepokernel.f90 | 0
src/{ => redundant}/drydepokernel_nest.f90 | 0
src/{ => redundant}/dynamic_viscosity.f90 | 0
src/redundant/ew.f90 | 56 +
src/{ => redundant}/fluxoutput.f90 | 0
src/{ => redundant}/get_vdep_prob.f90 | 7 +-
src/{ => redundant}/get_wetscav.f90 | 275 +-
src/{ => redundant}/getfields.f90 | 13 +-
src/{ => redundant}/getfields_mpi.f90 | 0
src/{ => redundant}/gethourlyOH.f90 | 0
src/{ => redundant}/getrb.f90 | 0
src/{ => redundant}/getrc.f90 | 0
src/{ => redundant}/getvdep.f90 | 0
src/{ => redundant}/getvdep_nests.f90 | 0
src/{ => redundant}/gridcheck_ecmwf.f90 | 6 +-
src/{ => redundant}/gridcheck_gfs.f90 | 0
src/{ => redundant}/gridcheck_nests.f90 | 0
src/{ => redundant}/hanna.f90 | 0
src/{ => redundant}/hanna1.f90 | 0
src/{ => redundant}/hanna_mod.f90 | 3 +
src/{ => redundant}/hanna_short.f90 | 0
src/{ => redundant}/init_domainfill.f90 | 180 +-
src/{ => redundant}/init_domainfill_mpi.f90 | 0
src/{ => redundant}/initial_cond_calc.f90 | 68 +-
src/{ => redundant}/initial_cond_output.f90 | 0
.../initial_cond_output_inversion.f90 | 0
src/{ => redundant}/initialize_cbl_vel.f90 | 6 +-
.../initialize_particle.f90} | 117 +-
src/{ => redundant}/interpol_all.f90 | 202 +-
src/{ => redundant}/interpol_all_nests.f90 | 4 +-
src/{ => redundant}/interpol_misslev.f90 | 161 +-
.../interpol_misslev_nests.f90 | 1 -
src/{ => redundant}/interpol_rain.f90 | 45 +-
src/{ => redundant}/interpol_rain_nests.f90 | 9 +-
src/{ => redundant}/interpol_vdep.f90 | 3 -
src/{ => redundant}/interpol_vdep_nests.f90 | 0
src/{ => redundant}/interpol_wind.f90 | 231 +-
src/{ => redundant}/interpol_wind_nests.f90 | 4 +-
src/redundant/interpol_wind_short.f90 | 201 +
.../interpol_wind_short_nests.f90 | 4 +-
src/{ => redundant}/juldate.f90 | 0
src/{ => redundant}/mpi_mod.f90 | 4 +-
src/{ => redundant}/obukhov.f90 | 2 +-
src/{ => redundant}/ohreaction.f90 | 49 +-
src/{ => redundant}/openouttraj.f90 | 0
src/{ => redundant}/openreceptors.f90 | 0
src/{ => redundant}/outgrid_init.f90 | 0
src/{ => redundant}/outgrid_init_nest.f90 | 0
src/{ => redundant}/part0.f90 | 0
src/{ => redundant}/partdep.f90 | 0
src/redundant/partoutput.f90 | 226 +
src/{ => redundant}/partoutput_average.f90 | 4 +-
.../partoutput_average_mpi.f90 | 0
src/{ => redundant}/partoutput_mpi.f90 | 0
src/{ => redundant}/partoutput_short.f90 | 0
src/{ => redundant}/partoutput_short_mpi.f90 | 0
src/redundant/partpos_average.f90 | 120 +
src/{ => redundant}/pbl_profile.f90 | 5 +-
src/{ => redundant}/photo_O1D.f90 | 0
src/{ => redundant}/psih.f90 | 0
src/{ => redundant}/psim.f90 | 0
src/{ => redundant}/raerod.f90 | 0
.../re_initialize_particle.f90 | 0
src/{ => redundant}/readOHfield.f90 | 0
src/{ => redundant}/readageclasses.f90 | 0
src/{ => redundant}/readavailable.f90 | 12 +-
src/{ => redundant}/readcommand.f90 | 20 +-
src/{ => redundant}/readdepo.f90 | 0
src/{ => redundant}/readlanduse.f90 | 0
src/{ => redundant}/readoutgrid.f90 | 0
src/{ => redundant}/readoutgrid_nest.f90 | 0
src/{ => redundant}/readpartpositions.f90 | 112 +-
src/{ => redundant}/readpartpositions_mpi.f90 | 0
src/{ => redundant}/readpaths.f90 | 0
src/{ => redundant}/readreceptors.f90 | 0
src/{ => redundant}/readreleases.f90 | 52 +-
src/{ => redundant}/readspecies.f90 | 0
src/{ => redundant}/readwind_ecmwf.f90 | 498 +-
src/{ => redundant}/readwind_ecmwf_mpi.f90 | 0
src/{ => redundant}/readwind_emos.f90 | 0
src/{ => redundant}/readwind_gfs.f90 | 0
src/{ => redundant}/readwind_nests.f90 | 0
src/redundant/redist.f90 | 327 ++
src/{ => redundant}/redist_mpi.f90 | 0
src/{ => redundant}/releaseparticles.f90 | 346 +-
src/{ => redundant}/releaseparticles_mpi.f90 | 0
src/{ => redundant}/richardson.f90 | 4 +-
src/{ => redundant}/scalev.f90 | 2 +-
src/{ => redundant}/shift_field.f90 | 0
src/{ => redundant}/shift_field_0.f90 | 0
src/{ => redundant}/skplin.f90 | 0
src/{ => redundant}/sort2.f90 | 0
src/redundant/timemanager.f90 | 627 +++
src/{ => redundant}/timemanager_mpi.f90 | 2 +-
src/{ => redundant}/verttransform_ecmwf.f90 | 315 +-
src/{ => redundant}/verttransform_gfs.f90 | 0
src/{ => redundant}/verttransform_nests.f90 | 0
src/{ => redundant}/wetdepo.f90 | 73 +-
src/{ => redundant}/wetdepokernel.f90 | 0
src/{ => redundant}/wetdepokernel_nest.f90 | 0
src/{ => redundant}/windalign.f90 | 0
src/{ => redundant}/writeheader.f90 | 0
src/{ => redundant}/writeheader_nest.f90 | 0
src/{ => redundant}/writeheader_nest_surf.f90 | 0
src/{ => redundant}/writeheader_surf.f90 | 0
src/{ => redundant}/writeheader_txt.f90 | 0
src/{ => redundant}/writeprecip.f90 | 0
src/redundant/z_to_zeta.f90 | 82 +
src/{ => redundant}/zenithangle.f90 | 0
src/redundant/zeta_to_z.f90 | 93 +
src/restart_mod.f90 | 241 +
src/settling_mod.f90 | 217 +
src/timemanager.f90 | 772 ---
src/timemanager_mod.f90 | 666 +++
src/turbulence_mod.f90 | 636 +++
src/txt_output_mod.f90 | 171 +
src/unc_mod.f90 | 75 +-
src/verttransform_mod.f90 | 1968 +++++++
src/wetdepo_mod.f90 | 838 +++
src/windfields_mod.f90 | 4007 +++++++++++++++
248 files changed, 42269 insertions(+), 9909 deletions(-)
create mode 100644 documentation/docs/configuration.md
create mode 100644 documentation/docs/evolution.md
create mode 100644 documentation/docs/examples.md
create mode 100644 documentation/docs/index.md
create mode 100644 documentation/docs/installation.md
create mode 100644 documentation/docs/output.md
create mode 100644 documentation/docs/running.md
create mode 100644 documentation/docs/transport.md
delete mode 100644 documentation/flexpart8.pdf
delete mode 100644 documentation/flexpart9.2.tex
delete mode 100755 documentation/fluxdiagram.txt
delete mode 100755 documentation/memo_verttr.ps.gz
create mode 100644 documentation/mkdocs.yml
delete mode 100755 documentation/program_list.txt
delete mode 100644 documentation/release_notes_9.2.rtf
create mode 100644 options/PARTOPTIONS
create mode 100644 src/advance_mod.f90
create mode 100644 src/binary_output_mod.f90
delete mode 100644 src/calcpar.f90
delete mode 100644 src/calcpv.f90
rename src/{cbl.f90 => cbl_mod.f90} (51%)
rename src/{gributils => }/class_gribfile_mod.f90 (100%)
create mode 100644 src/coordinates_ecmwf_mod.f90
create mode 100644 src/date_mod.f90
create mode 100644 src/drydepo_mod.f90
rename src/{erf.f90 => erf_mod.f90} (93%)
delete mode 100644 src/ew.f90
delete mode 100644 src/get_settling.f90
create mode 100644 src/getfields_mod.f90
create mode 100644 src/initialise_mod.f90
delete mode 100644 src/interpol_wind_short.f90
create mode 100644 src/list-of-modules.txt
delete mode 100644 src/makefile
create mode 100644 src/makefile_gfortran
create mode 100644 src/makefile_intel
create mode 100644 src/output_mod.f90
create mode 100644 src/output_mod_old.f90
create mode 100644 src/particle_mod.f90
delete mode 100644 src/partoutput.f90
delete mode 100644 src/partpos_average.f90
create mode 100644 src/pbl_profile_mod.f90
create mode 100644 src/plume_mod.f90
delete mode 100644 src/plumetraj.f90
rename src/{qvsat.f90 => qvsat_mod.f90} (69%)
create mode 100644 src/readoptions_mod.f90
delete mode 100644 src/redist.f90
rename src/{ => redundant}/FLEXPART_MPI.f90 (96%)
rename src/{ => redundant}/advance.f90 (70%)
rename src/{ => redundant}/assignland.f90 (99%)
rename src/{ => redundant}/boundcond_domainfill.f90 (60%)
rename src/{ => redundant}/boundcond_domainfill_mpi.f90 (100%)
rename src/{ => redundant}/calcfluxes.f90 (83%)
rename src/{ => redundant}/calcmatrix.f90 (67%)
rename src/{ => redundant}/calcpar_nests.f90 (100%)
create mode 100644 src/redundant/calcpv.f90
rename src/{ => redundant}/calcpv_nests.f90 (100%)
rename src/{ => redundant}/caldate.f90 (100%)
rename src/{ => redundant}/centerofmass.f90 (100%)
rename src/{ => redundant}/clustering.f90 (89%)
rename src/{ => redundant}/conccalc.f90 (63%)
rename src/{ => redundant}/conccalc_mpi.f90 (100%)
rename src/{ => redundant}/concoutput.f90 (100%)
rename src/{ => redundant}/concoutput_inversion.f90 (100%)
rename src/{ => redundant}/concoutput_inversion_nest.f90 (100%)
rename src/{ => redundant}/concoutput_mpi.f90 (100%)
rename src/{ => redundant}/concoutput_nest.f90 (100%)
rename src/{ => redundant}/concoutput_nest_mpi.f90 (100%)
rename src/{ => redundant}/concoutput_surf.f90 (100%)
rename src/{ => redundant}/concoutput_surf_mpi.f90 (100%)
rename src/{ => redundant}/concoutput_surf_nest.f90 (100%)
rename src/{ => redundant}/concoutput_surf_nest_mpi.f90 (100%)
rename src/{ => redundant}/convect43c.f90 (61%)
rename src/{ => redundant}/convmix.f90 (68%)
rename src/{ => redundant}/coordtrafo.f90 (100%)
rename src/{ => redundant}/detectformat.f90 (100%)
rename src/{ => redundant}/distance.f90 (100%)
rename src/{ => redundant}/distance2.f90 (100%)
create mode 100644 src/redundant/domainfill.f90
rename src/{ => redundant}/drydepokernel.f90 (100%)
rename src/{ => redundant}/drydepokernel_nest.f90 (100%)
rename src/{ => redundant}/dynamic_viscosity.f90 (100%)
create mode 100644 src/redundant/ew.f90
rename src/{ => redundant}/fluxoutput.f90 (100%)
rename src/{ => redundant}/get_vdep_prob.f90 (98%)
rename src/{ => redundant}/get_wetscav.f90 (64%)
rename src/{ => redundant}/getfields.f90 (91%)
rename src/{ => redundant}/getfields_mpi.f90 (100%)
rename src/{ => redundant}/gethourlyOH.f90 (100%)
rename src/{ => redundant}/getrb.f90 (100%)
rename src/{ => redundant}/getrc.f90 (100%)
rename src/{ => redundant}/getvdep.f90 (100%)
rename src/{ => redundant}/getvdep_nests.f90 (100%)
rename src/{ => redundant}/gridcheck_ecmwf.f90 (99%)
rename src/{ => redundant}/gridcheck_gfs.f90 (100%)
rename src/{ => redundant}/gridcheck_nests.f90 (100%)
rename src/{ => redundant}/hanna.f90 (100%)
rename src/{ => redundant}/hanna1.f90 (100%)
rename src/{ => redundant}/hanna_mod.f90 (59%)
rename src/{ => redundant}/hanna_short.f90 (100%)
rename src/{ => redundant}/init_domainfill.f90 (71%)
rename src/{ => redundant}/init_domainfill_mpi.f90 (100%)
rename src/{ => redundant}/initial_cond_calc.f90 (76%)
rename src/{ => redundant}/initial_cond_output.f90 (100%)
rename src/{ => redundant}/initial_cond_output_inversion.f90 (100%)
rename src/{ => redundant}/initialize_cbl_vel.f90 (98%)
rename src/{initialize.f90 => redundant/initialize_particle.f90} (73%)
rename src/{ => redundant}/interpol_all.f90 (58%)
rename src/{ => redundant}/interpol_all_nests.f90 (99%)
rename src/{ => redundant}/interpol_misslev.f90 (51%)
rename src/{ => redundant}/interpol_misslev_nests.f90 (99%)
rename src/{ => redundant}/interpol_rain.f90 (86%)
rename src/{ => redundant}/interpol_rain_nests.f90 (98%)
rename src/{ => redundant}/interpol_vdep.f90 (97%)
rename src/{ => redundant}/interpol_vdep_nests.f90 (100%)
rename src/{ => redundant}/interpol_wind.f90 (52%)
rename src/{ => redundant}/interpol_wind_nests.f90 (99%)
create mode 100644 src/redundant/interpol_wind_short.f90
rename src/{ => redundant}/interpol_wind_short_nests.f90 (99%)
rename src/{ => redundant}/juldate.f90 (100%)
rename src/{ => redundant}/mpi_mod.f90 (99%)
rename src/{ => redundant}/obukhov.f90 (98%)
rename src/{ => redundant}/ohreaction.f90 (79%)
rename src/{ => redundant}/openouttraj.f90 (100%)
rename src/{ => redundant}/openreceptors.f90 (100%)
rename src/{ => redundant}/outgrid_init.f90 (100%)
rename src/{ => redundant}/outgrid_init_nest.f90 (100%)
rename src/{ => redundant}/part0.f90 (100%)
rename src/{ => redundant}/partdep.f90 (100%)
create mode 100644 src/redundant/partoutput.f90
rename src/{ => redundant}/partoutput_average.f90 (99%)
rename src/{ => redundant}/partoutput_average_mpi.f90 (100%)
rename src/{ => redundant}/partoutput_mpi.f90 (100%)
rename src/{ => redundant}/partoutput_short.f90 (100%)
rename src/{ => redundant}/partoutput_short_mpi.f90 (100%)
create mode 100644 src/redundant/partpos_average.f90
rename src/{ => redundant}/pbl_profile.f90 (97%)
rename src/{ => redundant}/photo_O1D.f90 (100%)
rename src/{ => redundant}/psih.f90 (100%)
rename src/{ => redundant}/psim.f90 (100%)
rename src/{ => redundant}/raerod.f90 (100%)
rename src/{ => redundant}/re_initialize_particle.f90 (100%)
rename src/{ => redundant}/readOHfield.f90 (100%)
rename src/{ => redundant}/readageclasses.f90 (100%)
rename src/{ => redundant}/readavailable.f90 (97%)
rename src/{ => redundant}/readcommand.f90 (97%)
rename src/{ => redundant}/readdepo.f90 (100%)
rename src/{ => redundant}/readlanduse.f90 (100%)
rename src/{ => redundant}/readoutgrid.f90 (100%)
rename src/{ => redundant}/readoutgrid_nest.f90 (100%)
rename src/{ => redundant}/readpartpositions.f90 (57%)
rename src/{ => redundant}/readpartpositions_mpi.f90 (100%)
rename src/{ => redundant}/readpaths.f90 (100%)
rename src/{ => redundant}/readreceptors.f90 (100%)
rename src/{ => redundant}/readreleases.f90 (93%)
rename src/{ => redundant}/readspecies.f90 (100%)
rename src/{ => redundant}/readwind_ecmwf.f90 (54%)
rename src/{ => redundant}/readwind_ecmwf_mpi.f90 (100%)
rename src/{ => redundant}/readwind_emos.f90 (100%)
rename src/{ => redundant}/readwind_gfs.f90 (100%)
rename src/{ => redundant}/readwind_nests.f90 (100%)
create mode 100644 src/redundant/redist.f90
rename src/{ => redundant}/redist_mpi.f90 (100%)
rename src/{ => redundant}/releaseparticles.f90 (60%)
rename src/{ => redundant}/releaseparticles_mpi.f90 (100%)
rename src/{ => redundant}/richardson.f90 (98%)
rename src/{ => redundant}/scalev.f90 (97%)
rename src/{ => redundant}/shift_field.f90 (100%)
rename src/{ => redundant}/shift_field_0.f90 (100%)
rename src/{ => redundant}/skplin.f90 (100%)
rename src/{ => redundant}/sort2.f90 (100%)
create mode 100644 src/redundant/timemanager.f90
rename src/{ => redundant}/timemanager_mpi.f90 (99%)
rename src/{ => redundant}/verttransform_ecmwf.f90 (82%)
rename src/{ => redundant}/verttransform_gfs.f90 (100%)
rename src/{ => redundant}/verttransform_nests.f90 (100%)
rename src/{ => redundant}/wetdepo.f90 (70%)
rename src/{ => redundant}/wetdepokernel.f90 (100%)
rename src/{ => redundant}/wetdepokernel_nest.f90 (100%)
rename src/{ => redundant}/windalign.f90 (100%)
rename src/{ => redundant}/writeheader.f90 (100%)
rename src/{ => redundant}/writeheader_nest.f90 (100%)
rename src/{ => redundant}/writeheader_nest_surf.f90 (100%)
rename src/{ => redundant}/writeheader_surf.f90 (100%)
rename src/{ => redundant}/writeheader_txt.f90 (100%)
rename src/{ => redundant}/writeprecip.f90 (100%)
create mode 100644 src/redundant/z_to_zeta.f90
rename src/{ => redundant}/zenithangle.f90 (100%)
create mode 100644 src/redundant/zeta_to_z.f90
create mode 100644 src/restart_mod.f90
create mode 100644 src/settling_mod.f90
delete mode 100644 src/timemanager.f90
create mode 100644 src/timemanager_mod.f90
create mode 100644 src/turbulence_mod.f90
create mode 100644 src/txt_output_mod.f90
create mode 100644 src/verttransform_mod.f90
create mode 100644 src/wetdepo_mod.f90
create mode 100644 src/windfields_mod.f90
diff --git a/.gitlab-ci.yml b/.gitlab-ci.yml
index 70e18875..ba6dcea4 100644
--- a/.gitlab-ci.yml
+++ b/.gitlab-ci.yml
@@ -6,22 +6,23 @@ default:
tags:
- podman
-ubuntu-build:
- image: ubuntu:18.04
+alma8-build:
+ image: almalinux:8-minimal
stage: build
when: manual
before_script:
- - apt-get update -qq && apt-get install -y -qq gfortran libnetcdf-dev libnetcdff-dev libeccodes-dev netcdf-bin
+ - microdnf install -y epel-release
+ - microdnf install -y --enablerepo=powertools make netcdf-fortran-devel.x86_64 eccodes-devel.x86_64 netcdf.x86_64
script:
- export FC=gfortran
- - export LIBRARY_PATH=/usr/local/lib/x86_64-linux-gnu:/lib/x86_64-linux-gnu:/usr/lib/x86_64-linux-gnu
- - export CPATH=/usr/include
- - make -C src -f makefile_ci ncf=yes
+ - export LIBRARY_PATH=/usr/lib64
+ - export CPATH=/usr/include:/usr/lib64/gfortran/modules
+ - make -j -C src -f makefile_gfortran
- ulimit -s unlimited
- ./src/FLEXPART
- artifacts:
- paths:
- - ./src/FLEXPART
+# artifacts:
+# paths:
+# - ./src/FLEXPART
diff --git a/README_PARALLEL.md b/README_PARALLEL.md
index 2d50551f..a92d21aa 100644
--- a/README_PARALLEL.md
+++ b/README_PARALLEL.md
@@ -1,5 +1,5 @@
- FLEXPART VERSION 10.0 beta (MPI)
+FLEXPART VERSION 10.0 beta (MPI)
Description
-----------
@@ -21,7 +21,7 @@ Installation
A MPI library must be installed on the target platform, either as a
system library or compiled from source.
- So far, we have tested the following freely available implementations:
+ So far, we have tested the following freely available implementations:
mpich2 -- versions 3.0.1, 3.0.4, 3.1, 3.1.3
OpenMPI -- version 1.8.3
@@ -124,22 +124,22 @@ Performance efficency considerations
A) Running without dedicated reader process
----------------------------------------
Running REF1 with 100M particles on 16 processes (NILU machine 'dmz-proc04'),
- a speedup close to 8 is observed (~50% efficiency).
+ a speedup close to 8 is observed (ca 50% efficiency).
Running REF1 with 10M particles on 8 processes (NILU machine 'dmz-proc04'),
- a speedup close to 3 is observed (~40% efficiency). Running with 16
- processes gives only marginal improvements (speedup ~3.5) because of the 'getfields'
+ a speedup close to 3 is observed (ca 40% efficiency). Running with 16
+ processes gives only marginal improvements (speedup ca 3.5) because of the 'getfields'
bottleneck.
- Running REF1 with 1M particles: Here 'getfields' consumes ~70% of the CPU
- time. Running with 4 processes gives a speedup of ~1.5. Running with more
+ Running REF1 with 1M particles: Here 'getfields' consumes ca 70% of the CPU
+ time. Running with 4 processes gives a speedup of ca 1.5. Running with more
processes does not help much here.
B) Running with dedicated reader process
----------------------------------------
Running REF1 with 40M particles on 16 processes (NILU machine 'dmz-proc04'),
- a speedup above 10 is observed (~63% efficiency).
+ a speedup above 10 is observed (ca 63% efficiency).
:TODO: more to come...
diff --git a/documentation/docs/configuration.md b/documentation/docs/configuration.md
new file mode 100644
index 00000000..a025a48b
--- /dev/null
+++ b/documentation/docs/configuration.md
@@ -0,0 +1 @@
+# Configuration
diff --git a/documentation/docs/evolution.md b/documentation/docs/evolution.md
new file mode 100644
index 00000000..3d60acf7
--- /dev/null
+++ b/documentation/docs/evolution.md
@@ -0,0 +1,9 @@
+# Evolution of particle properties
+
+## Dry deposition
+
+## Wet deposition
+
+## Radioactive decay
+
+## OH reaction
\ No newline at end of file
diff --git a/documentation/docs/examples.md b/documentation/docs/examples.md
new file mode 100644
index 00000000..df635b4e
--- /dev/null
+++ b/documentation/docs/examples.md
@@ -0,0 +1 @@
+# Examples
diff --git a/documentation/docs/index.md b/documentation/docs/index.md
new file mode 100644
index 00000000..6438de63
--- /dev/null
+++ b/documentation/docs/index.md
@@ -0,0 +1,5 @@
+# Welcome to the FLEXPART documentation!
+
+Links to papers and to code
+
+How to cite
diff --git a/documentation/docs/installation.md b/documentation/docs/installation.md
new file mode 100644
index 00000000..614dfec9
--- /dev/null
+++ b/documentation/docs/installation.md
@@ -0,0 +1,52 @@
+# Installation
+
+## Download FLEXPART
+There are two options to download _FLEXPART_:
+
+ - **tar ball**
+
+ You can download a tar ball with the latest release from the [_FLEXPART_ page](https://www.flexpart.eu/wiki/FpRoadmap) and then untar the file:
+
+ $ tar -xvf <flexpart_vX.X.tar>
+
+ - **git repository**
+
+ If you have git installed, you can clone the latest version from our git repository:
+
+ $ git clone --single-branch --branch master https://gitlab.phaidra.org/flexpart/flexpart
+
+## Compiler
+_FLEXPART_ is written in Fortran 95(or are there newer elements?). The following compilers can be used to compile _FLEXPART_:
+
+ - GNU Fortran compiler (`gfortran`)
+ - Intel Fortran compiler (`ifort`)
+ - others?
+
+For running _FLEXPART_ in parallel mode, a compiler supporting [OpenMP](https://www.openmp.org/) is required.
+
+## Libraries
+_FLEXPART_ uses the following libraries:
+
+ - [ecCodes](https://confluence.ecmwf.int/display/ECC)
+ - [netCDF](https://docs.unidata.ucar.edu/netcdf-fortran/current/)
+
+These libraries are usually available as packages in most Linux distributions and MacOS package managers. For example:
+
+ - In Debian/Ubuntu: `sudo apt install libeccodes-dev libnetcdff`
+ - In Fedora: `no idea`
+ - In MacOS + Homebrew: `brew install eccodes netcdf`
+
+## Parameters
+Before compiling FLEXPART, you might want to change parameters defined in par_mod.f90
+
+- *wind_coord_type*: for ECMWF meteorological data, you can set this to ETA to use the native eta coordinate system. Otherwise, set this to METER.
+- *mesoscale_turbulence*: by default the mesocale turbulence is switched off, but can be switched on setting this variable to .true.
+- *max_partoutput_filesize*: maximum output of each partoutput NetCDF-4 file in Mb before a new one is created.
+- *max_numthreads_grid*: when using many openmp threads and gridded output (IOUT>0 in COMMAND option file), this variable sets a maximum on how many threads are used for doing the reductions on the grid. A high number can result in a significant increase in RAM usage.
+
+## Compiling
+_FLEXPART_ is compiled with [make](https://www.gnu.org/software/make/), which uses the makefile in the `src` subdirectory. In the makefile, make sure that the library and include paths point to the directories where `ecCodes` and `netCDF` are installed. Starting from the root directory, you can then compile _FLEXPART_ with the following steps:
+
+ $ cd src/
+ $ make -j -f <prefered_makefile>
+
diff --git a/documentation/docs/output.md b/documentation/docs/output.md
new file mode 100644
index 00000000..97bd5bea
--- /dev/null
+++ b/documentation/docs/output.md
@@ -0,0 +1 @@
+# Output files
diff --git a/documentation/docs/running.md b/documentation/docs/running.md
new file mode 100644
index 00000000..28942ed7
--- /dev/null
+++ b/documentation/docs/running.md
@@ -0,0 +1,151 @@
+# Running FLEXPART
+To run FLEXPART, there are three important (sets) of files that need to be specified.
+These are:
+
+- the [**option files**](running.md#options), defining the set-up of the run,
+- the [**pathnames file**](running.md#pathnames), defining the paths of where input and output are located,
+- the [**AVAILABLE file**](running.md#available), listing all available meteorological input,
+
+Of course, there is also the **par_mod.f90** file, which needs to be specified before compiling (see section compiling), but the parameters in this file are expected to not have to be changed between simulations.
+
+In addition to the regular input files listed above, a simulation can also be started using a NetCDF file listing all particles to be released. This option can be switched on by specifying IPIN=3 in the COMMAND option file. More information about how to use this option can be found in Silvia Bucci's paper (link).
+
+When wanting to restart a previous simulation, see [restarting a simulation](running.md#restart).
+
+## <a name="options"></a>Option files
+These files define the simulation settings. At the start of a simulation, a copy of each file will be written to the output directory defined in the [**pathnames file**](running.md#pathnames).
+All option files should be presented as namelists (i.e. &OPTIONFILE). A template of these files can be found in the options/ directory within the repository.
+
+Inside the `options/` directory a template of all option files can be found:
+
+- [COMMAND](running.md#command)
+- [RELEASES](running.md#releases)
+- [SPECIES](running.md#species)
+- [OUTGRID](running.md#outgrid)
+- [OUTGRID_NESTED](running.md#outgrid_nested)
+- [AGECLASSES](running.md#ageclasses)
+- [RECEPTORS](running.md#receptors)
+- [PARTOPTIONS](running.md#partoptions)
+
+### <a name="command"></a>COMMAND
+Sets the behaviour of the run (time range, backward or forward, output frequency, etc.). A table of all options is listed below.
+
+- **Time variables**: Flexpart can be run in forward or backward mode. In forward mode, particles are being traced forward in time, while in backward more, the origin of particles are being traced, going backward in time. This can be set by the [LDIRECT](running.md#ldirect) variable. The start and end of the simulation are set by [IBDATE](running.md#IBDATE):[IBTIME](running.md#IBTIME) and [IEDATE](running.md#IEDATE):[IETIME](running.md#IETIME). [IEDATE](running.md#IEDATE):[IETIME](running.md#IETIME) is always at a later time than [IBDATE](running.md#IBDATE):[IBTIME](running.md#IBTIME), also for backwards simulations. Output variables can be written at specified times: [LOUTSTEP](running.md#LOUTSTEP), and restart files will be written at every [LOUTRESTART](running.md#LOUTRESTART) interval.
+- **Numerical variables**: [LSYNCTIME](running.md#LSYNCTIME) and LOUTSAMPLE set the integration interval, smaller generally giving better results, although below a certain number, not much will be gained. With the [CTL](running.md#CTL) and [IFINE](running.md#IFINE) setting, you can make integration steps even smaller for the turbulence computations.
+- **Output variables**: The output is written at every [LOUTSTEP](running.md#LOUTSTEP) interval. Both gridded data ([IOUT](running.md#IOUT)>0) and particle based data ([IPOUT](running.md#IPOUT)=1) can be written to NetCDF files (binary option for gridded data). Nested output can be set by the [NESTED_OUTPUT](running.md#NESTED_OUTPUT) switched. Note that for gridded output, the [OUTGRID](running.md#OUTGRID) for ([IOUT](running.md#IOUT)>0) and [OUTGRID_NESTED](running.md#OUTGRID_NESTED) (for [NESTED_OUTPUT](running.md#NESTED_OUTPUT)=1) option files should be specified. Other output variables can be set in the par_mod.f90 file. Namely, the size of the NetCDF files that contain the particle based data (max_partoutput_filesize). [IND_RECEPTOR](running.md#IND_RECEPTOR) can be set to get concentrations or mixing ratios at specified receptor points set in the RECEPTORS options file. For backward simulations, [IND_RECEPTOR](running.md#IND_RECEPTOR) can be used to get wet or dry deposition gridded data. [SURF_ONLY](running.md#SURF_ONLY) and [LINIT_COND](running.md#LINIT_COND) are only working for binary output.
+- **Input variables**: IPIN can be set to chose the input type: either initial conditions from particles come from the [RELEASES](running.md#releases) file ([IPIN](running.md#IPIN)=0), from restart files of a previous run ([IPIN](running.md#IPIN)=1),
+from a particle netCDF file written in a previous run (only works when the correct fields in [PARTOPTIONS](running.md#PARTOPTIONS) are chosen) ([IPIN](running.md#IPIN)=2), or from user-defined initial particle conditions ([IPIN](running.md#IPIN)=3). [MDOMAINFILL](running.md#MDOMAINFILL) can be set to distribute particles according to the air density or stratospheric ozone density profiles. This option overwrites the vertical levels set in the [RELEASES](running.md#releases) option file.
+
+| Variable name | Description | Value **default** |
+| ----------- | ----------- | ----------- |
+| <a name="ldirect"></a>LDIRECT | Simulation direction in time | **1 (forward)** or -1 (backward) |
+| <a name="IBDATE"></a>IBDATE | Start date of the simulation | YYYYMMDD: YYYY=year, MM=month, DD=day |
+| <a name="IBTIME"></a>IBTIME | Start time of the simulation | HHMISS: HH=hours, MI=minutes, SS=seconds. UTC zone. |
+| <a name="IEDATE"></a>IEDATE | End date of the simulation | YYYYMMDD: YYYY=year, MM=month, DD=day |
+| <a name="IETIME"></a>IETIME | End time of the simulation | HHMISS: HH=hours, MI=minutes, SS=seconds. UTC zone. |
+| <a name="LOUTSTEP"></a>LOUTSTEP | Interval of model output. Average concentrations are calculated every LOUTSTEP (seconds) | **10800** |
+| <a name="LOUTAVER"></a>LOUTAVER | Concentration averaging interval, instantaneous for value of zero (seconds) | **10800** |
+| <a name="LOUTSAMPLE"></a>LOUTSAMPLE | Numerical sampling rate of output, higher statistical accuracy with shorter intervals (seconds) | **900** |
+| <a name="LOUTRESTART"></a>LOUTRESTART | Time interval when a restart file is written (seconds) | **999999999** |
+| <a name="LSYNCTIME"></a>LSYNCTIME | All processes are synchronized to this time interval; all values above should be dividable by this number (seconds) | **900** |
+| <a name="CTL"></a>CTL | Factor by which particle transport time step in the ABL must be smaller than the Lagrangian timescale t l ; resulting time steps can be shorter than LSYNCTIME; LSYNCTIME is used if CTL < 0 | **-5.0** |
+| <a name="IFINE"></a>IFINE | Additional reduction factor for time step used for vertical transport only considered if CTL > 1 | **4** |
+| <a name="IOUT"></a>IOUT | Switch determining the gridded output type | 0 (no gridded output), **1 (forward: mass concentration; backwards: residence time)**, 2 (volume mixing ratio), 3 (1 and 2 combined), 4 (plume trajectories), 5 (1 and 4 combined), Add 8 for NetCDF output |
+| <a name="IPOUT"></a>IPOUT | Switch for particle position output | **0 (no particle output)**, 1 (particle output every LOUTSTEP), 2 (particle output at the end of the simulation) |
+| <a name="LSUBGRID"></a>LSUBGRID | Increase in ABL heights due to subgrid-scale orographic variations | **0 (off)**, 1 (on) |
+| <a name="LCONVECTION"></a>LCONVECTION | Switch for convection parameterization | 0 (off), **1 (on)** |
+| <a name="LAGESPECTRA"></a>LAGESPECTRA | Switch for calculation of age spectra (needs file [AGECLASSES](running.md#ageclasses) option file) | 0 (off), **1 (on)** |
+| <a name="IPIN"></a>IPIN | Particle information input. Starting from [RELEASES](running.md#releases) option file, form restart.bin, or user-defined particle input data (see Silvia Bucci's stuff) | **0 (using RELEASES option file)**, 1 (using restart.bin file), 2 (using previous partoutput file), 3 (self made initial conditions), 4 (restart.bin and self made initial conditions) |
+| <a name="IOUTPUTFOREACHRELEASE"></a>IOUTPUTFOREACHRELEASE | Switch for separate output fields for each location in the [RELEASES](running.md#releases) file | 0 (no), **1 (yes)** |
+| <a name="IFLUX"></a>IFLUX | Output of mass fluxes through output grid box boundaries (northward, southward, eastward, westward, upward and downward) | 0 (off), **1 (on)** |
+| <a name="MDOMAINFILL"></a>MDOMAINFILL | Switch for domain-filling calculations: particles are initialized to reproduce air density or stratospheric ozone density; for limited-area simulations, particles are generated at the domain boundaries | **0 (no)**, 1 (like air density), 2 (stratospheric ozone tracer) |
+| <a name="IND_SOURCE"></a>IND_SOURCE | Unit to be used at the source; see Seibert and Frank (2004); Eckhardt et al. (2017) | **1 (mass)**, 2 (mass mixing ratio) |
+| <a name="IND_RECEPTOR"></a>IND_RECEPTOR | Unit to be used at the receptor; see Seibert and Frank (2004); Eckhardt et al. (2017) | 0 (no receptor), **1 (mass)**, 2 (mass mixing ratio), 3 (backward only: wet deposition), 4 (backward only: dry depostion) |
+| <a name="MQUASILAG"></a>MQUASILAG | Quasi-Lagrangian mode to track individual numbered particles | **0 (off)**, 1 (on) |
+| <a name="NESTED_OUTPUT"></a>NESTED_OUTPUT | Switch to produce output also for a nested domain | **0 (no)**, 1 (yes) |
+| <a name="LINIT_COND"></a>LINIT_COND | Switch to produce output sensitivity to initial conditions given in concentration or mixing ratio units (in backwards mode only) | **0 (no)**, 1 (mass), 2 (mass mixing ratio) |
+| <a name="SURF_ONLY"></a>SURF_ONLY | Output of SRR for fluxes only for the lowest model layer, most useful for backward runs when LINIT_COND set to 1 or 2 | **0 (no)**, 1 (yes) |
+| <a name="CBLFLAG"></a>CBLFLAG | Skewed rather than Gaussian turbulence in the convective ABL; when turned on, very short time steps should be used (see CTL and IFINE) | **0 (no)**, 1 (yes) |
+
+### <a name="releases"></a>RELEASES
+This file contains the information about the particles initial conditions: how many, where and when they will be released, their mass and what species they are (defined in the SPECIES files).
+
+### <a name="species"></a>SPECIES
+The subdirectory options/SPECIES/ needs to contain one or more files named SPECIES_nnn. For each species nnn listed in the header section of the RELEASES file, such a SPECIES_nnn file must exist. The parameters in the SPECIES_nnn file, contained in the namelist &SPECIES_PARAMS, set the species name and define the physicochemical properties of the species; they are described in Table 10. These are important for simulating radioactive or chemical decay, wet deposition (scavenging) for gases and aerosols, dry deposition for gases and aerosols, particle settling, and chemical reaction with the OH radical. Some parameters are only necessary for gas tracers and some are only necessary for aerosol tracers; thus, a namelist does not need to contain all parameters for both gases and particles. Optionally, since FLEXPART version 6.0, information about temporal emission variations can be added at the end of the file.
+
+The following specifies the parameters associated with each physicochemical process simulated.
+
+- Radioactive or chemical decay: set with pdecay; off if pdecay<0.
+- Wet deposition for gases: set with pweta_gas, pwetb_gas (for below-cloud) and phenry (for in-cloud). Switch off for both in- and below-cloud if either pweta_gas or pwetb_gas is negative.
+- Wet deposition for aerosols: set with pccn_aero, pin_aero for in-cloud scavenging and pcrain_aero, pcsnow_aero and pdquer for below-cloud scavenging.
+- Dry deposition for aerosols: set with pdensity, pdquer, pndia, and psigma; off if pdensity < 0.
+- Dry deposition for gases: set with phenry, pf0 and preldiff; off if preldiff < 0. Alternatively, a constant dry deposition velocity pdryvel can be given.
+- Settling of particles: set with pdensity and pdquer.
+- Shape of particles: set with PSHAPE, PASPECTRATIO, PLA, PIA, PSA, and PORIENT
+- OH reaction: chemical reaction with the OH radical can be turned on by giving parameter pohcconst (cm^3 molecule^-1 s^-1 ), pohdconst (K) and pohnconst (no unit) positive values; defined by Eq. (13) in Pisso et al. (2019).
+- Emission variation: emission variation during the hours (local time) of the day and during the days of the week can be specified. Factors should be 1.0 on average to obtain unbiased emissions overall. The area source factors (useful, e.g., for traffic emissions) are applied to emis sions with a lower release height below 0.5 m above ground level (a.g.l.) and the point source factors (useful, e.g., for power plant emissions) to emissions with a lower release height than 0.5 m a.g.l. Default values are 1.0.
+
+| Variable name | Description |
+| ----------- | ----------- |
+|PSPECIES | Tracer name |
+|PDECAY | Species half life |
+|PWETA_GAS | Below-cloud scavenging (gases) - A (weta_gas) |
+|PWETB_GAS | Below-cloud scavenging (gases) - B (wetb_gas) |
+|PCRAIN_AERO | Below-cloud scavenging (particles) - Crain (crain_aero) |
+|PCSNOW_AERO | Below-cloud scavenging (particles) - Csnow (csnow_aero) |
+|PCCN_AERO | In-cloud scavenging (particles) - CCNeff (ccn_aero) |
+|PIN_AERO | In-cloud scavenging (particles) - INeff (in_aero) |
+|PDENSITY | Dry deposition (particles) - rho |
+|PDQUER | Dry deposition (particles) - dquer (equivalent diameter for shape) |
+|PDSIGMA | Dry deposition (particles) - dsig |
+|PNDIA | Dry deposition (particles) - ndia |
+|PDRYVEL | Alternative: dry deposition velocity |
+|PRELDIFF | Dry deposition (gases) - D |
+|PHENRY | Dry deposition (gases) - Henrys const. |
+|PF0 | Dry deposition (gases) - f0 (reactivity) |
+|PWEIGHTMOLAR | molweight |
+|POHCCONST | OH Reaction rate - C [cm^3/molecule/sec] |
+|POHDCONST | OH Reaction rate - D [K] |
+|POHNCONST | OH Reaction rate - C [cm^3/molecule/sec] |
+|PSHAPE | 0 for sphere, 1 any shape (defined by axes PLA,PIA,PSA), 2-cylinder, 3-cube, 4-tetrahedron, 5-octahedron, 6-ellipsoid |
+|PASPECTRATIO | Aspect ratio of cylinders: works for PSHAPE=2 only |
+|PLA | Longest axis in micrometer (Bagheri & Bonadonna 2016): only for PSHAPE=1 |
+|PIA | Intermediate axis in micrometer: only for PSHAPE=1 |
+|PSA | Smallest axis in micrometer: only for PSHAPE=1 |
+|PORIENT | 0 for horizontal, 1 for random orientation of particles, 2 for an average between random and horizontal |
+
+### <a name="outgrid"></a>OUTGRID
+
+### <a name="outgrid_nest"></a>OUTGRID_NEST
+
+### <a name="ageclasses"></a>AGECLASSES
+
+### <a name="receptors"></a>RECEPTORS
+
+### <a name="partoptions"></a>PARTOPTIONS
+This option file is only necessary when requiring particle properties to be written out (IPOUT=1 in the COMMAND option file). In this file, the user can set what particle properties and interpolated fields they want to be written to files. At the moment, the available fields that can be written to file are:
+
+- particle positions (longitude, latitude and height),
+- potential vorticity,
+- specific humidity,
+- density, temperature,
+- pressure,
+- particle mass,
+- separate cumulative wet and dry deposition masses,
+- settling velocity,
+- 3D velocities,
+- the height of the PBL, tropopause and topography.
+
+Each property can also be printed out as an average instead of an instantaneous value. For example, if one makes internal time steps of 600 seconds each,
+and writes properties to files every hour, the outputted value will be the average of the 6 previous values of the particle of the past hour. Note that this comes with an additional computational cost.
+
+## <a name="pathnames"></a>Pathnames file
+
+## <a name="available"></a>AVAILABLE file
+
+## <a name="restart"></a>Restarting a simulation
+In case your simulation crashes or if you simply want to extend your simulation period, it is possible to run using the restart option (COMMAND option file: IPIN=1). You will need to decide if you will need this option before starting your initial simulation: LOUTRESTART in the COMMAND option file needs to be set to an appropriate time interval. For example, you can choose to set LOUTRESTART = 172800 s to get a new restart file ever 2 days. The restart files are written in binary and their name specifies the time within your simulation period they are written.
+
+To run from one of these files, simply rename the desired restart_XXX.bin file to restart.bin, set IPIN=1 and you can restart your run from there.
+
+WARNING: If you chose to use gridded data output (IOUT>0), then new data will be written to this file. If it is not desirable to overwrite a gridded data output file from a previous run, copy this file to another directory.
diff --git a/documentation/docs/transport.md b/documentation/docs/transport.md
new file mode 100644
index 00000000..24efbf70
--- /dev/null
+++ b/documentation/docs/transport.md
@@ -0,0 +1,7 @@
+# Particle transport
+
+## Turbulence
+
+## Convection
+
+## Settling
\ No newline at end of file
diff --git a/documentation/flexpart8.pdf b/documentation/flexpart8.pdf
deleted file mode 100644
index c16d122410821a4623bfab62909e6b738bb361c4..0000000000000000000000000000000000000000
GIT binary patch
literal 0
HcmV?d00001
literal 255327
zcmY!laB<T$)HC8zJ^rSD5to^QfkJ*#7MG2UzE5gidP#<Yxq^X0kiJ`HPDyH!g1%c$
zVo9n?YI1%`s+}EIaY<2XVlG$3oTXvDlW&{x?EM}7VaB;N0!{aA@~md7U4C1(`Sp^$
zo6N3<C3(kr<*EJsx>O^mEXenD<}voO3<@6@Y#8d)L?&E#IDP->zmF<EesY}PyS+kf
zM#$66w<d?5Ua^J6)L=@J&U~@Q#wr~`I?6#A6S{Q1cZ;81`#<q#;X%m=<p`6gb>jMY
zchz>J1@BI~5Xlu&IJcBt{8!ah@AV?As%y^9D!nUP^Wv4+-b-R8S6#Q~U#~Oo(B8te
zBXCI)hnvdN*SBZif6u;j%7Gq%pJ%@wR!C-&Fpb<IqhiROX_|I%e)EZjC5JxgSTzcW
z1*ENHwCaenQ|K;b&{mc93O3X{py8;s&|zlEFAhyU=1i|Av#%~+%l+DJ_XL;bt0IL3
ziWNF0%1joEr>GXs;Z}7hkUkwcH#%<Vk>szvdLHYKe_#?>yi}sUcK6-0tm#5KmV8_E
zqA6%jZ{8KnU$b|<*jQVA-K3a7g|$+%;s4x!uTLEJ-~2M$;MeRIZ>ksdyRa<N)mHkk
z{OaQM|34&7<DGN7sHl!pNmJkP$*fW-7A~Kphd=z6dQ9?j{iWOaXv-s$wYl%rtaTp$
zwe06vq@`qjJMzJ-$KjnHOb*-hEifo-ag}`dKj}`y?}MM#@y<Ve>S32CL+VWfzC)Lo
z{^wr)T3Y|+GV{SlY73TXy$zlhcsRsx|2k(OsSSrj&hzj4thZ)cc%@>-x$alb`|GxU
zR$Sb<Q|!5MtVDr&gH*=NtaqnlZff}nZb@6RX@Q=yO4Mq7zZ+ee594dz-@fqfmao$y
zfeD;{tT=W3Jon_kdg9`)8Twqh<OXBdy!;DxJ5$Uy<-NKj(`J2LzS(<s=j;>gA<GYK
zKfd8p?5Fb$^DgH0UAo?Wc-=QoMS+%iBHO<PuW~=CWc}!%qUfiGJxd*9uI}qJJofI`
z9u3{|c1w&|zV$r2xUKNyl;f`#7b>0G_}balnniT6%$EXrFY}*AUq7|`QK1)mzb(W&
zQ|Wlh%xm(u|L%KtYH85K?^mYS*=|*yC>n9<H0P`1!LqZ}*>fgOcm5E4zofKGIq+uv
z%QqIkD_*_4YZzBN{ShZul;3xA*=SMeg(;aU-~a02?$r{AdwQ}rXX|7G`)xrdo75`I
zi?qH4G97y~|Le!=6J{PgT2gGjZsq@?+BFwK|CKM0ob~?IyR(z_MDy(5&-n9%+V<4E
z6lh*c%}W90Pf)G|(H3TATu>n+1B|?DWJpxz4fpN8Z6=^w^=18qLgpheb)HkIvL-Ei
z!K6818QZPHaVayiS5I(tU9{<L{r!jLd(F5+jxuF8C|Mfk-`gWur)!|ZYF7VmyLJA)
zynSLv*0s)m7qjPn?z{aHq{0H4rGwtgGkeFNnb9e@j=RxNYjsljy*qnv>sRGj|4sWY
zK4+1Q{Z`c&g*fr(s9SH_&)$8fa@Ma)a5YP-_1Q<uzgcX5yfNSX^V%gV)OLKlzpU(9
zt@(}MHBK`EAMTg=l{)G3CGG02>m3^^UajFP+Tea5Fs^9-pU=zt>+80i7MWTaQ}_Mo
z8o@rTAolrXX)7CJdDs29v^i49<3P}c%X;5bTzigA&U)AX_XgkL?ysv|lzx7#xc=^H
z*1=mwhXU?0SS@kub#70nmUZ6Jd42DRvTb1uE>W)YZ!fN@NuJIr<a?A!qv&P-Vw;G|
z6FQ9!eO;1PUCGHQl30D6@2=IBUGn{6RSVoY!gl)zPTn<RrDN~$wI`?kJ;o?Maf8I#
z&<-`@f@$4R2fA+S3$S(MKg;)?&2=^ANx=&BYDGt%D=HB$)B6LDE{>io)fT#aah%PQ
z1D79MyS(O{n0i};WZ|q3`&%Xf^Mq3ZU*9?TbnR1)C9_<9OxtRG^RGyt;QEh0)e{WV
z*3@1q`WEfE>()f+6+vkSOJeIMoD&RFo_FHz?z<A5Iolu0ualD5)~h|mEqkqDpGJCU
z&-wZK!iMwbMn|X3a4A}_oN<Hmwe$~*9xk>2Xz=U9tS7DyTw62drR`W?@6BJYo22l6
z?~?`Jl26XHIiNJ1JDv5?HJ17NB0n+RDs<(&FXY=aeVtB1uliyKX7*6#xaE761@W&d
zd1Z6<lgja>+pq0le1FJh?IeQ;`RvDmXQqZ_?b!C@w9q7`n+?*N*KGN<X4*@Y=leFZ
zu_ztPo^Ypd=9Qe8hZ!SfPM`9czdoJMPmQacsdd#-!82l0UZuVifAW30&Al%VPH|3B
z+4T3a$ro9THm)SueKq>+&B9s&wNl2sYbNizASHD8o8=m#6aVg6DeweZoNc^NWV7SW
z%zULw#?#DVraV2T-QsycyOm=vla<e<g|6${<D$;bT<E<<(Z7fLoA!eLZ?5j}%UW~w
zO1a(-weKH(K3Uvu*JAv!Zt6|0&R1b++j)Y8kFJiYEu6M$&w?m-i)n^sVa^%bYz}^|
zP`@a+_p2d?Snb}alirDJna7y@n&WKTt8~rdulYS?U6}6saNJ_msofK~QY|X2X;HfA
zPvLyqpV_lkRey_$T59)F_qJ2gQ`Y*v=3CnnWdtJ2@=QwB-<|GyE7til)1lu#*nWCj
zdd^z8_tT^!vlNoW*M9teO2Yj|)G@u{+GdfexcmuBN8aw~+q+HK`=r21{jVws(|;`U
zU%QWORea5dQm-==t3`hXrK`zSuKIS#TYSTA&$Gp`F&8cbxn@23J)ObtS}pURn^Id&
zxVArj859;LZ+|Xpu9&{*hOb^(5@$j#G9Fr=Z}BBDi}7lY7QfB6&u+Y%o%U=Ce!U`n
zy`6%$Xzz~Yg<7-sEA6w8j7d3ghG+N6dEXa=?o(Q^vC=T|;FDC-J5yO#SS()u#!1<)
zEPdyJ84uMIG=6CDYDL-?*e*Hrv!%HBo_vi}hh(J?d-dISe;4rIP?xpa{&-hOvHeYF
z)syV646YtJt<c+?_UyyiBR&CBeqJ!#INv^g>dpN=%2UjC^u73BU|Vf>@9(;+nICSQ
zH?rmRIa6_;&#$s~zh+Ta;mfw4{ktETe^$}XZuI%F<3<t7d)?sF(u-HpUKqXK_MLzB
z@Ai1^;4`y-+jDK&`Tyvj>i<8P|JeKqsoDPX$Ai3GKX)v?y7sti3rm`;&xcLF7d*T9
z+;4)GNN>wCmb(>imQ3$5QgznuKL0vh!A7y-&}-RUa)*SPRHr!T1XSqi{yM%<KFs9T
zbwAck0h5<CoO_{Vuqf@{KgJnqb0sl~dT=2QD(ekRj7;E#y(LCrZwxB`3AWVMM)~&N
zF%x3lv;C)N@okn528&jl-)q@7S0dtgWO~ot=0*qQi<hIyy>mU^Zv6auyM|cg(LBHN
zDv>`7+M<-YL)XXc)p~h3Rq07;(!YoI%gR5#d~|tf%=(@7Z{L0T{kr@8y;EH4I;>Vc
zefqVX`**`0oy(_<JYC{q;@<1+n|MF&|92-br<uDaoqql9(d_cy>mtA8)SVCtOkH(A
z{#jkd)}3>nEjsgwM_+&T*F`$6vkpG`_GsJ8>0h&Sg+ev<{JI%)$~CGXu)@>7*q-m%
zuk!rMJ<>I*mwi%p?%Cs&9T@uh?)q!iOGQHCme&2RGYtz<s(uo-VL?!2-}U4C%e(je
zdEWj1Pm<p1kS9~^UvJ+2dhJY&CHueLidp5tYCY9mPt(OoZ|0Y}OPl4Ur8ydNS;Pme
zGERGA9{+q_?zYvcQ&*(E+IGV~dG&M2$5T3OnhS2vpCu`-H8uW)U;cI1Ak9yAtUK>(
zCU4s<&2QXYnDJriDz3oguRd`x1&F`af4k$h{2R-)Z(a3-K1u9IwDHlswa#T~)$R9R
zQWV+3HD~<g>+?Qw`uvd{!eZWvKh~$r>)JHs&I!}JhCgSN<G0T~SZO`k>Ds;9=grR+
ztbSg9q+r(6MN6#Lo4;e3su9F5(~_ZNRCL(j(bhRfIhiLdxwoqD0!RLhr{^DS7Lz>u
z-1%hS6+6p!X0^Kyp1%6?vx#|huSD>r<9U)FJy_WtE<c>RRp-tu`+a}Do>E%X;@sL%
zwP^d@KUaQ+R(-Z<N@aO1u$bf8&AIyX_W%2S+Vs{+53c$hrN)iz=e+md<gZ%azD_>x
zx_ee&@VUtACqu5B;d{TU>+{oHzchQ#&HlI{cJHDk4DP#q^G(*R$w>8Zf4x7%!)oE_
zJ25F!mh66}yhvT&rs|7uPsoFXy`_RGCKFsD8-F+MS#8kK6Li7g=)>L8yZ?2*+ZSDb
zifdv}T7BkqnN2@A&uI()7d|ifY+_oG&lKSgx`LtF$)V35<Xo2M3%JDj{P0;5xoLG5
z#JnpL<t7QPxXwT0;@7^lr?33}#VnH?amR7Rff|YB!CtEKQcpW^C9oaXYxG$1L%_Lf
zTjGsN)_n{5dDCPX`zv;t^t-d$uI5}SVC$V36cAvm7jd@hVbX1W`Hx##KXK+e@{~_o
zs&8Mr<k0`XO{cFXz423dv(#qg<R*sn!ju*U*IS9qt8<sxtp2b1d}nj8&Kh-B#v8@e
z^^sp5EUH}kDeA<AsJnF=dRQD&HUIyUj-D8DN?T~hKBdJA7Hr*}HuIPM{+X_JN3v%4
z6isO0v-eN#PIC%-a<ELs?)|y75l<H_;IK<N`tjL^LgTuB-P&4WPdP8`oVlw~=FFmO
zhDLqO*!P94LMNGT$E2<n;1c1tsJ!p<-@X2hU+wk0lHVWynPw+QYR&JDxP0aA?z$J}
zbY>Q{e(zAVf1Me*ENw=kLfQVcQw>c{SJ{1ewRhh1rTd@%-JY$LGU2|F_s;e67k<&`
z*d@N+RwP_==UMlefp$(aU9Tk^sckovmFiohax@{8WyaB<a{F_|{j*zT7#DqCCckIL
zdG7<aBs2L#{)>b*tol1IW}?Uv51Ga6p*FWtb;@7NofKm^Z`Z?zzmBSKIDA}odBxcU
znTB=zSN2_Y(Rx~Yb=&@#vsS9xE#2k#{N#x*^7r@ss(b4`m9z568~5+aD)PPRj1+Rj
zL;}|^Meoe|d0TON<TN&+GhCBan`pX-hTX~jqVK^`^lSb8Jr)069gSLQtnmL-`EiAn
z&w_oQ{+{Wh(z3>Lu@Xa1z_L4L&i{7{dn{OUIwSa?-)q+$OMZ3wwm!<)EbCaYR$8l>
zJFBKP{a`@rC4qpWezn*2Xa8nRSA3!@(^AM%nYoLtq(sU2`O=yghh3eXDtlk2hifQ$
z7G-sARPfGv!BCrR7qyi=wn(iua*yTC-y7y=z1_jd`|8L7&!_C{v7W_~>o#mCIl>TU
z$>nfX@)+v^la(`nnfm1}KG^-_P|2mYMt<>u9wNtc^CjlD%zSy_NXIV5@cVqbs=My3
z<C=dc(DO-!$SM!Xm);S~)!QYv3vwQ-N&PHziMb`EpsBpNJm*=r+{s-J7_6=*PM3VW
zVSBvcJWX2}-gA4duT3^lco#BJ;m|wYAd`h$ElCm{TJ~@69g=icIn=BAPHC<1^GCCn
z{jF&K?IG3LaL#f0l__1t`>k`r<8S4$?+WJ9c^78ipniGnykE;+Z<Go-knLDdrjp!v
zc+wH;3{xqCvr|@@E3I4^w)Jh|{b+W^2O_><F<MQ#{FP!wW-mF*;LN|SB~5bjy;sM$
z>X%xWzCB(Sp~U<De4kIGmy4Q-pGJfJ2@W;(Ysq4hxW%%xX5QU!?uC)-CZVLu{9YYv
zYB#=U6_aSX60%Ey?Z)cHEeSbi7jk<q?V10<gJ<#g!#q(ny%$+;7P-7joY+>DmG2ok
zQ^e+FdvRUyoeVi6=KBUIo0SE^UMja|>U=3$R)3(ydd;=2vmFNA*V1|~JlVt{J8$ZR
zG?oSRrEPPYPc`1D(^+|V%Io&B>K7(kgbk<0IBX5GYhASaz~r-j`c++TS+{ncjV?bc
z-q!uO`X|%D8((A&Z@MI9T5RzqFJPL3)QQKHH4n}T>`{HV;O4o-yxyEHD}(H|eu{Vy
zyt@5I@X;Ta&k0Pa<eg}v^k_|jP5tLzUpLRMcVIigw725awr=q%%jpLU&zm1!c|rQS
zUy6qD^DlC>U!UFms{ejn{JzTHNxAbHjBaqxe{Qch(PQy4i*?S2)|{xY*J?g8&1B+C
zNA;#9+lp%!cm!=QuiAO})~vA4Q^oAN7%wfJ`Yty)i&5xY_~A%>?g@KkduJ%-ooerz
z@gPz(S%t$*cIJhpQ~hhyK7aZpCzUGlqB$hc^t0>S&>eL@ck8}h7PR}$p_AFX5xmX@
z^G;mZeUMXD?8ny_22JfN48f|rOWP`{#jbx5T$i)3>E*W#Up#(Cetf{Q#zf@N;w5h?
z5C8kTExw@K?9<jM4#H)}LTqIg=ZbxgW^}hqJm`>^v|z#(-^oH%({5Q`+smTrJxxa8
zO2npXH!kw837UF*@|O+mT+i;iDSZCMcin??)n_JC(M->o3+L~*-C%gqf7TtDT?g-2
zFP!;jh4JF*w+;f=6LcR=<<+R4X_<ZP>D;VeO+IYuGXp1-Rxr+)7p^$_$9B6ne+Bqr
zCnj%tG9@`^@@F}v1*;8yGjytKv7M!Q-7iJ$a!>uAyLpld<!sm2-c61w609t^GyB;d
zPxaI#9JBe%4)}dy%(k}O9{j%3)_(<uWA3J}mu0LHZACs+R-SqOG5qP>8*&cYq8V#a
z<+P@BnZ*3;(n-(WfArBQu4jL<4ou-ZpJ2WBFk5J7OrEvaIhUzZkB6E*ckbFRyDy-r
za$i~g50ROb_16WpTmtSn=-nvu_-8hE|IuXDR~xx+-xiwYKcDaKqjaYh;maA{{cj!P
zd(d!b<|ih$vKh=*jvKIlVz-)Qbz=Kb*XF%(oS(j(S7)i8xv9td@jl%IWpA-3bBxb-
zZAx1ED6jSR?KMX#`f|R%NZq_e;&thb-Of+Xd0o4ZJX`<gl<Ry>2Q%ON+&qIj;@7?^
z!OdA0b~*nGXWL=d^>4M<(Ie-s+`JQ~%pKR^61L9mx6%8w2d84r_nl|jG+*gnt?aDW
z`&M(0wUw9&#<1sG+*$l#&b9NNevd9VvF3M|{jSSCFFbAEiVszp-2rEdy0yF`j=y3t
zoMqVfv_<0Z-vwu{8}+g-`MIsREsW{$`8R(L?mB)*O3Kc-l(*x{3Ev66pSJiuDmHmk
zZRe^uBW!u_`32T}=YHM)^W?;wGNaE@bLKGabV}{_m}l~kMOuEgm5%0T)wa*vCEeNg
zb3>N}mh73hMb~o0I@80(_mVD1XI_&!s2qPLdfoC5^VdJK&pySHS#rO4|N8R_MSZ@M
z|2o;gB`Cu2<=fT3zugrZUpod|aM+pRr2XlZ+OC#V#&VX&5|8p`ec8Z%PW03yuBDcJ
zYdtSyg|z&7_rRp+#&h5H#Ky}CheaY&Yz}k0?cZ}{+thU*p6OSpiHZ4p1^m0i_-8wV
zj(Aw?KbOa+8)U5B6*$~|e7(V4dD4T!bJ^Wg6c+T|`#--%AZ(4Q#*H60zm?5#aC;Y!
zKJ|&%pMTohW<E52bpE@*=A|#Uud@%aTx=!tUh?Af7N<is9<HBV*1e8!J(^~eVX%1W
zDb8Kr@2`_z^K|8kj(LmDx}|r1T;cKJuf_LyPZ*f4gqYn44>xMpVOe%k<V4rk?_clU
z>3)5>K6Xa^e`d1?k7|s*2)K^{>Wdf~8d}2oBF3heeG$+&GQqyc(x}^gpuWf-i+IEQ
z!iG#&mD1WTdO0c%VmEuz&AVIUZ%ndT8=<?kw6OXcxGS=B+Op$r4-}XKvf@_x&9w@>
z^8B`e!1jed+v~d@pM5_2{PrZd;`*+~Z|}?H)$N)t*uzpeqx*Jyzxg-zM`lyEXG*XY
z7X2>RQ(61(<HPf_O+1V%c;)P;n6LkuaIA$RXsV~oY`>*)t1sCEWGX06-7)=kWk8Cf
z$kKPYx$3=(ZF~w>tUVJU_e4urvhU%ornR-{ZI2ZAK3`aSq3ko$hU8o4B-<ych+BNQ
zQBr+(Mqy@HXOc{QLi=Td_3IufOs{)hnmzseC!ZZp_uqJ$>SVp@*2dTKpUpp9wQ>G-
zxdQ$~pD?LaMh1tiIkR1j_TOzx{FGAnqhN-);wJ?~@42fBbN6ksDs{HKc6ZNV4epjt
zw}0BzpM4gR&>v&vKIN;ywYQH$_}PCX&r=T+XkB^e`R^>7@X&61p2ghN2aTGhY0k=<
z^;dtgLjR)^Yx@=$?Ek*}R=96_dZ<#To((6v&~<g$F3B(_){S2#*WEn(EG$we#pv0y
zb+_Ct;v4Gxjq3Z%v)_CWO_bXHX!WX%i;V;d7m4+4_wd_u{8!aHGtMNd+hVi4Y??ic
zxBoi6&-&cy6%1uBr%4Lxac+NTz%;8geo?v5)4Nrd_S%IdUp>FO`>=vgUEq65&w#sg
z{=L2b|Ksu9lEp%2gpZ%$Yd*TQ>A@r=Cg<k-%|Bn}+b<4JwhD@WdFY||52gOUcC|MQ
zn6JFOQT{X};lmNF2{&6eOW5?qTFcE+H)-_f=z2C+`kG+4%!SwPPYea0tmIEmZDW`z
zDd-<5zq+g;I3lXEcjbqR`S$N+ER+r&Jlg+!P1P&icghcZ<<sI{UCMKoV)`<{*^1Sn
zz0u2<FJr^Xzl|J9O(&=2fA`l5&<MK!_t!W3|8x3vn`d0BF7A)^ZmIuzFiJN$Y;zr_
z)6DjB3Hy7@ctp6H*IsxL^?G%xz{_PXxuyp)<SzUYx$xhPc@h1uWiEtNNfbVtlCfy>
z%(Rm$4zJXDm341!7n9=Et+M==|D9hoV|f_YiCg<^%8oP~Qa-rW?OXYa`D?#jww=?n
z^x<44g@aMMIW$hVO*rBave5mVzJO3((o@c(ES=n|Pk-6h+<Z3ehGR!s*`xTc$?F^0
zOS=n?dN6V%ujxLf=H?u2=h7b=Y050Le34I7$??l3VH{PiZZg%mJlDQvJc{_VxMZ_^
ztBF}0M~jXJga5g=z3=9hF72Omoa^Dr4&7TXcdV~U5p%qKJ1YG}8LI<tBHJ42su?>!
z^PAm!bf;qK=UeOna$@m`3YrgYty<CM_<d_@sn3-1SF0JXFr|flDDrV*@G#L+y%bZ&
zUoOFB^zGlx+Y^M3q+Q;@_jOn8)oaP7SKKY0?ODju;_i09{PB#NBCMV3s!i4`h~e6;
zdEldbUCB08j~vDQYuXmA|2}nlJkz!fHKJXveTJJ(uV+fgY!ANP-?6wuY5tZai@tlG
zW_P<Mpl9dD+;%YNP3gbbLkv0*2~i<wlU6sS6`!uMDLec!;A?2ZystkqgRjVLog3vg
zXJzS6*5zR(0(bjvHN|xD8tC(F>PhSP{v;^LPJHLq;Esg}>Q^7jp5hZUdU@^2{0X7X
zlbojV-k7u0-9)}&np&;3>4KIwY>oFXc?WH*GKrqhzVY=Qg%u`I1=*+9o?d)L;{e-+
zq{PMAUX2wtbJi)SJ6!YjwB0kiYV*|O>*3|s_H8(CBXVb-oMGU;%9IPr0#(vBTn;Dp
zns2aTdi3o{x?xw5f@<icaJAD5;~4iXIk`8ZMc^D~^6QoUvM02+tY37*zC_r?nyEkc
z9Jj<w<4K0Qg#WGHmAOG@a#OM9Z28ygXB@h8B>I+j?2MCz$9Br`U+W0)NflSSxl(3_
zuUFp3<NNfk%j|i-@7_WYua_Uvn^mHDG$;Svo2`Fof#aIxH(MvGOfBDa|HAQ7?xm5e
z|2K>E@_NT`-sm;D@hrf$DwMP2tiZn7JFdNN+4yHo>Hhq6+P%Hb^=?fsbFa+UV7_w4
zPXF4wVqaHo+~36zt+`ssEXdcXRoUNk5|iYlr0YI$d~aDE7@S#@y39d}wZ3i2?r&8a
zGN!oo{Nl7Pv#nA){pZoqE8ky;en>vo#dQ2`siE|76a8(X7s{R-3%FJhU=v@X&$Y{~
zTHj5x@f+t&?d9h3e0K{E7|H)}D?QSFUFrNKe*1e5pWRsedEw@F-j@{~ooiNbb>#J&
z`1aOQ6NTePq{V~2XH=Yy?9norEOBkOy<c;(;K_4OzDOz`=@0&V%2Ti7@QkZ<ddVBS
zHoo@uuX)JrckQ)`Ni|nw&qnE2Q;&N6=GEm~#<)-3_n(91^p8S|UoeCo?O2+>sL3FH
zN=kl#sNknpTbQ?5$_5lJ7nytQ{Dl99YnGY^Dc=&ge^q#1*VPp#47u0vCWp%`5ZLsg
zjpc+=nd<+`CEec@x<0>e{gHXg{A+<jBCnIm$Kx(@^!qCLS6kkk<gjy^zQ?@=TmOLa
zE`?;BH#7CsUSwT(%D#pn>D=f3*zhF39!<-yD`HvHPwjHL{#1q6EGqE&u3X8LAB<Tp
zci3)rJ^DiX;}oCo?N8tO{0e==X34NbBD*42?%&?B-AmXGOD;MpXY+XK2IK4v+eA)Y
zo3bozgK_IO);G`OqUF@J_jZ2eQ{h&vnEsJv(e14UzSE~_NypY$JuY(<2|lK4D57$H
z$LlRt*N$_EX6b1BZr&2nzb>f$n-8mubU>cgc9$CG0*}k<7W{j=ed)7h){4GTo<h2g
z%-{NaT@Sqd%jb3UQA6UPRjpZzZ5Pcx@KQf%nxxRi{w*Q7E>f%a-U|=7|8<?P(COE)
z|H~6z`acP8TF7&_BS9iaYxnwV8@I^LVlFbTF5G<W_Ny!@&;FI&*YEAkytLzx;*+(E
zxwl*&yKV1qZ;A-G!8+}V>%+%ME+1X0%UaJbdjH#Ld%;Da?_VZOi2S$u_BN^GJ7sgF
zeq2$SH&=hX_57Wm<9*k*|6ltuVcxNy#p=QWe`m(Tl`P0<&QM;-u;lHcX<r#*g%b;&
zb?y=W7j;}nf6}E6t7#hY72V}i6%YT|$tG$1gmq`?o?PdqBX<lYC^!bH7Uc<FxD?F1
z=<L@84((@`eX-RzWW0M}=B{sr>Dz4WyPfBKIyreweIW~{9m6H<CrQgZYs`;v{+qFG
z*19X_%RM-KrcE;|WvJaet6|&ZiwbuuH#+Y6ylI~BlFQ<gf5@%YdwtI3!=A}gxCItP
zZOn*wsFj?x<@Cm=u+}=Kb6qRBA60k8tlDTd>50xaU)NoW=9q*(Dc_-?ZP}=rb2rtg
z<s^ef*7LxF+O=1XcfaG7o3oW?;ipYIg)Xc()cxpw+)D=cB}Y8ht>)+W`1ivhH+BhM
zqw`H^Gs{`;O!&=an)Sx@to_2w2O*XF_H9o{JhO`->!3zzdQ_IRhW4GQPZwpG8MZ$;
z(edStw6|q`ZC=?ApW9;bewNn*pXck!Z_{h26}};N^Us4xt0KGNwk$YXD!0|CvZ%Oi
zjh%nh;_1~_ns?9fZe96Xtm~n*r-%#p`>=}h#?e2mx+)L+mYAZ)D4X(9(s0p@tNqt2
zSMIq|$!$?RmwhU`?<;TXZ_6GB`aCT>*A*Ea&v`Fs--GuZpW6EW_}B>le6y|pXu03@
zeH)hLu5Wf0I{ajh+xCgi-#v{C`p9_J``Yv=MvJ551J>+4FvaM!)xMeMkA!5d>+3Il
z9pvIsQq^>X_hF+GC(|@J-B}%La<q4qwXEqoa(L2_JM2;gHcE-UPxmdTda`jFXY?M0
z#nC-$bkYkWLe&45D4f)@=atxf&yD9st10iimru9<+Gw?_Z~o5byN{f5YP|L~v#3|d
z?a@*>(>A8%8pdBf9hW&D)BA9*Rz=ItuzIKLmL+m~TP1=w_VX2W`8td9f6ve1>ie<u
zft&tk;R8=s#6DMi_9Zo+<s_rg?hXHirJC2Cof>@Rbo=+@@&f)tKQ_IHjA?hgSlsU5
zb>hsnXPg0>4XXajmHjz*Df!SoF{w4aEW%UP|2k-TUgBwPUHgXG=F+uCdLHc$N!m0m
z!Sd@2&*`lUFMY3x7o;;;8Q+gya%XCl6o2gh=Hl5QFE5#CzQ20a*EZ{o!ID2k87qG2
zn+ly=^x)FD<I>?Jocx!|nryNTAGwn*@c7NQ((5Jt%P!o$$yab@|JegO#jeY`hl}dH
zj##m0_qxd2XVQ7LZgu~*_R{Q3iS7Ew??s+}8mYHJ|J5ay8L|gNbXhK@#cueO)3bEz
zAy1XmC$~=j*&MKMmriYbWP#|*-C;T}XWQIafAVW{YkJzGKKD0D97bO3Lelq_Mb3-S
zS98-bOPmtRx>uy&{*@0gHxkyaEe-yhuQc;TgV0Gf@g01N%4XKos72g~HB>!#^UsCw
zb)^S$D*py|ehAv3Fh#U=|JhH^xGn0RtzXb_=DXjvw}R4=59jM@Mm)>rO4BWMJLpr)
zz?$CIq<nAJukDgdyEr+2J<&|fy8To=imkC^r{xRN73X%SfBVWhhgXDcNzrLTYlm6A
z8XSjvp4I&>`2D;0=lA-muBr1dJ6fO)6u6^hY+?ZKXkkwJm=HPXbGqp6F~PM#Wq-Kd
z>4a7|o_R2Ljmq>VMN^+@7-^qtl8#C6P&)LOi$Czw^e4ran_td+x3eMVa$%<9Rfcl8
zzZTC+`0e7_8h7w~wf_@cDlV^Y7uQvK=HJR)r^C&~ufI>_QFas*d-UnqyF-5*V$wbt
zaUWLj)X(45{rqrd-mYiUi}Kp)stP~P?+#(foa9~cb=kg(xNlqKL@EWIMYc45ZjNG~
ztg!T8m8^D?(ka)z<oRC$gieTjYj9pA>o@mR`d^i4j)5n5=JS-lUZT{&9Tmr)+IXVd
zp!D^ZVB`9W{EIYBd_G~fqOCAws@-v`aw(OW(O<v)^#A<f!Yg(o{w^KAy0<mv{LbdQ
ze?`wJD{prX6gm2~J0UiPMeywBG|B6gj}-dv+OXS}bZ|*}6dYs}(+tXX_*^BpBrq#J
z-mlbh^;OP5A(2aS*SuU^w({z(%Mv#Fcj`_EC%C6?*_F3Oa*<8P;<cTdU)(veQRmQ|
z$W6y1X9j+&dAUZnTfuLR;j&kbrCjF)UGrr2ESR-eD*U;-q<u%!afK-1ZJW(@Y+5dS
z&dZ4B=v(eDOBzD&K6%aeS;4<3F+Ak4i*?J~i0)(C_1E<jf3ld+`FzgeS?Q1EIHOg>
z<xjslti1NMQih2jOQF-TRj0N^-MTbOopJe216}{88#50&AG_Mg(X~Thx0+Y8PNCW@
z-mB)xH|rz%g<2hT?xY>``qnei?A3bqn#*&KCE7*_rIc*3o&NgHT!Wt}50~XueTkoD
z`9HCssaKVOb;gbc(~oa28^!aV=BdACD%2eGtek(t@og{P8{RSQ5;}kU=e&N^nF<G8
zT0cx&X#Hw`SPwUYR7*kOwJYaBs}5c``!{2f^68UIPg^XfaFt)GdU1WR7lX>F=T(v)
zMH)mGCTwf^(Ihi_wp>r-x)oCx{hsShJAG_X=YlPEyt%t?<jO5lVO{Jdx5`1sXZgV+
zemV@McP*Dyt~9)-B>7}vvlw5`gLz5neltGi^?X$7y1sFx-Ij0(tENLf%unwdwlBIM
z`=+;ZMbph<iRE`oiaP|lZCy@q@e7t+`}Oil2!F!kYUAonY!By~Za2N9cxuTu`{L%=
zHu~EpH-Fr7@~Nobyk&Vs5`8)ExE$2eC+$u=BKz#g<m2oXYQOXs%T9ZnVkEU`e%Ktp
zRarhq9RD2?VfRmYZ#wA_&!%g8_wL?lZolW>ck7;AEsuUbt>(#}=4_tEJn7?w#Ztae
zM;%pyem`DkGJC3~y(H6w>C@8Occxiy_kENiyXH);X;6{ai5pMv*gRNc>A9%1@P?J~
z>F1F%OBmhNTs)`ERSeGb+Aw+5sZ6&Fh9BkqW>*v}bvA{tdhk#F?9<qC|Dm6+qRoRO
z?RX_WaqAT?4rckSXF9)duG6Q_A$f&A1<P4KCO=o{G?O%U;Aq@$Bd}R4U8wcV3;~&M
z-pd(keN^0Hyx+7QdMDz4-E!Z<-g7&h=1!d?ayRy^&ot3TG1DA9=AATB$ehOa^}<x&
z`ig5&MLxo7r>-sBI?4UwEAHf`A~hjP%k;oAu?14gRz^N92)$`|Vy>^<hJa|bt-dmk
z%Hr$3WX)P`%E0f+<)_URV<}S4VQ}Eh8K<);4lGR*zFccKC7BZKVtkKrc2t81%k2J)
zsD?Q+X3R-3JHE|U@3KsexU!!1q_58fpU=)@+rOZqhvEAs*@eefh;ubZM)sWSTrNNR
z=7RkXwxq^9QobLT(BH<rh20}D+_^j}>O{SW)P$G~*<uRY&%ghDbW)w)k*}XDc*{3;
z9%y-f*xJCS`*_plO^e>|E{yPVJLi6D_q!PHc<ayrgDB%Bp1ucj_#6sM);Gna&3LxS
z%gD{*;6&Xo#~iee#9tOSC`eZkS|Bvt!`|fYr<-!z7p~a-%*;5wapt;$+=&~CmT?JW
zI4U}HD%!5wY50+4q4;y2-mKGQO&@P<2^9{tT(x^?u5Z;L#$ZQ@K;2mjd{;EMoms)L
zt&nxA)KSrE|080URxFox`>r*+@Fo8T?o?B?okBj``(K>e7xenzWsL<}>tza7&0$#G
zVzt`(tl1f^fciMaZvp@8e3P7F`ERb3nfhvb)f~?DCX2%U0zXw1x7AS_xRoA=-IQEv
zeZKOvY~wRQX~hLbI}h{a^zl90aOa##OR@dx?&Xpd`FXkADvC;sNdZqgekku*^gfGQ
zXczawEiyZcI{6Zg*<Ogy)HZs)_1HCg!QRrtCdx7=&YWHUt|y)4^ZmKcg19ZGT#GMW
zy`KGI=mDNBCOfjqws0|?d?cQAE4f>fcjvr-DnD+oXBHgBY5hgpGH2#)u;+4m^`^#f
z_Gt+o$D{{4BZ7HY-DE_zJm!3`JT%&r@%Gv)CcJFrrKc5&CkMYu%Y5dpXHc<B^4jyj
z10Rx;yMk6^r0x-}QDnWpV%gH8o8*dSmCk#2#?f(xh11)qOm3z(rZN9>zocD1@6dz$
zGj0YSV0r!R<Po1kI@Y|WBQ$%;!W4IH@vaDLU1oIS728=S&ezIJ0lE>KnNya;7@D@<
zSJ){%^-v4<PqAy2id$AF9P<z}2{OyA%z687rrvJp_H&b7nBDus)|)5!<&@buF0QA+
zmHke7-X<ay3|8lt?~jfD&!m<7L-ob%GR|KQqxRSSwVSlZJf?;3;lJ#8zxO^aF_l#o
zy1nno%f7jSwQk!#zTSW1O=9EkN;$)cHw91cpB2uy_|h5C>iPcBzqH+>KN#?{^A}&g
zbu7m(^6RFiMT@uf@LzHN@nFJyRrOQvI#{_vbZ)Hw_E~g8?Gj$=r(1jGU#RzS2s*3r
z=H$K|3or1kwU|>Cm?gkjWOM!Jsp<^f8`W;tIy(#&Nqp|n{8FvEDd%$E+ykr&)XQAk
zj6GIWu1<W}SUP3xwk0KDTYf$=e#F!oXK&p)>C*4hDXL}{4Bq};c_^OSzw5*So|jPv
z<oZm+w7ttr4OSO-XK2eO8#UikF%wwuZBpFBUwM;%#NV}UDfV(LT)QkQr*Fjp2e(OT
zwHtT^Y6FY(IQRbg7U8$<RAR47_yZ$eA1`NyGrPihoieq4_VQf_3%&j{=8>7Omhy#$
zUA}uX4{tqCwz7Nb9>(PTE5EGpst$h?eq(vyRo|n#7CMQ$-jR>DTy{HjPcC1@?y9{#
z0lG7?^!zH$e$sXMmho|psLYb-k_`J=YxV9vti35c=iHN9sRx(aOUHHXY<zh{QU6QX
z>9boWrx@MVR?MHj|KGQ_=kqtPcqYZo{&V;o{}e{8bIW;nvxFxJ?T)GJ5;-5{b2_Hv
z|GxNb32&;n@B6=Jf0FZY{j%Mxho`g%9#?H!{yLOZN@Yskjn<kI*_`Yv;uIT9wL4lS
zuw)qDp46zjt=vA`JTG99T%dB1&=c#|0{6Ec-gx9#$*kAAJ@)5?AFNH_E-zC)*x?`|
zt;#fEiWSS>!o8XYW3D>g^ycP~i{%NP`Nr>P#ka41{qKT}`D&l9bD7j4_3eGkuGw*n
zOLmv&GG5n9JhVIba={FS;3>7XiPI0>;c3cay}!@*%$I~cTUj?8oP5&kw^P%i%ok<9
zF80|4IoV%dbzN!F-ES6bXU~hg7M`-SeD&c!GvEH4y!P`KzS?)CFZzYuil!9hR^Q3F
zmNL;_X1DtL_R8*Ka-K|gj!RY8uH}{#lz7Qyad?R~izdf1c?Ze8KhpNrD}MQV?`he(
z^|t0ad3Vlyb4Aq0|4zSe?-}t;-S%JC<i||^9pf$E@~qxBY}dwl{~h%UCcc=(A}PGd
z_LI!-8OaBl=9II(=hMB`Y4rHkgzw5X?oL@du~gM-8{@SZ7kHZ7tW8%Z%G`Q*Z<4h`
zkelv{^i^xscN^&za#!o$)}Jgq+x1PE^^HS~okrCQjb`3qU3X4t`fJ`-%(2Se`t$cQ
zU*DLowc=Ur)h|yovi8m}56qii|NY<Z@Efbolw6)8Sf74o(QU(vVqwDnX0os3P3xYz
z?)qMbl*zg^nM>9)?^Ei%ab0Pj$)&y856?W@v+I(x;<;P9UhADn*AGY+nAfq$<J-QS
z5;+r8XTSHfxc!n}@!8U_>u)dIU;jV)KI2{IhKEL+pR}#~tzvyP?rxoX;hlGm_S*Yh
zf5M_qPS;4OKIwe-rq^}WkL&#W%wO;L#J7W~*nIii-TCY#Y(<TU)<+wJik1iR+&rc+
zBa{Ey@>K?pH!Ca(@8|m5T6)H9skWuh^&K7C+ZB?pMhhiNr7!nh_WQB5qi*fK)pB9!
zj!$L&R`FlB)m<y(W_5OV^??oCGvgHn`PQx6cBubB<EsTa{F9!n*`XEId@*&^PVeuI
z{f1v6D>WnDFuNxoozY!<ZqpOqvV>fZw1j)h%AV-{m;c13QLyFV<Z_AsW|h@_8*Jvj
zy4Kh2yMD&ix4i3T@LnjKB;&3)?{aL1TU3kmHL2C1raQv=p4@kPS-spn+vH#FwZ4l|
zr%$asernfICiaK_4hrYlE&1Zt6Yux3j`M4~z3JB7Ymz6v*L$s!KgV|OF-?h||LxK(
zI|YQ&=1oh!9dhH^nacV<D<26jsXg`XwA#~k+h0skFt+p2@RGd!zVYXLq1XGSDqQoG
z>e9LXe3y+xEJy#fwwteKpRSL4QU9NLwQk8rj2;)bCk5?s!Kb!Nj4`IROiYMbQ@u6H
zJO7S_5L?lg^&bowZ^=wt6jxkaHrcTuGQrHC?E8c6JG#qFS5K4iwC(%+db@{Mq^qaj
zoP#<w1_#n6fBo}nbyEF4pO!s7XXO9gpRZ>ZU$bvY+1dZM=j+|S7xU*!U}l71Xwb>i
zvww4cXRVA}aazgKWm^2bIeKyaZ|~gMCzzjCw?AO#g_-9PE}wn)=<C^y8@oFLr1m`$
z<Nq3SJ5;k|*76;@)>m)V@SeD8!`E|lvCEXaz4w1xDgEx%xi!lb9Hib!x$O?`obrvY
z_It|uAf@zh-m-M1Njh)-9M(y7db&VU&-9&xCYRL(t~johtCt*Dy3V%o7rXWZv7n_p
z?^~N~-R!A$%I5NpKmTmb9Z$32P2Oxg|Jef9NY6iCZq!-r>JC*5S^76IJlUA{Ze<>O
z_OjI>)0Ot`VJZ&Yx%pMWs@rv&l0uZOJM!e;aGFw;8KJ6mX>GpRdiRtY+vd+bsFmlE
z-RbniGV+nh8I9^$pP1)lToVa5@^*<_7E{DENk#L|$Msgbe_TEu;`%ZCgKzHs_vhN5
zEtI=^&m!z|P=@55o$|kCN@}c~BEI{bRnMkPJnsFy!VYPRChhE7%yQ@b-_Y-y?@sIP
zIrQ!C`uG1n&))0NnBV+-z5T7VQBRB{{vOk5w9r}LF!$G$Gv_8r@#&>@%KM(R+5UHV
zW_y%}tlci=$H^<wjVfL~{9zKivq5u;#}byq;Yylwe}2>JPdeVTaGB(lP17z#Wr)68
z@w@rH|H6`0`?oCreDa;1t5f6mRWIL^P33YuE`KZdvcJHw$-EtFgiguV+b-0Mj60`i
zao|0VqaSZdzi$q&gj=JT+5GcwUnEJ`1!jKucvpDVyr-Y~t6pm9YI6w6?RwiHu+ZaC
zbK%{UZ|6!xa@}fC;7OViEw!w2;XM8=8)eT4r=|M|oL)00O*(Ab!bwjTeaOpvZu%?t
zrJ>pHhb+rw<|tLVxt}>+b!<v%d6la}vh1f9Cy#DVGhp1YBW#D=pSo`!il;h-h_pVL
z=EgDUj`r6&yWJdN0+&M#Jnx&db1H7}YD#`T>-WJ}UNN0a>lHsQlx=OiCNQaTgZ0A6
zOIZF3mNY%y-|yG{O!R>MwFxe4H*L%^>pskHo?iNQkC!9IXU5H+(;i$cm*twy93)Vn
zB-5ZaWwx4J>;+AWEeo`iq&6OY%gSjh-@fvo(#+KxY-F>~JP!H9vp@UU@ntUs|4H1K
z)0TP6M1wPD+2^|!4i{N&@A|Y@L8T}(HcoT)sWgABC4U#OnF;&+Sy*pzK6@imspk*f
zzRD?V(M%zAtA3ZQa^9(@u)uf2=IZr^ysD!ApC8g<@8MyqTk$-ZpEc=LkCsQ`q1Tr!
zC0xZFW2)P?O}*WIfBLmtmis5PmNU2sb}yQ8Fn*uTvk)DAhF!mJIvYL7kaMYEal4RU
zQXurDSusXxz3RUJ_VB4E9Q5QR12(%I;D7zhMA%dC(3it+{8rp}mwQ^l{lFcMhth&<
zSLG}vrQgny@(*Hax~pAeKj(Pqf)X`>`fbP49Yj+@AAaoIGT*yVVfpHWg3oj3Ul;#l
zYg8Gs^yCw@kB7}Wo^5#a_U=sSGygWXUaXk*;BE-73)|d6rC(f*EIC1eS3g{3s1SSj
znq}5P{q-ReyG>5+P`(nMv^*dv;$pSUw%?C$m5F@yIdQolqvq?%4E+bZN$xQ#YA-N7
zo_0^AKiT>`Z&317hfZJ9aFf6FY)6*8umAbuq3*KmiH0f)7Csz&y4P+$wdvYY`1nEI
zjqAl9R&ILJvwBthx>xz@+(K0uBi^3Kf1}VmDbDIr>W<^x5~41_ISl%jAN-2HE?>8|
z?)U56=?&9Amar84usgjqdcpgJvT6Z4vUf3VG+*lXSnzjd^u|d$5`Pu!Pb*kfIeSCj
z)0WNsxi7dx9^T=e?UQkp$^5zCf=_FkP83P4+RiM^yx!7zL1x6|V;3HKuQGbR((=uR
zZ9Nimj-LOzb0xFlQOmRiYLbOMZ@)42`ZMJ&unMS+Ub3+=Bg-$Kk*{d^oyUI^#V6$*
z37Rc9`_>#|o3%eTe0+XRSn6oewXY0Zhk6q=B&StBTzGT)cmE6eQJM@(R|+n?qyNad
z(0s#%NfU0n7AL-n<M^oSYISDKlrv^M>^&x|ON>4zXw1=eSn#0h^}L>Us#Q)&M|VB`
zSF`J|A~T2oAEC=poU-bynk+}2wQ{{&aN)_FSf`2=8tm~lp@s|JDE8D8*Eyt0PQ9_p
z-6Hkm491H6bBp!w9-G{(IwLc<s%ia$DGZX{I;R~%Bwq+KPBdG*_wC7Ey~tua^TQS;
zht=)l8}t?{ggo;InwqV`_{+mX^i%NXs}tt4@^4A^u-GQJQ_{LJ*f)L6C&9m;bJw!;
z#cg=<Nms)Ad~T+>;exouebOBZBPJ!yc&6QTqV%oPhDm9LTnE#><cQ8v5xc7}=R5b|
zNVd|*ttLx1#aJynXyJZw&bj=pEE0=3o9}aOTK9R2y(+8Z?u4fttCmLG{`+j^teB5!
zFRD!=)uc^l*6z<XWIuDaa$C;s%TtwQXXN)}9$L4}`0b|RsCm*F9mlpjkoKP`v0d%_
zW=R#_HWS@<?SiYm9KIkgaPvW5kHF>ZNT$q=jtSWf!3FH4m)~D^;ZnBHs`c%?xu~-I
z#KEg2&GvD+Wga&}KIKm3G*p`1T6d^OdN0pspCzXa*cHr!*EI1v#;#7>>QP~P(4$|7
zIe2Edb-URGPf?bA?EBt6J9Nrqr3pvB#jb}2(u+gGCd^;FbYkhgxl94w*E9uK*^Ou1
z%4y|w6Wo#0r>&lJi^somO|jIA?yS71Pq}<cuSHJyd?mr3cNQ~Gb=HLg&Myp~O&4p_
z{{L-uzq+D#O*i8l=loM^nMEt|zMngjVD1{+(Vm#ayYb$_9Le5y=B9668B9tPeKze`
z#<H@F?>4<ZJNuH!{e2swBwd@s)Iv8#sg{Jj{>xw<a&bX&ea^T4M`t9wo##FIhQ<10
zC;OXJZLJ-SOa2KiGT-sg*kQ*KwTh2MlLfyj9Nutz>WL%IO4V}s^&7g_ME)9dn<nzf
zPMNma@(;H@vp^odg($1P%95n_jE&!?TO{iL%ock7BXZ}P(+3T?WDft`<hYirPkfEE
z_6f=Fi)T9=*3FsPxrO2DR_nhn7Nx{xS3j7^@BF-ak<V;J`}cQVU$ouVbeF3tms`g?
za<-kY>eQyzm#JI5ROdhAJh-AbM@O^e0N=*Yb#dBrrk1*_`Ng)l`Rn!gXIsN(Zj@N;
zwApRr*Bqy}*A(5?YRh-<O59SF<;t-9y=zX;<eGQSubJQX%Jr!(*~Gi}&CN!^kPn?P
zXEr3=b#vw~*pO^6J?Kf>*}6#a{iPoE3dhp|4|1>>XnOBiwB3AudXeez&gW*cb-%wc
zKEd;zV}4BQv7hW2n?L@L+*_6t#}V0Bs{c4y+wH(jABjc6{wKnFQ%)%xq&-#Zo3_Tr
z$o1~}W{KOGb{d9m$NsIG(srV5|Ni8^>LvR*H_xpv-oj=sGAU!}`*WMW20O*v*uLv{
z(Z@Y0ty(QQ=5Bp&bgUUFTiJs5NVJ#V_##;-@o#ru)h(r@Z{ZT%H%tDr@@#RIH?+HH
zZ@anf-{aN)RhUCxR<5mI!tYR(^`(0AzN6nR&0%&-*sw;%?tj6|{Xf!08#tzT`t4cK
zsvyShA^f4Z{g8^uy;2j4s*a-l9fATDo-gXF=j@!yu=(PN3cJ4E<#Q)}`PU`VY%8HV
z|FB{i$3CAKXLQAi#8hV6o)%uU@MY(1{&kyEzGmn=zSnjn^+3;~Qz_mtYu0e?6}kM{
z^79Py%7gMNJ6CR=d-z6OR`s91Atx{Xx_kfM$M@gQU7DHrr+eL1VeYV(dGYy2Cp|Pu
z+2~pkep6}BcBM0W6fS+<b6xk9@Xy=cj_d5N-L;)ob?wjI9g1@WL}%>f_<H&6bosL1
zr{CXPn0%w+nfv1lA8Rh_Z?Y^92n&36Hu-M*eTJJ4A1!)nmH2yh;cE7NcYF1!iO1)=
zsvn(yvg};gq|(qIHjj?{fA_iLdC8g&|4Mi6`N%v$V|xDt_jq5&ZHWw_4wnzEwmNZK
z`+LNV(5)Yt6~xLDEx7$IdoMRsJ19{r@zk)-V(zPT+&uo%*YuXNI7%Md_KWlUq>lQ<
zY_r^zp49~Z{k3*h>Z$nsl47F&*Dm<Y+Bf${`@)Ae<gP8;v0;;@PRm3aex^^AtGG*M
z{?}SD@77+^EjnDu541ZjAG&F2{Q7;K-v7$PfB)F48M7B*_BcR232=|Yz|xotx{K4q
z9J9w^K}?ThX|#9$<70wm&n(&*{;^w~Q&P?|pMBPyN&Z?JFG~T#aS0Vmo`eF8a~&I9
zvOKjOe^lI`R9~=aeyHv?H|y*-iQ+-4<wN6ZzlN5+KQ8M1qid!8xA$rFe?R_u-1YkW
zo%pkLU*F#S`g{Im9y?F1u#Z>oKHmD1F<$iLssx>hKVRk5*Ba;V{+C%*{(b)IEnY1r
zRC;#aj=6s&d9~e>%0os!T7Pc1x$W%wsx>|lTE@Q%cVBdNJ=8tv_W50L^~WZMOndkI
zalxG3ap!;kOP_e@Ea$`%Ay3L4T)vU}CF<m2Ntt;|JSMN%;+%iA!Ke1<o%OHpy;<&K
zbf?O?@9>K4dXt2<@5^7lvMy^YqtOqyB}cQ_UMzc=;m3V#)rF|J_m&$aoV<JP*S5gP
z{rXjT^9ufG1<J2=4LrbiG>g}IZPDMOcf<5&9f~a8|03_j{9QkHWZr-OD)PT`uV!SB
zQU1n_@8+NJKdo~1@5eUx*OF~<GtNrw@nBiEQT{=4uKYyRrC->C=Uuq`NkzZt;n@u(
zd3$HGSqFL9f3k=yPUSp&|N7<hyw#H5+8^^Qm-|(<eBZg^)a379(;}q3r)|iH3-EsT
zdfoLjzit)x=9(LC*Mwgd+I#E#+YE65qmu$G_J4l--Cuu6etD-(;k5Z*RU#)9@1Jh{
zc8ZITg4tn%yj}a|@$OSOaP6#tT=njLCjZ|SeAV0+d3vAnC|?!4d*OLmP<5TXqetW8
zFDb6`o^-r9yTB*GHcE8n?JI{1-k6I`%~pK4dkxd!P)_Z$XYTHat*WUMd8xK%f8zEx
z|K{GcNUvkxe2n=>ZlvxW8JT5k&nEs#JaU-hltIbmnVb5)Ul7mP{y+C@es8Kp!`b5(
zPS3i(e|IUL!x@{y^P-a1$vEwKAd;SCWgIz6jY;uSk`9yMq=zqMm$NMIpVe|?an~eQ
zo2LC<Ht&|*-u{=x(J1qTcjxiHj`b5lR1KCWw-!q7_22#QAPa*)bldAv+avRN6NKDm
zSFM}7G^pgVJoogCwp+g1>~v0Fv_pi^>{qCrhw4|Zh75b3s>e)^=CjT`YNYd=V|v;4
z*=zV!nRd+6Z7`N&EI7#}$aF)O)A8vw<v@+eQ>u5@6?Obua#kaBn&sI!JmIV+(k2d%
zrgn31w`Cm*|KZwx-FN%z2G_6WT=^0{%=8GppLip)%k<irh)H3pTbKQ8)0X=9bMH16
zuA55AGgn;{-dUn$w12{R7Z+t0&3Hw_Nhjas-+H2HIOFun0K=8yb3y_>J`CV?-psJ|
z+G$O;{>6_bEjk^%(Z?dqIBnCOO}T=*7z&zCb4N<vRC3I1yeMJLv?gTc#u&~G+Q~8e
ze}jGQGss^yocHL!f*s;=(ThAT`8@gbNhmdFT2E)e!i{s=?gm<ZxR%B~p;Ob9sayZl
z>Q%pbil;IZnJPqFv1XkSw7}`ZD{c1*$tHs)rC`RMq}*+d2Lfd}Y<5Lk@aQ+n>Aw?u
zFt06oZ~gQesVr8%o1-mPTQqJ66;5zy$x_&4Q71QnC2*?m+X<XqM`Ta4u(M1$ve@tT
zyNkD2XKZ&;{QE&j__odBvRCz&?fYjf@UrkLt1sT#-Bq5Da3EMtVd?AHvKm*NZI7v)
zYqXm<-)Gen&xwgKl@Sd!0xIj@_f<RVFIpse`0v@0nhjr%iriK<Sd((k`PY&CHf3+~
zg!K(iIk9dze|y=Yh#Q703{K41Z@@c6i}mwQ6~S2cve2+O>}?U<T$@&v7#(gp|5@f^
z_4<$p$Fye7ao<$tclonuPVS~z5lXst*?Xsogeb|BORK*y@Xh*RS3a4|aoIArDswp>
z&uc&5e_C92=PJARYL`_>at}I+rz`F*`!yxvW&Fd7=U>m7!uR@D=DOd@Oj8$~dRKRP
zYoJ2qtH8!W4ln-|PR&YHvyPYLh3w4fpYOSUi@&&}Zk<cjw8oTGKZC-`J{i}{%w+ns
zxMrVvXT*`~9uE`t{Ax0tP~u_rWr_2o9EN>UyxcbXcHHq06&A5!RP0KMEInj*aZZ>M
z%Stn=+`k49y=)IP;~Ez`HfRJkOJy`)IU2bC>hI=<wh8H;T$<5NQ#bfTv3dmhBos0g
zbtl?(zS`*ZILf~N$~}b>6PV6!Qv5&vr~~Kx8plP(e>wRs&3wMvG=yd8O5Vn4GN+33
zZ`8kf;KS8sbFHuV`j4WfEt=mBFDsP~Kj9z{bv(^()*SwsdtH(`&5DnGd%RIv_s4-Z
z8Z0rl81h3rxo)<+`M35er;2^h+%LJWPi{UCA1@g(RlMVTK#pJQ<FcIFTi4&|*%~6x
z{CWSg*ZU)6Co1mEZ{PU4_C@;V*=rh@1h?+n9v-)^tF}bY=iElFx_4FAH*#{l`kVOT
zcHO+Z+Nl8>6ds>{`|m>E)?#H{r@PA>tdcL9$lhAEJ1b|xl%@9%e%tZh?CzhWz1kOc
zcXHn7VtI4lW0kU>>Z(mE{%C$Xeo}PvlVJb6CH@b+<%0Is|G#_x|JUZVIUe6W&0w<@
zO1N{s#B=tI9XyYCPxW&hua)IK8Ne+W$q*`Z;NsDv=bXGI^(CJ<yKEinG@(;DSK`m#
zUU&0Wt+CFQfXe9{3w*1u-Y&Q-^I}5ANsYx#JK{FI`u6l-k>nDtOR-1Hdd;$3gI|4N
zdYL*uLf{Dp|C@<vs+l6+rbXOjz2U#@g6OI<U#$x{YaXsv;99hA)q*22SDGEW>>LtJ
zZ*E|?8RfzM;+VNXaHs^kt9fn$<0GyRy?uYZPW@YcZpPgB1I>p`U;f>pq-ay=(ZO!L
zWC15zz^UT92mE*r|I2cFsxyOwXK#`6zD_;W5H?<}RhO4ONSKgtiQ8M#@G;vT%Uwd@
zjZedVne7YWTD<wF*C!Q+nGK7suP-}hx2uZngOtnhui_ex_AH%2%evVVKiF(~zU}S2
zZQCN%7TSGz_%JkRXGWCn8bOYC#t){c^f4akpC+S_SaB>P>bi~glSNJX8N4DNJWl#o
zJSnM<ie8zZnE0{u&IPA(1-*sNvwxW?6h-mv;p|xc;X#zo&#O9i2dqLCY+SO4A#r1@
zxK-7s>khg9f3hyHJ8SiDoo}|$i;KVFel%%l-^#Rpyi{lUr$cgFsY2$5gk-z#3bTGM
zn)cFzf7w0RzoEA>IRy)=JGosRJ6!Ly`}ymb!Nmv9lXTb@|Ejf$d8WOBq04F7GWG+j
zWwr#ZdU41{^fuEU;eZX_7O!}x@bmZP)`M>?wcI9I9?q&f7E#uDgR6AmllDFDJd+k~
z7D+zYQqmO~Rcg*KGw6XMZ`$YF7xni~SX!0_ym3nwJ+$D|<~K!K!c=1RcRG6t$sU&!
zUs+<(ck93UW20O5S1iuDWMZpdAXYI?Jil|#d7~?ms{)(;=63fADwsI`&d`=TXe+R8
z);V#-RW?U&Ex5@yInexJ@68euE%P&epRXM&aQ*!|FmI<oKr8=>lU}R2vLC0h&))Ps
z;MKS5>6yyHiU&ml-mo3$bvt@_#jM0{1xs8%SiC7)che~^Zhr0t(bTOuQzm3Se`sLS
z`!z9JFYMr@R`=VwOadqO8y{;BnqlB~B`bP@`nxBRdsAzpA10mYoblq<vfCDlbGx6K
z7I^)wRN7<7^?pK{jcvoEpR3bF!j^nViiw~4_O@^OY0=0R^NvrK^}bYg%;wtPD?6ok
z@O1gTtN(D}-1)UfP3O!|I1xS9%k_O_P8|QUOHM1IeYQuhS$N4+$o9VKi5r`|1@83!
zTz#79b5g)>QKg{YGqtO3#0T7S$Z@!|w&`@)4X@%mKeZLE3Ve&cd;Rj3Hlu=93-aDP
zpW9Y)^2Ji^%6P}3rdQ4l>}M2<qvlSu<}kWv{@@e$N}dbb?RuK4SW}`dZ(8#5yvf$9
zpShoz{Ww^qfBxgLM^1KUHr)A}!=dC>k?_gDHa}{OZ)CtMD_;Ji8y|Q-pS)_zy&Ri$
zhr|5dyt29_E1NrAj4P~ul{&*giO_|wRByaqJ9UHc$DfI_Z=@XASU6?YT*E~?-`|Bq
zxJ}r1W9?Jki90(j4?plZe}3VivsWTib8Qnh_s0la+Ba*-+3;K8(cCMeo?Th3Vs)Z7
zddi*k$4;jDADXwm%1h97+nbrKwGXx{&2UNhvQsX=>HC%6+>b+a9v)xWv^_E4((D)8
zU%m{mKOQC-J#}is!Y|9dnD);8HkrGuRNQaRoh|co@|4eud7Nza|Iqg~<-V9#M{4Yc
z%Kyhio<_WnK9P0z{V_L(fR-u+?OYxe26xMErxq=jm*OaKe!5E8e^#hqREOQ7mCyeg
z$S&CT#-wa%h}Ny3ydQs7J4oHUs{bv~XW6>18-M<Kcw0U{_m<N8Y0JzenW#Ug|DM5W
zvUJU#H#0Y;9-VS!!M2jd@PJaKzmxTE@%GyOjCx{t>HC&%TrYm!C|`C}*v@D3+IbHY
zuh(h*&8ZZN<4b)d8~9F-L)-R)wy}Xu&4G~6sk>Awdx94JNb;G;Irq)A$CsCHUvc$U
zV%##n<Q9*`%@R*}b_biONgcN7Ii1=4!0)S(9J}}F1$C13SGm6khOM%abezEMyfueG
zc=CfI6<<{kCzMP)x50_UEB)QKwPD5wZa!1mDDb80^OE8?HB}{#)1DUB<?bhm&WTgp
zwqy78CHK3(a_?jhxV<Sv#el!*ft5=f^Dgxyr5O)DZ57|Sn=xeW9q)|fr>Q@#9NC+=
zS!db(Emev4zUJCWS#o^pyTb6~(!8U3t2pI8zEWSx^tgXpLX57%JDr+S3NlQ`rC+a$
z|DEMubn9;IHV)3MKgz#yY<Qm)9=u^rdt&0%*m;_+j&EO@{>&^^KJ)N@ck2tOLk)4k
zf8}N$H@Q4#_xaMKlf|;;-lApNnaQ74-_S{1ee_(>t+P!XKAG|Azl6N@T87D{*`K;3
zt;}wDUz*qD_Rd@b$va{$+Zin{##yt}ntqn&_tSRv3|+WWf5W8iFEeZS9(ISNSvcO%
zp73g~pxpzd_3O`U^OuWveEPgnAj|7~Kz^0l)7sqo4;_=*mYiSwzp-icj9<*to4wY}
zxusFDyJ}$spWL*`Ni%J3vCYkk7vV7dyvb|ol;p+vsnO0;6y4ibGL|Ul`{{*#oprET
z`hQyc@f8LujASJ<`9H{b@q7GXEp9k-_4)n#YyTCl{r5+{?q11P%&sn|3k&Y*nj66n
zEHXF3=<1q-=GzGF8`~Qdz5dQN!E;Ynve&+Rs(Iq@zN?OVtdv~6Qo0yc1}`_9uwY$v
z!<UB)jeAx<4&A)lYTA~vH|_tv@tst(yz_MDj?Qj|jcb>lco?(qXPTS7c<Mp1r9b)q
z$GklkH*ar@!S6HwH{Q~fi=8vq{xQ=$kzH4E3JXi0#U*sN>Cf7vld^Zmjk&fvq_*9D
zxVgK2e&LNxQ<$d3tT`{Y=iPVxH^G5dd}AM8zPdr?Sn2-!=jZ-tR0bCQ$*eLyd-t5p
z+KPqRiXVUa{`P++DcqVTayWf$ZP~vydMj^uhkbVHJUZ!m>xS3=9#1>@q|7_6AXe+`
z_w%_&BM!EFJ6@Zq`oL9rM$`u<qqWk%5BEQ7PmR1%pjJ7@UToUNpw{C1&(4Lm>Xb&x
z&s}|0-#UDz@7~n9=VGR&u~$U4hH_4J4ZWSZ|NPsf+<K=b=}udv@lfCIWc<vjrGcEW
zRl#wy-TU>${u}TepSxPub)ndrq|$>|7v)KXaiq@qbaC?L&+7N}pMAVAckcfU3F*)8
z&-!m$^~?0n$0zH%`OnGO7fPqvhNszzpVQ3RxZ?FL26eN0vnPJa^%MT!6#A;_;K8YH
zR@pC5Qjj^o>fKhRrM-4*V12N3?~JMP3tY8#ZPHtE?T)qaY015s6_HIM-UeHP|2?;S
zx_MPYh0dykck4gRo|<rq?fmYO%4cM~UB6D)8n#$EdFl5&-PD+$WyxnNlc%1MT5aT)
zI_>YZy_{Kp&i#4p|DpV1#@ZA6ALlFhJLiVZY+z#DC7!fKCOabH_H6e#vsPa``Sinj
zzdzv_9co{B9awl9j$XKKRx!`-JhS(MCVt%+Q4>B~lP<P?-PG8sy}5X;SI1xJeC6(2
zciVLK?7uFP&KK8YT+ClMo&Uzubg@-hs$D`;c0D<@Ot^XX?7TNcLXIz{vAuiMV8D6j
z=<)YV<u3(q?FyTGK!@W*^Uk_GiiJ})nBI*L>vD<a<J`Z6Uvh=3iOp2a(77#Ngtlv)
znPf6e-z+TFN8GD*?Xo=6H`mQ(I`O=i;PX6hi>6qD&+7?O+xOmGs5NVbclsSMrlmQ5
z4sER8xKWUOqUx&&-R5hpxr=POcl-U_b$E~N<IDG+=AL-^aZRkfuZQ?5sda%reXd&{
zWJuleNWJM}#r^z!)qmD6KOwt>tLg7k$y*!J9{%P2ViTKjOi?Ig;oRqElXuTw*H(D_
z+}_I^3jNO>_B_A4%GT%G2d)p>`hudSY7`h8eUf|KW=)PtakFZm@9whQZ*z8pHLO$0
zv2KofTjVAgvd3<9a|W}G>~f~JXBTDE->(*av7?H$XH|B*%o~3vkxL)M^G|aA-L$It
z>hHT>x7{xNy))YSZYZ03#G>82aT4=3XsrHjHbK*l*DZHdg2;a>7QZjs!u6(DSnTfC
z+o5`^t$F|E2iFga7A?|x_j8@yL^u0gTXqJNG_HQwFmGMgtajb_ua9dOwD)aXp6Pz(
zj{k2)|Kz|8rS(ru4;)Ti&+zTr>byg`Dv#qPoo4UnGN}~q{S@0?9dhwtT+iDt7ub{b
zeBAn3uOnY_{ic#-SK1oGuS~hTA%A<BFtcsq<f|KQ%YOTNitYH*^sq&$cf2J{CtSZD
z`<i#*wzp-UV&YFfF#NqP+J8lvT%vj#lS2H5o!2EQ8d4Q)roEQ?bA3nO?kL@rpKGt=
zUcW3Jmey=?aOJYY6|L+JE<b~Bhqm_}T)aB2|1QgE>(#Z4H#^w*XS7Rx<-B6Zwf`1h
zyXhiFUpan_I?d)96+V{^=II<F4;Iyb6VT;4cuhquQFYe-zUp@usy!?>OCJ08c7uB+
zYeKx}BfeFZ{T~<tHqN>o%U{jF_PjJmw2`fVy|c$<ioMV~!AU;bnV;u8Z}$EfBy!L`
z`A_Ez#aO3ChSf<emDSe^Z@*r6|NM(XI=c)k&z`(JqvN>z_O~xWg_@tZw$DnwICEL(
z?zeMRNhe-158XOFidkN<Vz+yN_SLlyw#}-J;rKdXN9w}MOv+ohWeTpwf8WgOUu~^X
zb^67E$%X%)`xP`y-^BG{)5}|ucQ^Me`}^a=XXlnYp^jMVv(MM>KDkdpi{oEHTg7L!
zv{`=*&dvUuX>rEvqi3_jcOE^-@|kJEu`lkKa_9>knAQH8al-qm<cHxJ4o4PfF6Vrp
zb&+?w!povpx1O$>Tjyl3z_vx^oqzjt{bTn&YEE9{R5v#*;(lK?{~xOrrq5Tc|K*^o
zwYY18uSdMiqQ|+{ouqE8=$PZd>^oWIRPMW1n%#;;EfI?UR==9T_ViD#J^y0wyaP{H
zJzjH~=krH*yI0#fzF4WPz8)C2UtNp$jQ^w{^WO=5(%Wt`HBUJHqEU!xm2kLgNSkNJ
zlnTqe*A*>l#M%mY89BaOVJ?tlwAdg#X+!k+eohVRPbmTFF)z~-CfNN-R;k_cHL}a$
z&{O8mZ~jCcoh-y|ly>Lc$@_A)y4Q5WcDRQ!>PsCGh_SM(XPf87J^7RZ=bEUlOA4DK
zwF0JTU0dL9{-UN-<z~Lxi7(OTOO(#<$~#_mopJr^`)uKC;!3qU=lI*0Z&@k3S6TSO
z&29NLd0o>ScQO4@Y)iGMIJGkQq~!#L#HyNQJViapTdm&k-4=_?=IwkQcj2-`nAmF#
zrr8tDebLM@iu%luGcU;0{ne!xeFn}P?_--Z3tKup#21QWH6^^Ap?N3j`P!f*bJ;yV
z*Wb>Mt`D7H+H~})#T$d4;S-P9|NHe@eqW)2QZ}=dh|7YWrmW0avA&avIy*v^d~5x)
zwZ(vy$%a>XnZDD-WqI5;3!QGV=uR@aXv#QsrlI%DAYZnpEITJGpQ_ThcXL<Dn$7Fx
zT*wS%W4-gHIO)v7>^HT|k5BxV@?wU~(c6qZ&Lvu_9xSLmacGH9=JBh`j^AA^F~!nn
zzMrA)vw}xfuh;QTOu4^O_N|SPgY!+cHpUq{)TFl-M=LxKy1B@D!q$l<>JN&<GX;(_
zHXYZjog&XL|CB^e+i^LkQf?jAM>ZeROwJWPZ=c<gbh~Z-t!)nrFUPH3yzFn`Vxc1w
z)C>;rOnoi6&*b!mmt0S-Bu&fTJ#DJNUmp(h+dB36xz{&ov0N|MBRhM>vDeG}emoZ2
z_HxrE)(Z}|wRpDFXD%q?G}Qn5IHz9v4D0(%OTw#E0xxOrb>%3OSFCu)k$TB>!lUy$
zp9Ia++TM58+i%wN0<$MF5AUm=J+17|=zUD%>^&B~iHELTQoGW5Ehtm!v1THt+ndfu
zlLB_UwD34=YT0-HvBeqPNt2TM8H`fTY+r6v=d3lkt*>g!xx$TGSQrKL{JjKHJ<j{8
za?G??_xs|Mm<WAN$J;v;E^S?Z+=qMX!^R`&8?Kbr%{b}9cqpd*h)KkPT^?2{$@{rd
z88VbMEqrtB@T&Ru6OOG+IyvF-&IHc;hAN&c9e1=oDV#Xk)%vzrsx2v<rS$7>z2kw6
z`%Mj}-%k1wS~&ITil%GMb!OFftlM)IopoW_C=w=Dpy>U0&hC>@ACC4H&v?|PwBwQ6
ziKpDY50qwlnSC&8jp-=7(aSuucK?LcKE1mh^qO2^Jux+t>nF=<iGoW0uF4}#Q`AFU
z)^znnXI0uC3EJ}eyQiFVR#13#`<kG3mkfo1E8k|8J-H>2`{nZzlYKQG4r>N7mOYT~
zithF~9nR&uD`4FbpT}%oXWHY=MeJ~FjZ98uRaINCeYt=q!}Tqp)yWLsIr0;pU7qF{
zRM@hM=|y4b`dx=ki2YIIEmJT)WAa2XXUlp9{<<qns=^DymNff&*iDI<eek<&#Tw?#
zoeAbXbrx5S=<-y{O#FQ4ue7h!?fqA_^eSpSUHjwz`N|tPvD)5&%Cib9x9Gk6RcAei
z>+7!1KjytXb?jw}FxLx1Z>xZSw#gP{Z|ieU9emI<CH1$acjSzX{JCfEPYn55cwXm9
zyC~x$hfm&x?@N5O&u>v#7qL!7?0fOulsIATaL>!%dz2<@yJkHli~nM|=TkXvw<5kP
z^KPv0yzS}9Fk$_qTdQwIR!5pH`{n!Q%L?iGLlSCdFF$lScKz=wT{fPX6VjrY{g0Pz
zcK*1^BFwPX;Ha~_kGbQ4)7GDMn0#Hm|Ig>Q{R<ja*WG>^ymQhP<>!6g>30(EolMTW
z5f`6d{rv3IO!i}oY8@UZCC3^iDqKFdqI*_P#jd+XEB5*95S^>GBsVX(cAk~G*bC18
zC%22daM;^tuu1ybx`&xoiw)zg!kct_cJJT$L_qM*77q1~Gballw`$t=CS6C1&sop8
zSSiz6s@B?h*-X1?8^7XNXH1^In|$KN(a!>mr#3}uO1!(|QuSQ6;oOf8ueyS6y}rnw
zrlQV!_o2Z<o-h%oxnDX|WVLEc{PtNMest{MoPZ4z`DN~%opbVn{q$Wm_tX~OK73`Z
z?)1l#j+N(S=KL+Ndir(o?^%2aziu+;{(H5jl0UrvM(_EQl3Uk3T&^0Xt=rZt9n!$$
z;jHc8I=Qe$h-Y{E51rpjJD&V>P}|&7-WyR=cEGO4KiR+K+mp-fneT3ye&S2s|Kp`=
zSwr#l<69?172NBY8=fc`dSkE6jkvw9E13i)cUev^TAuj()bhV4SZ%ZoS1$0;xqe=4
zS9MS9r>}ndg8m&+ow3+T;KAgXW^b$4FkcqV{%t8K;PG((<v+=Ji*MCz7n69_zH{y+
z$2C)Lg-<?{ku7-2bM2e*$-7pbxw(JO44YpTH+36>85qS*ZCP~o?1E``-UYsUlI)On
zyPC;f@yPpc2O7^>Y?*k9cgdE&J)&D=ziv@AZ~1+ZZ|TZp$CqCJz3#Uz(_I~)dw8kn
zoTOX2-|F}T`s^pPaEWsX#!Xvy>90ciy)B1-%$_rAO76u=Za4Mb7tS&{^`}PvF4w8k
z)?alm?*9C1o$qCnSJ7Ut1NP6_*DrJAb@VkgwZ;4PpVoGWy1DXP?7sDHBQ7sK^qgbb
z_Y2kyi~rsKGS8~-vUS;wxtmk|PM<FN+y2Gm=?;bOf|kEEpZn_5mU`WvOp`KS6s1c$
z$#4Yzse16K(Lw2$0)M#M@ntS08TVM;&iMb2ds;(N8%9qR+ye#oRL#r`VUw~Jm?xZA
zm=QB6dp6oLU*@>zwx_`retMQ?&k8NdEPWfwS+YTfRZNMw)A@*aoZDeF%a1x&bQUeW
zKUIFl_pJ5rUP)dOYIJDO?3c^_`AYYG^s~Q9a!)KdYX9$fP3gCPZ~nI2IDe@BXV#}z
zf8HGR7qZXv$v*Mq&#N<knPzHOO>{FWD%xjN{p-oipY;ww2afj!>TaC0OR&U9wKwG0
zi<3W}-n^VYCt~M<PfR->c<-0fXSv;0e52v>wx?llzHj}S;=D4`R7S{k-!}K^TDza>
z_xdHX`t6_c=G@q}jL|W(Cu577K-^x->W|NkpRB8XaW3wUjbgff-GTpmejWe*;qlpc
z_4v7a>mG+yF$8V!Xa4QA_TwLp@aWz1GG?^x|6TllXPN1(89pwB>Wfo0YUiq`RxOfN
z?U@+%$urlmC1IAg?)85WTJ^3G{TDd77N1d9U-Z(Yp+iW@H6l4dusMJ3y|kGR^&UQx
ze8)3kL5KCjAD_7&oa+*1zhk*#d&}9K*MnXq8d&nMtv@a$%l|Kwcg=_J_CN2l92$3R
zzGmQZFtIc^+T%fQ^O2*MZ#gj?uxj0&6J3<QNAyMcZ`F_QGCdANZ<oB0|9YF=o0G+R
z^ye*HlEboM+ZTraoc6oqpUufA6)LuC*b^f8vSf~6@)Xg<lCzj>LYyWCox2ciV>W98
zzszrzd6%*e37p>--LP3q@8RrO+(k?YCvqPz`S)l^hN3HH<`llT7mrqQSWoNrm7FuT
zVf(D2EY;QK4f~6v<bS5J?Kbj#wx*YDKidlJr20C>E0t%%rJv7K$&Grx>ikC+uBVHN
z<X%a+xMm+Y^3!SNloj%#sf#miGb!bN6x_$VeW}v^H4LZQk~zM%GF?8A+WNIW<{|%{
zH>PqCCQ7^C*gCz5_`p9+v-I|+!llN-B?rYO8TKaggiZ8(yyWtZC5dZTnK%5eD8HP$
z`<B@ilQ!<SxYc)#iP&Xq{Osq!<@-1NxAbl^#(RfDe|%_m?)|Xhn6$L#Mf)Z3f3545
zaOeEb)@PKS5awPzD>wYx^v35ecDTk~dVA;-^Eva^ck8y@d%WM^vWHu!3$M=GM>juf
znXSrX6_5LL*&`syq(ASpRFlwEGY=OAR%^ZozT0=~D|B~zSTW)3)Tv8(?LRW@=6hG0
zDW33?Y4zFE?L4oS9gi<Nx8h-p%k+Ma)JNfWKUH2$ZajB!$JgtjQ{C3~d@Ed`Xqvjr
zRh!8{m-8%xGOr}lvQNJH;^A>Yfk*$ehcEc?dgs(M2QdxqtZ(aX-!GjTDwg8%QvRJ7
zpNW=3U`j-K`R&qo$-F*BO=h>-b^T@Zs(Bn%eUn&{`SP&*;r#WJ_0HTeV_4vE`}#T0
zsQmt$>8pP|X5#iYinm{R+<pq@wt4nanuU!2U8H+$e9i4t=G0gg{NMAf$mh9#)$W_+
zum2`(`_j)9Cbi*q`Rdzw*0<&7NQ)G_lrvFgyBYSDQ{SNG(50DnZ#cQzrRD{g=X_{6
zYPqs_{)3e0(m$+?+%tb<hhF12(zJcb)SWL^eY;X|!^rq6yWE?uov}3+4A*IWIQu)M
z^np0Xgp>(Ifj8Y)zPkv_So&)J>;turcfU=4FLwIqzs0pyR}JLuC-1wNxBF+^Lnq<s
z3l4ouT*sIFTR&{FWp2o?t*g&oo89MGz1~dw!oFr#o*7+2h9_E{hwS{}`&@3yHeTV2
zXJc$?OK<32yFT}B!{Sv(Vs|fK$X%v+`dQ_U!lJMv8cCYWZ3dF2pF+3)IiIubuBG;r
z2bsL*&l;?ZWqZj#`)S?wIkEQN4LVXnCWud%c%$>4PUMNwx4x%W$RAFM?#@z~n{GD0
z+}kAee}>bOke{C}@UGu*zvBI&kP^4+w`V@*RN6U*KhE>QyO}&2LV3MzEONG}o%%*{
z3IDZ=yxq2{A`et@+9q<}lb*0J`|`slyMLakR6H>&<r4G%b60zsyu<$qI&F>Dn7DdV
z&JA|kdoB#;uW2rqklJ@GOfUFy2T$PN8%!qxWanSrXTaVke0A}&`t6&u+XdBb3ogE!
zSS_j%8q|8zrloAE%;%zS7iVU7e)<sW6EMAd`R|+hhp+B-h&_1OrS$&QGu$ONmz)lt
zsQsG7uwsSq4BMOUzRk1C5S8`vlkBXk=-6Fxt);>3(W2*d^*1!%%HLHAU>A1XZ~5od
z95D^;3CkCnIXr1KK2frHYrKofeXILx^7yNdKiY9(b3?g&wwhh&yo0_gxpwb#@;u>Z
zc{*FcOX!TZ<83)p$?$}~Qg%$&n^;3k=I);L`{D!32b>aZrSUA8+1Hm;yvWoui`%|V
z=bC@Vmebky7pc`mYpy>ukx{Pg-8rULt5s6(GQ2iwy}f3hjIH}pySOl;gCQ=Pn%8Gt
zd!iH=@WB3Dwm5U)1KwpeS95bs?^$16*rs+v=JU~q!o3Xlo=5S&*7`Dw_3zPFOLZ>j
z%n}s~*}s9|TS5OJChwREnc$<Tk-R%?1r-)Q=y(`j@jKT%-ex9$@PVGDmoD?3ZN7ce
zW`k=->q+07q-m2Re&h(QP<ZOTvT8lsMBVD$Z_5PotX?ZE7nxL=Ss8hzVSn}4YwhB9
z)B1!?Gh5G>JNWVNS|&riJ5~aXKNBsv@A1pb?s_LFaW$=)bIE0Ex49bWDSkGp{Qr;j
zryMqB-@lX1>s#itaEEh};U05>mR)A?d%5v~*6QO7E5EeroY)j4Y`J9V(Zd$8EE_w%
zmTjE>t0B>|T+rZ|p5qb!AcJ3-hWlsc>X*+82?|(UvG;4@*K@8FYM-6BY+ml!efRek
zrY}ZEzu$d$x2*Vv{<V7+61pdpbA2pco8{e!2@RFM;^6jQlqqwf-Y*BQ+j|}eOmSPF
zImIhj^^I%q%VlZngnWBn#x?EuvGtUlNmYm9d{+6SIjg(gZ~R=z`{|lu>Uxn{uE&1n
zhu%~NsIC@E>tZ!JG<j<EJ{LcGjt55<_l9t7Y>{~<aOsTF?7h1gTR*Cww#hkF<9n&G
zF=+FwApR(kD*+|8GiU$je7Ys~=&_cy%anK?<Y|AsP`7Z-g$VxImj}1|=C~P8Gv!&M
z^7?bws!#gav#0VtQQsQ8TdE~EXYRcc4=;(%zOF0ZosJeIo|^sIwbuKBqqDG&e9W>*
zYvmh^pZ*fcnd$Q8-Nh-gy9+9oo!`Bo-{WZQYaZ_4_ZzNwXv!{TlV9a0&-kpvq4B_h
z3q~w<SJ$cOSc*w9C4WDyKfSR2kn2SA$zpFNzUB;`P_m`p(#-K<q0!5}t-I!Ll*#JY
z{p?QW0n2Ye@(e#F`YBlR?vPQ4^X8M-B_OhJYpBRF{=g-d%=YuA$-jy^6}9N;^y`;a
zF*=1X3jV8SlFD2yY_(46sGp6UK#sA6!_31R_tW`pA9(#gv1x^}Zs4s=Y&?ehHmyt1
zn^#tH?&&F=oc~tucX=OQ@o<S&QRflqO-`&uXB<==Z60qpeC~P9%TtpcNQG!+9dVoI
zVJf*}ZpNy}U0ESXdzIs4IYcJ!Kf3z6_U1hwUL{|x4HoG;rmVf&eZlL`3b8D^rd&?Z
z52&5S-~INV0k^EFvimIO8<y)$+sm$IZChg5E5oTVM`&&PGOLV~8;V>xDHr5+B^_80
zyv<z9D75jN#Bv>*ibIpOi|VYD^E6C7m2Vb)UO2V?>a~k<0cHK{EUWi%A1o_ZO$hJS
zk1T9{9OAd6WB&6r?YL=jJ5Llp=lJAy(843K>W`%0+^tR*8lAob*~V9MIXyP`dR6yO
zNz0whbM9OZWSTes>TSOl$=?#+ocVmGHz~4wGu!QLU0Mp?)TSie-mN-S#~`>g=sNex
znMRWhPG)YtT5EbY*RXWvvnJ&<-h~|sPLWJ|*1SC{l^6Wn;OYy%xVy8J-p_f~^fQ2Q
zD*ySo=F-_B*AJTBOIm)V-P($y{3(}wZN}+a`xh1{RtR{PcCXRr@_f&w9U58P@4h{G
zdP1f5o3FnwM4tE**DEg>y@+f1oZmYYCO`l8-m3oM8p9nCck^;TGBOzkFcdzSHvRB@
zKF!@ZA-gW!@wa=pCzC6r&{62Oy<EJ^c8{qmXDv`RWm8|#ed}5t<3WAXwUviGZPsNM
zO=%9i{jSV%_U}Wt4%|Oz9DHeh`s<_RtUB&Bc25Jg#m`PXSKeJ)npNtxBDdOS<yz&Z
z>e6CIcFM2WdS+Ew-IG0$s~<JqTwgR%H$Q#Pmw#&6mUGS=NbY=NuJ*8i)BpM-FVS!7
zvhTe(c=;=n>yo!~C8O7K3U?isN_IK$zj^<1uHSR}uS+)98f@~>_^`Fw^w^`#p|`!y
zlpS4k=Hj}D`lX5CZ&JK_*nMs937!6xD3`m;rL!zsTR`Me*KyZq<;hE9TJ;M;E*?{h
zwJP7Lee`m9?3|FT(J7nnYzf->y=`ZM>>S%kN?y~s*jA+;3qEr3nOOGQ?0Y*^wwA~4
z=vo=G^VTk%U(@#HuMr5*<zanipsalSpS9W#k-+-CnM&9C6QaFtEanRoK66>|@p4_W
zV}3W4yr(v96x$j)A!MF}soNL#zej%^n{kS#wE7DFivaPrFO_$CERC_fl=AZW$(nZ6
znoid(N4G~ry=?o~6WISNSNFF2EC;rvuZ5;^*IwlJWHP_`W%zbS@Qd$HyptD|{b(!t
z&)R2y<>tOq`|Vx24u3UMZM#%=y|K4@gQ2?%Yms`|bBi@kCz<U~F1Yvf#mT+whx{&_
zJrd8o>tsL2t}O>sJfo+6$xpgHhv{S2RVM4!v`DL~KVKBj`Y$ORb^h4<?{j~%F)aNV
zb7`5;oA{$C(z{!9-p{)GL#H?C*|fC1;?orkPr4Z=y9e@b?oX0C^T2)A0k#S=l>kNe
zxkimkS0;Ti`rFrKuJ`;n%d#0an|ZRPTkp1*T6uWWx75bBO4}|ax=);LxqbD`qV)AG
z%t4)h>ci(d3IE)r{BQ0ypOc9eZ^C6dOH8$H&aOKn_ie+!)V&|WLvr^#x_irhyO|+x
z^>s(3YY$(Cy{@#JrW_}szpOp3VnWSr#oolFAv{Yq@x9~lW%B!5u%PBE%M0$;U$0gx
z%QyHhvhChGcfr<#rqx${<Tk(Fm{P}O*Cl=1scZMY*JWZ|Yb;JoTK4Vobs-~-faB)T
z@spSS4Deanu`f1drLM!IXB)Gl<~@_&^v)&n;+cKH0l)JmeT_c1OyQO4{;l`k?7f(-
zY@cv%_EYxtbEkaRut8r)<nebqVSO|2IBjj2J^%h4pa1`vEt}upi8Wdp^G}+blu=mt
z|Anlox9g@KYgfFH;67s4qf)pg*v(=4?9>kpO1hgOs%PBZaw4^TUggGba;^!XxdlrX
zW$d5vf77>pUCF-1Ke{gQBpm!WYloZEj-!7}f9_iNF6?>jUp<qlERTI$E${8Rf9{!I
zjhDi4A&cLKbojeCx2C54cwYb7(!dU*mk#cIgL~<ghVZ4+7MRE5SQ2$S&ekaJewpop
ze3Nd^n;fiHe46WKuIb4-s}G8sR4W*77fk7uWvPBS^X1LV-OH=5@~@wA|DpVxq|GO^
z&J~m`J<!IWdm!<1VE_7ks~+tRmFWy!^Z()fvkxELJ-T~p#IZN?&nA9-_3hEq=$QvR
zLXItsxcg4;413bl)1h+5181$x;}@TP_Q#`d$GK;OO=)eppTAvv`d7bx(TM@A8U;Dw
z`ODH~MjhzNY&vZJdZEcA$u~*+^Xzp#fAUb<8T;wNo_My+8t02r)AJUmZs=j*z4tEL
zR^zco_uU8k^4@))EEoQ3iD%d2zePcci+lX+XR;>zpCNYR%Uz=xZiNrooZGi=_fb~e
zv^+1<CFDRrpL2cv*RMsNOuRB4FI;E#yGn4=sR!&+AM&3~QCYvJ$**L^J@fXT3+g>S
ztyplgf@$J~vQTSj&(0M~7T=5QyQ=g*d+PJRnc}On*KW-D8Mvgd$NfymGqb(bjp2Gz
zCnsHAm@<{iV_N36TfSc}e0AIBDYbOtX327~zpX{?doDRIkX752b#bjgpx^FJo01#b
z?uY2|9lvz*;T4%4gDLkscQWfpX?|6`voh~}+?~BUoTP(S&fc@G{O<;xMPDrE^oF`!
zo~e_(`$*!wH`7@UxMwsL#&6Bd_igC;vQh3$Udpq_A!~0-iL!2c_p(!`(~@n@I|Dtw
z#UWEJ{oMEVV&9`HC*NJ{h!9EHaJqN1$05@<)6eqN&abUpv3!^OuWkGD11>}gKE1TE
zI@(t>D%LA}eb0jfdyUg1yIox}gSv#Zw<(8Sj<VF?obiNb-+P`O56P!F^4aQ>{B)LV
z7GBn~>bB6f9V=ZkUR{3{VmarO-yYMn;HKRtFEo7%{?d`X;g*KJ*M&q*hQ}`rIz>Fs
zKe*B1rNdPoyC*_MwP|Ox{k4iaCf|H&BOTKwE=UYGDEi1axTn-%sp#SznlDUGTUd)F
z33X1Iz_?V_J4m8yVTVeiOx+sZ8Skog9Gd%ikA>Kx@1?g(N>gK43Yz{bd&v+f_iNiM
zsb)RR9nx!4mBLppjE_(}le~AY)5McKF2}AenKWUwYTzW6L%ll65w^D1f}|QWBOF_E
zPMK?-OgM6nAt5}%wdZW@^*?pNrIR=QH@RH3sr$^`ZE~*!eHP4m<vJzur1Gu1stugG
zc-<?mC>QTpCcS*uttg9$PbzjZh%8@d?R2LjVD=jhbL(AGiYG6;B_Y7FA$rdA)dvCv
z)UGbfd!1zx9%2xDVse0B_v8aCo0NV_KTk||>}=wfVNnk9++pzUH{;W{+=sh44JDll
z4x1kNHGdnol(v9~<@e<F$&JaJ@n?)CosW6EJxTA@@3o3e!Z8c~r&hW>Xq&|-th_ck
zgK>-SJH6uFu1}fvGb<WC-IkFepr5p@q~9xK=VXtkVr45#t~p;mFQ!*4ChNCebl1vK
z(QbLka*y;Es&gAn4lFuW+%~1sq&T=d;a%0~r*|TkH6GO~P0xE7UlSSQ%4uD>b>=Td
zTRmkNZrRG~=b1TgoOAj0?5*?k$tj*!ce$@l{84@`Yh9>jNlo&vwZ0S1-?;Mq>cfR=
z1!aU}v*v#Ox7pI+K>WGYLFe+%&X`|x=REs_r%FdzBI+Nhy{}Hrx4U^;vQxJ40P~7N
zA0!@#8@a5Q`<It@r7q)1!HK2kPH`9&Zh2!-&{JW*?e4XL(gIbt2^Y9+cy4@&syO2G
zmg#-qzgdbEj5)95fBjxqbz^pc;^G-ICvtD^X>Q5imv<}eS3`LEmWz@?&9}v_&E+-y
zxV1y-L(=gZ=4)+R6hu}oUnkeQpk&drX*+iR$%<S5_SPhY?R*AHR`ssCP~{yJJtej8
z8oN=7i%hV00F(CxhNousH#e(rX<VIntI;&$iI~Qh2!SZkS(26_OEuUl8M(z~Z=1iJ
zV?C#LBwIJDz@2%YY#z9OpSD%4g;k!jk+Jv28&*B<Anq8Bn)Ku|UcdQbUkEE{yK<MS
zNb5E%TGEsne?m->^M;e2kxYYZ-o-6T3s$e;UGF<@DWlHPePNn6%CvU;W(avd_fkue
z;J#M^VUkZHt<C1ndo!!(Q?=Rmk5hy1N;mO4HU<3S^x7ryb?by*KP>kj>-D{!tktsT
z=dZ8(_dCB`%BuTcOm+IiCrnRFMEa_IHmP3!{rFyh(cG5?#ZuRJBYu2fd}w`=W#-j@
zmnOv-|6V&83$Ul%?i2Ldb+#u*z)b&iu+qc}XZlZC|4!>ZcB;#z;^`zq<wcKAFKS4%
zoS6{Z>rvg{_j9Tk`)tReiIbZv7BD^#VCwBjH?oVG+9{lE@R;}A&n^F}cHX@CxY8xv
z&|Be~rQrE!<xfpBtMdigrk`1LcG>*i97P@tr3#TVmV%2D>ed=f=>D?eS+Sz*8BeQB
zQ-MQfGvZ%Vi3QfZe#F!9N8)w#LDASN_g-COa+*~1*|quc*3Eq1lUQfOzvBCATsiCg
z_P@@5x!Ek2NjmkLaI0+5zrQRl^heaQLr;zvEr0P%)bDKgt~QD8R4s{VES1h(0n?Tp
z3oN&v-5L2Nbe3_$A<_9iDl@V_@J+k*&N-SXv{m!eebMZb>bu2$)zmzS7j*Ty^)x}|
z^V8clkMDcMGBaO%_2lHK2mK3;oxSEC-Pos)^KAZknb@hRFXjK*FEl-9{<rx5Sq6#r
zd%bc^8jSZ<Hgr!a)R`{7@4Ee-eX)NZKf1e$rEKRV*MF~7w89qoELo?mwn=00q6=%A
z!p+6?^Y=yi9*&9M^CwYNFRpIs|LU)I#XmfMcKYgjy}0{2+O5AiGdIj<`0e1d(W~U)
z$uA=NcsnD+-*$;E*uL}e{3fxDTU2ds)}=lBxt53XXK7S~|Bl@vho)>0SGl$>v*+fF
zqTbexkIydAYqLtQUGALFe{_+vf8)PGFOxk@tm}i^SqfwHJ+=m0S<GhGwEAE|z{$%?
za&xC?M4Ejme%!S5QkAXl4VEC={QcMCYd#;IeRNBTN(aBpuiRX%SE|c7AMe>G?=yuZ
zb2`h}^Gy#|p8w$WSWU(8GVh1O`zJ0CzjD@Ox8xB8-9wx!WhHi=s<7F?d_(%xd4r0L
zHVhF$Wek2fPDN6mYG16dn|EVz(^QrzXN~?JU$)sY+p(soX2ry-3@Mk6tvh$((V<F?
z>AUtn)GKFmH&$#(YJ21G<wcohQ=sE7A2GKlMy195!q?9#I+t(%YqrCT<NN;!cUCh>
z9Qyiwd0T{O^3|}gDwW2&0sCja&THOit2;Mdviob7=tRb_qgsFeUvdpokv!13H|O{E
zmB*f*o>;W$b?)X1Vuy7ZMEr|;n=EE2@+=eh7oxR-li92LEAPA)!3r8FYgF?4SZ1ZH
zJh^55S%Vwfy!yJ|{fpf0TYCSi$5UaCD;y7AC>UM&@s<D6g;|>vSl&%ZW!`gc{{+$H
z7JTUoge%$3{ZaY+Zj;pUpAA3D7hNtdzr%T1Zf~oFUE_QnyZgxr*M4_a?zPB0Use5n
z_BPi?CnweJ*di+Lyf}XO`}rT)W_mv~3~nk|=z8LH_`+qMwq>S^zb#tp{aR*Wkjyl_
zqH8kWKZ#vCvvkX<2XB+_h8}C{%9mYeR*|s#KAV_V@AN$${-J9pF>P(uR;~E3h;6gH
zeBVV@o_h~97sX9{@o&@eCA)4*HD9#VEh?N{ySeO*JX3PN#JQk(vm767cQreF=Kjv)
z%@4}Ce6EG=xmK{;H`~XvIJ)TA!^x{G=7)U#=B;qHr1g68&6~GsP6?g2ys*6N>f|Zq
zTW+VB-~1K#GIHM9MgzVN7y6SQ&*M$mXr{DIEjsm^RM85R_pSVnu3<l(_WQrM&VBFk
zFV318Bdg2LJOg*V6Ijia_vyR5U%q(j4DW@Bj6H^ylRrO+3<)@=oVsn#(h08np4jbo
zI`??)v1c|L`rkF5P+}8)WZ7?XuE5c8*2kAV6E@4quKv7yisSnjk@Tne2XcMN7KEr2
zrN6ja6LEdp`a_SN+)Wj}y3B*`j@gBSUlx5{5X>`2d-InUQ?CZ4EdEz$yW?Efqm$hm
z%^d_2TI{Z{|2c9?ZT0dx2QPire7ASM5`+8I&Nlx|(z@~Cy8z=a#;!#>E?v9(cZ)sm
zE@h70$0X*eE&sdikI5;ytsK{{_r<*^)0}+FaNf>-oq03uBrSML<yHhAyyfcumD9h7
z>Al?S3F%L7eGe*F^L&n$XYtmE>adRZl@kO?v~IA^k=b_fK+(OGTsj9EqE!vUIM?-@
zoO&{_e9{WdKTe@nwpl*-Y(4Yy^Ol2rFD=7bxRPvnj{80eUUIhL{7Lo2I@9eH7yDe_
z-1|AGeM!Ka@00F4w$Lw8Yks(6<~PU1jI*3mq<W9(Z({7&obki*UihWo3X)-x^|>3?
z89vbMcjVgN(f!10Qw_(GuZvav9{f6x`&M86`z}Xo^LHGaD%xM|ZdUY{I_0%WwjOzU
z`jOAc5JvIyk@wzuE&F6q>!<Pd+Y6sMuXLwW?nNT$S_~5&b$wCRVwmtrPJDAsL)l!3
zqx1cPj?R0S+j`P{(R@3j4KmYtYMl<B5xrWns?2!%n$--N%swZ6oZdCtA%E#Dsbv1J
z(m!ecBwaljCO=UYNzK0P{wdLB*=zMFEY&x?`)_WT&3VErPPmF+m}PN0*P?gJw*LJ%
z<&a*1^CSl$cgwp!IO~4hsasQBr4-7c&=QlrgsVr*)81<pE9X@EV#`B;3q-vx3-C#b
zc^yo>Sv;YA-@)U`b^nad9iCLBptQv5?qe2<>nt}C`=@@74|s5<&&@d6aLGoi2sP&v
zMX3kB8f_FS4os64nBG(rSheL~SHip6&Cg#hWN*1;-TPc*LWW4I*wkgOPWLb6{`Bkq
ze+HZCc#+gRv^!D3ojq`;(A3ZfHg#)hjIqer614A@;3DI@QPKUkkBR18-u_p#s^r1d
zH!+ot517hcE3gS2*edSPkSDLvxqFfB#Oz6%X8-B^#{T`x-yV}&cSStqxtO;(PBec0
zYwr6wGyS=}ZZy5Je|P`uzekskE@w49|HuCI-$z%!9=&QEc2GFz@+{qT`TB3za{@oP
zdTIt9eN<Kd(Wkcd@53fhmlxY#JgO@G_-1Wgh(PGU>F)xK&)u!M{z{%jy{Y@qUxR*M
z`@8&)*VIp9U1^c?YTrxqUy93JL^dq1-SILnpFi0A%dh3D%VUx_r}q>qNk;2b`mQ=v
zvw*{RwTHkCkq9T(S9@B1C3mU*xv=he;-8xx8i~yxF7CRymVb8|Tcz6H*OLN0PZ<e5
zxcxr<|Cei;>$FtwF4w;=dDt^(!zu0Zweq2EI{Sae-rk<P`S#7TtPd~RwXZatUF5bz
zV^7xSZKZMxjUsYiefxgySI-nDt?z&0_iuTea7`oOsY3MTxb4<A!d`#Pf9&H`AyOQb
zf4eqYHsD$(^NygFX{;~ScT9QqcK(}gR^OyfK{e+CcWgGlUvXsiB!egOEw}qPrUYKT
zwD;2;4L{Gw)~WwzMDI|0;234QWrM=j9`5@!Ywv58_Ozdmd-8>SYsi`A`@x^*G_Yz;
zY&gG}N$uLtIonq{eSFU9Gu@N*kLGgb7bm+nTsBv$`Fbz$srt&PU*(%kRydoSGn?-H
z!|&nUzJra$1qq?-dnLAqMR#pd+GM1tz2oP{)7zr+WrZ9z{n+xtXV=vwVxrnft7H@c
zbMmgXaJ_4t@0*la-mQ_XXSrWWeKGTDPr=U>66S9+QXV9DJPqA#bJc8n;Pvx~>VXxk
z@AfQdXmb_(a?0zgz?-e}`Pih-=riyJzMP%@{(0i=-6a9R;*4&QvEkPq9Df(X#aO9x
z`sk#{BX^!S`Auv({=iJ}`>(2x=CQlGW)%d_o;E3@Tj(3>3)U^+zv49t*58YX+50om
zu)qD=qgTgScklS+_y6mwxA70=o7czwdHCq7^zNW-Tym`Q*Ea>M7W10ga?@(Z$z#Ua
zolQlYTib)ah1{udiuz}}oy(u=)_<Yee-oqGxgsMsvKI$ka9S@?9JFALj>YlPC*J1y
z#kU>m0z&>3-Hu53vMqXRZ2j}DIMMEVci!GUJ!ezQ<FJaiFGZh5u)Wz|bE<UPs%288
zf2&%GZl9kXsd6pM?wh53+i5Gd@UrK>6JOOhbx)e2qw*!a+nnL4;crtdi${*~E^5ag
z_$}Id>E${3u5VTwuW?U#>na!=dxh%)`=tOaj_LQ6uJ^N)?$pa_u;(ae<>0^lvgEwi
z+@S63Tm`FkX)!7u=svS2P)H$Az}uTmD^TlP`od%8f0^n&-dT3B_NFiQf`wbAy<GM?
z$0RWKrHh$#pm!iAZ&|~mhTnRrvaRew>zo|yC4zogYWei8?@9f0Z(5>mJJ;7d+c%1B
z(VJ)MaDL&oYiN)DZ1#m!E4c0SjmSH_bKjf4+HsRbWdBzy7p(`Tr&(2XwS=cEP*}J>
zIe@8*NwBeY#Y0^~js8aV;wRqTBCOB&Ewj(G7pBg0YD{i)kSS|$J}0%vYGd2CI7y%H
z%MVxC9l7^n$pY^~Pak(G`1njaAa^eLb<h<j{cS9nm8}caTW9HfdwV;RBd+bn#Epl!
zsvJMBn73y7$tL#Vwa=EWm_H%=gP?y<?+vxh0>9X2XY_^bX*WuIEMm9lpz;1~Ki5n?
zH1G74i{|&6m{fV@s%)v9zAw6e*(?6vWp57bIJd3o*t>fI&$mwI{d(Iz+Opt6-t3c>
zlP_O5y#Cg<@^gYZO^5&8E8Vh7r1jC1%PEg@8Zth=O8>s5=lr*`?#IPVd{Zx-w)`UZ
z?SO#I!M%B9XE(p*n!%H0ZIRR_J-0=*oAbxExrtLVH+gw+NI41yu2S6^;<@>a(GJCJ
z&zL$UbDhsm@>ga_{MgK}%;eDHK>x#6GX0h1Ce~$LZ$2w~qtDIKCp?+8{T>&~mur7E
z<*v1@bj?sny~$CMcKvNk(znXnKP>`h7B!l*L>ZQ@p8K>~$f8hGX3HjPrD-)Y{HMxQ
zSx;nK)uwfOt!|Rf%gD=`FE(tsp`-jtBe+iRmCq4Xwoead-%M@mT4S|*&djeFhcc97
z9HS-KtS@JNG5sZ2qM`Br`e6$v&u_AELe*#g{$00OTfcG1q*EK(UNj$^8XYx%%I!%P
zX6)m9x@J<>-dVHPm2Z`)32u+C;bsV1|N6|4)vFGDD%`}%x~3{&)6oqtbAAbI-`sWg
z_3V2qLld?hyB5qG!gIZM{^^(7l==AQd>4tZyRq}-@5HisdaoY5oa!!iz(8+9<=n5G
z-e<L<-rmlelheH*y;5+-;!=g)^9|e;_Er{+6Rgg0{oZ!hN6)!`#)T)JB>M$wFBP<C
z|C;#E!Y!&vSSznBO3_64VDU_=t_}G$dQOqzoxC&SOw-;b&fC>%oVQT@kY>%3iU1Lo
z-~f+xA2+YIo4}YTwWT=fw1iq?!z!7yM{D=(h|xR!W20$gYggjDoZ74J%<NuG$h1rQ
z@VU;;clx^Wrtpigzsue)v(MC33{z{2n*04&?{vNCOL;0U-%UH!{db=7+;<;;Iy7pZ
zt72KP?Wf9tD?w9Maw>ZEq#u~rmMeXozrF5q&)mN}Q7$5P7yetsb$|Qh!(NVs0(ot=
z3>Q<nS=5!7E=rc&?7e2pl<s7pYoF^dWm(g|ho{5uS8tN^*IL84{vP9D|69q8X%k*o
zKCei-weqUfu0Kxo+t$zNX?BrezbwP<`}r%I(Y8{X{^Lhtw(dSC>2f6R;pwy2r)}U`
zwRy>*lixmY^88q+b8e1c;oYw?a|Ih$aom-AAKUd}p0D{`_aN<qiz62KJiK*ip0&8%
zfzVY7X$t)vA?e=tOCow1Tx0J)tI=K<rz~hTUpnF26SL>DmkM0?u;h+#$CVek8kVcP
zcHe!{BpkYQg<|)&*UMf$5NUbU;nlhR?F$`_8{c-_m2sP%%_A&%f1mRjgK0_6|86K|
z5x!&`?zN%EQl3BI=EZR9Cuh^lJ{)R%bVRrLfzup^0xz!s9;q^B`Gm)E6UCy^1QvFz
zkV=d@X1g!{*Y0bcaUX9iw3y@Z<YRMLvgpe8Z;GD^)mHub=ws9C`@Y&BL8MZuZ2nxC
zP#cSa9%i|&4vp*4`|F)vm-YR9@x-okbBX?o)qK_ruWmY*HqJK8PCMKr;hSXRtnx+i
zP0fuh;ky^^H~w$DW!o`#fmtQO@m7zgysWC;ATfX2x!Z|v>Lh<znymlSv1tCJdD6Gn
zhwR$n(jm1w?P*WZoYz*hj~||VSn$)*`VeDTN7gR;H;09Ta=-Q5*4?TvJmIc||EGwZ
zOs;|#f8AT~EhgGQoYAsp?gM`QJ`=CLzv>BZUgz>(*lQ}bZpl3T4NtCfE-09NdDoL)
z5qz(Cb~buAAJLm96a7{AOJeo)KO%(^!T}ER3MLA<PHI!@*Lm@QU*pgXzVhT^ew8a0
z4aw8kEq*9&^GVQOmaMt;`g-0zrq90*GqN=QXxKkLO=l|4;<Ygj?Wa#T8P0V(ys)Lm
zQCs??gov_xbc)KY!0f#~X`33(W&N$?Y*%miJ5~Hw>NU28h!vr=N7%d>?{rS}w3ljR
z@BK6DuF0H9Gcx7eq)mU_Fu!yl!RqS?$9IuDlR}#ur>|S+@Z$!59>2-uJTvLw92tg}
z>-1E@bQYca#?|57^6if2*L^p)^z||RleAjqZt%?fz~SImFF(Y}d%MfZuZ&}@6PFj(
zUmX<g)|Y=QCR*mPO<$Bu;pAC;6_!eclV@Cf)4o|bq9HWpld<y+A*ZWzH$_Z;=ETJ{
zY3_kp;g4$A&njM=Fyp9I4xdVuK+UPZ;-y0A&&r>@*mJwx&_XX!`|Q3}hZl7l3%PZ5
z-)(L<_V(_JAg-Df&)w{PSe@oS`{Uw8XOsQ1IujmzyVxl4^drN;f&-acOFXxCX|RU(
zTF-b`bxP#V_a|GbOr8Yr|GjXw<@MVQ^V|MiQskfYbK@?p^LKm`w(bmX%x}-x#JJS{
z(ap_V7x*^p&{4cqlJlzE;@j_!mi4NycEuGi)bGF0JtyPk+(tF^$xRB&w|Xr-^={SP
zb>&C(?Vi3mZ(lrV>PhYUPr?s|H=dLAZ2I1{#`E%D22<gK|8Jjm+qpHk^nA=Gk7aYu
zZ$7u^2T$G9%i*&=cPZEI=HJQN`0-EJyh9Qn>YuKZ-|WfN8Sz<b>KErc(}wt!>)*`r
zs4iODV^lj!Dxl4?q}BEQnFHYwHTmnZ6?Rn$1@McWKYQcuxju~r%z_TTYyIMEi@QRW
zo%Eb_&#xoa^sMZJMPb#KTW3b<ocbuV?gIPALbnepKf@xqR{s}&DsAkx)Aq~j8~m?5
zk9|BCb?I;l@9XLxXKwm`s>^sZIr9>yCZoOclcgc{<yl*$uiedAzVg<DM>qJFZqu7*
zHF=HX<a1wrCcM^*61%Bjzf&qeRZuRIZB}+0x5u;&EkQOj&69z@ZhR@Z&}H@On2_C^
z)Amt|qFniIyp%rQ*R?>!QN`IK=RkqRl$hpw+k4-7ir6`Dv^$0Po4dSXDo_xZVzqF^
znKLeDb@~53x3@SdWPsVl0(G6hT`Xf`6L=TP9J7mMp<tjuu#0sz=5GHTi=z9d_nr-&
z;2dXG`NCb=T(^75ihgT}6Yo;>BM*qj%(2Xod**t1?aZ)kyRS~WV*UEBxn6z2suN0)
zA)Bk!`i^smZQwO^6??tAF7y_Ew~1i4$p6Lr!*{Rd50@8nvfo_4wyZlpf8D)3(=Ba0
zUu_ZVp8Z?<b5q2WqQGUDi@J`UefR3B|N8uYuf0^2)_?py`|H)!X)k8|U3K(%{=L-+
z-8%lCw6rrGRvBd<N`B=sb*e_@*{wJCX}!8)S9PakHLu;Y4O^O+-)#Kl5vWobmG<Ss
zj`**KFXYW$8T)$fDV5Jt%Bugid3@S6=}XS5vMPDa$!ql9*lk~bZ|2?4OZ4u%<LCbs
zIW6Sh-?a7oLZLyGM)%B*J8!=A;`EaZHj}>@G2Po!JNE(qOrN5u+P@z1JKOhpd)Hon
z?;f-H%!9g3I%3`y3-rF6+Fe$a6J0xX4bw)8e}2-=o15B~F3rDt_wrKjmoIkbx0kJ7
zs(5;dj;vt++?~B=CT}S@6Y+Jo^Zs^m6HhIFt*O_HHCfWlZg0Hq|9Z)%+i!k%vZ(#J
zwDRY~idoP4Y>F)vCm;H}^R|DP|I6<=VXOb`n7^)5a%(}4ob@Ho9o~T!Yd6|ldVX`S
z{UhZBm(b<Yrq5=Zf7Nqt=%PjGOMY!y(Rz2CX+GDtXWM2k%gt^H7xSEz7E`fyn%h*4
zZSQM$&w7!S`D|U;ef}di?*#99`<?&v!khLln2VO2?@YSe+g>K&So$SDbrSdY+izFz
z&)J>!=cvIdhK&ZjYl<(OSgIlNL0~Jd$I36~|6h_hF31z}zSHbc+?>9{bC(Ic)8{%p
z@$oj*W9dqst-)*aOn6$exlgZ3lj*lkUQyXKM{CZ8ug5gax7hFd{m%ZsPubx+2h87}
z^y7Xw?Oug?l4OF9po!wUaF<tRJ%Uz#&f8~glYjZ+P_h0azU_0rax5*^_<L`UE^Ga(
zRGqz_C6+%sry(Gb9%{`uX?bK?D3_ma;o4i<k7s6VbBR-vRSy4KcQ-SC5$hTkrMI^K
zH^pyfj*a&!|2s8MUO{uMjAz_uS!c&|>!=x(FOQ2!2{YRIt`=U^v)f-d(sH51<LO$O
zQy*WRylR?St5x7uon)au7i~^Y-EN)i-1%u!waF=s#)D^OPi$vTG;q#gD_Z@a=*?mF
z!vP-(&dh9V&p9!Dx@5+>Cr#aK8|$`O$ysgcKJet7-8{AhrT*I%8GV0KxL<Bo_2c!$
zj7*>0b{j5}d8PQ4JMO;p#g7T!b}aJ^c_(3>%hT;Fdi`3>j1&JgzTETU%&6tEJ1P4i
z`1)&$THkN+znS0pt$Af3xclIlx5oLlI$xS(-yC<g_i1}NgW<qa$<qgY{bsE1Idad5
zYgvt(T!K(SV%T}Uvj(NB*H$X8{wZzu=V}~p8{48DL*0@ucDuIS*8OPry{_*1UmvZ2
zUp|L9<QGr*H1ky2i+=vu_ck~!JRn<N`y#!h=JVU#*+t3;i*Dv*9#l@S=4qQLRN_7F
zhm#y@`Q3Tb7R}wgRIMR}HHE!W;A5RaxmK-|S+2+38IF~kxc+b0`MQ>8&yyaXfT?G8
zSLdpzGjCrZ!}-tT>Cdm{j)g`l2v50u+4iP=G1uGn<m6D<lIf`xVcN|9+|GB$vY7VD
zSaRI3E}A~GF?7Y{Gdk01nm6n3^|U=!l;5E$`b;J!ZuPOa>7LKmE$vy8=9kvs)BfoK
z&ys0BH^?ccbFP|rx@zN;6-$nZbgoe1eZ{w-<&xyj=%^re?*p<+{bs};?OR>oDs@Nh
ztmfHMtSN4hvDe#J&hC1jC-%QDG?0@ot1<MvP)V^Oi_5J=Q5q|?dIAEhYk&W}I{W?q
zEi>AZtG_;LZ{1P#dHs*$+w1=^|M~jYUVq=NU+=0nhi*9#bdibs+`%00g|l8uy_SFJ
z<dGG-%xS$_*R%)!Pwg_BdDD6`*Aqq_UGLD$h0Wrg!5bqE8LnE#eX!O3adFr3S@wk&
z^OJK}CUQ#_yqRAR*_axdrTaua<9E+x?lzvE>HAJNY@DDJqmeAm9AvDpwW)_qMgMY0
z)vUD%uWST*ytX>T#TW#<cDVVPRe0xbeY0QF5{?{LZsS|LEK=P^yr6LTo%G1QvePr`
z`VP-;-~Av<>)72WN0+}$ch)MN@;Y{Rz2*_;o!uK3S}o6uFTSNX!^?lS$fNEVI&*|)
zy|Fy2QL=H3U8wN{(Z-{%R5*+C9<TYYw@dhhlnKL+=&HRPyDe58(5`3nZYpkIj6ZO+
zl}9^JT;bjV#h0P`J8ufMIhbrwRcZdfudE`d9&jb-mc@6oZIL@%j`7IYE<W{fm5|P)
z+vOEej7Mkf(?~y=oa64X{tNGqLtptrPCeOrdDZ>nlNeU4n6&1TM`OVD^(*66Hq@*3
z-_UcO7c7ued@+UD_n3NPNa$RR9=l7=%+qf$wa)F?oXV%mRQ*#cKF_nh<NVnlhc}BZ
zZ#-LM;S#&5s@cU)WO-){U&&EnOOHDd``$9T9h-6PO4)>q2D3J<i!?tx>(rE>opVa=
z&U^OJzSOF5Z=a`P^OLLTTLPm)IpU^${rpDsY{>1^-J$81E=p<V-`ITMgn&pNtA5Lx
z1E-o)-}85L3kEG!aX%*TSk_T$*@N?yny)vP@_8N0nyB7-#^}L~Te<sRE$g46yId#Q
z&d;{Fw)Db^%7bO+g0lQRT{o-?i}+-baB1VD)a$Ry?4wp42u>(FbINkEbF@{Snb=jA
zJw5?v9X`oKvy{FlTfRV4;53)~>H9*T3e(!|Cg?g>gd1%=+{bk}$iSjk%cJd=Yq{*M
z_Om6sUN0*Qi})RT{G0^W6OpEeQqEIuojCmU!rj@2RSNnXvlQ-LebRVyQ_6ui^TYmM
z6BL^6T>0YQylIYda*_V)dIhvP86@@ZxWtAYEB5{%y07Cq-x51f$AAe%xhD>m8%Y$F
zH8Vv0>tA_aB7r&ZvhYRr=l61c-SvoL|K`aovuj^%E<@Iv3p;At%4{OG2u|^y*RX!!
z%-SVhQx(~koDryvDJpXon092wdzV^C#tT04AOBS3Q`mdG<k>L=8G$eNcJjo$o2c?C
z&%sQ(xa7<wMIV9a$oK@_f4MK-aTxR1%sI?6lYQwku_H4t*%qJG-FB{f!d%z0y1Sg7
z+TPSH-M-GVk&FL@@RcY7&%b-J_=P{tYRtX3&0S>krg;aqM5Zuw+~?o>RcfmE`tXpW
zZ!h0BvJMRKEjQb*nx&<g^-y%4xroFfKigFkCBnLdS7<c+UmS36SFB>solA0u-e27P
zZJvADtUQJ9C*}qx+-Y+5X6t8OAO1Te{qmycDk1z_PJv-_4&Kjc{QJ9Y%_gS%Qkj!u
zx1GukmTy$|d@g&&;o<z2r#Dp7pUwCwa^g^w==<zDH`5k;P%O-tuJ<dwPu5=k0B>(f
zeA92;>mld<$gP-lZ0{7CR}ztPSw1cJQ2k}!DWfmBCcJEEr>x9bFCUe;F_lg9qP1Uc
zva_j*?$gv)2cBM4EDaRd=+k`c*xG}&jazv>zTcJ-m@sXtc_mkgBl}@CE0fCn0}tXi
z-M+rR`{GU=qq+B-wg$b7WDTj@To5NL74dXQhuuW3ZFh5XU+Bpn_gS^d;h$4t(4G{@
z*w9}hD?d8vES|qcn)xh;Wa9d^sU2~t-H$DGCO+FR_3^dkOq)2eQ<DO3o%tuk#9G#!
zQ<GVC$npk%Et@^Box$_xCt0;C0xaI{X3=&2;n?!}X#R>I7S6w{`j7O^v&U*3{aL^k
zZdSC9LwmB`oa0mcRTf^{GE?Q;f+M0ow*TS&utV$Pp`MfehmV{RJv5(D?cBUhMOO>4
zTXUyOZ8MFZl`QmWnbrnt?!QiZ{-(SzKR)F%x4?YqwN+7fSi2mP_s>^(=YOoO^31N5
zzhR+&Ro^h5JGkb-XA8xpvV~_jk4}siZQEA7WBtwW<r0Or?9AVJD?ZvOksI6mCAOwj
zXo*Gt#Z8x{`QCS2o2a#D&iR~-doxd(n_n~!TD5METi@(?TwG=@KVE#wpZ{>DqmWtR
zNo~z77dFJ{tekY{bBwC%(G7mKZ_U0Re|!JJ9~XnoFS6TCseiM`+PLIo*P3Su%Vw`h
zP&Ns$az6I%blaW;WyO%oie0abe->sfyXN<mqa;G-`&_f$xzAVIuKw@UJmX+OX!54o
zd#l_wEM6QbJjbr|%_1-T8C^Cek8cEioEFQr<g91vJ9m|`vmcZ-xn^rBu(57-ILP92
zLV>+Fq$X_h>|JTzpNmxE>oRYt%Glp3U$H5T-=*uu#4?)@Bd*^YH@C`9S)AjfFELx#
zapETxpXjQ0{q1efJhkn<J<3RQQe5~+^4aoRoUHR5{*<zCDLIRt30VJEnf>D}udb_`
z`{&NKN;2NN;6Rz&#I1^Jo;_liv+IS5-9Ph8i`Vvd_Ep_qe>*Mz_&mu=iU$PV+}O+%
zXZiYXnssi$D$o6kEOwYj?vR{#PD$e7t*sv>txQ;G^QF1IeIdK;0wvqW33EPsD^>Gx
zOe?-t&0*c!oS<~l-_f8bYo`4FMU~qp_A~`PfA+G8@xjjUq=bcsWh7o0`#JBgSD4Km
z6Stk6|BgPdd1!BPY0aVU3-50KTexM~<G-JmuJrEyxbb71z>I@)56r(J%KoLy{r>HM
zALoo0@qhpGcjAR#U5Cr~3{y8AW3-y|^Tfi)%nMgvrA~{r$*aG^cw5(l`{|vNM=}_a
z<q|%g<2$ZzToC$V<&14{a;o#spM1viW2Z=&sQl3)L3N1}CifOxI_cWsb^XP<JDX$e
zZ+KQ-<B|Mjoo)Q@!()q!FL|_b<)m1qo=EpvFX&s+cVBsChxD~#1>Fu6Ii6JId3WoI
z3O2aEkYih(9Pz#K&CS|}f<1fsf~zn5^GMrMT-(f>7jSdhEgi3ZrsBf7?~00H#tl&#
zk3?TzJ)-n@;-26eXNx%2JmF+M_iMgg>iyMM9_IR75?8pref=@BOBbbT_0>%h1zx{>
zeSfmv6S+h03Kx9cD9s!G$xGbqOY|K1qo03HoRArAx9Z=;8SH#Hw+!3@Di?T*I~`dj
zzbpRN-zRH!e3I3^)|8$b_J3;kOmW@9)jP$mou4PhTXozxV%EX$HHWUbevF*%v1ECy
zlGyPz3}0$iIeSfQ^^a^wt2*}R%s%z`CnrSRKPeK!ulFP<{WkaJdx?T3&ji)YZP`}%
z9(}W#Z9VI|)_Z<;r$-)f|Ip@X-ZbB^PRUv2K6`Y&Ll0+$!<3&M|F_(h-KJ|*uD;hu
z;zz$}{Gz?9{$EunmaJL!Y012)%Y#p<`MV33%_{!g<>YcsUqGI%Jn&rY^Do7l7yns!
zW`pjbqa`=ozI7BH)6RN0*D`F=^(lWg6qQz~qzC?bvc~*jkAJ28*V1T%`ut07=10%F
z8MK|?-IE<;GxuksUBFCc{Q{BS2~WRWU4Legq>7M=+U46C0!?wjnU8<PbmTN@PM6Fx
zR%rM1f38sXW8%5{$IG}1|CyAzw;oRMTUamtG&JGzDV>SpWeXLT3OtHT(+ucoUaPd#
z;{47qz7)>$c~3d+Rx=bT{ElBUdGY=uht>uD+jH!2&81wv@~cA9mOCRq&%TjYP|wWj
z&HMe~E_qKYV-;?`(`zRE3v>C(u-xq+*T;#DbMMW2XcIhL(Jge{W5<srn@?rvAM*YA
zTxe@RYumf{h-(Erd`fn@Z#G|^H(w>^kePprZ87h&5d9Msn;Cz8JM>oSLsG@k>0)lN
zkH5u9oS*&D{KenrFXo+fS8%R;p_x-~_1%f+ZjbX)>l{x?<?py;uP;5{D1Q3+p8Rzx
zn<bfq?L!2*&cEut;Pa=(ch#yB`x-7fN%qY<_S*ADsZ->f%`M!zt8|X8Ulli}#6qpI
zudV&Q+MoHRcebYe`=42n;+3}UVOo$)$on40)fbn=_};e&-In?@G^aSVc4M^I-hv<Y
z3Kjoa55M3Iao!oBTlDSgg{Az>T#fSG9_MC#=sWhKkw-SF@aFnQk<M%F^`cHaImxe)
z6IH%&V%p`m#=TpNf`2uuaW&RwYcbz*>)duR#Xx|!%l)qUinJ+>Zx@7#v`IQyI3N4}
zkNv=tji*vEroBO9Eub+O6B7e-*qDr=fg#4AjG+POz%7EKGJB&vi*LJ$owG2XyG(8S
z8JUVLr<Ho*Hk1g3A3YaTICXA{kZ&sAE(Z~nBp)UdhNx-vfA`#rXZH1s(+=Ipm1DN+
z{;$37ZTCej;f!4J$^P^Etm-eXUR-Tjk^XJ|)v}LYp1imyKjrXbmnBU)etLah#7`_*
z(5>V<Stou@PXD|3wXgTp6@0Rfn8$j0rH4ej`^!g9{=BHmpC;0+B<SjOMToDy=tjEd
zq&+^t%fjMbPOa=R7xp~aBEY@p!^Rj7k4Yy@f9ZamefMSU=UPD-wN~Du>KXb;>ouOb
zWoAzMqg$prQD93-&7bu*mU8&7s0l4t`MfICQ(SV5&ZeMsXC^64o*s2b`a%C3nSJ&1
zJ`_1lj^T7%XH~mkdaIV!Bopz>M7|q5MZF#@+Map*d&5pCRZc1jSW*}9_ITdaueEzu
z9$S|Ev`OZOVo{n{iMZRf)UZpl%c^wcQ#o6MIaW`u%L%*cR>z>G=wSA&dG#_|`>_7*
zmMQ0gR(-Qkt7c+9b+`JT-0s?y_oVO1+4=pQsr_?>hta#~TVwaHHJhFN^W>yd%N5I6
z?oRDIarOE0vj*SJ&a_n5z5DTd@>)Kx%tL#YR9Vz*pL#xW-V@35Z?eDL-n?tR{r;?D
zTW>BsaYyg=uAry|1v3A?<lZe$)BWh*yQkwo)s5|ES4>;R`PsW&P%M0J)cIh8;H;$u
zan->azx~}6cx}Q8=joivd0#uj_TIU(I_1WE-qrhV_B#92%H$oI<GZJ4W&TMPjc#L|
zzlV<<_?sGk?C#8|N?T7=W#l;ih;V$Q<}xAo%h%RxlBpKcdgp#*JLFaK``6Wdc~fr~
z|D3t|?Twt*2UiH^8eiGHYJHDr;j}4NI{&?~DpNf)>CFC*dV*SIuG2V5T$kQeRb{=w
z$$GL`bZXS`Ta&$?oSeH&uy0OIfLy2=>$ce*JQwaSxiUZZYHs=Oi$`bs>@uG;eWI2A
zoR4uOdppfjBX6{?&N5iUo5Z2A)J)AWBD5mjw)eEa5uaB6V)n%~$6nrTs+qU!NpsVm
zkmC`J_g!^cy{)%Rn|G}2<dpgd)>`4IVM-S!>7@BQ)H`mqrzl`^Z@!uLf#CI9yYn``
z^kGq4c|GcKoRqoZ5!Kh#e-}7QdIsh5#@4TkEk4OLO@rrQ^Rc|^<@vML`lnSg?MpS4
z^6vh9khNH(ZFbqa7w?XWm{b@01ng6MdnEJF4z^3a*XKyD)~nIzU3P8d;f8~|jqjS;
zUjOA{S#;KX_qx^<S6}d)J*}etZgY3-?n&>BuLV9y+%fImk|sAUzXkg~^slgQ>}QbC
zntVlao6-OIeq#TpU6{;h7JQ-T<iq|+0Vg(f+f21sHRZ>bmzx*6pO4cyRu?aC`zzbA
zPwubM|L<SE%RiW(Zm+k`;@8WW_cXbZHfwa~dNNI$bF!Tw>Az%gp@CFs!pq040;*+q
z0z^Kj?pmM_zV*rK8)*gA>kctUnCmugIqKxW^FApop8q7{`(>&u3`(reCw%x4AS8L2
z^<+wb<F1)$C$HSOxOVe;k;&4F_6Qw4U$9C<z$B*4+V;Mwdt|W2rIzYo1<NIiKV81f
zbaLh9mW&P4+d0=fxaP6`-;RTE2jUg#Qcfg1Sf-I9SE8c%aQ7}D!KRZX|4u$tUvOpd
zcB{$T{`Wuexs~<&+?2NHR4>7EfpTs~y;4<<rv2XQCDm|sj}u=k*O!T|ufkUg9Ng#_
zte5;{c{s<@7_N(2Dn)a*2lBTq+IK;YXV;_m9Y)I|+LVgzG|K%BH59IXd*rChEn8jt
z{=30HrRKZrGxLm?WjsC0F2O7Q@nq&z3;#XgDf;@{K%jzu&)e9y%oDa7eeX|}|53`n
zn3Lz<ly8OJT*8;Cn<scY-XIqvc(7_si;=t5iHL8OJ?*J7$`j5{DqoN_Z`oYUe;*cJ
zebc3I@JoS9Ko;Yd#}+dVdT01(H&i<cvBn6;dDw0j-c)%1NEZLRlT$Jqzr3ssdR4`#
z#pJM2VWVoO(zN;iQn{R>l4|4^HZM?-pMBMhG1Y*@rRq!R)~MG>!gdel-1S(=`}^M^
zo3pkbBi81awsZ&wUl)pWx!-Z`cwYMUFZ}O&{?50leRsnwo;iD#hxmtYPKM9ctlz&T
zeA?=URcB8h{p8Q6Dm>k@_~xut{2Qa*F@1im|FBbMQ$eBmyWhsj&LJxA%-bp_9#AX~
zjqK^VQL;KM<PX<khUgo<+vC=*{uUHJYwC>MHhce1k2)*V$94Mbf^1_g%W0YmCAnTa
z_qAPf%}cSz@kF_`_l2@w2QC>s=$ok{_2hJ^=sbhsvpVHpzx02N_<noYSJr&BWZBAa
z;ld-_tr`sxhof%Zoz(Cs_`?)cQM0{&|NL40|6g9p%*uaHPs(Q%Uud0vuG4KNkL7Kz
z&2tL8SE#<-wYf?!GJKx#$}f?XeY($2Wo*=_Il0c)#{JFZ%ExQ^s-hOXTPu3f=tkj|
z+wb<s2|fO?wEkUYfKzhnuBB7C4cOlozB=l&G2@z=w!p@xlHBLp9TM}7DF6AlZ9ij!
zwZd1UBW3H3`I<0uc^cg)t`YBEnRvr@t1y>Cc+lH>oO7SJK3wzW-m<>AIz6TKf4)6B
zIyt_+r|q-Mkr%RW8rf7;!=lo6>}wFu*<C0Xy!vyN`K*lTzbYQAmD{LWoaB0DhR3Wa
zN6#oaxt%g}@KC$>-FCfRHHUVu*}tBbn<N8|uFeW}_xz%ITIH&c!4vidW(T&9eh(ZU
z1uVTaBX3ETSP)y;`pbuF?K@a@7T6UfSj({L$g^wC7BRlOJk#*Bh{mc2&h$$zbG5G3
z#?ChAjC|<ko>XzFMr7ivaFH7ea`m)@vkUBs76<RiKEcg={@$mnDmKpA)y9iGO<D_X
zUX4^ZcxLOC0|ygicl2DEznMc>EnvER=hWpMJNBO}xV!FJ?RB$e<9|%=o&*~!J!;;-
zeeu;+!4%CMrDA6l+8+K`mXVrUr+hv!-c)%;>z;X2?``Dc+Ob8Z?CYwX=?$GZM=dYT
zRAAkC=J3D6j;j{Dms`?jx<^3cOW$?tn{P}0x)hw6B=uIpMEBB_CA?i50(s2}>}H%f
zuc}eH{onZw+pU|<cAorwc;5RZQ>}0OY5ui(@6iPs*{;90T~CXB*}v0p=adC?=ck75
zPTxBBh2*gkw!}`A&&O1XSD)N*abDW9^A!?5GedYcJ>0i3D^5({lUk@ogr`#kr)1q#
z^YmkVDK|cRUu{17$c*ZTPk&_RzB^&Ns%!iH>!wFOJ8E_t3v@oe&imzjLCwvOZE^~7
zvtn*d=e$xhrSi}*<9?}Cck`IlUTm44S|GW6CVzKa_^k(APxi+CHxjzAM<HhNp<BUv
z&H}EROz*q7cII|Dmo!JIr|!`2Jj0QAB`;lBqS@uy+6Q0$%}?H5c9{K4Z9u=<2@zlR
zoJq;WNABeFHtaFUJDI|KE%)P_Lk_-IrtH1y)+trFQ7R_<*)PX~4+IL{ofo^6K5faq
z$USejxSwtlDOz|n>wb9h+Q)1+<}UiyWDu1w>6qfwnmB$9+mxoH_CigLHT}Wm-`?IU
zc|AjBN8-a?rq6dxZXXkw612{4)y-$$*JyV?k#V(E5DhXCa<vU+aC&PoF?z<C=AZL>
z182`U{J>abW@1d;>nGkb*(U3UmBe{$-1lT#cjsotBbU7Q6y!{DeOP*X>+BVO4jgXz
zexCVLbIX*CyBE5d?=)FD=fxDRC7E8$+syW@uocKUpmg7uQHW_<j^4)x_6CayGcG9B
zd@(kabYV|9zM(QdNKZ*_!pcR<x%^{Zq?|6?w145IBgyV!r(Rarvr5HqU3_`!YUaW-
z4s0AtcM8tnOyPXd@@!G&;vb$tq5J-Inr`8DT%;g$M^Z>qU#a5`Z%9&p>h52g)Ldf%
zvMc9@@QJl>Mit9Q*`*u3`n5{)*@P8k$~V`P%|2^&qEKV|t9NU@ZF#q7UEo4ixn4W&
z@0Knv*V&sF^T+s!?AWmG^~sl((_I!>7OYSWJ=@N2se5^wh4tH>mDhbucE8#<(NsUt
zc-d;VqXN-ZwxT<hI|lhZiE7a3iuj)rdqU)nX?(!KdrFpHLt|WbuIlEUb>ql79iJ+J
zXRoxPOwtx<EV;5$CUUYa*Rr!Fw|0c;o?RMWqI|Rd_y+F!DUyA=Z?>FR_)zEKb~WbH
zFJo74HN7U~!gYm>(KuM;{_)GVmR!%+8dk7oQ%1jnjM1j2Y!}y_I+OY0HgnzFh0^s$
z0yUJ)r%gY2rb%Gum51uv%M`B&G>YH-ZL)Ux+#i|w%jPUxa{T`7tbWUBuXE2BJ~$oV
zEyC@kTlzQjjqIdl4{n$*S}WJF%4n%YfImyt*A)_Knq4)M@&ul<-MgLhJz6-Gk^N?k
z>HHI`%&NU#pW7v3tj%Zf_4|3L2@8ItTzFx?FTSSBM7M)YwPHf(W^T_nTsp^Z{QkRs
z!nDk&x;5HIj(@D#*`s!_J@50aC;kVrpX%oBe7<RZvOuk;@oSCsyarqqw|-r{7k+V0
zvfHu8L28|g1*W^j?SA*`S?=||v=e;y-nPHFw{l^t7W<LQm0ZE!dplBex)ansrN`g>
zaq8|878B{trIia#&b%Kvi&bsM8k4CEPu3gC_&;Z_z8t}9xI4S|Xi&~czaYuBdcUAq
zyCy3$?&B8zC><~-^K6T$7Sr^jZyyA;YHo;JGohdD)}qBnF3mlqnW9`YYj(|o<=%RM
zd_HFa9xvgZu;I+VgyZswQ7J7mzb{i_+j=zSfWp3uO3ZFaI)WFY_P?0Nb9m#^SL^o7
ztqD_6jWK`VtK#upbK6_D)90VB5Z|&cr_}jl@MR;;TC1}8*W~tmI4|-(ZtWal&JX^_
z*Y|{PomaqcqwP|(M8z~6<)R9i&zTqBecAo5=Xea)L`gf9m1~WBs$YF>{}XoO$0OB$
ze_K-gdrbtNvK#fC{~=t{_uW6kX8HE%MLAJ2t`SRw4@dZM2cA5)@;Q&vhS!T?;?A4a
zSN-3#al`52Lx!qbi>u|oZIf^5dR)Dltt5H3NTt?kCXqRLj}|l^tC6weRr?T>|3vM?
z`G_`!>GIE<1B5Kjv_JVL&erbCdDLg#TcgMF%dWiL@c!-`|F}gWFXl+Syr{1ADn5UC
z2ixO`E7r&#dv)u8_mv}dZwi*Z4^H}_82S0>w#wu(|60AP8#J#3Zk4oRpQhOED*dxV
zVAn!%k(B?-V#{y8+m!b@Z~bqdhbqT-Lw;;*%+`G5a{a8@p{@IRWR~5F>`;1WKL6hp
zm4wEoLY}2LM}>a(v;VfXbonn~yWGOTHSMTR;6g)jX4ef#Myn6&hJ8*J-+#U_;%a#G
z$vo5iT6wdhosZiDR|=ROefV(t@2edPbVQ;9bR6&YKCj?AcsOG3v!mrJ4uk}rYCm_q
zD$*nE#H5GQHZogF`n)yd|0`qgLRc;-d`8=m?S?w#674hQzMj4+cWR?U#ln4(O59f`
zy;3-=At!t5>)mzIcl`fznfNUa)Ofe+Z4%q0$MfE8h`KH{!O8OY-|TZ*(H<vdFD6Vh
zl9k)Me1UGwwYRrFFZC2kIH&WcaM^2t#V2R`mcFf%Z+*0Xw{yt`RpqWJ8y2XleKzor
zKVHUpvOnXo`+tkK(_%mH%jg<9rP)7Iv{_TOzh|%i#@>pnvV3{z>u)aEZknEZ>4vuG
z=k{>fGN~yWziq5e@~@j;-S$0elGV(^JJkK>-!?kSezNp#%sO{#*_pqMzPMgDd;7_J
zYJ^1s`+M`>(_f!sD167B7y3l-prHa|Y+v>k^H+B=g4I>0N5~v^U)160`t#)ffBZ*R
zoX0$T%@9070UpaRGJvlyF*LwDe$CK;sPos}MtkSW92YcuBkkWOzx;`Tx%Y;fub!7|
z&z0=RVOKlA(s@XsU4tX+wCc`N@A$UzU%a&5KXm`H^ljfAGs90E6i^T{w!Iq~A6grF
z^=?gM;32K9|A)>${PN`K$<tjs(?1?Bh_c;jQTb(xcZHMA)-}6!Sbdb=;Pu%n*efJ9
z*2iCNPgTXoM=pYKhYc!f3oAb*n8fsb)C_jn5Y@JPY2%L*LT<XI(Qdx89#;I6isx|5
z(tPzH$xz0}?f!$}ypF3ut<OKFmDU<d>x%vGlA6(T^riaZn_oX2^F7KD{&MocH<vtf
zIt`;*+QUB^W?VXR=ff<6qhI5KnoLZ6gRB@$C*HZF@*ty7+L3AMj(c_+XHO|qN)_te
z;XdWc*3^d=ZyMQLzI7x$nVm7&CFAhn%~zA2lss*U2tCeu-0yU7qC-&dTqA}p-xSu*
zW1e@~@Ij}toUN!$IoHw74&(bgX`2~$7IA4i_jqLOG}qa)O0;33&ZD@$>4lfiOn-7}
z{e@EN2_3go{@%SYyWg0pPhhEhMUUnIvFUTnra$g)Z_cn^%Gq74!~VZ?1BX+zi~Ht=
zO<50j&oU3@@1Ay~XyW5fU%n<76;8V1a!sr1=Zb{ZgDovz4>T_lI4@_A{dIHuL2={n
zd$XR&v0vr2XH}eT_rF$Rkv8xBpl5AY&bjJzcxE}T{LnGgVeLVyYqzxIU%YjDbtaJg
zVtvl)v-%ku*54BFx_IMP<(9We6~?o6DTpi7tbUmKcy4ELQi;){H6L$Wb=h9Ur&f0>
zYUUH8@_!S}awqV_ReN5np6nUl?=JlQl@OEa%nZZaSqB)6j{hyYS7Y<BY2l92t_ROn
zW$^dao!oZYIeX=6+c$+;I<D-tuDp9D-?NZvzEGT&cx1(rx1Z8PwutHmm7AYElI&ZY
z+kWr=!Rn0eGmIXy)64!no?I-{;lDBE{N~6HRoATi13#@!Gs?X4y@Anp(*54_>z#Lf
zv-e&7e6+xBU#y;2*u)oFp4UP-vwwtMaGBls^ZJ_XV*Q%XS?q2OkGlMf<YRlE9lWWq
z-X(MTS*x`y0u4EqdXqMvO1N}poxfwT`jkWGqvZK5xn@jN^LBH{J{0|#@A=uJi|3kB
zrld)lUA~=WHmmZ7$dT&oTj~7MJ|E0sWHI?_>Eu{6jdRrkZiD>O$FG0>m})S0)5$M~
zm(7gtOK)Dvug+>GQ243ynE#=u$!#*hUWUt=OcvaEX0b4@`Q(qPuyc~LlEt{aY)kxD
zEN4opP2PIXl$m|omSv@lzUxwo9_h8!|JmAZ9M1Xt+PO8)r`bk6KmGB-WVH_rx!p@s
zzB{N#20r=Ot9UdgK7Z#dd;W)~qxvFz53PCdb64->UeikzTYju-5xybG5nT2rX3IMM
zJsPzu3N<FKQK+3(SfBIkaoVGHZf2e7Id#@E_?InS+8=*XkyS0nV|KREB=Nc;mDOdR
zURIdRTer;Bt10EsWZ8cKULsr;lLBx0iaf7V(O}J6w$-R^$vVx{tD0xluUUIDZC<m{
zYNptjdH!;@#n-()==xB_Fks<(%{hmz?m8rT@^VA`Lb;s{vmdJ~@9|Y~+W7O^57B0!
zJ3Zx3PHUxKTekDyo(I`IyV56JxTYz7pT+&D?&qb2K3g7NlWtS`+WjW_S|qbkx9Zk+
zS5~tp@7ZI=lj7HzY0P9$@6i(AIipVLjo2~0dkV2?uedj*crO3=b1C=x6ZH}4O8>1|
z+VW+%iVCh*b(g)Ks<r8H*3B~R0QuwLr$3s6tk%+ZcA9!`?dk@PhPq_I%;HJ1ezT5d
z%vBZEk!+f{mmzy{NZgud;fx$Bd>%h<e%MiQzqQpWW|iV=2@cnHQdTm*`)?*$R=mr0
z(fss{C+o;*!&m!$Z1Xtd(P{BZWR+5A{_66bB?qUrFMPagzW%EH56zf8`WIb(CE~R0
z(gjC`a{<Oh8u11Ck51k^xp=dE`01ZnC7)i*7qzbZ!u{|2llAt8`Zv#C)$dnl_t{v~
zTqmURu+xGoU0M-B+jW?twXRLR%W8FM-P*4cY9F~@+j5#a&U;0##nL;xHG391AJ{9D
z5u)6j<D|QGPC)flN8Wo|Rv5mzHD~c*w$~P~-yG4sS;L;EdSrq1sp)9~Pem>23T~eF
z`YhqZ9G5Bcc;VFtxgxcDSBf!vy_0yV)-Kg)+$^QV*zum(>29d1BkyJB@7JBqHb2@n
zd$sGePx~}p9*?!^cRuI6xuo;G>q(wT916F0HT}C&m0c^BCbaYAWW^n)f6tSMu(UTm
zUAg4R@ueqsIlE{o7QblM2u`RFkJy*|@XGszYr-cVXfWWaTg1A33g3gR*Y0dCDcGMf
zHT=GF>{Hf4#qArIe^f<(-e3K6tKRL^lX9edcd5mMOGK>`DSrQZn@Rcg-!rsU>2{{d
zC<i=XyHUkb7R(a7V|JF-O5MX5_EI++^BHfRlnN^r+%b8T@J-R~{Je>qYgbLU7<yAL
z-1XDW_<1|D(^q`GyZ3F4_MctxQ_{TmUF}O|FBI5UJ#9Dd9_Fj7S1c&<*&_V>)f2Uj
zHU`Ox=u<ZHr%YJke5avWD*u|lH&;V`)_JkM4aPdZRI)dVeO-Jh<nFxx28!w4n;HHG
zGCq1L_+71gM^s7BylHw@9qU5ec`bAmEwoO!@}0;`XxtaOWwT+zY_0S6f8LduxOMIP
zX;;|v8NGtzR?AvNzx8}}!z%i%N80jp`z&6*yu;6&!4mVzx8}U}nvdI7Zl7;z5nN%A
zve2Z%@O$aRAPuz{W;SN6ftqdiF8)62sPxfb(+S>*C#Ei5QL8jj`fbp?jeCWz9ejK9
zZrsb@d$Yp79qudl*{!vEUA|PAQN^RT#ZTU@=bEa;k@6@ie%dv!*+K2=gDN#Y8?Ts^
zx+3WHjGsHt|Ixf$Y!g?Y|NqH%^`iSX3;rGN$TRP}_v3s>8PmrfYH!$65AW0e_1my(
zuaL;G+}%fF+s@vu4tmuW_f%rtZo@mXmkJ-wKh<|&rNKj!yv?tqVzv5yEL8Cm-@nM>
zSftvfbCsNP^5nzrRV424S2lh3=*{(mOBR*<*GqI}<!qV!zE*C%x5n9^>^BavlP8?o
zHb+CUUC_q+!5ND#mgD7;-!eGw%zYZ-RJ<nkTbA&dv<bcj?owaZD=lHm&o|g>zr;&)
zZ`c!cmG^5^MD?`G`5orlYWV6}GZuy@F~~eJOI?>0&OcMwacA*r>+<Px^Ti!ok8L{o
z_x{neiA}wtr(Sg5onYc(pZVgx(J}VZ5}lFTReMcd{7z!|H_e>yx!tN8uZ<?$%JY_K
z5}N#!_d(`#^9^ivY4;ACE}LL}p!mL4eu=HagH-Om+1^UY+&>j>JZk4ZC3ZBjY9WKI
zXt;o0b^9U5#}3B=-&ao$eb_m-pV|CPTDd@h?tOQG4^g{vk5sceZvVXbAWO_K=LOYy
zar+*d9ei>9_M>m@)(M+#&U=-<^l8$YdB=>W^sX*5cDi^YcK*u?b3^ae>h0nDDW{XG
zJ8x&oG`)8k5597Aw)@<xn_nNfrnlu-?K(041y-V~H~w2#-dkzm_AB0P^;4Ue)<a#2
zyScVL-XX2OyyI8h@w;!+j$hlHckX52!td#KW$v*&;jg%{xAVle8^`ZApOBHw(l~p&
zM>y%seU83zoutnfcr{+yZMpquyR>K0_6zU!x%OVynB=l_ON5KW=9OtX^F<!&ev{bC
zaDhjEoBG?zy&pw97biUUuXS$6^4obka|G^8ldR3ze$;z@l>DjOYQEhsv)oSfRX-}(
zuG$%N=bg1(Ku=N2iw2KYn_apG_&2NS-OF!yf6(i{I-{OsTw^wKOun_+F$VF{HI;m!
zXSF2O-xAsO(8+oG>gwy<yx*thye@6y*S=+2l^Fg`<&kB8{+{&E8=qe*y;l4yz0iEa
zy!{IE^4vAcL(Yi&)4Xb!@2;6Md*+gN7gD4+Rz`2yefY#Z&$ykYMd1NI8#NkMRn2Ak
zC930IQuTJ%&A`LAD)=A1e|c%y0Y2NmJ1?EnnkLv;|Dd8r>zY^PAMV+1@221Xwkq!D
zHord&tZ#m;)SMwNpKHr|{O_!{*F8VkJ80ym7byi!bJ2}nXYEn%Rg|KA$Y?{vhDXaz
z%l>0nQorQR?e~k;&F<uI{BUE#_15EdKfag#C_gA?J8{dg`v1&A%z_g!CO;wl08o#?
z*uV&Wvyh<y=21|Fh6co}N#7e4oqy+=Am1c&+pXu{9^U85rZelg-!_j%i|N-gc(!yl
z?0M1pC@Ah&OwrlykmvbZ>~|EuD=yRY=38^1LA4<L{7mEYefj$&U)@zZe?sm0|2yZa
z>c72vbGL0q`ak!*_xJ3vss6b5!3P!X&y#ZW^3S~yKjF5qCoe?L*v)+U@6Dg>ZFm21
zm0sO@%4@1{vX1eo&vSD0Jk&xX#b%#=d-LboZGYYsea_#j+~|L%OWZ~~A#jrD2W53v
zHSV|9PKT%K$L+m$=JBODdw*0qpNsqB{Qvu>`1=R?!|&(WS^s`FHTLD>8us<6o<`?-
zKX(_;ld(L1YLm%1@yc^OpW`FEXFe`H?K@L2Xxgb6HBZI7w=bL7RB^Da@?7uD$INBz
z%*Tp4f;l8kCMN#;BB*S6cE+D6il@C+@>dC2cyKJtE&ANC=4epLnuhyxPsU%Hwmh=a
zXNGB@&}@wlQ(w88C|{ZJH!)Y0^Jk@C?i}Y$KGU1-e>(K`+fCc==eIgrFxR<$*OENO
z7&s;M=lg=SU2=+v+vT+KHcgr`bHcH&_EE;O)_95jndkEQ)tsl{=dV2~JQ%W2u<+oL
ze|={EK1(T7uo*DOs5JaI7$sJsd?2XvP+F^zWa-4&SA>=t#$J23<-`xR1Yx}-)sLV2
zCsnwtdB$|!%jsd6;<w5?<*nWxflbYZk{YI-3aa|0K{k;_0jo}ibItqsNZGPB(p&n&
ztqqK-A4GdLl>ApZt(*Dcuw4T;-?@wT6-8n)92NxJY3F{t^B`*ri=y);lQahIETIs!
zm!(r)FIf^Iw={f{z=5q_PO63(MihADaHP#N475sN<T>eV5Mnj2zbR4S+wlVvj!dfO
z5sjGl&(7e?Ra=88rw&}W_ehgRIG5=|0-L;uliPf;wh2`%cYf&}dL`20V#C)`=GZ6p
zM?k>Re9o6E2OqFC8cNBB&+iM=$Po&5_wny>nRxP!!o>CtCZU(hwLALV7cFBFI{IX#
zRI|e46*jT1F|JBq6xS)R8O~7n=<!8}L)Svbq1bk%71Kx7pDJB{7OJUt+zZ((|9qwR
z-Ue4S`#{Gf%M|P?H7u^O3bsC4*rd_jemYSjz@NiO^i<*sHwLFPM~;MGfur2hs?Yol
zxSD_aU++HwucU)B@7G7&+PUkU)aT9?=|!h%jr1RHZR~E+nRdrEcGt4?YfI;89&N3z
zTX8Jw{+Y8k{zaXAd%^#f3nRnngrHddG~2a~BE|f?JG*;Mb*OH(%HjI(Del~EwYsUh
z+T-_|{9$;ydP?Hn)t|RsNuKGDU|Pvu>3aIk?{C|KlWweKm2+@R_AdGQW@mJl$PxDy
zo8CPyP?A3-^~f;%Z_Xh$En7BAIs2OZlFzrTvnuarjhV*8Blb^i``g~np%)8Y%}&jV
zZ8%jCzWwc=I$bG|jCRleck{1L68ROr_@S`XzfxT#wsj|7Xe-#3>-x0#e#_2Wm)YUD
zF>%_7Ud7n^&aZOZ(k@5M=9@Bc&DWcIuTJ_UFmdbK2W_8ZBouCLG>vWw4HUCup1$(t
zuFYLWbGE+iRXzJD<E3y!(-p4mW@nR4`7bA4@9FhaVN6VaXl?F%UGm6*+KDk0)8EVV
zX<m6)(VZM@u6OW&)uT`6(iS_twC~C9)jx3j;`E2dEOk#GQhv~WELG}C!TT$-HySlA
z*rnBSclOO?*?}pyRA;a2o3={N`1A*!CaFZOmq%slBp4L<drFocPBc%v!0WndmCiK{
zrfYc&`y_weJk+|{XG6gme`b+&a!g#yon~l7-tm_{5G|emVd{yyOFt<U+^qc}P&MVS
zPi-xaUDM6>4}v{))^;6drh1k0{Fso$D?df{G4mtEun!AUI8L3tVWJoE;`L_>8JP^D
z*`>QWj5|F)ski7b>u{*@pNac=Onb#Mj-HIj&%Bp4t*d`~bbrm*pSxUg!j3JM&&dS^
z@!WfTYQF3oEvAb0dx;A}7}NCDpI&mW_v{vFtIbV$o(m2vaY$wOw4uqf>(UjA{f8cw
zbw-K>mP@29=)5*v{2=3P7WZ?aDng4*UsOF|IJ9G?-mlkhZ&&WBnr3-Tvy0(szU;RH
zbL@NeZreCT$yjeultk@G{mc^`w~qQJyo#DE@c7Ll{#w_by4&ZQcUQX1&A$J>tsuqL
ztEY%lYx8HZTT)_sS{Fx#*)0^9**LZQf!xB_O-;*}ek)u1`C-*G#<a36*VdJ)27QmJ
zx+i+-<E(jCo!av@l-Vd~uG3W4DD+z+bUpaqav9%3ThC=r+r*Ff<b3=7DcA4QqYRPz
z>$2_APG}0M->&SvkYo2#<@BN!y@n?%mT_tyHGWv+<#O=nu9<9;McGzGg|e-v^GT}R
zc;&Ou)X%Jp-%GB#-mXtr{#Rfh=cl-1NxQlh?aOS;cYp38xVEvR?cKG+i9+w@N9!z|
zQ~dXyt?-+cqpUhoOkeJrudn}iZwJpKCpL|o)jNxLmU<jWvhUgV{J@IxrK<g`$)aEQ
zKD$h3E_<V{u3a}RP-@BFzIv(OvXcd^Tm_@$%5Bw37tCzQJ79eH>A5gBFT>|LwLM$s
z^-O6Dab7d=+#Eh%UeUGITiM*Qk3~<P>MEIc=2p~8w?kXaqy1wodBq=U2&M?FiaUGi
zX;}W<!!|`#mv^VHcvU^k_jFn4^}~-uR_(hxW6|c@_Wj~l8W~C^1##BK$$VL`zVgoI
zPo+~ArMDlp__O?O_~z>j3m2_l@#xiF-9;NR8m<;+w^;{1sGQBGx$%AfhLu0G%!F;D
zt(QA~aX)LkHUHPQ;vX6BdYqXeI^3QHUH84-^Uh^Kxg{t22hX()-$SOnZsz9coLOi7
zJ|<@&Ur=MR^eu+MMg9_9Oda!`jepHzf4)@dN8yWUwGskHZdI55`~EaR@qEcHmIjl5
z|0;bdUP#WXww0LeVe9g_$oa9d&d0r~%|@9;ev?z!H0;VFR6f3Yx97`}jb9m`zG{j*
zmavW`DeHS~c<(vY7osU19hK%evI&9qY0}ct3H#r@&Z^08<t^Zu@+@Rx?8{>DeW8zb
z9sD%=i-X-<@idQK77t~|S2x-ESgdq;q;uMuE%<ChpFRvVVtJWcobkY(J7HnxW%JI^
z|HqgYHH2xL*mch}^jN3w=X296CYz*LyfWWg_+52@+N#i5d~<`EOwOKQ%)B63eet-w
z_Irg#LHtt-j`U}3ydW;U>Bs)xY`@qO{`@=pzvm6RRA&U|US6-X>b>z+&lb=5>3myq
z<~q&9MJze{_$SSJ?0EP3<t=Y)A5592*yecmTwun`i#OID>+5=cJV<io@2nhc`wQMh
z+6D(-i8Q<Y>|M0(k-(BJVa5kl9eFR~j~tDjS~$@>`E~UsBR!#alGoHGdhs=02`DeT
zoj2EjeWuuQ)yoMdIp!JJENX1I-5w+Ij5p%aLc_CcihtAlqn>=)5>vhYGUKtmj&<)|
zI4n|p9c2*U;`#H3nQH&v>GRC;Ru^W!cj%w`spZ-BUfnW=k1N7%3-BK+n9CJwb2LRp
zu-k2up<_{<ev<2&Uj9k!v)E)NvcGaZ{DSf2;geHEdl$Z#cXGD4y;0Q_Ud5{mQWGA1
zJo&}>q2$fb8!Hbi5w2iZ`)6mo{#`i(rl%e!LLObY%QPih`}9cxsV}8IOxB;Se{?pv
z^iEd7f!D>rrL)1U&?0<?Tt({+yD6$wi^@-lA6<FQ@7w1Ej5GT-{WfUGnKLKnL7<)g
zX^W=3J66wx9c)+GOts0V<+yd{TI}bg&T6NdKX2Qb^y_?6h>|A%;VW!^&mG)Y@xXh#
zduQ=RIkyY%+ZBJPT3&l?^(QX9Bh*Ydu<pj2t$}=>=ksUfUTL+ooOtF^S!ns=7&qDD
zS|;)t@<lPXVkUaB)s*kvW)>y1D`ZLAWv4gu>+Y3A+rMx;w$9bmAV6iOnDPz_xw~r%
zv|p@$y^iyhN6VMB1xK$4|GL~2`9Seo*7sXmYm);x0u}`p%{n35rgv=u)8+G}#`jIX
z9hy<seA4fJis<qQ7lb{xGI4g~$!-5u+no31uu$^jT~C<WWv=%8s5+U-leInIn8QSy
zB<^CvAhp`}?$`Fc-u5|_>q!IGmDKnuhs`4KN4_4e(TZ+TalNzYOYHA!jXb5B{rHz>
z<{3Q{$m>co+2$Mm-2Uw0b=JJak3Y-u@;SvTZMeo*tG6dj`A2X1i@%&^`QO^hzO4VD
zU>K^Rad}hN*6i~QZx$?5FRd=va_&Pnr~Kw6pP5ZV`q$<@iR?6WUwU<|y}_&<a^E+Y
z@Xh7ly^LM)YWR6s&c)w#uB(UdJG1=K#<{wuUw*SnIB`Aqh*74q>S8WVTi#i7*6%aT
z__gxpZu47nW`}D$Y}lnfdy&Q?&miTw&6StmcdK(>zTzV{ljmz}@>lQR^M`-j%k8^W
zoN;&h##M8}oSn^+XO~S4fBt_>jF(o7mQ36R%_sBzyk7bAbk@!A+V^)I^e^7o-OqH|
zteN4qq_{<W>EXSbDw58LnCZ*#`Fwiy$Me|oOX2n=cCt~{FFo6X`sKb{m%A#?WfeBJ
zIpg?x+rUM3JMPN2UEJUE{8w$=iJ~3*>MqTn)xW^C|G*vduj^jjKDlRka~WgijUQzl
zbGEHJdHCrD+10ae_BXLOCfl@2h{^t)Az<O`c5R0J&)r;ixm@N(lpo$SSEu-8pu5Lp
z?;f2t<E>Zf83ph0zFcCrckeY`W3I_&63GQC;-}fg%=+sbqA&F(qATdm%G|$i#C?_C
z|B`Umy_S@CJ^RMlufJE!II+5Swe26xZ1;`@Lb3e6nGL*6s}HjC=s3$Pkn_7xzsoHu
z!;RZ8PMUL#+4E!bxrHqkwY+<3E^z3~Us276zl1+`x&8lbZ?|H1G-gi`-2Vgj6itl{
z;Ok@!G0%rGGz9H(CSskecmACdf^in+bDJ0}pBhb9h+EV4PW|M)<B4y-Cbiy}-K&@&
z-dViBZOYNJX9|3ZQndGL+Z$Yc6K;A_`Q*F`#REns(#lJ1_x)P6>uZ^#(JqBw$N$CU
z`rVtiC-%a}nZLK*(wR4JzD?y(7MqhIfhC1?rAc-Rx|?*loQ!7bpEFnQU%zYDzdwJj
z3%eNwK9O;o6F<-9-S^n*@3v1r`^|U$%j-MOR0Ib7{`F_qyR+e1!aGI2eOz_-ReMO<
z5}i9C=D#MMiQp@`;r=x%<Bfw~ap7@?zbnpgE%Zo~=Z)R^wmjGT%dfd7j1~WWSS4-0
zpfc>q2Jg=we6Ppo{SMu_?zy~)Tii6k&|M!7mnKb`l5_XMfi=s2@jj0{H&giIA)aL(
zul^duuecwtv$f#Y*-740pL*#`+j1r(@1FI{nI~92du=ni+;g(!j7!DL^|#mk^xrMJ
zrpGCBa<psi@z6wF!DH-i7kX}cn;`G?Oup>vI%f78d|xekQ)U*e*ULNpa6y0dlInkN
zo}RzoU$jw&U#}$M;<dXXkAKQ0Uw^ww(oHgA=F=nnXM3jYymGE(YfYY-=0%mYbxVx;
z-aIe2@j7Fyn(@<fZd~dVjUd0d_q5h<oURrZb9^|JQ+luZ_Qu$yTQmN2KEDyIKf5lx
zyf%58qQb2m;;EP8u3bCK`eXKlyuimID$0o$m(BnEbX(lj+W6A#W?w2MRA)RdD*t+E
z#!436Vp$%pDX*5u>`Lp=2}@b?rR^^Nxt*UL#N=&X>>)E}*_>D1X_megD-`avB)mE1
z!lDzQwg3BW+bP02cUHx|H@|(xE3i%c{%p^X&OPg9J0JP3Kkxsi%Rfv{r@U-_ay$HS
zK;!p<ygh9jADF(+dYzvtv29mg^>$6yKRpxKZm55KqZ-Z<Gx?zcOLge%suheIRvoNL
zV%*Hi`1@+<-j!?BR~?Ez{FwLCk>|6scCU9Y=J2SuoPTKEsV*kB=J&n*_4Zw^jNF_H
zyO&n~=|8qYMCMBM`Lp}iK31;CelEQ?(}zXNW2WDw|9z_uOrJ7ksq~JheOc|<6Uyf_
zr?^JE`kK6IO4Z+;-1b5T))Xyl3);kaGRS>?{HE2{dpjA~b{yY(X-#aU+u`r$n3wo*
zp1YC!&cuzm_`)NHx=XY9*M;OW_^(RLZ*o6Xd5h7Um#=j1eUs^8n@zWP_WSg|`kI<w
zJC*Id|2d{jYrehCS`obEKo;A<g=~9Ew=zvPnlSHj&y!OxlY$wq?UDcLx7p~xy>;2S
z4>m4XJlk!vigg6boDE#82F<>PeWv1v7hRjT{nxTr)w4f;b~s+Qy*__?%rrZj*>6K{
z=hp1;m{`fab5nxSW}6inM=UNyPZ2*5;`lqZ*FZe(spE;gamK}e^j|!`vreG%XT7ta
z`V7@phxHnVs=MW{MLVukt!XHcYhX=zrYPoft4ZXb_p2+{_h+*mn0@gqi-f6)x4fms
zzwdju{+}E^C-Kl(hs%xI*E$NCS4~dq)3nw<@W8mseP{gBi5oAL^jf^P{eAoN^!xvQ
z#AelTaGpxCO3_#qeB|Z_@x`2+Tdqr{hWPQ7sIREMnpgH)affV5viz^!#tb&kp7toG
z$1eGSEiYR7&P-awcrNhknY!%1xA&^9n7}>p@2%C9Odft4?&j;gGSsm+aPqG3oym_i
z!=9d)cqdu#jBQsy%B00_CMvDj%j+ezs<)xw#J1V5uDuews(LkxHT70PdFTd7CYN^`
z???X7nz(KPqs%|iC+8mr*=RGLleA@=vvWgJ%+G}~N2?<EYH}VWD(ydgxMqPe|Kdy4
zGx{BtX{KqoFYMU*gO7C<cqFQw^qc?MjvF}p9W7%aCUMsM{(qfj;xFUiG$>$aRY
zp`o|Kjz#ipz`EdnEW0$0J~P?1`9f%d4ZF{7vjalx0UXnWTyOtldi8(d%~=QLF5-J4
zwWoWw?`ON+UJLm`w$7>eZ|{3H^Z<veO>&z}-lhDiLrxD}=FSn|P}`vT!~W9#qj3kr
z`RAFrxl2zn{-IksuW*~O=H~`Ag}jyKZf4(qZB}G)7mSw3>Ix8UXuEc7-<l&nH@27?
zY5p;rq*0dL>)UigJ}T8`szA8x>wjgtiwdo-GJRMxsa49r#W-9sp6BbiG;WQDsUq&{
z<@vW;_a4qZJomtb#^;(&Zk?wMTX)`!tIsR#II*seRl2_;HM4NqS+R^G>#l|rg%kz8
zi1>EUNO5~dvE_xfU0iGTtqwoCcxrO^LXnMYwin)Zc*7O(OgVfPSIoYc(znMR8D(8f
zoHx^brzmr1;JHSvciMk%%<_^-3l};Y$7?1YXc=pKE-Lr>p3H4#u5P+*%uOw4IM*or
z?>JMLC92o_xus6@)TEPaSBw+(mENCmDf`x?OlyU&yJlHzt(la4N<e+z1$}3)8{f^$
zN>v{(-L*Tt-R}Q~DGWJbYyt+Uo3bqgJ~p&5x1PGd9U325)LZgD<LZ^$Q(0v~T<^_V
zDD-vZu3fKguML!Hj})2xZGMcq8o$PbE6MlE%ovh)t>g56&ZVbVsD8#k(l@|JaIyW0
zT`$+<E7u7~Ezyf^J2yT1jM1d2ji=t-+IO+*{aj=2kaf!!2xhQf+Hp_BdwKhedD3T2
z9q+%pxm(I2HaC*t)zM6Y5>}1FZ!bPb_!&6IS^4>qgE<|-ol#t?S*qUfJe1qmdCb%x
z$bg&6jd%0XOQj0WcW_s1o4Y$_*Y2JuhgrpyOBH^qep}r><NaZembZ7NJm^vVJ41L<
zNX_z9p$gvl_pZ!+S`$#!dZDU3Ha}Z>XUoY-?#sg2$t%>?FX>o0<pO84-n3opS_Z5W
zjxrg=I<8PH?9x@3Td?$s#jB&n(P0IFJAC&V#5ZlcI9=dS5Qq9PaTC+s-x_SL|6@LB
z@rGeienN<~_0BG>4;z~vamN}9a^J4^$rXw563XA@9L-YkVE<3OL@lA8Dk=YsZe0{V
zDf=?*(Ov7Nq?HO>J=|v77Cs4T()wE$!z%FGYVs~kzJp2jwSQ-DH%BSwHalF=OHRIf
zaqY?;1~H9q{F$;G6JiSHmcOmDpLnfU_v_qqqN^Di0;e3?xum!w<@v*9FWdG$bq$bg
zvwOEE^ws%`IpIw&J?6{2e$tWi{r9_5jW*x^E<Tk|=+m<L*jE<I!|bZs=MSbd94;+>
zdMSV2)Q<nV@)+kcZ_vB^_elBV9Sqj58D5+VU)_C;tIO(QJAeCE&FfDjlFyi@##p|P
z-Kp1j$VW!u=caq#_T8Nz96RkI``hG8>K;cEG_2O#ezxP{7p0l*4b#|#=Pyf>>o=?|
zoYgZY$XtHuueD0;6F4@jEnL*vVW54ou5f|FH9dZ|F1_wY4htVgp6(G^;8(uabfvKQ
z{DgyLug@{G*a>pye3A-UmHMCc>Jql<$@%O)JaLa6Sh4In&?V2c%kax#2}jAV3x4<h
z6<De_>6=(z#+m6WS4M_Nt(YQs`i0x!_~TnS-<gM)g?z~EeZB78`rBWZ>Tc2q`fz61
z<l@?{w7B=#;hPpsUa&k=KC9)x>)Oe2=N!G9*O*^8nzOJrdwc7z-`l6It#e!UN^Ij*
zes`YO%fD5G@0Xq}yZYvu*c^pYuE=A#yxtN1v8qB`+^a<XX2tA3@O0PS?G0<g)-QD0
zVYBsN^C`|%Trc^AzFu=OP1R|8s5Yn8cQ1#X>+uKrvIX4R|7_P>-kI6Kf9=S_-ACqb
ziTmA}eUO3O_4%UTcXv;?bLYpZ-CG3v*R5=c*3;0?pW8aIc+c&=V56?c${9kjTm{FA
z8#sSCxum$1dzf#Nvw5XbwPl5{wCdffyY9|r_Rrn7yMM)>%H<a)_+7fkA5>oO#<8)~
z-?Lz?v>*4xc?=@ESABfYVZHC<ZRhD*<^QK{nv&pkP=xh^)7=?6ZnrO++0$ne+Hf@X
zU&g*)rkxXVmdvYoVy>CV^210+aK@k0R}MvOvGH2qJ85FJ)4n5zV@xH(m8Et&ZTUAV
z<w&5zf6ciLCGT5~CspRUM8+^C1lCI*Nc|Y0@m4L>a^nBZ%sFnYF2x>Z1<r*I+cIK3
zj(nWuS$%57-Y>32%o8KrGeqaa+qx7fte+njIZ4j!NxEh<^C!)x{z;RUwedu+YR|B}
zHeK`ey!rb7>OPe*t_$z!ob^IOTYQSxGP%}GZsnO_vnMZ4SNA^`r`MJjKi}qOrKA76
zKMVd>{<>`Zqx9R|N1G=<Pk$Wq(tGvf1~ca`R=ckHg|4iB*}Z!G<=H*@0kVnG1?;lF
zeeN(@UYmH>V)1&(X%l?DPb=9XdF$_D)=a;hlfSL}DRAxRftBwWJ?yMxKUaM9o;2~f
zvXEos-0l;*CN6)$H#b1fv3Bx3yRv1wSG9R=5p!iUKD^Gy@Wc5jtx4~##Mmx-K75=g
zaK1bzWqIoC!wPccEIdk!N@aMS@lTxdYTCQ}1?&AgTfS@Ah27jgiAQ|G$_EVr9cPOz
zU$%M*_uF5Iox7z+qWbRlz}JzD{;u=<<b?%i=G}AKA<q{pkjPhRT-A}cWTnF6(D1c~
zJUNao|MM<yZsIbg{h!olT&(MVz0qa+l37>2HOeezI=*egBIA~1RfUCfJf$4cT3X9|
zH!YsrFTSt%4bx_kLq=gAMC9kbE1&el{?NK()x`xeLR&8`JLcM|Wt3-UJ+F^H<$ZSa
zBBL|2xxbe8nTqc-n;oQZo~y{8Sx^4I&4I`(YM+_T|M}veVzlg8t=5v+{I_EENZvP@
z_VDJmd(MezRavvde=Iw2@ofK(TkLVwmo}uWaF&jqcR#iA_J+7mLU(lX_P1^`6`A~^
zsxAMtuSd!iMvrYL9u>b?zc%mb-cE0GyKZKYx~!i`K^8T0r<g`fT{dTh%*7>hECR3G
zyk+t}R=w-77&Bi!Ux7fMh2E=&vAI=C_8d98I@$Wcr?`@1^%;}j+?3H~`t+Rrz~;TP
zTOV4)<hU_(m0G@@>blGKm)}Btm6Pqy^36`(@6C0d8nuLD!B^84zMHq!&sr+&|M^%z
zq0jm|4V?R~@6Trcd);WNb-wz~g?jJT80(rC8#@1=&}X1jA(P-K+S%j3=ycqp(-TuC
zxAVPz_I6+4_m>ymo~j6Dxz9f<C(G0EtkA1@OEpRv&Dhp`aozmyr+oIA=qfDTT~H?$
z+}$-dLTn2)#5}9Z&=9nNlyG-9>i*>0+XVgYZm)im9seb)`dAZZ1Ix*>PYLSht{9ij
zs>)NF`|@j}dZ1Xam(Ao5(f{9L|J-S9xqR2s^Z4W&&W#U}HvX=?ulFHyqT#+1U*x}k
z&no}=^3~<0+3Ek*U(NgY?ANQS?Mm(HYtCiu+i@@ErudIVBHc!(BNmEX-@W>IeMRBl
z$#PM8USZQE&7HZ!I$RIBOie8++`F&p-ruL{ws|uRS8nRjpC-EcQ2*Y!PDkQ}eRNg+
zEO+OTwrwd66P?PS{AKep>9dFD6bAlkf1S7M_3Y5y*X*B83T+Cn`?D)MZ}!e;)7t-$
z|6@XQo+s`)Yw_kzkdifvkJ8kV#k;1g?0UNDoR@iuT+ro)w@kVJHBEgF8U?1eN`JaE
z<3!h*b5r6E-qY!BzFQgbaZm19=c7h7H_GSp&6U*AI+prQeXsPhGW+u0j}`L*zn^*g
zZk_Dxp9b4Be|OJmy*W90-Hd>y)#~r8ayG5udcSM;l<2H5?Rlp^M`)-XJ9MwcJ#2$$
z>DGv*?yOQFRi?Ye*Lzl9tJ|N}#Qxnzdil+sb&-)Rw(obJ&0+Qu@p<@yo$1su#v3Ou
zp1b#BTT1JirpN!Y&7&MRuD%Prt?sOm%;o$-aN>-f>1PvLCK&onZ1PmR`v3Sn_m)5N
zgE#BAMmoNj+O0Z6Tg&)E|4Rm)S5jv7>8yX8FEZ48bxc*i!SpZU(!_Z6aE8-o#7!qB
z-uRoLuJ~w^&&92)tnNww^|gAlx_VFAze>fc52}q;@7KA?H7hHBz4(8I59d?Q6*0ei
zFo~;&F@?c@HPZ(D)h4ccD$BpVy8HX6johu(;r4nzuCCty>i^!K52b&+zPr79{knVm
zjDu}k-5*#tL~^TUPhPXX#oOyM{~^_luM_tt%B!CCmQ~n)=j$iCY6ZVlN{Io7zAs;?
zuya|+hpvRsytcbG(_cMnWi^}3EMR+};n{X`wt|uxr3XIkch}vnFFC`0?dKW08T>__
z7c(u+KMF~T{=l+mg<$sYd;Zg>ep=~Zs46?(xV6}Jo(wDF?&Rusf(%y9JWLL2`6~D-
z_F8>8n-h29p}NV<$(aYWwxnNLa>IhF;iGDw{T<!2KZNec9#ek9RkK5Gjyku?^~ZI#
zX0t1cQev(sDSUt9Hd!`%_SI{w%}KLbIZpo#nxl5Rnt#2B=qmyJsVq<OCGY(DCS1I4
z#f03Hhe=CW*3bRv9{OSn=b`Ism=3JaV?KHA_OW0icdxeESy9JNOo-T7{pa`L^M2e@
zwa(n}>${$nbm)bvaQMM%x0mIATfO1zDxTYgzb!X%z5Y1qN2=8wzq`9yEqh*@{$;)X
zKB4hkI#=y8-gS&?nh(wuH{LLR)sowDu2h*F$zJxVt3Bl1vBdq%E7P~7aQ+PC{BTLg
zZb~G>&a&XECf$zWjdNbEJ<c%A(<E~7qkxZsnk?ED%dT%Ix192DR?xv6v#iYnil)YQ
z-8%n#_Eno-xx4)>7qrKpe*0lFx5K2Tb}Eam_%oll;WX2*|L)pC;S8tNh6huXmfx=V
zd`E4nh~T5yOI9uRys5@nw;;Tt!|gODtM+Fr=khgeg?qO&E?y#5V^Sca>yYPFk|<EK
zWW^y4?ZOA^8jt>))5Ley-Sx!P?{PDp*9EQ*UftNG;(o_WFiZYt<-OdPH7nV9i#<aF
z3JO@6SX7V7Oh1@%YWw{?|36wEpT^=+cKFt#B`nM#6?e?%>q^fP?PzsNw%6gDuUf!!
z$YuJo0~tH_iS!;}=Xt1P9waQ9C$&zSGwQ~Qvj&$A=lNddxV!3;z}F*dAMvbisAE`r
zKtVdr@2P;-1P<2kzj;=je6{Jk$m-9R7fB^)yZ_i}V$CvnzOAPEDi3RiZ!%?WLK5PR
zvf>*ad0KH!ny0a*wz|)#INejP?M!A~uZwULOTzj@uWNb}HGafq{oQa_a?#zrk&^7w
z(~={f2g(YcT7J1J=4flr<YZIMqNX{izLmFIrBmk??#RvCy>GU?^}RK#G^Xl`7D-<H
zDrP3qSb9EAtz2}n#`2gi9IJTq*QzQcez=+EFi%{(th)A}mS@8+L(T=(*8Gibh4UCL
z3dvdiw&e_%$g)HIibd?h^^#cvPrZ&>Jac|qQYX6j#`Vk;9XU2vg`-;Yx+5Q|cqD#&
zyzT2<!3hma*(+T3)V`4^wN=>l{rN>F=c^yK_Jy9hez|h1z;?6Zj=m396H5*%7XGN4
zA^UXlvGAgMWqIxzGP2)ZdN#fF`|)f`Ij3p&^PnX?i-RQ$h0RaAwY%iDKykL_ghgCi
z5C7Y+yEIl)!)!xx<?VCFuk8|GS$XPk+aK-flmBxY+#SBQ3d?Sv8@$xiz{8_y*?czl
z_^D!SS8g9<K4#t8_v-<p%NnNLXUY#>IXn02&P`0mxIKiou;1+bA|kSe!K$z;**t&k
zt!Z<<<xRf4=62@0Z@uQrK2$vyGD&%4WO8Jw+2&s}uUW1)-#j-)!(*O7WXgm5aNZlS
zYf3-wTDH3)aH{qH1Fy8Flq7C`G|jPTVNGnxBVBQYDq%*axCq|eyUXkk?z^!i!0q+#
zvzDucJtZApxg1iS&J}&o=+Yd?$=71;Fu(hIvG2xnwMk|f`bv3H+qoMiZWQq8QogKQ
zZaFiVOFesU;?oia7kiHOhW*;_y#p`KO8#(Y-r^hcw>!V!n@~C@Y`cy9`aEx|Zha2!
zE2rg;pIe<#<kY~b`ZA;C9P0z##v_J?tB=20amd#8)TE5O7w!{W?WbfUPL}uDVjv)_
z+kN7s*;*bw4-eKSC(IZ6si*Bsn|<4cAzbcgz!^UEnF~L@U-U-pqEckrL{qbQM-`*I
zx)yE|VEO5rajNpxcR%f4S2Z$9;${5L=uEx&%w=6A|8Li|tB+{Uonw>ru)^$eVogx2
z-}8ra-~8}dox3~x|C0hfA*~(fleVf%;;GmwTl?$juNsXT``;b%lzQ~_nL%aJX^pkJ
zcpm!9OZP~*vr3-t_0zPR-0H1Md^dEj)v}l2<;iM25`4Sd+PC8Et!>*>_9!J=9ltis
z>g&vM$%)(^`S%tbGv_(U_?XA$wi;i^d&{KP^S^Gp%&VYgpfj1zdRy)OJ2(GvEeKL`
zme^^<tR#K)de)nUn#67!(UV3J_cl)3Tk`C}r>f+=e3M$-i^8mDhe#+loPEI}8kkTf
z?%*@=`qr~)D$8#?6BGQNaYw18(w<8#_}bI2&AjIxmu;}(yx}b5YW}|MW!~z=w-uN>
zRy<g;(EiPu_9g3{9%d`qe00vFHK{q}zT3C&4!v}DR?SJ*EiuAN`Wv*K`~1p~HV~et
zP}{bbH$70p_I;9OiT8~^F&i#%HZkq|&u;DOdsvKhX`N)E<bk!bZ5i~Z+L<l>Twg75
zH$O;xALk3fE#`NBzGj}lA@uWS-ffF>x|wfU4_95Pxn97X@H~O-)Al0*e)76IGS+gg
zyURPbmFMmfCz-izhciw(XRWYm*S}=%rDxz0`umf~D!;GJoh^Ihg~|hE*smNg?PB|R
z?!Gt!zmV=eNw@u9V&b$GZrQ<N`GlkMG3UO<xMy31_5L}p=DcC){qfJDf1hOhHWXjB
zQubI_UGk6RaK$P6Tbp!x=JCa4UH33OA11fFa*?L*f$~>n6>;pJlh(3Kz4YYSi4&@G
zH9SJg<dy`m7S(=i&O4nY;qKx3n!%xoNqqK;!27|>zRj=SYpR_r4Bfu@p@@0fww1;Q
zuUTs8>up=$Hd{zEG3Ya^=vL!J-`*Wwx|~yC`VmXLSIODuHC)}+JH5=xmiQQ9q8`4M
zN&DJ!(R?RQ-}2<!Yu+AP5%gZdc2!jnx7oV3H~Tz;cE96WXB}{9U&{R-Y<kCk{CTlV
z=jB6_7vI}<%IXzr-{)WKZeJ8ovMWVt--ZBX_4?l-4i<;G_RQRne|zg?dj@A#rUT{m
z)xZ4@^DH>c&GPWNyo|*}rgyg{Re7$T{`K#JNFMFx$4};ku2h;SQ9mQbX~yF9J1Vxw
z-qCtgrO+6<edEn(!CIb~!a1`i3v(*m$jsB>o%2nvw6?wJkKkT!bMHIhXTBcfz5Yr_
z%X-R<=WC-jawzA`vwwY8bk~nP{Fl_-AMgM9`}g<t`~RDn%AP1`dS$LJ^CzUi!*1jI
z=l@SyPFbLGOiIyeG1s0p<>%qm?FSa{U%2t}1=D1cW9-?Yw(dI*DksKfs)RDEvU+oQ
z;=*K&xm(^Z_U2o??Q@e)%#~oyzx#53^+t<XmV3sk`gmDhnmRH5!!Ls}`Gpx9mv>z}
z+2YPoy^K3)tJ|d|QIj_ud-H3(VA$R2n~$G}h<?hjN?)5e*=ymB$Df~SvUDxhlJ`>7
zt@<)CRpP5rYEaEnca>bGIg6F_QzxgG<{Vs~Cj4~zpC;cw*EedO-}J}REOh@)-=LJ4
z78^OI<ge45BX?`*s;2>If=7jSRkd*Bmy~D7@CBSyc^EoB=7Pn2)8A|wHnocvX=OxN
zbku%r48M3axT9`@>91uO&)(hDWM3k5^M|$e?xIOmhbwZ9ZM{74`CTRjrXscC+iU(k
zZh!u3T_yv2vGBpGY0J4IiUMyN2d;Utubu1Ab+KDXZ&XzDCd>b2)SbZVbSqfY<&{KW
zJio%zuZizNL^OLBT(h+D_qZh;YyEwaa9_aAiH|ocuv_F#vVS(scmKOBC;rb`UbD&~
zG-D<I{ljlI9_2T(j(bv>S-ax1!K)x^KAo?+jDm#=lq((>Myk&`)lzb7TmHg3k=98k
zKUhU;Y+86vJxA=Fw#TWMbDTdrSM}wGOuTHZE3(o0z2u}Ly}B3G&1aaT3&^Hiaf#eo
z{lMm~vZ20a#L`_gxv!si1V_s&DbxyHwwe>}_1#9?d*;j6+kUC%8QqJSa;^R!`~9uI
z<gs)YL7hNwchS_?6h1p@gyj?=Bce_bS{vnEd}oKCUuFI;(Os_VE+ud_oj)u$=SXzn
z)pu$eOHVk4YM$d!F?_~zT;=$tZ}~^;EqE6-=J6<=?AMhIX;o}=v)}jb-z@oa!iwjG
zKezuk-@TbXUH;tDJ<tB-mOZcEY4!VK?yQ4dD<((Hi@!VPrudV}ne(Q5Dt&tNC#$@y
z@cz5)`s@EyPkXlL3^%KPOzwHTUwb1b&s_0I>*&^FI-!fsyjpT(>FtGgyMDe6O39q}
z@YDU@KXX-us(#0v&t7>V<L%<eQ?5}B9Xpn=Zw~8PwQfoD?k(P)j_m*coPJ&Z|FX{N
zkS9~^e_V|g**)Rkgw>UrhU>j!Zkc?m+B(7Y<@)Qrn{TWXnfa+pqVL;9uauefC3kb~
z-9LXm%qgw%U75tTA2~r&^P0={@A-b^U0UuEuO%f{zP3jG{<zj_=T(tA{Z}sM-geAi
zHb3l=opjWW6Rg$Wemz~YW9lm5iA`^`1=i@TF?@IH>|Gs4-Jng;*0Z)oU0F4Wb=})v
zj*IJ6R95fXcuwKrNv`X0IZ=D(7hLE1@+hx5{i>|iw`KBcxP%v;ct3}WJ8;6T^1or_
zZ~tBUGf6Y>)RrZ_&yE)_4Eq0L*-NwI>t=rFwGn(*ms~GnR>dlHrTyf-D5<*>wr;Il
zf4{%{ZQ_<wrycA9G=t-+AKP?Ae(}?PdQZMQ`}KLQYsKp){7ZW&<hM*vf2Gm-@N7|w
z^$U(4kG)*FqnvNu%C6wl<xZ2L_DAn|-R*4OSbBTe?mEkE4u=VBS+eO045gu`Za?QO
zu9KX6lruvqD^)bk>&8Nc*6RXp*P?U(Oh2>zr2i?U50ky0*FU-1o;Kr_@A7ohRZ<LR
zR&SG>qoe7nW6_xBW-GryYvS`KdCvQ1e?RZy<aasZBNv<hox_K8chwnJ-}vLLnf2@G
zFQ@M4!k0<CkCrcd{d)lmV}J9##66;&AAL>StTVHfI?N4LU3S`B{vhN+s5A?QW{~F2
z{`(D{&yPQhiQHiu7R|8kFUKSEyE0K*1E#uPea&sUpD8hJ@?yDJy+`|-n77`~F!R!L
zjjg&Zx9f4oi3!)A9Qwd^k9*PFGN~^W4Y?*(@;kO~zgD>a<Epmo={{E%Th?YhpMN0v
z<?{ZwUmA{U@bw1wJ7x$?W<D5e-B)qI>#3^6M6QOUdJ8{|jc4Y$M7BrXT6S5qVusE$
zjSsu`W`AGd`IuYfhU_Ee8%<k8&#v(c+ff)*{e9OyhWE#{(`~w|Wmag+tjoRE+H%BY
z$C9O&y5B2pP}=^5Bkw8e_Y<pv7j{`O?aS$xxaK`COXiyLn<vX89{l=dsqn?T|ClCc
z!Rqf-8N0rfb4%?My0>A<!iXDdf4}5&oTWN{xv|m}d(NY|Iy2_4^zu^Fba#q0j$3rn
z(xW7{|Isy(Z{KHlKD;?8Ca3&}5R=)mtG6AS#iJhtt0~M;s=Kga`=&2dzpt#j&Bt^u
zYQYH~w+Ct)Uc_{oEZ2H0_OAJp!>v<7(|*noe^TNv*W@b2czD*lxBbF)YgCTkf4pz*
zvDAtUo7hU8_AWTs6Xl}4Qz6j#=3n{Oi!XZdO=??|lYZ3pu7Sw?oD+NhmYnvQ<rVa6
z`PxgXFRfX0NjQ^xr=NR&v()}i$Nzqn-~aE|tL^)b`ki9v;;O&+ao^lE%Nf#CTCB5e
z?`H2U_naAb!*p@Kb&*c`CaIivv3CDnto!@KMn!nl7j-_hdxEzlD++%bCFCwkHLGUI
zypW$|)u)nnl=c4CB}z=m4A<KJoj=vlBOcbV#5GF&U)cnXg{B#?FE-8*^JKf*y!y-v
zj@f&~lDZCl&JXx%*}E~Orv3T~3k3t)85-)gB@qf6HTtHO@IMxMag1||MUrp$gwFzN
zHieyzWH;h@Td<>A;&$&;#WhTFQ?EBWd)<EXn^X7voqj$Y4TD{B#$HPgc<-=W`H8t@
zofxZm%JQN>Rrbomp_^Xtuc<gPtF(;!fTXLg(AKJgw2c~0MHZJ%ZhZUw+zm<Xe07#Q
z$;o>9ezzKy+HGW>H!*(F-+6ETMI4#2N{-t@?dq*xTh7=llASw8^r-gqzb0+WH!GJo
zsxhrRl*I5}p|bIF&OYD6Vqpp{8*D^YPMo!MtA4}8MO&0|l}tXq6Hd&&UcoKb{Y8*D
zRx_x3FYk<*d6)I$d&MToNB2hhtNxSwzGCha3$geWOO2T3>vYI@u6KWP;DDs+OU1PI
z=daYlzPWt<ce!j%prs}g+k=(~0Y952G(1pwerucF0mhn|t;^YuPn%*B<z_4SEa`|x
z+S<kKoh2u&S<c;A6DxT9fNh!&_o0CFishS5-un9KfkNx|wc!$8J?_8vyl;=aTsu$R
z&sFlpL+{7cIpu4vo%h-LT=mNXR>Mr8{aoCllRw-Nzjk=x_sK0)7eg8pI+uD(-4MlN
zs;%i(lPP#a(Q@@8k;7kIwN1Xgd+?Fv?fd-P^sf;=&t+(zw^zIK@OWBz!4=jYp1U;4
zKf8NHWVAljWSPC`8~;89Lyk>cNhz0|cki0dmVZ;}>GI<tdCXi1or1B}(FxB!?J<#Q
z+_H3y24nTBVph!!$3Fi{k#FhVz`js?#p^4vPOjad9veJ46V97&cGGS-WwHG8!y9}l
zTt#Nr&KaIN+ZuGl@^`AjdRg1J$#x7}0zO)&R5ngmoy2Bo^3+J7%9e5Zk**tGZqIT*
zzge@HZOzIe4#!EhH)N(7cl_LO;*M{5iDhf)q;-$Dl-P3;ymwCU`xVRIw>zD6<>H^r
zc5<R?EB^D<ab@grJ>k0|Gxyl?E7OlIbd7w)rg*94X1dOeO}|u>a{q^h&3Rk1=eO32
zJ=@pUSN?r<_jS2p|GDCOnrpr;vs{$2Y*Fu*(`%-4Rwd}IOSX+DOg(sivfP8}BM;Zg
zUnu6D_ji86D!)693wpC3sjXYHhoRqx|H$mKiD^bFr#Bim8{4M4JeN^_&Ymr7`SfLO
zG1sw~dQS3<8mSI%m^Ot7$|uIOJYV>~=j7H&G1tmgPkeBiVWRN-^1mB2L|dc8oGu1S
zo|caY(aH}r-sN07jpe`e-O|OgUu;~}GUa^1fhSxssmVI=KUTJ;6zj6yIJ4H_)6zDf
zv!6P?I{mPDSQ@!r_~X)rR~J9NGSfc)tK)mw{wXsbF1=p<zAKq6x%}@X#k4If6E~~Q
zocTFX@jUaw**jl4|JX5)<x!mP$tP!hd4#hTC+|#|QrG3j9)2pp!-At`PGnN4aQd`I
z(brdImfiV0JtRvn^B#lA%ue2K$9;1i9Qt2$-D28;h;I+O_bCPWbM{Cd+rOufd9Myr
z7~|28x<cD6Jl33fVZ-09b5~68D1&zLlgf>uK|T%(ZML?ryBZz6pdd+R&lyq0Ii{Oc
z>&|{!AGLGJJi&MSFWfErS+=JAu`_=F<Ky56$CDfv<@@GeFiUmJw3!rs+g3^Qh{*C;
zO3Qdp#W-k+GxA)Ph~D~cE{kWG5@Q7GlU2<Vc9h+aD)4?En|sQm$35$^%$b<P+^GK(
zx30XK(=&Hg=a+2%9yX&Xvray8`7`0bqO+apA6KTVd6NFLR#-9P#2zERV{`c4UEpi{
zY?su&YQ^P8{9ByMR*BwLF4$#aCiCig@a1=f8`xLI3dIV$fBo=P-{I@b6@P?6`1h4_
z2H5^h3VA-oICA}yYupBt`p-M}q?9l&v|8-Dh*itE)J>=7n&eN8I`Pe>A~z+c+&QM%
z#p2nr;^@MbS!>_U-&9xrD&^SB=Ck`u-yLYNyYx5B#Nk0&@yV`>8^csh|0f)-PIB0_
zt7dZ$tA)2vov;h%5-sH)r+s9eG)(E2y5Z2~Yi7vaaP|hn%U_Fj=0=%MNV`A($E9s*
z7Y*MS`%Sc$`=<3fYO#&<x4O;CAAH|^x8d;m`#cZLbJl!JwuwtVTKZr0@P;)JetVTR
zcT6@&SKyVKrOz!F!E3!vfQ$PwmxV@8S@|5Pb(7WYeF}`)g5L>ropL|Db(dXgf%uI|
zqp)uaWL*6+idD`=b+#wCntl?HR6pAHd#&8DmG5KS=L$sbR^XAiWgc5^ZGOk=W2eO?
zCry{wADSm;bNu(`;<@$uqHjwCZ|^Vuxc5~hb|-HhIea1ii-i&=o98^9y4sDhasv59
z+rDqO^E=M^M7obaNx|NqEz9r6FWQuKe*0_RX8DgZ95d$5eWvZa<k(!5r&F!VC!Lux
z<>IV;96|5@oBd7Lcj3zI^BQ4+t@Bt*Q>C`(Esoo@BY63moke@Bav5e$T=l)bJZkY|
zL%*MM^R8FTn6|F4b|TZB1$|7**e9J+m6}xhIBjQl@^zlFf;pkfK9=(JEp7a1WKsX_
z$%~S&&lld@zg<h$@#0b*?xG2%pErpa8L_7Enuslvl%AUVb%*3F=30Ldt52GpM!)#u
zIvMQ$9y#vwDmG!A!KBkS7I@koI`{m_wXd5~l#@&z|5&`+rStzaAI>w+8}@yRJE$G7
zrZvX<$-eUf`@8vdZr<tM*kfq*|Mx!8&3bm_>s+ra|1@LX4Ec)rP2H+BlLRY-U$48#
z&~`EMTKTm;hqcp<mn~S|a`fJ#S#uAFG_F4TH_di4!@T#k*BI0{fB5m>;>rb2HaF?Z
z3f}IRxMr&K@44JeW|uZdSWdtB?yi5CU1_K0w26f(f~#NN_x&6D+)OPmeD}2p;TCfX
zGUqiUZJYP$T5|IW<_8u(_Di2PxSyjG|G>Q6`TDK*hB?!wJd+M#y*MeoEqJE(mP>y=
z{d)B$KK<GI|ILh#GBLYy;0_wND`$e-mBVs~iV;zVsBDe$?gw?{zFC~;f8jmB&`7yk
z#I=i~W<&Yj2<F|L#&QalXIvMD`DZVlc56~q?*HE+N0nAz(Y0sFdC<&g7OHdY@#^(m
zpX(;8B~9K{|D(QiM^*jTI^}0uKg5^b*t2VYRh>FlglA6H(Pwq#PwfSymCe<BC&%Q!
z;}5_7?B?I~;ZEu^Z%@s8w>|uN{_V>P%TCYqnQ~54&)@lHcC7E;3s)BZ{`zxnNX);r
zT0+So`*uz>)9m^=+x)IhoQi9l$CTh*s*|6bTE;fLZP%*ZC)XZcuEj1{_cucBbz<DP
zIckYNkLf<`WaLbIdH2fu+m*|s`>n2T4hRU^{P}iD+!>+B89d_h>r!W(YES>Xb?&Yu
zhcC$g-gs|U{1l%OwX@Ili&iYJwa-6WR5x*@yS2xq#jkef-tFDIG;~@@rHIYj>@Qxc
zcyjG!ZcBYNjuiQOQCHM6>_!Ot(Or?Ofht}{rMEq8u;P$xwL8m{zgfwDOTg^tA4gvO
zoGxEq_xJsF36@Gh-d~^c#1<t~?>S+6D?-Gu<=5pB8{g^2Y<hjao9sS$Q`bxPuPm4E
zv^BRbTU0(zm%O34`1I7b%Qwz+HrVXx^{-;bzlHKqHV&OG7yTvJPg~?nww%zyc>8sN
zTB2@?W0T$#rB!wB=PD^aDBTjjd2RaLr9LbtE7pAPEoWS@E>h&p-dhRpO-}k8eEYVZ
zQCljwBlXG&m8~MCDdLeTL8%YBKF5{>d3bdh-HE#R-R@4zg|^_j&o@;L{xHjtvRjxc
zvh>8E<ueyXo3{UA3tpd4AlSS^L2`oU*(+b}cH9hckYN32y=Tp~Gp@RA(Qan;(+*z=
zS<9|CmC0a2&%(;AT}6i^PB@+yFx$P*{*2eEBR5{G{A5(wwrlNa!Ou>Ir%tOZd^0<5
zm*a{{W>Jby<~+Ur*T7_Qztq{uE54_(EHqO6T=rJIW!D@LmvZGlDStK{<lF3i;FOwM
z^_EX-mN#woEy=z4ZARm}TY*dY&u-aov-eJ3y5rL~Y^e$smkVkxzy0+vVAuS;YegEG
zwj^kKoMIB*<TtNoQsd1?r8jMxxa6B&&Fo#3EMn239VW}CIbXDC%7M3<2Ln0w*lc7e
z(U1Szla;c?!{Vga{>UdBtc9<RKbE`G+_6wKCFRQt+hw~&Iz^vcT&SnMhg-!#O8Lu~
z1v(RJ<nE`jDdowUsGOhaY~N<Gb;`1*9p5*x7_3{?pnhSUtD}N-oDzS`cN-~_zgrft
zO{fTRYpDFfpv+O^$2cQGRCDzz`_juD59S70G)G?eWx4P`iIkk+;+6{s!<KJ*w<<to
z>y8uWn0O@q23I;a-<cxD$?K{jSiDB9gTpE?^VnR0yFB+yE}s2s$o7LtclD;-SDtKi
zb31h4ek#YR=@(h+cW+Q-xh%H0hw=7fbrwIizsa_&DK&M|J<r{ZnRs2KlOy0c55K_q
z00noy!%SY4Hd}f8FIE;X<et{wesoLnrG1|tl&xE%@BJ|B{{P3*<KzDQZ8xoD{Mpj8
z-D}TFi<1jxoqH8iZe^qN@xr_dMHx-Eav7v57!=(4e{?D+xu5e3pQHO?nX=FnR}D8G
zwvdGf7VSFqLfavQ^UmefwR!pm%-Yhj$pX*WPAh)sG;y7t5?_8Y<|(Js!=Bt)opAm_
z)2S=kj-Pc|BEt1TG~Vlcg?~c1f^xr+(&{EQ7wLDiY*p%Be^xf`(_I_%q<}5i;)1;3
z(Qlt}lNNqrVZ0!g;~%=_^qHI)Rg&*5k6nJuaA|hl)v5~?nS%MnC2yxYUrE`XX2<Ls
zd9b(q-t)U&i-p*0w>$LJDC!v`MNBRam#<QJw9>L&{2Z(8E&at0EE4V}hQC=|C1ZbC
zQtHM_l}+b9)W6kVvsz<fjnC8i3nw(M-nJ51+p~jt!dAKFlSXlmvwai%LcYgzzGnX9
zbY#Px$i*k+j<IAj$gfM@s3ozzd5LUIG3S<U(WkkwQ|C{Zp&_}ppm?T;{Hp_!Gh<E|
zE~zqK_-0i%!}TdHw@<wO8gxQeh(~~7TLR~krO69C7VS1X!M#fVK#;%a*7!s7%1<Ti
z{4!_nztn9eS9X|0RejlQ%KXaNvd_~%-u1M9Z3k1=VSZD$#zkANiXETN^o#rS*?Ib>
zf>fL)8BTrqATvJrth|Man$nft<8?DGu(btV6<y~RvF?O?^2_D=7yMF1HtpWJ<Ium1
zclTQ-bT8Vnp5M1Mgm;I)#g!i;!Vg@|Gx$|p_)hKMyZ66J`G2mv{baJ_wVD-2;;!v+
zeQ$B)_(HkDW6ZVl1D@obQ97LQch!D@4uu6PCG2A6_hmR<EBiTR|BArwd%pteO4@!{
z<$lQIzB8Hi{dP(56N?ID4a>b_!xk=MzTZ`MM{$yY^qYn<rOnOL+Pf}p>(rgpV}8$(
z|B~;%#*#Iv``5TtZWAiY*=N$yv_T?u&4;t!gnloSsQU6<B~s$;x<e1;-nAL9%h+-3
zf1L4J;PGj}2a7Lnc+vBrGCM71%AXVW{dbi}$UCO@@+LSsS}hRv{^;9zde#}!z6}lj
zEAHH!{=Bi9r^L4DNrGh0T>Y$j8&v--NewZ4;=OOpEy)cEx^sPfIqo;#UlF|Tq7$RK
zvt7)3&S2wJEw-0uNi0y$S@1i&$H;ri)BfzHw=t^S`kdzu$gXj+-|ezfJbRMj;UcR)
z|0_S6vQAH3@lPV*T!z_Zx5RIspZ`sKyC;b;?S9fV@%pIAn|VCef8VL_*dtx!%XZT}
zQw7pjs%WPj>t?cJ`Vw>7l7ai_>fN)qt(iM{=g;CZ7Z2aE>{Ea7;=<O(*Ec<SON;cD
z=Q&9(QB?Q+8)5ABGV8{kMF&^yn;{fZYwnk7zV_aUPc!fBVm@NC;zyE*w|GqAX<M(8
zW)m){iO#5Cn7i|Iv3trLv&Kn0_m{~mo}8|^dCHbMO4lzh6tFZg__#(qTReJM`t3w^
z1&%`bb*UUXjP<4MbmBgLx@LNc{l(F=`%fqJyWgA<5&z}Rfz5Xo3(6P1J6+Z;c;Hp#
z?Kfe~A|;czyf!{pkZ*R%()r1?TleqFr@vLXV;5d^xPP|inevD;V(&EyRTMgWYwA=M
zaLU}<Tl@F#?CbCM`E4)on!G8!N4{qI=CGLl+S~J-m@GqAuGpxx;>5FJU;e}4$5x%1
z+J4COW^Cef%}&`<D~~ZM7Ra+pbH7v8-+6w2jfb|MV-sIj74NGLX)nEgh95nxe$BOg
z)2aE#FPzZ5r`sj{MI-zD?04I;eovO4eZ#d~V7J$`R-0?N{i}0=em0(D_~k7px7sKm
zXs1z`YVU6K6zvCE)pos+vodG3zly$drtMXH`e`G>D=XCINq@NZIn>fkDlVYAZ*%h2
zZ$1XwixUg$4?Wu@aBk8bNeh$PX`iBW(vGaY{A#70%tFpte*6ACJ>|KRVeJ>~W+!u%
zH|_i0&UgC1=&rVs^xcOnKF{`?%RRmF%hU6PQ>U8SIZn78F8ZP)xgvGJv$%a9b>&PH
zz1)nN?8=R$CpVo+3`#t>u-mYvG%J?l$Mon7yOkyTZZ2FhWpeHf+j2IcDidk{zcuLx
zl9TF{uJ6p7R>5SqKI_}x<Ez$f*Pal(q~6WxKta*eSNgiI?p2)E-BqEltuNZQQp1%0
zQATo_WW(9ZjBhI}qqbZ+YPP-li2Q8b+O8bUrH`GSX@6JexIg9R^Q}og=gC=ZZ2H)w
zDs&>>iRntng#57C+m;JGpM9zKnV!XiN1}o=QjB++pJquuB6R%6#2>X0uMXc&%i#MP
zd~=JUanP=l5$zHuUmj?GJ^xkWs^?SKv^8(VJ${|YxNk#ud-o4<fmzp$5_9|B&s;Zg
z`-8^lxs9j)tpBX@^XuPd^TXfWuV*|gwGPYnF(Xi08PuvavM@j#G-8D1pb=xD4;m3U
zEvWY4+4Cp0a*oGufBAbzkbg#U%Tk5H1A$6M15J94e^cANIjvmwaee)&<?A=!ejLlw
zr;}*%?&az5(D>R=+j#9BkJh*S|L>mR-zQhI*5kj<pR8wBFTOl@+W(TBBb#*4+&GyX
z;vP#ijkW|yC@ZeM{PW=FbbY`7%!@VUd)n-anf2$)led|_?u|f&OYgFOH-D{qEAQp9
zHR<2ORV#nD^KeSZ|2uCd)ZsPbwtd#_)0yR&^NqVq9v-sK7kle!-{{uk@ov6d?ybCB
z`QTOwv4<aTex7=Jr@~Yxx5P{DW0cpdNE3B-OY-@((EpCZ$xn?!oXHt8dZz?D@JL>h
zVtP{Dy1FpqxYUsuY7Zy8{~H#vkLk~JVck`njzVfld}l5>32m(VSEJyx;&_wNxzL8c
ztLDbVeN8a<z$iK~I;T12Q0>k09s>Std-l#U3%A|H#wmO8Z(#7c*Z+TgH|&4EUAtb%
z>(Q_4n|EdM+tx4#tZ?g6y+31W!)$}Kg00`x9vHi&y~~=w`1^!z`BBa@H^00-`(=;)
zZZ{R((rkInB_&pAd%xX~Y?+yIF@E>f@4m+-F4EE2o|FFJ*v|IWrS@yY?=gkAuuS{9
z<@McpPAwNR8mr7cb7-x+bffh3-8zYT!buW~<}|K<#Bjt|ew*f`_~`{~)f#N-tuK_0
zt*CqOe3HGlMbgEY?VmR`8PC7bczpTQ_tVz4xa~<_%*hgw%F^06Rpd-j=h7{UCpS-5
zmtXbu(=ywNpWnM=_SEG6xBT@(tZwd~Fk4FtyFz2p%KXPA^S<|N+2Fya@pVghPegNv
z^+F@J{&wxhGK{u2FG>WTck`LQSL2{zqSyBWs)t$P?<Krw4Bzvu@6Z;-e}cNc`foa3
zEI(eCwAs+`Vc|6Oqg(&h-xXNXRo65zsIXpL)lak_;AqHE#honsj;JoMRBF2<AiCbG
z*zwMc0v)yPv;#~xPDYq}oo-Y-ljoc<Px263{i3dIE&ba#l1w-7y6jn)C194W*q<ZO
zpfpF~`$>)+GZ|0u8QocKy`*0=O=OYgGLCIGqrwjfw0?NZD!PWbC5qGcO_ufHQ>{}@
zf0WA9EOGd<=*_J;2mD3j{ye$2`JbGFg)FCvUzL-0-pAAb7VyvQkt#4+w)n+^A9C*}
z6)fO1uzOa$;f3099)8A23|~4|erjwKcDZG8^DO83*%Lezre0n+J)cEH_}cl)k)77B
zTRc;XH*(8LPy0TnZ%Xlzwg-|a?cJ^3>y)NjUH@8So13P1H+K=QrAxGeqezpP@_+q3
zAM^IaPhG}-buO=Ab#$)v*Bb}IPP&-vP`>Egu;%20SoQ$>Un}P7?m3sB)HNfz-otaV
zN5q{u)xI7drm3-fy5}ssPfIJS=fDfas{h+Q-4eVOc>8rt`?r*7T4hrOgD+(5HE*1q
zKI_e!%99BjD$;tBCN5dCsmt@=b=Gx0TpstfW$Q~@_PJZ;uNPnavTE0hH}`jJ+b6~G
ztnMz)q_V{f%?=B~6rM3j9Ll`6_>@A#;<@7D_bym<_UyVnZ^wMGFTQMFw!d~|zv26O
z=KX^8;)fGw{nE?Gkjt&u8)NczRmZpXXU?@-UsP>jS(4{-=wWAI^3K_p?iCl6&zpWG
zjV+CPnW%KC?8#$m+;1@WNXxtu&%dD)`Ddlc#$K_>K9ObG#vdfZvnJ>)oof24p+)ZV
zlcl^}^Y$!q_*M2cTl0hUHc6MXn!SrYUHO(ExH;W5CQ)<doU-@1`F_SneqK-7w!Jil
zO(|WGS!;Gd(f8eZv!>^6{Kq(V4%f@dOv&ggs<H9q&s`;xC;081S~R;&LG*L!+ilEU
z{mZXAJ+!Wn2+Ee9E95B0d*E!g_+}BGJf+efynN;%bAB>jIV*Ute;5DXg3irW)ungM
zUavgQXd=60%d<D<Hp}{7>9Wy$H07@!^JcA%^rgjVwE^KSEB5w<f5}p?6}&I^`pU*5
zJeSu+Zu@#lmB+8RXz$#0vGd!NCT;rvbyM!L>z7MqFHH>aked5lde6(v``quEbU)o`
zuPCk{`$%iu!HrkvE(n;Pp!w^^$F0}*-R)%jyw_6G(`G~avLg;RPtN@K>Pv>phvGc%
zB_``Un9r2umbfw7EM`2-|N8@jip$Jfmg=dj3ys{kdbPtcVs6UJT2gp0V@JZ4d#58x
zdKoHCef|9N^y;I&`uk=w#!51;zA@o-ck>L9`)|G-tM4nx&=d`_i);TDuczR6;n<!{
z=3DqX3RbW9)>ja)%cghT^;F5k=;>82EM`X<Pkz1L`vlKttwO8AudX(|b#!sM_1I+j
zt{GFzlsMQ_w)DA8n&f%%?I!i~>$@&|e;}!%cYD%~34hxk?R<Og_PUREk}qv3KX+^=
zTk%83oW6^XFD}+S|NLTeQ;pxp>MaFdc8Wf=;onpgz_Y8up8Lknv!^PrBrwO{da#ev
zeYWy)|5)o;hh<dKJkN6m{86o#cg|+E;jX~K;MMbs<bVG8_~Y%#kI(DNW5ZL-vs8np
zrMteLtoZNV->*O9<(>O{nqHn&&)<~ezx-VL79XMa$J8ykekv~AoHV~a^nA2_)+Uv2
zGj`TIUCQ-zVqmvzU+DG^?V*|c+vhD`$aMQcyj8f~w_6N5Upzf_)$OEFepsF1LawbE
zp5k25TVE{LvU%aQPd6EBbmlCLF4>%U{hIgk6)n19=FEE8snePICOaOGtx8=K#JY3W
z&!U|r*NxB2GG6yCcgof+ub*!DXEfLMdU@Qpl=cs)`e!FL@cJfMiC<Al&zZf&{B^=|
znHkPUc5a%WoM!!G)9b+16Y{L;S&yv!)~Pd9#_`pfnyUMH*WaGuj-0yTo7?N^_aFBd
zm%O+;XVnh=q#ldv#y!h7mCS$2x_0vW!uAEiwSOL%96!1#@6b)gQdOnUo;$)~yIJ1~
zH7zLoc(YnP!utC;*+s?or(CSOQ+VxyN2OlQ9>#=h_mVSS|2x)vUB|hh;jy)Lvge%N
zj+=IreB`)nZvN3|g7=T)m?x)WH3fYn(mFIJWj`%f<uwR7)*AP8&%bB)m>Z|0>u@pg
zT-hXQcTTQe&sYDzuP_z=OFQOY{&OVBWmfuj@BLQWPhI^O{aj?{s_NIy%)yFpY<bSI
zUVhd(+0R^H^Ch+!Z)4g8Z8J~oTP&1)_S2SY^NO-x^&07&+wC8nmh=Be-@T0ib!_3A
zJfhdT9Qn3`O)`33o4;gI^&ZXntYW9#Yvre`*>U8<lxXiiJR#-lJlnmWZO>n}Kh$q~
zeh|lkTU|*ya$mpkc4aZ%HrnAI_xXLn-?IVYe_hKYzA(oz6%>{KpPX!|qOdGSl+W|Z
z##8ZbVZuhw=OxYc%js6zzd?w9<z?T0H;+o36**#|qFluPb@?wN;cu^x-YUJ=*jgB6
zdUwZ(JufoE8XpFAN&j8PzKK=D`Qc3u*8KCT?=~;oU~V@lzmn(f43D4rHedP{sRi#&
zwqt%;elXo^|Ab36H6cP@yczEbJ=ttk^KD9ObS&FNw@GWdq8MT(r^`Qb`8xM2r<8t4
zZo~a(+aK?ils*Yjox)}%JgaBTb{CEe%_LEubxYTXL|Xpj5mMbMR=3BrYQ~l+5>6Xa
z(<aw1-lG4odAVlOOFsYLzBlj7H?yzh=X5vPditY7+o?s58}Ch+X{|Fock<Lgm6Lnw
z?0G)&<O|&FUaGx@P4?c`sjoSB^D|;)ul0*nvhI4(mGI$DTfWY*g%w8D6PN#HJYRO)
z{3fsQTYL77#pmX&zjdWOz4_jim7f#lD*rm#u6N?Z72bvW<eFYAUfDY3mEz2)k0N(!
zelkjI5v^O`B=O0zAnamaz>JSyo^{AdE}M~hLu^0qmX~D@4z)%-bXN%pXtNeM_V{G?
zqL9<2xBfn_`nzt8Zq8+coD-!{9dBK4<=2ROPFGZW<?#D6d(cP2&zNJ|;I=iS6>f?+
zAlw+sAr8i%{VxP}wH%GQn}6q+ApfN0uQtBTZm8Z8D8Ds6W|Hoo1Z%IiN{%t!4qPFX
z4?b$hCV$eHyvO2G{Qbyx*C*WBeD0?fPXyD}J9mGceUo2je7am)=%Q%g|1;+oSyq>S
z%X2-R{>}a3ntAba=k8Brn&%>U^2MuH&wTbfgmXr#wzzDJi8W2{ztmyB@7Kp3&WZ^I
z5(QgrtH0d!{@Sx_Vn=Y=yuF&AlUCf?`|EVnhmH*qYp&^ZUn=?Yd-d#(vQmPt?w!24
z*rdzTE$H)$b#GTMl$!oz;+Ync^Yuafk2*YWtg8%pwLQ3EijRBX#K7GywGzh-rBr8b
zVY{>C?ha|mqdFUROO`$MnB~%P#`mm}W3Y94yU$b2GpFDDinV)jm7)Gs*y>+}d_qfS
z8vosPY4>uQr7zucWW*Ob^=@7t_DiyRhP%;@@29Ve>&L~$tg`2j3_PYgWB&E0!kf?D
zX#SMBENk&Ko7Uw<k!uyDj8?`*lr`iB=N)fNw0fyi5<NXK;k8m}bpEZ}$o}q29m@qg
ze-*}?wp(qN?qYm;#Bu8T?P>p4&QE{wX^~9rS%sh^!P`GS*WI!2UaT|Qy36fQ{`$P%
z2hYvkF>!YF<LNqu5xmx)>)M`g;c!!yGGy89{CH-hu6OJXv$u6Ou6~!gWzj8kgT1ND
z#-Ko?wx&I4+39@KA2Ez?bDmi}N-#}ge)#<9;)<Uc(X)Q2{@ZcCY-wK!$6*%9+uOe$
z{N?Uoax5=eZ%@QCh2MMDY)=zodAEL3QHJiSd&Va(Evw16^)D~HEY$Fvu432P<L-wi
zY1BQ)xOVGyp-SzZhl}&V?Y}%VGg6e8d?W9R*YUrz)FoRAyY8+@xcHFswvyhj&+B3~
zh3%I7l$Fmn+v@zgmU|_+$vdJ8*w@+S841nP{8#z$?$cjKPj}~Eov)&!HRtI+l}R23
z+o!*FKkuDv=f(5g+ex4OG5?W-O4*s^Gw&Z3<~3Ya?8dRTPDWBaJ?6{?=6_Bl=8v`f
z#JBJqJpO!ntnrPGdNIMdtJ^j)3Y~6mX0s8S*t|Pq_c|T6X7hfDVvk6srY#zGe%vvN
zYdfP~(#HJTa%z%Pl0|uB_JQUgs}~bZkNn=c^{46A_9;S6(*!@P|GaFiZ^^-(g2EO?
zTLWMDdES?o65gB5)~I;UV9J$)SC(4+Shd^y_GG#C+?B?=MLC!@iSH0TTY4zl>8W=)
zgR}I#X|)$ar60=~%syMp-#df-#p`^%f1hu)gul6bX0v(Q-KFO@gnMsIoW$^AN`+RY
z(9zhu8;97O=JGnmWp-ytEVru{_E(YG(cmtrvDwsnQOFO;goI6A4WBq<*$?%2PFp#n
z&tylmt(TCEY>NK2P0H)!Tf<l$PW-jDmgB5Y|M9z44}NWAYf$E@$cj6yRy29l_nZ~=
zVo^0-D)H?+tvt@HJyRDJZHefu5uBwH*e=~)^-C#**Fu)_%6*Y3Px}l!{$FrjHfzpO
zqfd<We?2^GMOAuDCM`bTmvgCt|Ku8;wao53N52(HB-<UDA#}*FXR}tLgv?z7=jzX)
zjcmy;&lOgz^W^yP=GcU~+pKbRg+Fd;+xl;rR(o;N!Ry^+@l&b;+P-;swN0L^9HgRf
zW~JYRh8OQoEz)x5dZffu_VrZK%5UYVrMsn_3<{U7ii!Iz(4;x{$fe(0CC~1uJW=_$
z>v_k@Y+-$&720M>%>lWGCcHoH>$uW&@0kxDlx7A#|L*24Jk{jQs^qi=)kwEDi_?$Q
z9GsJ#D4n-9Q`GRWTf){i;zh~^7Roh2dU}zDiJb!6VJVxFHCbNpx%aesKJ2WzeQ2Ym
zZ<N1n<QKPB4!1rmdJ-iXT_t%=ZFy0U(xRZ;ee*M4racK*<t6g!Q>g8fyLQ)CF)=LT
z=eS<Ix$=Uh@Yk)+B>Q)q*dVqxug5-FPUGf^_9uDe_rqP|q!qpP{`oXj^3<E7>vHZC
zTnN0wyZ?1mKzy@hjDYZ==ibE@%Zt32m1e46{<k5JF}&xtNYSE8R=dlenSU<3FXhO#
zFjKKI|8F15;llDDosD(}=lXByVC=UPyu4+uF0VuMiB9XTZ96YpH=MHg*mWbMi09<w
z-Fr^Y7E)UL%OL13M><!{<8Ia4?427^_MZKHDNO#1_P+&tT20$lt>EQvYM$<Jx<kP-
z=KI=2!DI4zKQ>6LdsP!WJ*>-V;elsCCX3uoEu8hzB-B$((Cp$xzKN!xxzk@BS|-*g
zy256g6Vu6GE^*A;mmNCVew#Pi!>1{RSK1^(y^cRjzT0BywTA@{xUM=HGD%)(oi47m
zxo2OXR%V>Olf-GycYTHPWEXcdd(YW@YM+z3fRN5Ajnj$O*;a}RX?{NW;n&6QZt;uv
zIp3826=d2T!LmHaIWJs)^`qSU4qvrZf1CY<&Q5Y!t-0c~=BnnLxeX?aA3U$iv8~wb
zoG#C#@zLPkw8Q=n{=HC3S-50}>@@KJzr59d-*N=?oX)#@Y({t5iooQn-wyA3e|*6+
z>DjWAJGifKILx^Df34e$+h%j09lv1WF!%GOq*aRle;bI!a&T`j>U|t3Ik8<=(M|S8
z<9<z@RgWL%{)rBVnjLSSH{nU=_qS?1%S+b%73Fq(aayy;)nd{K3kLo_2Yoz0PEl}^
zRLn_T==N1{gOHTQVvEx=Y`2@FFm8zV60-PSv8iCC>M@ItOT(JHbg!n`Exi(yC1;w|
z$H2BImf5UxbL)$AZSx~rMTPI=ZTl%&SQl6J_FLV2^JQyi{@j*kzBGli@}TSUWit1s
z|5}%rIBC|Qr;C+YPc7N}>Pp;(KIhqQ`S12ta%o#=>3?~8<dH-$hr<0#zTjB`HnDAg
zV;&qAFrUf&ck;p7@)OkoioRRVTgyr<D6W)xyoPD!p{ZV8{FRZfKh`IOu+MiC(^xq1
zidB-~)Kvofvil>SF-97yuM1#58{L<3J5BL8-`Csz1uIUTmC<BtZwo6qFm=`5o`pPI
zt1BB;7uicZ;I`^3eE&gWhQi^??R{z@ET1QHE-fmWb;9UXl2DF$``+xB^IKU%iVJ(B
zZl3zHVM~Xjz|UE)FGxoo4Dr4jIO*#<m%WY$_qQ!N9bzVM^?{~gp=<c7=<RjkcY8N*
zPwjmB&s?GZtEpd;=}a?@C(^5A_UC@TTKD(vF%G#s54Z2Ww!;75a^H`Ux#6Y-9M;Oy
zL;J6Hmm93V+BAQ4lc?v((+>l#|GFgXm-?zt?(8L#JM)<LvD+QoQr~m_rcsjEqQ>lF
z6YG68i`uZCnS99Z=#CAi`^Cdo*ROuhC?vL0{6v=S197jHH{?=P{6ZpwP14VU+Caa`
zOiS87z4`N7)YiIw<-h8GzgYiNe7*W=^XBgGs#On`vl=U1cD`cuO3k%1Vx7JIkJpMz
z7(%j@<`&%&cVyhml$Q|o^XhMd6{{4VT|UO{n<8;!x!8-&Z2`PGU%xhf*Wv7*B~od+
zB71q$yUiDLg6Do+9x#KE*P*Z>=(e7W+?k9u{ym!|RqnHtTfQud+&XL1%qZKl5)*Fk
zpKVwif9$cTN&K%OJK;}HGX?$#^jIv~w_ro_Ke<O)9=BHAet0x3>!{k5l_x9opG7>+
zek&hycuVQsSvJzYxsQCG_EAyrh~6XpU90j-xP`xPd|cal>D$W3Pmk&xzx7ti!$^2p
zFstgW4{szzxQl19SW2-T(PTQA!tR+~Ud!F}OlxAHLgs?s!5+Vqk4`xE>g5z?b(T|o
z!WnA84mqx@f2Qo0uTS$jvQ~rrtzMmAty)pmCb<Rc+P`kFm+wrsc=*~SaRpoKuO-Qk
z7aX`yFeh?GN<E8F$X6}(3wy4eV!RwB&cqnk5P#IGw#lgPmv@I#(By;Hd6de81WpGm
zmQ3#Rbe`<n{-NNmR;G>B#Fagjd$N3Y?#lS+GU;#As;MjUx6H}0es<46QuWW;^B;xS
zYGsS>sDEynv|!C6>60cUo7?5$#C9*c#n%?KVvcyk<<keR%i73g9nN~emS3M?mb%=!
zz3K66o&_s*U#i)Auu(<W?DwY+2dk%Pv`qTNci6eo%1fj+^}(u$D>|)O&62)zf9_s3
zIi__{ga6_Lzu7lGEvr9wDRWW5an_^Lqih~jA6_2c+9z!K>)!KsS}m;MJkQ!}BE6(;
z--$b7cUb;njpQ-O?dE1neK${DpWZa{L+)06X^lBtvoHL4d%{07euXqs?2&*!3%y>j
zDXstF+Izq}Pkk$I(~7iJ$E0jO1%_M=o$CHISSSD1t`O6LbghIE#_em@)V{F$%JwQW
zct+Zb$r{b)zufljJwGc=Kx);}^Ssi+(_60W|If&?(47%W?*!E60QF9c4ULg{C+3(}
zF&kSDa~S#A=-Yiywh8ji+5WSg;qSA^if}RgU8*0N-`+U)EbX}50SBYX3o9(|o?5ju
z&hzcZALeiP{Q`9+xtcC7e{;a$Q9JLhn<*RhmivVk-pjkxk{k3_{@-nxb@$@--rexj
z__u%Yjhdq3uMe-s98&k38kSRBT%THZz>M|2Nan1RpU<8Zl-kOMUS9R`=-K)Q?2#Xs
z6@~R&`RsSyjEmi#=D8z%UP|iJU8;NI4o4_;O?sGKYON=~%yXhRlfBOu_lNoU-?AdZ
zUzW<)&)HSBeg4<ydps`rr2Y6ACL6jxw080SNs&QQ*Bn_d_tiZ$=!BN;hs6)=%B%%8
zpYf``^ge0(YN2UWob1Kc6GfhHpWOK&==`gKkYwBW$DVr4^zq6xHCbpBRR86#ft+8g
z?drFitb9M|ti2}nw66B9$>AMqf2ZC2J9WYWshyQaPc1n$ot6LXp7@eulS7__J&*5Q
z{&-{Fx2%a4k2?k4&Da%xu1$AI$@L%J%hMKD&un=0Ry1#YWayOb`jb|iPVtPgnl4%B
zxlwb{Dvz6+RJ?bbNM&SFf4b?F-n)pUD^_JCi%T92^;Gpr+n)bw-N&xUmNk{@EY$Wa
z@~<`Ceym5nPPam#f_2xUYsqC<a_=Yoo{><%^Y~p`r=jDl=Id-`AKuNW?)6(<cysbo
zPd=-HZzkT{ubdapx|O-jjZOUg%>B_vI?t5^ZtC_c2^25j7JIR%(n&mZQf2HN{#bLJ
ze@qXiSk+f%{Fbc>jI+r9b8SZOv#G+tzN?}aO>Y+dc;No2SKnIyxoub?z{mPZBWte^
zYXtL!x1tGbQOd76j8^XWc4&`JaN?AVX-_rpuJ>@TOu6X3;*3vyKFd$>Zq6V*gN&;`
z0(0K$2rdmj@U}EZdZxjqXDerm7-=6q?X!_t(e0B->cLjKjz!A<?w?-nw5RjK73Vis
zgpy9PY>v<1;hM(Ovh~K_#<L<ztu0sG49JytUE2Iq>G9I`nR$h}9D9s5^Obbn-u=kO
ztKB9{V^QC8j<2t0S&OqcY!BRj^~Ut}?LY4K<d|jc+7T~m<Ga)P-K5h0>qRQ%%)h$k
z{_{%Qte`T1gMatM4^yq|xwmmGsef$PBgcHRCEtk0X74-m9Saw%ZfFh_oj&~xqeAR5
z)&rV%-|z?SnxZ~u_v!m_=_?DF9i9YLGr2xtf1s#!N<pD=3f~|78NPZ_I;&PK`4y$Q
z!X@fKA$R;Szq8YQLTs+*<!yF;6Eat(qCoA_YUBKsLUC3>f3B>Q)IU<3(6fG%f25Je
z)NkdBt(cYv{5|wyNyBfeQ#Q)sjF%oPjf{w#X7G}y>eW33|A}=s%hON4dY5vFb6w@m
z%_<vWY+7P=27k4^wB%B8bEX{M*O+qsz!1f`D?ZB0TrrXP-hX$Iw1Vo={j*cIbuasw
zC0^ijRzp%X?`&q?Y(K@@CxYGc@44RF(KBJYtDula!plXA-tDSn2zuICG0*yGWN^c)
z9k=-^c1LnQRJPfe^{UQd(W2t>(>E|Yx-x&Rjhcd^Li?$U1t$*8Kb~1LPfU&Duuh2>
zw+gqV`kV<%g?>F>&sUJFyL<KWa6YF^i<V5YdiUCM?&?&z*LAzhxtfbuG`8+-H>_Ie
z&GcOU`zptCXAZi~cs#AVKjO{DQ-#kwJa}eYE;_$PK3h0>4&x6C@!SnnSH51fs<2Q!
z*f+J==1_6$@rS`~7WNhlSKb8*w-tVF;Y^*F{>Ene`qc??Q<4Im=U&xbR8Vg8)%*ls
z;>j8gJ$Wa|Q~IwC-{IrRVY2${yt}$HPto+6(E1&#kFzebxMN@Z>brr%sf`DZDV%o<
zKi7DMw<N?$bDurm<c~s(NB6vUw&~<#W3Xh^+@j#W<h$tVQw+8~f}*=#GIPzkB=u2<
zq2-git&4l_`#hVciU(eG89cxG(ScotyD08Up0+usSJ`~Uj^3t>wzW0AcJE)`{NXV3
z)v0M#jW79i-5L(fdwS@5!G<F|KFu3B?ZT#>56oLy+2?#=?<QZZg^dTMFE{ymWAV0C
z^KbnW4ELTN7gu#?PP_CUrfU;2>*IuPt6Qo~fBkFugT#$usT}FsrbHf@*7N1)9lb3_
z&9|ssZ1${p_r*u3_Tk|j+0SqOXi{T{yUM{fb(yJXDT}Fj=iS%}qa>U5mwAVtM%?K=
zyz;(YtQ_aFPixnnf0dTM_wZsHCE4q_TATEjtz<|IlTqA!pyTY^1(C&Tj{jQl;MrS#
zw$@KQyH;g#B+Yi+Ubka;*<sZSiSv>Zq<_>dK4Ej!oFn66ob0V-W<1>&|6N#-bs~~u
zXQk@ewtdd#{JJl!dz)nJN|x{5wz)7c)17YtcM$JG<-kc-4xUqAoUzb&^5!dlDngF2
zs;t#n)Z|irZI=A8h0<kVjFpa$8G?RqyBb;T)uVdQ|AY1$COsSDSexR+xL>QU$Jczi
zsub!O%)ZyvQMy;H`oPZ6lWVe)UT&J-{!#FxcIMQ(arKL=_T)cX`!T^x*JEK!fAp8W
zOYMzaN4)ROJaMV+$eli(8BK~aXZcs&vFT$@(s7x7`ukfkV^tL<d8t75weE){c9hwb
z-}xJ%-*WPU=e#BNzQ*cIn^$Vk=ro~PU~2Q@Vp~fNnf<GmpY)JC=e+3UtHk?KF$@Lj
zw#5z;@9qnqEGQggy*A_5-97#1;~9?aW&e{ft>x?PXOT~>9G4qLv~$@+Pe1fkqS40m
z>|00kN%4y|wEADv3!HS)Gxr9U?2b3b%DT5LI+u1_h|!qYt=Z^=!d3>A2sNE<72zef
zi<65C9HfeOimh(h#L^^V^60%)_3<m4LmMA+KYse{vj6w5H~7!a{yy=LQ2MMhs)rY?
zS}lJ4_I7Un6GpO+_Wk~Nw&s;j+U0!@-kw;s$wY9|Hgg9?%^CAIm<N<;9zN3djW60Y
zbdvk6Yfk1z*YsribZprA?e~pq6YiauH05dFv`tIuR^JMKWArm<Td4HJkO#Al#mIb5
zdg%1y)B5o1`)fbex!enR)n|6W|3~<&-R~ChgkEAg!W-x{-^1VI(?RFWrz%&RUYJ>G
zm)98^o3-v?%yUj_rz4(XTOV8Hr6#zy$QG1(q;LDw_`CgpXU$xu84Y`$%6vSoFCF^b
zKG97*+1fv5>HTNNuh+K6bKE^#xH{RAWyL9fwdZ0}1n;k0w(TZw)5+%<?N@h(7iQ05
z@wpK5nr;87wwO{rzZR*ZEygAmpF?YO`e#*KH<sId>cSruQHQK9d#&4xBGRrqb|=k<
z>P{+neC4}RQhJ#)^XjR((H;De3;1TGubwEMa{5tEJ+t*!`xU;;I#)DOWg26h_bYz?
zdZzQrfBx>W0Fl_3owFxpZc%V#eI@fTnW>85k9%v0kl$0o){P4S*ssmca$IrCG~6Ji
z=e6RT&-V6H&f090I97K3TicCBHltHH%{o)q&!tsMP2^I_=&_g={-R9aY2^&XW;MYi
zA;~w#WKxf8&eZpaUR}F><=P#Qu8$A&oi`OP>OAqI!prNXIeW?GGxuNp{+#;5+b!td
zZ0Dv`s{2YG@7#TP_U*IBuBLFZd@L_|xpm{rw4+yU2pin1T0UWcsNF@s<GTXQ7(bt?
zJh;dG&H5LgJ0ya9I=l{LC%dFHygK8#`sKN>$PAU0a>ni+v(J~NYX$_w*4O*3Ui5m~
zt2^msi-RPhpS0bZn>+UrORvN#w?`~;S~mBmJrDA&KK+JUK7?P`jcKLz_iMX5i)|M)
z9k`Sz;8^!Kt?Rw+-ER#2Y5|JtJPVI-9WlMs7R$s`=*!^#;U^cn|AZ&r>t$}I7rj?M
z@^rh(zUhuqG7)iePB$8G1w3ypOKHCR>&K_amCIjF;PfoIXxb`Xap~$V-PWb&_w#Mx
zsNMfXfH`Q^g-{jKrrN%V2?s*$3~OY*C^l)O_nDmfzhsy5?!&nr#_Zi^4=i4I<4A<c
zg{tbajn8*XSDdruo{z!ui;^6hsu$@m7r#_Iv+B_`Mvo0sCcU_EwoSe*F4FvK=z~)!
zthFyhg&UWCuupE6nWTH3>4tH5$`j7JipS=jURowJD@9-5{>!1~{Y}@`IzCv)x`X-d
z8=-<_irdXJBh6RL@v}2O;mqB2aM|`#`#1l7c6!E%1es+!-yd2uz4Q;~#_5x;uU)nG
z#JcFzClO~21sNi@zWcy>$S`^71pRj3ojvDNVxtr|f6f1WOGotA&+hrIHzE{5yLwv%
z3g+jtvdrC7kaMJwk7LU`7q%&%4RS);^Y49%dCvc6qP)Ao{r66@RNhzo4*k)=*|6r*
z+cn<XRhK6pGO&LAvQhtq?=6$}oXTsO3qC2QmHAD)VqVXo^1oJM;;U(2gyiL~+%VfZ
zH%+`}z4Xk+vSYVqG%x?PaLEVuRhipn2wiT`4q2i0CjD<hx~ffLVpyqhWKI34zZ-rz
zmL9tm6SREK#eDNE4liy+zTy^D?o&zG*q?Fhk%s0WDV=4d#-~0%ku5W}T%P-F`C0iR
zA-B&z-e7Aw<MP)U^G}ba#!Do5)gO4;&i7<*lE9DkE@~y>leKJ)as7`mKP($H{oT_g
zDt}*i{NVY1Svg5Gv+q?%>_cgpgD*{P7Akn2=I6i2nj4pNb;;k4hZOW{*R48XaCZ9E
zC32fp|MloJZ7a!b^*<4qCXvY}_dKqB`#OuyE2E2d%QY{Eu+cxUEWqFv+rAYUKf6|_
zX+Ag}*W}Lm&}7b+o|{j8KXqJmH>^K++2UFjR=-JAdI{SvZMk}~|GX8;$;i0cCnu_^
z-pu}M@#S#l#5*Nh!gEwB7RpcEb3LMM61VNaN~cfZPS3YJ6>OBwee+t+Xt#6536GZ_
zR=g6t`%TuFQ~K_f37bsCuk+XaDSo{7)x@+3dc~XN8>$kGo_$$a{^i@(j~0B#H@f;<
z>VG=dQ{4YxnIr3pCuO^O5|-WCGC%GQGsmx_J^iBL9rK>d)M4RWHZNgP64%|Oy89M=
z%)MWt9=(OhBK)1y#_4Jo&mCJ;sPsonT)1X}S6Kh<rRy)9JahT03713v9oy>SeLgI6
z*__20(vA3AHj2v{H}qr%hM8<U{>dZPb4E&{WPV&gL`l{ai{y7~TU7sE*=c*jaDm#*
zgT<oPf2yeHdhPXCBQmcqZbgtp?xsI?&RvRp-LdqGs>qZr%bC@<H5Du7zKs9={Ci_b
z$NBIk@kT?bJ?rPYpXQOcH17)IPmVc`w|XY@_$wb%-C_AsecRrDyQS~zP3C+l5Rslf
z#UeT9a=FKraKW-VeW|wR`)?SqFuZ?tl2PFykDjO7BXf@}=S43jcdM1%jJzoDvVrY+
z&9|5L_x+VQslT%Ae(+r}VZFsY-@fiuZGV5``=UQBHGg76CqFykH&c<NVE&=QCm+<k
ziMqJ4E%ivsnH}D&w^=m`EFxa0`?h#&e%2Y;eO{mM<Gp!NDSb^(wKbWO*p|FdRqLBH
zQ7&`I(<jGvWlo3+O^+87(3AXIt(y?>_S)AQTEBjrewg?3jF`_q?j#S_WtZk9rGH7i
zYuzPyC|kmPlUq*t>lFRW?_Un4CflA}%-ntB{{5}rcIIW=nvvGHzC`zt;bqa8b$ceK
zp1xmk=z7h^-RJYn{_nW-|F5_d=j!cPMh-yZ0icls69ZEV`0)!ShL|G<CPu`J99#wM
z**PW{w&u3nXDgNIJ0sgnW4?8t-S)6q*SeEIGwcbgkiu(b)5CX{+8WDDlsWlnz5mzU
z9%k2*-8qG%KS-tcmxq>K4UZ4~_*Lut39ak@ckQ43_vq{H>)J{4e%jCe`>K0&_vz_V
z4o~)Z+O=j~p57b&6JD35p84z}vU>I3ql=9mOa6WFYB#r=@l0+$?{(Y6`}e)M_p;q3
zm9<^|M*HnwH@=;{u!a3^-}FeoqNn$^ny1;G^a}j-_4q33S!XlDdAI&{e0cB8>ckb+
ze+zuOY_v6F*RDKu>e8OQyH=mKn6u&M!%0i|-hYjDT&w!#_A#5_nMtZ2opM*rjoojm
zF7m->&IOq}oGSA!%#SO5o0-AqcI))?o}}XD7NdW0-po=d=4CH`q;XC9*fb?CbL-75
zceh#Ik<xStyYL|^<L&vQFP>+sb@dc+s!f@xb>@_L-oluJ$}@#G2c(2(g|53+;C*db
zS?I)mmh&PSkHTW?z2=@U4qCO~cK^y)7qz0P)tBSyms~%=!!xNm)vj1f^kdk+nN~dS
zcxA6G6=9yJsy`!aje(Su^|GU<D(6iWjr$Q-s-w`gs84=**|-1I`<+-Pe_Rx|v`^nC
zuC4o*xnGm_&-n&-|K8T|)L)^K);23oM7B!P;M7Leyvq{<`?mbQ_SW@7oQ`q{>$W5>
z&CRbGZ+ATmbyb_PNG{j&mC4Mfsq0D)&z@U&)?4b3(7ceMJu~NM{LJLq*pVc;{9o2O
zdCsKu1!q%MGBY?|yuEwZ>dB33jgC1VixilBP-vpaY`-I7N3U21E7<S26Vzbdey8ZR
zWWTx&bAD3Xg0vMSyH=L5bx8WL*V^(}vtQ)7(-hcwl_6XFV)5(P-I;CWdMAxei3$5j
zetzkD{oU7KuIF7%tlss^$K~X9@BL)-#x=zAa^jY>32z_jJ;-O1nm<{#%jo>gA{h&D
z&TczzE7hyZr_NOHI=SPz#fSeB#FjLePWHB6#(aCpsvTLgyG(DKXAqCLw4)==Bbc4J
z?6M8Ju<hmNwKFW%#WaQ`PF7#(yQR==QodiCbxrBkU(yDqaj#-cgri^o4-Cq>rtCE{
zn}^Bj`_aqYr<b1(cP?M0ulIkSlKAxci~oN<Ix76*^Ow_Co4eP~n>F{+ocx;Ld7lLf
za&N?)P};nue+svQQtAWq{pSDJBi)1rW)>PK#kaA%O%-uw`pY`u0EdfTLyPMBfEbZv
zbK7MqOcfs|2#AHX=L&Td`7U6(8e<V2q<PM2djI3an@$PscvaECu9PccskYYobKA)t
zx0svP+V3@Y99t*w!%z7_!_nGpzFXJJ9&W3h!SUP1ZzaEv+@<CN-|d`h7VNWmGGoby
z+vV+9_j7or1?oJSz3l#$xGILAW6X<7&&+i^!M=aBRJ5c4hv<zOU$6J(*ZV)|wAZis
zUSwg*Z(W=Jpw(erzxCT-&RsqS4*s;9<tMOkgQZmdwdH<SWuE+<!;xoddokGmXsF)t
zIz#TlsS_(wy*ZBQ{+!cz<BYb7L~+Xj!~KhHy*>G|pdqI+d?vRbSAg2GOR>c<_9m^o
zDjM_H*H^xN#T>@Az4_3J)#g^3>Fbsx|KkWZ?qmM>b>*wsvKCJl7U>;5*yz$(%e87p
z?ALRxTp@D|pX}O||7)RDPF8&9(Jz0BU%O8^r<lIkQ=<2T2miwCX<7Hgr<Hv@w_)PH
zb%qO+8)V(jg@670>i05JD?!E+vNQdzUf+9=A?nqllgIzuPTOJZuW7esQ>eaa*01#2
zxx$%(SLPLP&We@jwyMwhc05bit5m};kTbgc_Zd|&q2Ijqo9-}#SNZ)346HAHbs+8T
z9IxEh3$x0OaZPacsJVEZv))AI)Xg0W96Pd)FY2jTAaG>XgB#)d4sPMU;nWf;p1Wa-
z26OYBU20u2j-R*mJGur`PP8%G*3S6PGjQ>O&#M-8ylY=)d*@xwB8G3O0c@7n*gce+
z51&(dmy*gT()Q;4`^tNJ0uL@b+h6)@Pvn%3eDiC+_HQliVw$3$e0lGNRSRW4{q$zP
zq2S(;^jYIPi~G8}^S_1Ft}Bl5sreO{8FS43*4FKz?DO7i5;)?)aM}6x+qI{S`efr@
zCxs|V9?05Z$?<2M;Zc<hVp5skPR7gZ$d|NLUt%c4D^aY{uV=V%6@$g6>Nk#;&s3Uq
z@$ly;#7pM=yt4b9<YYD0WbgO>e;??%Pg)RIzsCG*Zz=bI1uG_s2RkHjCcS%o>Uew5
z(WVa%g!b^Tb+;TgjGgqk$9<W1cMSXSE^gWG_sy^Tgk~?^Rp56_(Xl9RQ?uG`PrG!F
zDN{~rB}YYVDx50VJlAcqWVuZFjssnPPqJyYBuNHGzX&f1_51nYh1|U}i`f3`{$zK;
zMJ=>t!8+T>gO|h)%zU(q<A;Ad!yM*+-u0iD4s2BsIhP)DV9WbSPd12|)n55ySo>5e
z`}AhNE!-cRW{YkS{4Chmz_69oQlYgcL*l*gI*kRNcjPO0Dm5BZg&qE@UhLX=bK`kY
z<;-_)?ODDZ*ziNFSW&rsZg5eFSY~6kl9A!6+yl!OKd<`mLiYSA<=BF>#wdmBN91nX
zF0*%;ckkNSw{ycglFX*3SrmA0yVY>KgOlN_b=IPn4}^3I;_HvQ?Q@!F?|w>QVOwRf
z0!#Xo$ICXioJ?ylWj)8LD!F3ymhCS^>&tAl7Qb`q=hE|DRvp56ZQ;k9iAQr-r>uS3
z@P_Z4sLP&*&ej&!&m=2l^G{38;1V!y`7Twkbce}I4)eGFDx{dEbO!M+Q9C*1+{MBz
z?a#y8N|q+G{mA6=Ne^+ocYhIcT#U<-x*YD+LQ{{gPn%IAHODq|OZwK=w=LJN$jf06
z6mc+rka17>gp7Sd+PUA%^1Bq03=dUrH`ZcoU-yg8EPw6H2HVaTvNz}0*52FQA@0Gu
zyJunQtY>=*Y*;t$cePr6#%0Njj0bxrxzz0{yn3v|Df(7g?AbFrw}>y^{pOYOkyYwj
z9p)ruKYZRKI!F6>$;nVJg=HNMwQ=hsbdD$<x0PN0afKa6qw5Bn^=pg+YRsL#?w!n{
z==9cmn-ZIU@rGvS*x$$FHqA4hx8~s&SC^!>tKQ80E+v{<^>@X|S8p~hp4ZwJP$PZz
z;lq{RzJB7URex}Pk!|zjrk%O+%o)EuD#T+}tiRlBS^o7_>?F>>w!O>pzp01oS=*dd
z{juthbDHgsv~#@|AN-Dd{Xp`8`k~LCO01U(HB|_{-D`XG-1z|8cY0|i;eDyfu~PNx
zJ6raCZe3Yv_j{(YfDH37e;=&{@A^Ww<d<*weM`3FoLmXB{)wPSouj_1*6mwq{lrkI
zt32Ikr{Q9w-~|tw5`IMFoH_Q6>vSPI`;s5B4K`gY&yyPZKML91P+k5jdD}%9v)#fo
zcDxE|cM$BkCAm)e+{3yvYwX;7U%h5kipf~KZ^hf$J%Zo%?c<DM6L|Ig@#d6A(cCYb
zo5LS)&g+|W==ibd)lXB7Ecl%5(OS38XyG%SljYNwJ!|^tbkuQOAk&I%DXsUdYp3qI
zomVwsg_#8Z%t<~rvWs_b`yRtSadY_lXVVMiP0RnB+9GxS;jOa&D-*Bx%uYIRWXJ41
zf3#BLV)GU*GTu7<(hKp}k3B2@PPo<9+jPDDilcy~M?aIheC40*tb1xSyFaE22QV{j
zzqYiO_rU#S+k~XTuNO|7e{pqTwu91Bd7UHdQs=JQ%LE%W?q~dxIJ0i972krxHJlr!
zox3f+<V}dwd-;Pkzls@t?c2{1#gQ9Zx_Prx^(&Dz8WDevJ^i(K$$x(>*1bnc9a^+L
zZkVc(W+gvm)AuWkp8nCA7tdP#NZ!YKk#|BoU-vTWn!cCE_)^o>GIUS*J@bEl-SjPU
z|Ecj;{#4iOP!*EUa$g+#OqpBg7{|sxE5sufi$?5}YC9@W@o2(@@VZ^b_Ddr*g!7^n
zu(Kz0ww;r#n65KfaI^mhIjwMoo%1$0KXOez`O56zZlB8gq5ZM1oR1dHS+4X=bW`gA
zb$gq?0pB&7*UnUv=t-{n_BGSumea(SE<!)fycQO@yD;0hTfcF?QjEm)mu1_2=P6H%
zov!cwS9a1Qp?g0Q;+|(@?eOf>^KIB6xN>8=eqP|_gp6-5^{X_@&WGMwY$@8LkSTtI
zWB%ugADN38cg_o7%d2A0`f=>(r=X7p@;6jD@2q&atJ(MWLcebetQ$B?-_Cq8gV`bV
zc}J_plQnUUOAiUnlo74--&gnV&*%MhGlf`RFiB<p%v|rV^0?{YYim-ZWDWMtG30mo
zarlma`J#tK*V|SzcN7S{nYnImzHIH4Czd}-tm9|>*=lXm@A5UG+;_H*TLDw(!xrOx
zBC!Sbni-yIhu?;*GyN&QKI+svm2=C_FG%MOdMW2RaZ1*#{Lhiezc!oH9z6N9=g;Sr
zzPdBc>zw2YG@Lox#&g;GiBsfv|M<Dz;QIEJ8alizRSqYDZoddDe<Sj*=x@o5i%aSz
z3kh#BkDD^@Z|k!_N#?U({Onf5mdC#M)!J{r)l*SS`eI4%ysNXVBL8r8Etg)mky$k@
z#5UyaQme(Uo)v18nFXYA>+vq^O<1utlqXJ9;c||{f%M1UxfjlG`MYdB@63K#euv3V
z4bOX4_Pta8@Z0{b;g$ItjdwKs)GBsipX9TwfLo}?;qk`~!5O><S|6~^$X>fYVB?j^
zmkyl#y8l1Z0j@Qkn0+^Jj||jzGd3|oTr6gS<-7$G&>k{^Yf`U9-R`?{OtAFJj(EfT
ziGsRE_f0sv?IFAOKF$u&;}JL57AZU^+9Bm;d|344$Eg1g`TazHhxvY6b8XY-1da=Q
z7Pfb<mRc`g^`mTZdd}p>_P@7V#_ZW!u{-gz@%QDHIrCy;ZT{|?@ImGB&a~O9XLEmM
z-WFK1_>+zHsk2ufKKgj|c=-RLOS2Xmtt~Rs*EJ5zSZh9AM|-u6`0Ukhk3PP*=E=on
zTBld@#+F|9-Tf|O+BC~ptxrBikqtaM-o<~rlVLvZC70c8)pVE1i$p?oqLR;FF4=69
zY$Nn`@syAcfkkKEOsx0xTxvWmd&jfAL7iQpMw+2}X2xi}**qnL^^Lg5!C>j5-gZY-
zje<X{sOeuYOIwutmyK%Exg8Gj3%LKcasL;Q`dxl1Qu6eS6+2>s`QO&eRbuYl(Vkqp
z<L>t8KTaW$Q@NL)t=d$se~9n#I{9T~GsKH`?XW)dc>YJr>5)s9-cPYts}&IQ)IZdo
z9rAQmH#<x2%$G*zBbQtW??3BxaPf?@T#K&O*3ar`3fdjVb<k*H^0gHY7*=;gW>35)
zzjOX^_l-u{%|i43KfaxBU;oqfl}u;j+t9zSl4F9;bRJ&)(?VL{$b>}q^mj(54<F9F
zeom;!Y`N&~lG_hAbG4@VJ+&{7ek>-lMg5?~vyWeQR|Zd<>gsA1JHNz6c3tmk9bavS
ziie*conF%HkTm5S*SWu}rgk0&N<(u})GFqEJ~2^Azp-WQlqnmP8(%221i7X%`4#hh
zD3}>-|8e2Zr&piN?=VZ97iv5!rs;WJ3&Z3oSC_3xnHVaXbZN7=xPN@j?wM`D)gQkc
z=iOcLi}&C6H@lyIcz#rTcE8@fn#65hOxGXfiS2kW=cmL{qtpYh`S(7Qthrp%JpG91
z-`=m!v?OjHIs7M@v558foLA=8Ob>9+N#A<hKS-~D^V@lg_6vd<Qog57@76qVlI^cZ
z-Hz{FFE}b(4}6*wQTQ^Jt0wL6W}!=adE}0D^(vh^((!lexl;*sY~N3-+;Dw$lecdF
z&&zvQ&pGaHp26`Z<KJ{mQNyVli<lYDTJUQ8Pz~L2#=%s;*y#M(x%FP}Sl5}Xp51*$
z=XKCQ_MP!R9sc($)#;I3^k{)jV@6qjt$fz)*2Lpi7IJyWRhe&ntFEd4eAkIjmsDqj
z_j6}ndbKn_bP?BzuCpzI`)aTG@17#w*j3@NP@XU8grK-r#wCSkKRe?yg#T;RuCix~
zS5?^4=W5-&zRm7(Yx`vjV~&8y8hd7~;|==Y!%|~2=UedeqOK>A6RQP2adsS7={&os
z>27%a|4+-`>*#B0^@q)`x7TkqIrZoLdY)?^gPxyyx~2Shn)#RGd25!ho6i_@@a-1y
z-!}U<s&uaGs?4|Y)|nB#`MB`%cLi<XA_@k7{!Gdgx0x62@s}YkFjW4Kw$Wk<-tfW)
zHK`?MKkJ;Y^;@nZkhFk{<3T0E`a@Yqy5Ie{B^A#6y=FpCxE=3KO^J_(Yj;huTypw*
zu^T5#W+b1D;g!`&>n88{ywLnkH?t?dpUcF}Oo!Q4y`4FWC(4d_`L~%ot2S6Z2nw<E
za=V!^X@=m#PZRdPT4u@n)uf)eVKR6AGGm)hCQ;{C98x>^`NCQK*OeO&r9993yE#zp
z*h23kZv*yk+saYIcV2MzzZ+YQXU<q$Jm;@Sl5^q`=8()M2|IY+<nLXnvG>$G_x*Eq
zS4gDgO;_f-tAEXwbyHORi$C0-nJt)tZtTt3ZCmm<qqyCr=<QeYEsu5Q*krpc+V#iW
zT-}H1!`&LixEDU0p86t(`r9Y_E$*~+_@kt9ZJFJ=)~vGHe7?T*-zMBz-h4})ckav(
z6~lFsk9O`^@<LZ`&h(r!nk$Rd|J_}eU3N`xiOI(f<&{Y~k2+TL<*IWlKG3-5UtKLK
zDrPiUDD%MmFNbd(U;p~q*}FAnB7vJUYF<eAGsa1tlk_`&aWiit&#bmLch|LQNaaj=
zu<%IUwYr!rokuA${yx9LT=&~cwjA^m(VxV}Uuj-eA-%%JX1n+^Nq*1gw<am^6`Xcz
zyM6WdUe?;F?Xxb<Y)Dyqd*S_gv&yX5jXz|HYMqz=C>YbL)@GS=(YdC|zWCb7AJ!}O
zoVnU$<k0m*?MPbfZ6gkc7aP>H_PhQ1S8698;k{$^X{K4f4(8hW#3uiVpJLK2_o{G9
z<n-3y1DD<kPw#1NT^GL0WTV9Kn;XqvO653gn^U%}nAy}@%XsyJ&QjyKJU5&aIs+!n
z@4IWV%Y*BqXu|@YjxD)?^>;UJRbW|mrjo^JUvj__3z=Nkt(RH)G8u&SCB{{@v8@yG
z5?OV(@b~<U_PoB6f~PX<Xf0RwpDivO7Vuwl*TV~DZ{J?wU#UCwn9w1~jBQF6%qD3v
z1pQ8Yy~2Ou)H}O(oHuQ`9>-er@adj=)(im$KSzk|SYUlmiB)1Rhq-}XO(st;)5MdD
zLy~K6AJUz^WOh3LgM&A-gd4xqt#8lEUaH)9d5fBkU}w|+(#5K$DsOCB`TcAr|D5D|
ztef_UG1dwx^(=qQ=)hT{n`*<EX%!){zVCOs`TOr|?-yuI_`#a3>#Wf3k;G!%wrk@G
zo;4~ile();d<kgy+_dUHTixS}@|}$F(`}FJ&)s%-SJm8nH}BgW-K{%YPOS9s>~r(+
z%(}HjbMlwxKI|7C`luXij_%m+x~lp@{@t2KD<auk?G{{@zgH9W?fSI6%ain``gS{=
z=l1>0$;D?8<MqAxR>LZ-TlFbB=V&gv(5Ch8zf{0cHpR<+=juFOas*YV%3r8ux^wK?
z<o%y_ew+N#HgdJio}XJ*iH1s=&X;){>lY=FxTk%Jhd?k-xVznjrDno6gqN(&3;HcO
z)92k*30bu&+cx8M(Q!=^7Wq%^**nQX_rsn28XlWhyZjf6c=Bt_L@PF)HOx$ZCs?sf
zE<JGg^|fPm`kJ=f2jW|UrXR6PUTKm3tG4i;N~T~ztY}f;tvvx@Q_8g5-wNL6Ju>(0
zgK$?D{v#I!FM4}1pO`Q`PEdcc){_%eH*0sz`gJnM?8C<kFSss?O<2YioZhdpgz=f<
z<4#v|wQFZGCJJs4`RG`FY-8ijj_+BYf?ik#=xvl)bMF4-g^N=!Iq9EBs9E|%Y+jM~
zsoU=_dtB;Ndad?8<dMeV;|aFD&gHqCJ9%=~PFA%ly!&ou!oPX96QmciPQ9^<H)39w
zbJP0QOO11K1ygR`n!B#7ZNtOM0@WLxQV#_=7+aQYTQu>-j(rcCelcEHr7GK9wQXyn
zIICxAz!C>dJN8nW9d(lfju+&7-*!gJ$*AZgA4B_!CsIid*4_5otx_i*Vf0*arkeD`
zG>exl|DRqqmSE-j$(t{_$Ggke+-**;tc#BIOp&KP&l%cf>S}7*Q!|9x8g8<e+BzJI
z4|>k*{%~PsabAjGs2+d#@lP6#R~~YOwcdRlqQ4;NN}y-U3xNf<^X6o&Sj^)qUf{6c
zrTgoZHm)h23-`Y7U%&h1mR$XV&!6*ewts#lcj2a;rlEFX$qU2VgHo@RpT3~<V^wvn
z(e>`=rJa4D+waeJ)A{yB_CR{mmb*VXc^jMB>KDEDn5=T-=bfMaM=Jed>+hTEonZZN
zJL_ker_o#2wIy#3-Z;gzVn!U3bc*!c8xEH;U32484y^Iq6+6M__2cYfc^RLOz?UhX
z&2#UUM=zhMWOH}>@$2b9t~HPC6IY$!=`#4V?Bw;g8)X-W%=Mq(z;$@dIW;lAB->ZJ
zkJkDniTTB|H_lkQcG}4V#yi{R&We4VmFnu&^15XH9G!@I<%Lz3=eK<geBOQTV(BZ7
zl5M4rV_HjY2fg>bu*{Udut#>;xq0ptMX$K{+)FcpZ>;li<k_v@cXU&C+Ac2dzQ{|O
zle@p{kFwJ&de*YxF3;Hw)4kt%?r@Ym#{4$=dP2(#o+sBQ%Pka|G~q>jjGO4|(=V=w
zEin~7Y9E~Kez;t2&w<bDlwR33Z{HonR@rr5A#1~gho@3@3cqN}P!iDf&|2+t+GOs{
zpe$yd-8B+h4?bIbfBWXPRUb;(+|*AVuj5+qVu^L{wAo38vJ2ju>|o<FlNQ!hnUpTi
zyZE*BWZfgPcDz-1b7xB9hVEa-o>op!j5$(e@%E4Uoz08hNq)Y!@b31l@=Y5jsXVd%
zZ4~2Ed`bB3gL_N(zD;mH_W%9T|8x3ce=qi28qhs`^}n1&o_}`#PPv=H=_I)9Pe2sI
zwq8BS;!7NLUq1@J)?K+!-gDXC4O^deXLRj9ylHCBWY+kXYF$;ui)Xm?w(mPW!#Fnb
z!yAXAv-ZlC9BZC(<>SknhixnkCa1<_o-k20b<I*Sotf?+eWS=oW^dhQ*?Tuv3pDM{
z&HufzcqQ+B_2jze?r-Z}r@3a?)@i<&kaX4gd7`|xzhIp3bn%PU2iBJ6J<@EP@MuP;
zOUo5DtHwRyOKkIR2Hcsi&-MAD+W9gk(LFOSUtd#p*0^Dn2LJjh_Mj}|&-~LY?N4bs
ze`(@8k$G}&X{)l>^6c-EbeCRS_};gS&)9I1&bzj}SvgsP4-PzJoyqd9bzhxmnZi*A
zKf`txtIp%@zpw2PX}qbqUp{)x<H-7nCGV;luB29b2rdZJ={(F7FJ;N{T|2;3-s$wY
z4Hb(fusJT?Dyii^g>mV=^^pZHwzH`Q&Sk7^zx?s!EasA#o-7M2oc>!&zb_E@Y&*4s
zSGn@rsW*LR8+JTC<rcZ@6!)htNm0R`7aO-(-`LWktkRIP>VJOKYpax1WzX+znEdc&
z<XPuMO|M<nHYSD5`FvyHy|UW3xBR-|9@pINZ2Gz__f@3rv$GvD<|o8)-YlMaTFcGj
z#*OIX>YLrZ>$y!iJ4s+?N%cwLynfkRhnTn3p4DJioO&llODFM}{tut5XD507{gyv1
zX!Z?DXA;y!1a~G)%@F6Xn_xL+#FVIGM%F?%INmY0-TwZ2nDm9UJ9j_PyLo`WFL{aE
zYm=>_UzqC_zSHPFdpA(Aa^jTz`!>%vuHLSGv@cPC>%`uhKj+;)^WnMc!5@nZ{{Oju
z_1l~0o9Bz)vE!}}yM5GLJpKIrPN8`lmSy~S^yt-@zYY3ZB3>*?m>Lz6bAFzgkIn8M
z_h)K6Y@Al`AgT7-m*aO=Nk89q|7@-K%<HE=)M-kEUH^9BXlZ(V<c38Z`|li&zc+jO
z)CAYJ@x0;BIK_QFMEywLy!fD~_QYcw=I4LgT&c$$W}f<V{`YC36IQq|-8K1syX@Vy
zXQ7csv7Za>FMZlDea(T#tIK5G|Gw+~`Polv%@uVihf|cd*zb(ay_LySc;{ls)UM4@
zN4np5E?3ud6j;fpsyFMzL0{{0f3qI<o3C+f`#m>w>l)M5EGuSRUlYil^~j6e>vrPZ
z+&$B{LZ|-wcqRY)?6P<5cXw`ONKf6d;BKTT<6W+kYj*FH-v0Mo_R>`mk#dpCH6H)G
z%Aj`d?BczL_JlPRN<N)!H9>%9)5cr+qS+}If0TzG&UhL6<=?v4*l2qppK!0Bxwno_
zYGh~Wv$L7|ZTjO4@m9W}ypLU{W~{njYWet6n`Y+~$F|VjksDX9Db@b4>%^D#^fSBX
zvOWLAfARayj!8bo8arg?Y9Er8o12;I-@H*Z>i2ZHUKP>RAGSO^Gvk8w)-<M_JEhul
z{p>o<3q7sAQF%~a)aw00%jrTpE|xC3Dv)|jY3TyLZadXL;n(+UR`<pWR9^Q}V0_Y@
z5h%X&{QZ?`hSO74wX_5nukC8ueZr7EK3?Y^=g)PIPNi*5J^6~YJ$|OiViuRC6~2Cd
zo}In<**stT^N#oD=Kaq;cz)jhtAC!)mXA9)-~7JbKC9}#$AnI)`^BA%dDhZ>W^*gk
zx2)N=@*yTIaiK0hV@-?}&Qg-NrE21_V$ZWz3eOI(8!88#_qu$Ad0r|%w?grZev9Da
zk`_DjZ*R5E*E%<Og=LxO<XhA3NHw^<Sn1Hx6`<*KLG^cyLe_#+QgX~6?^K4yUbVT>
za{KkY<^64;rC(M>XtAW-D>LS`%UG?(Rcih1^PRUfpRQ?XWy|f^bV@CFoy*^homGz}
z?|IPkxON7!=%fuH3lB{Tyb<5Gcd7LIzfVp7eR_OjeSd3I>1^I&u}io1EI9b*uR;03
zC&`EAu8-Dso~03(&?=g6JD2@9_YWnJc?uuay{_pvE#zcx$FHQGnj*DrZn<G+%$DD~
z>n?Bavr?JGwEE5Dyv_6e=w~%fySMh(y01^SPw{!6pZEKx)oks_UY{e@J&}kAb3BmW
z>Gts@e^=STl)F#5%UWj^ZoeN_mVDypip3nFD$_1~OMV`l?Ro0G<_5;b>#d7I7PIQ_
zJ}V$(67HD2ec>uok&3-D4QH}!x_zy3F5AXO2aA_;#F?-@Tl=@<-CeIqU*5S)P{^K=
zeSPh&OfI)J2ZzZ=7hJBWd2{V|sM&OnX4Q*-<&0F8XsuYB+O*0*q_gh$Up*IH%@qfy
z9w_Ci*_G*jUQgt`#6-uWz5+#0!6UEKs+J3McNA?{CUmUHJR@wf#;%uP6DI66XUOVV
zc{Q2i#FcMNTnh>XH=j0;TYYn(e}&pApMA;`t8cEW+qKolxlw<$LbtwuLD+JMtLlp`
zE$BLCCh(x`nX1U9$JZV|J^tcIq~Y`j21^Zp6{=6NGJfSf(P`ET?<)~f`AH{DTpurZ
z&M=MfQ_GC`2c*NU%grqedlAtq%euk#Wx%(~opsJ30oIGpnjg@A_-=&=(>`zB)GXgU
zELpx{U)5@_uCCux`}@=H{Ng7EEn-e69NVewp0G~ho*~15^jV8PO=w_WUol%~wu$Pp
zliecG%9a0*tQJ`$6)JUi)4_sSRt|i61u47-lqa2(wOcC1TN_xiVfy{Obzi?ve}8{}
z-Tw;b12LJ`0$7`-?^$%>#HXdRRLYJExGyR3H=kYi&C^vQ=t3G(@S$LV3c25>A1u%)
z%4p5fxVUwRht4M^T@lS03!593OKrTH812=N&1bsq_lJPwXS-jy1vs7Hnep_1;<>#p
zOZ&{%?N;C2AttiyW0}=C-xuk;(}FTQt=>=K6=ktGGx6yZ9hZgLN&;o9S<D*W7n?h^
zre?n}V+%2eU(sp*@4=e;6K*V6745}(NyKxm<Lk*fuV%fw@uYEg$i>5L2Uab)p`qa@
zW%Tgj-sU4B>W@lOA`Eh_@s&0F*rW2OdcpZ%or<PIB5PI)zgBYa2<Q@Dcv95Nh+%=+
zg^IFS?H4bzu{U1o-MJ{1^@T@<`-%93zqht!&+p!15URZKl;)YUA3bm9-}0VrzhptD
z+9Q$9&a~;7NAqm`d9U4*$ULJQ*1D3F>*ftcox+bn*B%`B7`yGeLr26F^)8u{n>;68
zwwhJ&bdJK(qL~K`tL38-R!S*b=B`mX;&MXeMC4}=^`%Fz9QQQ{PHZwZ4Ceb5@O{xr
zUG^6~^FE43NI8gZeHgitW7hp`<$ufaFDr)}kvh+|I8w_Y?pO`OAIpZruTPaSh&-5b
zoS|K1Lc*=G9Q}6R{KnNLf1{TCn{2Jq(O>fTT<_m$w;u8MO}rqT?r|bDV@uiIcZ=^z
zA6xBVTV<#@{Y4tfG2g%6)Y=?7W$)KrZ$7s@Zo6pJE$5o<u4%h-&ExrB7oU$QOqh3T
z#g+q=2gMS$=x%y@j8}qDoYOPwlvt3@jFh6V$8%n{X;o@!8#gbh`^Is6Ny-nVsavup
zNQDQ?dn~a_lW*CsOxxcdzPP_AS{{FX?@`rTE#|&IAI|jO%$0vsLUrHV*XxpcysUPg
zGz}{}_o7iJvFcWT_&weOD*``->RpvjmUm5;mYA}n%vwWV`h}UrQJvX!w|`HX@y*!t
zeoRPv?PtfsJ6`3bm9OQj<heGR@xoMZnF}=uyuSr5`P}+C_szOZqP6B{98*)ZUZ{si
z`fc_rk@Z_RLBGWGX$fn>)5DwhTYQL;E!oHV#IIr-%cH5q-@^Ybh-=U+Js8`~cw%2>
zmH~V4tv~&1J>IFr@PE6!YgO)chGjZj8zT<s7TQ?voV?287gvH%haSt0i9cUYnVY;h
zWlqYG-Rt*0VeOy!Qm(Lk!}IHYySL2xGb?$qU)|S3m)C935Z8O6utL-<RKF<7sChSA
z!!}MUd;j9&TfDZ!NllM)>X&@_ue>kj!h;|Q_TsSbLLOD;MDDx@(XV*tWo*3Ob+16_
zgE#$_u`3Fc1Iop_=Gf*Kc7MC^tRi2>=Ha!(tW#B9p0ij(Y(8z5@n_pQ(eZtL!34wO
z0zXtmj&vE6Oc(c!_}{nOD6gbzpN^F0i~G-CiZ8wRL43jduW7qKbEwaG{A+7RSe}o7
zn6l}Vkbr$Fw%ld<_wT63)VmtaMg|NnGX(oLR8M?8r{Wa*;fa-eo4e0CK2q!tnh<F7
z#Ikg%>A{Ih`PK{d$FU08R$Xt5*#GR^B*k}p@4TCDoC$w$sLRr;{?x}K-0iUnE~3A#
zU)&Xcec78MGgeJ07G=1(btbD*krvaBou;+!@3a!d*DU-uUr2tJ!B5LD(dBEa>XZsR
z=T~=0d%V8-T;gBCv%?mKd-7xYbr|QG^X>C9OmSD4|5BFU$TV$PzJ->e#2d$g+2>w6
zUb<ap8^3$y#szmZ-`&cx+Q}m?U?CBC@o7Ps-HWJCTLS-Elrh#%jE!U|PhmCBZD%yN
z@Gkk9^R!J{ify~z_%Dr`s5E!CO+m*}CAl*P+V2N#-1Kz+MrpmdMM4Y?lYi}7=QC{~
z`+lp5vM07EYK#6@lJThAQcu_B%%AQx`Lky(5GxJqpD*`U@1mQPx>3WQDN0hEcc1r4
zzy9*x^j-a@h52fZuehbf16-Oq_?LPKeiAo(m#!9kGV4BDjplE;4Abt(CZ}26O>`5E
z{%?L?V&=^?XKsBI(Df*N5~#j4IxY3bo?Qt6a)Em5_VK@}+_c|j>ZAo5*KE2Z7xgvb
zmT=hG6U%;tta%ZzU4CDv>i4;NXHtBMPOS=<QGdC2*{e&z)91<?E}gHGvVE!f;VX~7
z8*%Mf>p6{iCnMWjGr64+MzuCmy|{hems!nx_o^`7OHH&tfo0P?yF(mLg!jKmQ8CWk
zd+U8zibmuD56jjkrqXOL>$e?Xj>?spc6{ZUj3qy9uAcMQdb#58Dg|M`)cb9XMXvVs
zKM(&qcYpQA74cs*QfpQ&yL{clWwVpK5MxI0gF_!P?D-dU&S*QdVg16*b@p$xU!GHp
zbe(-ZiZA@4>fE>U;#{+ronZTvwR!((t7(4?J|ytZJu}N+Kl<d64;O8>c*Sm4S@7Rc
zbh-2E4HH&xWsKa}8pGtxzi(HFLRiW2#r;tyt>@%V3R{r9{HK_5dyR6T98dS1`(+O|
zm^wc*P@k{O`?x08fBF1L6D|u0eldA-ICI{bl+DY(o9D%cUOsW)z1553qJ<OLosKL1
zc+hA&)9wDdX&Yab#B;f6-`TZh!DQDC<=Hz<?~>mg$}{Cl_oD;u&b;|$PuG6-GuAm)
z`ReI|@Su}%S8G}}&pGgCT_a=uO1WkBZ}l(VpP`>sXueNYXY-lu&MEglojjLaw)cig
z<#tw4vv<s~XKW7X&3Yqp;?HmUqnquRFgsn~t`xY_Wo%-}m713VVjG&8DHte#ST;8L
zKB;->B^e5arl7r?1ZVJ;M#c8u*~P0{bpKoUnPjFn7SmLJF3#XuvNKa~!A^7EZEsIA
zwO)UGv-I^w^?xVS{(fDm;<f15DKpoJ?F`%87M(bJ*tyF7{iT+-L0|d*=lg}vUvKw*
zMqS$fY`@+1cVhPbnZa2xDJ1h~nfY<;&&=DjH^oj|)_JDfeEI6<?PZzEgUz?Ji<|%7
zGf79YBI@9-*@v%wer&O_-AB#o!1^<XpDw)0|5@cL|Ln4c+^QRCVfwC9L%v<DxN<r&
z=+vi^w#P~>*LPQ)J7}e+Vz+<3Rc`b&wU}pj=HB@Jd25}XaNLfoxkd9|>|NdR^J@H;
zr;~Kn-+6i~^X05v$3F)hEUx)@`Il&~_NPO63GYPjEt;1!Z^iGlx37=>2!7&uQt$81
z=c?h$-h5l*vnpo4Rj;=>-!FkUm8IL4<t;0`cHX#P)%UK_g)IKN56i#$*D+oH&(rF?
zn;7O#TT^pL@s_yH&wVvo6}fk9GO9PJJbyRgy{rFGPxdEI-7V%EC_JxqL+ss7@ywuC
zTXnAfK9u~-?{}rm)w>(&uQBg<clGt2MeC1m{xtiheammTZP&lOJy^KZRw41))O+^z
zS?y&;9ye~AKXHHGmsUNG_2v|{L$eF5GK~9U@9$4C%syq5*cyG0_r<kCyMN8(y!>pA
zQli~~{JPrz|Gw(mANLbbm3Wg-yiRmawU7IbvR6*;6Se;yJG>%Ue4g3X+UWCaCuJ6J
zt$!oO9jEZsZpQiC%eL8HlD2N&yi|U6)MD$K%Z}_$d>_>GoYl9pGV^uw$qz<?SJ{46
zPWrv&_3?-MqOUQ>?O0+G#?S7<HEH>TMJcrp6p96X9_V=P+`Ucph{EH=-)v?-WA)Vj
z?AgS3RqxRiS3`#f`=lLMp4Zg;e!hLZ{ocPK&Mi|q*UWj_q2E#PtiCUT;d^?)mId$P
z4L?kH7Wy=ALr=zv6*UiTv#!+emQ7rj{<lYcX?%pV9MkWh*ROxq?I~6{W7E5M@xkB!
zp4XPYnh<`ln&r*%j~8y)R%o%>nOUxMJl-f!y!{`W^0J^iJC#mIM8sEa+EZ({X8G>2
zL*`GO<hh+Yb3*rb<&g{Ck9Pcue<9G&w_1zYPC2A#&aq&fchwq20TN9jl}5h=0_Sho
zuFv!E`ONQoRhec^vCC`N#TYrG@-_e6JwA8m)-f`C;)^g;*bq}O$J#=;>I18`{@qNy
zB8TlqQ=e?vt*UTf;Uk;g=Y>HrLErzH$MUkQz0`5egdsM4fy$&S_di|WE8bpn+v(-E
zpL_24KJHqhqJ6aeLD2)gU|z8c78keZ2y1pS?|Le~Pi=*K$N^8C?dCpx8)s;i{BWxN
z?UcMd<mmKB@jY9wioXlq@mZ(hYb%4=yiLotWm>l=e=Jz@FS^q?=r((=#(|x7TQi*A
z`C42xer2fe<BV*`_tO>k57}99Ik6qNWAfNaC*sC;nGEa6JxqU&i@q?@YjbZ{A5`?G
zNb0%qoO>@1sVo&=cIp9(U~J|2nyB~BzJ2Cux~AYG)_Fp^Eq{IQeXkGEg%7K}Wh$R_
zJT^(H6W{mkxJ~~rpC7*c!MA69UiiaMe|b#WM&E@Te;?}IQ#-cvgY>+#D?8u!-EO$f
zRu~$&bX|?`t=60`JDoO(IKA7vWwXO0*UZ1yY<h~VV;1i_8+`t*>8fbY(`SOE=CG$&
z-(02UHR-OS|KWujEaDe4JMNyuRJO{uk4dQOlHx&Axt>RV^8UQqyVtN+z%pyef|kS;
zC3|&ewpN`gcwTC8WpdxHhUi}^WkxoOZAE_V4A7dDpUh;U5bKlo_T5~=P_3Vd&Knkm
zJ=}6|SN6pkMg4V4eodHUS<$d4(%|Eaf^*XB(lahKU#c>B<G;q;d)5=F4hI7jUpe1d
zB1`K->YbG>?~7dcU=^swUE9Rs5`4sR-=~0YFQ-j(Vw)hne53sP+~AqhL%hnF%iLE*
ze-*I4;@xW^-*u<_a4`Gkn#Vy4$^%>O8nP`tbGNYnZc_C2Gy2~|Cq22~|5&W3|HKu=
zkLAqM?kcP()E8WM>{NGAeQwf(<z5Obdp9oUxKv>0Dmc^W#WbZAA981Xee%16)Abrt
z`RVf)Umg^z@NO@i7<~5qZhocP@{XxnB}!L>ePZVmy8Y4f!kXNCk&s<$nQ!N|)#l#%
zX0TXm((J_MOyN_ntPeh%x8E>-lS|c)q|Avfe{Wx^>|HvU^ZwFVSLcW*JvKaSS9Vi*
zQOL4&F6>bp55g-1|J?bSuhQ)I_{uG_&7T&$>06;XbN?ZhLkni#Y7V@7;G$Cbv>jm$
z8Rr)?hB2?qW!}4X@0U};3({>Q6&0qm-(_32AnBBcs$gcwIpq`4GCdB@^?rOykW-#k
zbGY|e2IHe|o1|P7S8l$T|M99&bA5*Bx9=?`UvxtgoQ?U|7cbpzRArHLS9O!**KM8_
z+$a7!=1Ui*)_$&X%sXQ?-89rjL;Q78h47}vC8cxB^|_2L%q!{q(Xy<^Pqz17;Li2y
z9cq7^-VqVDO2hX0Y11xgr8@rX?xhjWT%wL&abF^4%Kx?C{W9r!c1fXEKDI5Wy)1k<
z$=ObF`M+;U;`zR6-u{|T6EeK211{}gvDNrKePaz@=d14@>XiBC-tS;NTotspV<Lyr
z^5o^;GCs{0tg_yA_R+FCp&!3|na-oBA}eaWeA2^9ss~QYEc>wex$C+BAK5$)J&}g8
z5{V7&Yj#}W-4^m7<59qg_mwN#S#=d3Z+psE@#tTo$tllOJ2&0debu=0vZz4Ec@tZm
z^P%_U{2Gi+8dDB0PhBN`OTCFhaaHY~?=M!BK2+8Fv%>J-J>z98NBVhsxhFBDWXw7G
zVr5I!+s_Qq{-y_S_BnZ9`kSNnY?9kO|1*}0<^5v*Dv9lqOwd@WyUx>U@pIoBQ$@bA
z9$#RkEc?0UWu9r;!{~BmreN0#B8~T6c3s%9LE{QzdzSy6&(}BaOrI9~THj4|>iX=n
zSF+y3JXZC{tJ)$MXT!Xi&%1r+9JQF3y12wcD}_wAWt}+DxoQ%By>XLLiE-E~hlY}F
z(H)JlOKym7XuW-F*=hymC1=_9pP4>)cYcIlbG~SuQ@vqbOYgbGC(YkBX?1={aN%;V
z-mpFY-v7V-zn(K_2$r~UigjEmH<0g1*1p9Yr1m&Od8KAdx_WDuaIM2vb53*bdw!3a
z*C*V|JM}J0%(ILC&7oCYN3Nu75fP6sF0ya^6WgP#C-P}}+N)_2mJM&3*LYQG{C09l
zyV<Y2>BELd_9HWymhhj{jo5r|--am5^h3#~UKuFue6=-x&5RE#uDOK2IP`!mBP)Dw
zrrZ9Tzdo8ccI%tDlxxiL+TbxM@A}sZF54Y8GP2DSzg;+C*Y?z<O?8<(TFd6~EPuG>
z)A6K#zyGU0OE8!iTDHu;ePUo~#r@o=u4}GtiC6AWJLYdzVj>xymo?2=cEckMPtn&#
z|ID6=|7F~9Vquopwbu8Au^XG+T~Fm)oU)-yb*JXq{j*#v_XST{(eR0(`;*HGqr~N3
zWUepya=_^=gOrhf;e&5lQtKAX{IkwAYtf6`LxQK$^cS3&8~ufGX6x^__m8~cnciWv
ztJo|3)cT~`9(O%&JxB}X35Z;|`LOB^9i9~nJ~=gUJ2rpLSo!YKv=6t>ez##OnRwi$
z?BYbv_v>#QH(g)Ra$d9PgpyISN3wjghnLbZ?n~wDN{ml}UH2`Yvs}z7f6CM8`xeyy
z{G?drxJ+cu>gN-+rNjbft@~7ZKPb|V<K<~7Q^k~v7Ke;fr%1T++a$@ARCd{~-p9Wy
zJ@DkJ$;a~!7f363aj`91<+U@IH<ML0c<mqFdB<NKvT6K2(^j7=A!6=Q)-M_*#vgpX
z#7t<nuUf%d{-xjYo6L;WNe&D%^R_g5Z2E7s;p(ezOF4}`s0cO%XK%Uk=fcbW=Rp@V
z?mA63vb*6HI%$8!CaZ}Y-*@@1dwX%ow`G}KQ^PomqHeri8K(S3Gi>e>p@)4QTmBlC
zY{)%hnkDkoll^GZuk4;lv3xGxrq6rN3BU20dm!sX*wS~^aho5=2O7G@TDruE1iU`;
zcS+UfZ)xABYkz%jAM-5T3QJob)Pe`K>WwT-5$Cv@fhJQxqDXChGtllUf^Ge)QPKH#
zb_v>f-2bEf%}`S*N~N^cr)W+vv+tv0dbik_+ZIjT`|9RYvq@%tzg}C5=o`lr&VBM_
zsc(bD0?n>Dr@z-4UwIyS=7&~T{n_(X<==k3`P_9r`J4OR=)L<at^aEXNhGGme7bt}
z@65V}^+g*`J)W`j=Bu>wZ#J6eTz@`#7N5Q-A$6jf!PB(bZ+qTZo1O?36W?jl9DgO?
zlna~ptc7Vaj#Va|JY}?5_<ehw`FhUDpWnPFoHyl8&zIYW*99(~wArLgfBvsZ&x4ot
zYzQvDYB5XoWOv!y>)WblgnLBHR9`76ziQ>%n>KRBfxA9x?`_?5Kse;^m20=t;$oKR
zOjIi0KlA&s;%N(bm-!k;yK#g)xVY-=HuG;<m1*Zc-dJ<?ipnw86AxQzYyKX!nX8hQ
z6zrd6FsU^~>14PdJAZ1LuycLIjWf~bBBq_-DNo<7ShV|>MWf}f!u^?F8ZS*bdE@7T
zSI>M8J^GOM+vE1k+-W-g#y_vTx_sgN%SW7#-$j((<<EY+KqYnNgVuc3b1tveBuqaa
z(PLeiv-_(>^`}3|HolK6g<MZQ+7jXFd8Vt<==tWomfAa_zsBy*+qQWr%jC}PjsFbZ
z@=uPtetxottRnMdw?!$faX;LA&pfD1-?nho?1L;zzI<Aiw=1)6e_r28oph$d>}zW8
z@vA)%=JC;=VEm5#Q^qIbV;^rn|6Vn7@sZc<$197@sQg+hbxmyox5=A=7sqak>p#Dl
z;C`noGCV-pY<HPVbT238jg2LqMrL<!_`TiJW3`g|sQ%k8XLFVwS<B=5q-hsJ@}vcF
z-xCbG*>;xv-f3U5b+g(Yo8DNFg`x^oORG;VU-j?r#Tz_6)8u9<GJltwnK*CG1{VwW
zTTj^EC#|`Db(>wzYR~7TlMD~a_DLKNSu<tEb*r3HOL~gMpEzH3d0n>r&9(BYGP76@
z7&cws_FnGR%ME!-6<7br=Nc(S9<rTm%k%cvQckC)`LCZvF5k}aV#4D?Ywsx?@O-)L
zN6zgRDiaPVcQbJun*00k{rtM$6+g2zq7QJySS&w3`()&thmG>)dp~OJ;1f>0`(A6W
z{LITP1_eu)W>~D0Y}8VdZeX3fb8~fUso2U7jiuH3A5_KlzP~Fy<Ro>3<9N#|j(O1<
zS{i>fv$Or5v>q~g#rgOz3)A(P-wH2ZlRoUIsdRqb%vp6Ww*PgG&i<aRD!gOyHsb>-
z3i}Kcu3rt2H0xCL%sm~*6#P5U&%L8Iaz_YfVfpc%r(8Bqdgp~tsO-PB(o*s4KZ_<~
zhFqRi$J30o(|2flo7{U)^&^c(_hR5{Hi@NM-}R+P89%+nA=hgvXP>?8^~D6gIl7a~
z7O%JPx;1C1(D{v9yaJxgNYD!GSBRXrL0VfkU10`CZeO)Wa;}=gHl~|V&kxKo7E<E8
z%;D=gA<OBMW`o&8s{qNunwRtW;tT8jf_l6YQ$HW~{*h(<&HKZ@D-wTBOxSXr??P+U
z-jkg(UhA44US}FG#pBq{#k}hJtnnY}&l#OzlZ>o%GHE~MlBVNW@cvQu-8aisJEJCj
z5R$(??eU>=(;Bk=RBx-vWDBm53uRp}_kgT|$HbH8PBa8P-8j)!<tG2%UjfqAhw@J;
zTQ_|@ILS`V^jWJ*P087eO$Wr~Q?AP_xY`?ipqaPm&Vyv@Tpj_zryDcn&CYI!Nxsbg
zcK`3ZOCR}fPFF6ezqHbgi)k;no>St)z!^$2-OL2_0(8zW@jRb-+VIJgoBa)jcb=+#
zO84sAx%C(u&%=2;{Wq=<FKlyte=k1fe#;6IebK_GU;~@((r?kWE~~}WuW|fh^75G$
z&3ZauQtt1l*O#WdP3XR&Yw~XPuG%ywo(X)xS68s{Nq&vJ`e5$&$46&(ub#~>zuvjs
z*IUC$#yV5HVS--r?wd;|^(~nskm|<U|H5_Ebb0sn%Xctx^{3rGV1IYZTu-g$BnjUK
zEzXC6l(w3F4qCrcr%8*o^S9WPV&Pj$G*ub}JQXW{9||&6+%~&6w!vfRO4Ck74OU0n
z>pbyi%DRmTT{fHUo9e-_-Kv+1)#04u)eB+s5Bc@0OxV9_R%i4!2F(W3-wU26rc1;|
zRj2DHimg`LtSu)Hyh=m3(a3Mr%NeU?y-W%?lPJ>qiCMeW-1?|EpKt2H^-qpW2n#<I
zpfW+}Nl911k_L16dwZ+D{$p?1>e%cvWuxt*;0%Wc#rIf`XsmQ>GWf|`x+F$Iyk-qk
zkjzEvV^W!)6Pz14xV#T)${tz!@%{TV;!#{{ea@>jekd>7RV!z-tK}4P_?umNDFv~P
zJN{f*x^Yzx_q+xE?!v-_`z}0)i;Z;t!>}f!kX=<F$V|-TfO~|%%!-faZ${2)W;rO%
zq|tlq-I6rLJ!hudO6L~`c$-x89VwUjaQlw!2Pr@GfTx<VJ`=e1>|ecXK{|_fz^S@s
z``ve|_TGF`7S$1ZXU)H|Z<VTyTf<k?N;1~0bqP8%ccx0%r~LuG7p_lFe?I+v*yVzZ
zbLakVe3bsYKJfpZeO1i%diAk?i^>Wu*MBjd8#J*<<IIvO{v}86=(XNR^uAJ`8n~rk
z;-1{&C#9Gi7w(Ve`jEBTw5xwgLBg?%Q-v0;oBCu6TfjfgE6#k^IiA|`y)}6$w=87+
zk$Z{#uhjJalr4VSnzG`+7Jqe-r5<9-7w9jp4G?Wk*5FrE@v_;-xX;G%f$^T@Ti05|
z@!13?c`~T*ee!p=UZQyBd_U7wYmt;`xraG#2^W8S@A>tfnWT_N{M20LR13E~&q^0N
z9(lKYo9(O8t9?IjmAY>`=iZ=k#XZEIgJ;LamASIKmQ$1#PH_uzS=lm0&->QfkTcmU
zrg==h?{IuguTEIeX<gS0rU<2vzm{#&<tg;s({$D}sap2^zBe478U=M(pFRy%d-vVX
z&S{JKidNpTMm1;qy?<XHwO`-!*>m-)tL~HMyD+fdQi%#VpDXlRNJRJF(=JY-^%u4p
zC}d8OIQz==@{OE>D~}0UemE4g^7#GmS8;m(=J0f;Xof~lY?J5Z3k_s%a&{HwGI{er
zBUIRcm(e+$wR4g7g$)0fwrAHWzka-!+mm%k(DU-Fjn=IS<;KsQc@}-!x6dfAQ_xxe
zUd$qy?fH9l#QDA9JH7Gl@~1P_%@MbGa@MemWzGCmPEAq&SI#!|PpP=h(_+uICoRBK
zU}u^|rt8$H`$WJ0etCNCRI#N2R@ZMmI~Q@${Ko91ihBCflCR$_db1(AuhuHj_5D)6
z>y0jDyWYL1YF@6lw2f`Os?yAJ<p%eb9{s+~Uc~$9@vf8FCUwuYCFPW_irK2jzjVqE
z<&W!Ly!o$suekNXx!}FIM_1k3CRx4cD(A^bn*YAc{Iq1Lkk-63@4NZ@@v%Pg@2~e4
zHvi|;yvP@uE&b4C(&q^MX`e(lB*_)mRy4frnXb(_Cz?rq_00V*IzOn)oMHH5?}pt^
zlrlU6+F7qu3&y_v&i<IgZ{1br=*CmLr=ERD-!62=bJ?k*e=^jQU#w;Du&@1bK|0iv
zA+-0uTXenJ7p^ZaZ(r)!=J(Zf;akhe|J1qyCoQ`kKEY7@`rX8I1I<aR&K_3Xdst%m
zsTvzaqgAG!vg)1J-n{7zaWrYx-g@$Z^ZgsICTwwAe(go~ly5~Fqm<L{hQ>3dJv-r1
zq&D&NM;nEuD^F|+<;`^ZC2A!Y*M6}^R57#ruBW)t(!yewRSHb6PBADPb~}9gn@gPg
z1O2DpAFmF6@;9N(`|4^7y-$CCC&WI{zgl|#<ut`B+)GqNoc_N*n(*fSjr}IeP6ztf
zYxTzVdcQ0cdX|*+Q`zal0=d=xE_d9G8U4&!9&C1*AW-K0tYB`0k)a1i;H0zWYF7#!
z-CN$)Ub6kK%d73b!;InDs`u5G!zONFnQgXg{>$3M4NuiA+a7gaT<0)r&bD(Ze*<df
zne3bY!Q$oxqc8nOZ(Xvrmt($r>3-tIZ-)&RXoc*5onN4TAzJmtJN9q?e;J0>#vI%B
z?y5PzSwUcbyPXlI+oc;m!Ww@Mgy;IR3&%2bthm?0>^1Eb8_(-=U+><KZ?o!H{Q0kg
z&eML23(0|7-&|Oseb+9>=>5JkF^U)6F4pGToeu7BXSh7Y;niu~C5Ieb^Yd+LLLQ#k
zVd5@Xn)%o1SJm&Ir=1j5SAKpaZTjvzm&5vFH?%qG0vZ}7Y|yc0YH9r%qQCXSq5qyu
z-6?Z6m{iPt78`WqwTbB4C(5fG0^hAWue$e@lI!vXx($hXR&T>+8JbP;yPs1L_?vy@
z<dU*gU#tF|ITGWyT*q1bFUz!Dho(;nE_2#3C#tWN`~G2})Ve)$x+X0Nxz3izKK*84
z{n6-4yZ4`Xxm@~-T3<~-<ZADK*S<~l-ZQCkm!%_@o{;*ax@~3&#Y&4m3hxQ7T5;@H
z!RG7vzZ!U*LKza}Uu~J~`Tnx%<@wHS=NQcTel<+&Nd8*2!s)=3q<^g^uH-+H=KcEJ
zp6$%r0L=aoxYq;f2^kxinZV~l%wQ*5+92ja%s@Mw2=<TGLi$H~pI*do)MuS@Xtmd(
zb^Xg7m}D04zg;Qcb;x1C)k|@v+L?>JW#-4<SG0V>6TW5g7S{%q3tmqO^zPRfAJ*S(
z;Z?TrSM&dEf6q>zt-ssFe)In=f8XhUH?RNayX1q)s>fD0@7mv+!9OW>=DSlCeV>xb
z@87>;=X>|#<)@o!{$Bq5yZ*3w=CS>npH?*eKV1I(`0U%(U%lj>7RrkMSRvW>Z1?KD
zt5*0WDu14IFZpGa<h{jRMGwDaocp}up4a0QLahguzqQcuHD4j`BDZwohTrz5U2VU7
zcV76X{rF2)d!5Bvi`zdLox6Lfx9a7ZE+ebA)|GbWqNXUVx@2?sIREz77hd`XADpkg
z(K3cls_&JNUyqVd#HLeaN~^jp{JzYtH_$)y@J6@ml<Nv>V|92lv-Gtl#9i54JL}NJ
zFSF;*|FUw^3X!R{q4JYhw#-reaEjk6sb5rt<%`Ji)Qz`4AML4}WFn+;^09^OVpG?5
zYi|0uo49&@dwG0uO~v|HpOnCfDL<#0zSc-rvzz~R=gWt?H=D3|FS6SCO?I=<4wpw;
zcrLwk<+AY0jGyjXz3G}Ndx&0-H}|$JHuJykO6a#KTX&)FvdZ(*7BagXXD`=Sw4=-`
zvOUaihpXiCZ*!`@X6U~%@!~ev`01Y0{{>6ptt{Oum{Q&UJQELLuE=<LWy72&I$wWT
zPUqSpT=D&>(%Q-DU*6SZsqJ=&-FdvXDn!e?L%aOizT+=EA51uxrG8W9<CIXAz$E6d
z)vG%$ZRsnH-@w~e(R8Wm`neg6hcfP;Hj%p?mX(~!6mv83cfuq2Gg0B4w$H0(94md<
zwt%I2;_*Npr8ftEJ~$#(uq<z)+l&{664I3+PtIMdxU)y;M2(&2;%Gs4*M}vyzfLcV
zn&s&1z09sK>>b;OEBiJYOnuI^=dAxT&q>AqnSLi%bROc?f2+-8GegH}EwfW<;7);x
z9doCrMP1PSbV;+k#zj<3b>)WF*Edgld(NVO?e`(^GmViSp0qF>-&md)>F)Z>pf=)n
zv*A{a#V#xj3zifY{%K21didsTOYcdUcwe?=hGGN#<x8`rSI<%@O_Erzqi8u%)#?8H
z=hh<Hi2~nMJ|_CyTxM(jS?BEQf-O^0=01ruQ_Eod6LjflYRiq|`UhrvTJ79&@$m25
zCuN&AI)yTBTXKi%vytB?iA26$?d@0Ai|ye4q<AR&;mfMVA6ZXrq7#~LEc<*g-#_@W
zbm2i>iGaxYR}6Efx)|yPy-WLRCH=hFCctW{oXV}uD$i#pupYTT<zC6m4%VZNPCTAl
zj2;C3o0j0ad(AP`OS8Dka;6<yv7JTa%iI`M`L%aKWbfR3oSgoL!zjVCGdZJ*dAEX(
zr+%<g(#pO=mJ8b%qNbM~6ph#<^JLE%jytZW#O&tlu1z|(sMt7Q%BmHUx0lU!jCq~)
zMj%<A{lm*t(=J^G@uckm#)}2B7BRb9ZVxVZC<(iH($b??Lh$6KGdC4Q^2*QcXFRrp
zk?+}4m0~3c)`LGE9qIgVM|Zivwcm3dPQH}PaaXZu#=lvQFV0~tk~zJFf4fmt*Sn_M
z4c^bgJwIJNd&=b0nmQjJ$3rWU*$aXVa<%GL*u3K9Sy4KhVL!v^UCnaa6>jR>PB%Jn
zCp6A`%{KXa+27YM;tHBxTT#EsVn+L%a(xEJmJ{okGou+5<Qp#}G_0ERQK?<mDoUGK
z&mdq~j(xky^z5Lw9?989YE)0F&s)DgiZxZ`&Ev|y->ywkeZtjs_{0kLr?*aRa#Xn`
z|Nqy+`SqJuc&_|2{l37)nLpouRo3{Xp&?PUWX=Xg;gHG?Ya)dTw5ENX;F!HM)$n;p
zZSqU!IE(q0w66q63wo#UEco{FbC1LP3yyO>vb3MM|I}oW=j&ZNoH)e3oUPm%5?PS+
zBb$TAr%hkdTKf8DLG$yk4|Sy!@h{-Ja`;a8!Kre(N$T(3mglPT_A_@)7qrk<?wSx7
zcd15*arVbef*Vi!d+TW)4_RNZ?YvmPt4&oW7Cb3kSh)Vh@>8vBfemUK9#yaI|EYAF
z@1@|2$q~&9mqgoJDSnvV5Uct$Pk5=@>ORI(JFBG(q#cx0_DA{gK4NxpompYSrq#zi
zC44hylIWHahEvaYRM)*Uwur9Eo#>MDV)OPkrHmQ#vy4g({ASDEzJ!Bw0q>;gQWmwp
zrhef1XB4?<vT#`a+hbR+Wl4(iIr>>2j{7VoE}wUuJF5Mo+45GC6H|=yLtEZTWu+ZF
z8<g~sPbz6C%SFy-o7PVhKQMFWZ1EC~R!+XA31^lEx?a3Jqh#{ttS#^NMVc|O>|S6u
z@%Oyqn9sEb3tkl-6=>eD!ue?Zp*`hq_07Hu``9*Yz5O{$yMF)Dl%`7;%H}t>&z8B(
zd~SN$tfk&_r{33Oke|IPf5nZiiZ=1pJ?G!~?m0duq~Nx}yfX_fEo@D#uw2c?xaYQT
zRDf!{*8ZoTdNdS5SfBTuV_c)OJ#L<1Ipf{(BaEDEldsF1-BERLx~+q4>dr{7(@6(;
zN_jc|*1YmL&;G#b+4`t=lO{Q{2e~DCuL}~DsarR%njv>hp-||J$eq4*;k6q@<{3)2
zJ$P_c;QDjspBinetV5(<7u`@eQ)xd%@|Jf{%Y7b2iMr)SPA-`9goDr3=H&8#UpnHM
zKU~%cT>G1LTE-(n<ve#;k*(tIi(3~a-Maqdj#uM0W{$bV(Ob$reVfHUYaQQMnX7B5
zlM!hD^a<<s&gI(2G*>J=Ce=~=-C8K(?!Drzhf;b23{_-$>MpfB=Dp&y`t80AqMLs7
zYnVO1)X(VG=>Cy&%2%d^pJsiyDs0RXlY57OU1erWU&5D{3d%Ni+yY5|A_YF$vRb9|
zRwiavNt~Ly>d3LvI<rqQb{}`VI9uT#i`l%G&3>vPH<=zEU%%<mS-*2;@@GDs=E_Tb
zGt<#cbDL!6!utk%)u)4Nzf@0Ner%7L%U{hD1vbGSHLqql?<nNbv{#gwqaW~p?cq-=
zjo;_B>8HLl`EVtdS$oL}h7ZEoS}TPX_{pWLHqrXKU=!Dwj?x_$L~7y+a#^p1SM8A1
zc^`1r{`eV<`9^YXMq+bh_4?jl{O<3TGymwS&H#^x0-CCm!<N7B?~<!|C6~8VyV~@7
z0>^=^nj%I4IUi?vZ*^yVe9Y(a%c&XrG^Pu-a|Nt>Hq~9!=lYdz3tS4%PFWDZEjgX_
z*Y1-hA`ZtxPtJ1EVQIKK)h{pM!d~5OuYJl(ncZZ*wn^&8G<$wveVP<H>8qG*^h~FK
z=ejMvIh#HdZ)Ek8?^ydF!O7J9^?$u>2a;H?n8wAc+?W}Cj8%GSlliheVpTpT|33V-
zxzKL^QHiAM;Sp-D-X}_`t(mf`Z;$Qd%AA^5C2f;~|7tm$Hq4x06tHdPm0*@*+-e+G
zh0-4j+r-XdNmI$`^^}Tjs^1`XI6IKv#gVyFJXGhK`T;fFnx&gIyyj&~zVFkqhCk!3
z#&OlYpZqJdeBu~flz7>#nWkSp{l-nobo(6lcQd1FA{XYpz0wnyt^eG#`!nydz4PBX
zFp4Mq>5i)GQH&@*{7p~frR%e+)9ZvjJWF<2E79;{uj4d<m0Kr$x^_xwIiuH?hn$kx
zCqD}nCH1GyJSn`ZFmN~L^XxNDl6`X|49`akzV4l29yecVv-^gR0ymsDBz@Gq#HbS)
zp!nmVcH_S6pH>B_RYqTBH%*%)mT*;8g8x(KQ_1(wOIZ)R&$8KdUU0I?fBw|M<~^-h
zl2@ut5~ceDV!5r74(%4%))w$M#H;h{H6ynlQD@!m9N%_N^h$W$;pefFudJ3?w<$m7
zpFl=>gR{x6@Wt`Zl}isww;$WHDv)>ehiQ9De1qGb-^=*+TU>w5r$12*Y8UT`cAsNQ
z*|X4R{qhFi`g_b<weNlV>ArFIw`ITYOFlH5@h^wx#r>wlk4syM8;d4PJGnIL$GeYA
z(iNFUf2-Te7sdG>ZjJF%`CQMvlSB8Il>Yxswzd85_CH<q%COrdX3|&Pzh=Vgo7W|+
zJZJXv@OvqH-mJKF;z9N~QKk3JBunH5B`%q>RAEJZ(ba&Rue4lVd|0FTZ{y~JQ$FvT
z%DYVRXGBy*KtuUs8y~f6=du(wZZBUSk@$G(^BmT&&<!80R(7ww-Dkp;YTg#HzEzZy
zPdz(7_HkRyk(KWxAN-M-rh4$6-mR|i7qzGEaBei#<CYKl@T`SB|8tgQfN$s=$xk;N
zgWaB7<C&FJ%B#2WeAJxDmDBmpPjFES@$;E;?rw2H;I&J(@|&W57;#4_J}&R(^Zi{Z
zoxbql@%}K)=-^oEj5%?_1^LRSV_4T8oqkzGwd;IDo^{{ljnX0Kj&975S$)6!cSvZ_
zFWFY6U)~<8N{-x5(bn&7Oi>jMz4$BXtXR;Ej9u5J_Z#gy>AtvgR$*yN^?Grk7q{o{
zzRAR*t?LxbS^StidE(YnQr7#=IGOK_h?{x+<T(}YYXX^P54?ZH^q8Z=LMQmKPWTiV
zmb)(_5^t2>FWAB88tcaN%9Y1!x{Qm{_QJYHaT<5^5C3TSwB!?4vUE(`diKR9UVoNX
zWr@j`bXuo$=H^7+xtp~;KC$zyO5MrMr=c(O&&Vz$>`rX;&N*(y7rAQIt&(Vdm6JSU
z?yuh4wS7-Fusj#P+A}}VBHMq@K0)afvEDzfdAkcA>)NL$q+}KP()WDblXK0{!FLV#
z*X`V^`!c>LP&_j=+oDa%Azxx`z4&|9(gS*ecLOivS^FhbFTLTsWU=b6EG9>_GT%*F
z-;a0JJ#^ZaU7#)a>)Xpb{SxDly_2TBn$G`y_x}4U?Ef=5drWr4(lG>e_rM)PQ$u4!
z#}IaKA#%qMv|EW_$8c$scm5MIA+~QX;xBGLqm$#dM5FW8?G!Ucwi$1dA03wCNl7(*
z8+K{Zt*Rd5|8?Cd6LnTzl{?R7Cy}uE=ZasiR<G~+yTx1LzUnjn|JUDMy?pg@-)+PH
z>+{O(@5I&q_w<lRObz;U_wC`SznSifCWWhTp8j+<xB6>a@w9z=|GxE_vgXVuk+eJS
z*5CVcnkRKl$cI#!Rc$L*_DelqrE>OT^WQu3-eeryw8QD@+p`McK3+F2^4iT_*d*GW
z8g0EkrE-qB--g+-lZ`cvIuHNN%=&e%=l%zqM9b;BrHjSBb{Q|9qx$iT@AnJ*xlgB`
zHk$Tp@B4d8%)h;GGWgN7|NKgMY2&}QYE&#ErfUDmxZob!n<sv92ghz7-_>txCK?N_
zFD(4GGJn@gDcw2CjG}KAB`)q>z2&OKE5YO4JGk!LST||2PfO^k#}{uIhe{e->||`8
zy0iF@=k;E>_xEls74hDw@gchO>cZm7JFe`t<@S%9w(7x$g)`Oe&XwOZe{Fr`L6<$3
zuG}`{Th6Eb=jn@gOdcMUACBFfUARv^VdApQyX*dQ{&C+hk2CC-s9yuqjLKQ+-yS^E
zd%Q>^a?<oW>vPs;{|QyQcW~ECzFSiM8q+=`T-^2k0YkBU|8adWH`UXVc3hhM`x#sB
zY=g(_Nq5#s?W<^TpYZeay7kIJY8)aDoy7X~zgz8@AG=Z{;kA;)>$h9GtwXisk}@5l
zKWDuD|84H>4h934Jz>{E5Ad&i#CVJS`P&{Phw|U=&*@*apYuM%QhE9&ADd;zmd))~
zR9b3S((%|jd8Y1R2alAR!v?op&)m{u_+-P~zN7l|oa$3Onht7(=iA@ObbkL^a^UvV
z!t=WhB{0u^+OkULfzCT&HRY69AMZ>v@d#2=_P(j@J?&(}%JY4XUF0nNtQ8z1go}3U
zs5O6iP)|wafa9;ZTBn&3G?V64Zx`?1oqVQ9%}8qg?7qkiXRgaK?_A809i;qI;?3i;
zPiGo3t@@hK(-}DZxlbC`9WKUqK`c>{eCi<_{Xd^5u#0J)dJrCamHiA;s!VClW}BPF
zv)1)2>@R8FvOML(i+1)oI;RS5&$s*cLw@$|po2!D0$<)uo~xyJwsqz9yz*1NZ*BZ4
zs^rc~?wIk0d0zf(K8fV~mkb(4Pxi1W+b}j+Jg=B2qQACVXT{oN)s`SRALfredpKtw
zU7g5hZrT2vwRiV#{T+4(A1+v3d)YRMTXL78XN_>*bcqmGFRKHS-X&x!%sNvyt>XNF
zy#l7|8O!C)mP-Bl8?$)pfeD!>Rz*+$ZZmsx%NvW95b4N&#mto)N7?QuboB1D_TOSx
zo3y~;o{*cjt9{I=)oN1~N%p26dMhoxaA^|j`M=NZc0Bia)Vpo+hax_s&CE;U-%OWO
z4!ZOvXy=t_6Ma6Zhb~K&w~)5Hu&?}^fM#pp=Ldc>g^d2!9Gi9ZLdf^qI-G*~%9bYT
z?Ju_GI+UzX%G>4Gw|L$JohdvG99dkS*4cBLJD-}P7qR-|K@PVNRn~*4S?X>z|Ig2_
zulwG=KmS;epXmJ4TP4%EOfD&1&nrj@`IWBb?Q`!F<1M?hS8vFyKEC#E@eOYlY1Zwh
zPAvbrP~Q2GsH*4W46DdG(~F`3;ViTF-;(NUY7{xGvZ6j}ZNm%=Cc_zA*++N|PG-20
zKZ(6NS?@`sR=g%ZgYqdB*3vlBiaI8>{SJjj_f#azbeYsvORW2O{r$wvN_ipQ->zJB
z*VXHX!i?*o<z+G)dpX2;M52%U&1N^5u*p+|b+-Bp171gmQyE)4F1m#LD7v`Ix9N5Y
zLsEx#R<rM#!<LnElIMJ0(Z0WHee&JuRZXjkRjOC;hHd4D>YDBKOUE^4&4vd#B0Kql
z_V=-G|7yf<p}FPBkFzEdr1`ow-CxQm-hPkgz1x>Cx#P$7U7hhOCFRtrb<Y>BGA!^o
z{)qdMS*qiCJ{F1Nbzj;9Tk5S%a)a_xG8xi;o!uc-8-FnCS`YUZze9zkHggv-l?onq
z-MGqNTFI@i!t?wE?^<Wwf3CoF-I={4=1I42$Nm{<oRczU>0VhibMwN9_YY=nyyGW&
zIyA?`bl)VMMQ<uEG{4L8pXE76_K;8BPtRkgOWU;jX0UW9YRWe!2MK$d<apfg-jRCx
z&t*lI2rsRk|Fie$r+2yATJp}&VLDjJ6~>!-_>QUn=3^I5D9<b{uI}H~p0#Ac>Y7lY
zN%QzNzdtkK)M6{SYL);=&IdP*moM3BJmCq;&PCTAcg%mz+N-c+zTm<MN2;x!TV0&Q
z@oH+?`h_x;8^XLDSGrWn?l%3V=f=Teyk1A^@%Cj4fB9Yywl}FN5o&Wj&`_B9`r?8!
zarqZrYU^8W@jQ6>Nnyn`j|<Bm-}x1mC3)29?wPk!JsR#VI{S0q`v+YTyCa>XC$5eb
zsMbBv#4-1#bezQfW5q4+_!Jv&#j@{bXpM_Ha=_m1(8A@;-Ql{6%<jJ4C^zeO0;`<8
zla{HF%8^qX-`!uPn?&|Je<X7xj_dgnuL!f?BeVE*Qd0H_ESSCKfyfb&Rkw6z{S5Ug
zXq^4Bzjw}$uYb}%K5KJgez>MkR;9RI)!|V5GwWLxaa(5R{H}Bf5%Sy7eBovL-nX(n
zGnPB#rM_I0vgEYhsaYrfKghTgdSsc|4wL1wN3!Qcxy(~o!m@E@Yjf*4rA&q&5(oB~
zdaSo;+sWQ@M&!I1<K!d7>}x$-PM@CT;gmYH?d-3~?-JHA9x6M_?Xg5^(eVU}_5T>R
zFcrn^dNCzqj-TK68zpn!PkHi1>tMhuY3Xupk^CevEum>@l1JZc+VC@VpS)?x?7Tx}
zJ9{1Ge_3aK^{LY3h;4gvjx$Zts4ci4clZhC(f#H+S=Vn^KX`b^w_8m=;nge0BXNf^
zc@Kn6bgjC(A-~5qNOErB3f;Ean7+>!kIIYaI$cU)yE&s|u1EbO6ZUBveFYMdf9HSW
z?h<p+uV*xFKH+?2-B(Aqy%|;Y6Zh`XeAr?WeL6k*ufVzEkCp_?IPZK~Y}4H0bT3Iq
z`PIV94wx*yB=>1%@dSe@wbL$$x!f@O{nzk=Lj2{fgh#VyOnEZvbm<q<Nha!N3)izM
zm@fZ#!t}`L3+B}#_O6l_o@IOgX_@ZwXicTmsrM-}-<nB>XmmYbvH3M+%bmUc=Av5r
z6s1($7BIZ_Kg$vFMk|5O#&uq?Np;Hg7iyxMe;H40E!f<&G+j_lY;K7E*E04C#g>(m
zWM^M6Ve?6S&3EMKr?dR~em_)}n^0l1?+BNx$0qjaa~7ms{BectXW+~wTV70QVgIO;
z$7Ef;VxgzMF`LayFDASG;E4efOgu!l-n7_fQO#<$sDAqUdz>8;Z=ASsE9v2()_?bu
zPPTG820sZ@y8k-)zHQYq6Wh0;>_<I!E}dx39a@yFV6PBXzbJe8dI$NI5aGR3R!={D
zf8qP(v%|vgp8a8xEWJh}Qt;{@xexI_Z-rbm(w(tLC0FB-v?KS;F!ocSQ;M!{Q+}_<
z?|fhBw?k%`UlYrolxU42?$3LCd0#aijCs^5yW$?B<M!QuIllH+{GNMoLs!dB;R_QM
zx6TQ(C|m4$arN!2AGO+R@29N%eU?$P&hEzx-(aD=3vHdUPOqE)VY~RGGTC{xiNVKM
z`KAW9Zdts~wInU$rgi*vvn68P$Kv)jPhwizvwsD{nmIAbC-hS9y*hj>cmH+wCF!61
zKE8e5wqVzxi~44Z0<2fg;9vMD%_C^Zh4NYpjzd>|Oiy}tUN&d{$0NH+ZzR{>s(8nh
z5MdLtGu~6gEvnu0|A+pYPdfkaJQ%X=$KIpY_@nFYTU^ZaPP%rvr!YbO=DGSy&O1JT
zy&b+ach-Z=LI+yE7<qh{JZDp<`|4n;?-eD7i$DB&$L6B>D^SDu-{ZIM?uS2nUmv<G
zjuT7c8`Pu*HNK53Oc2Kcn1jv&2Z<szzRf{*ArowThxYsC9WoGb6TkaYWHXE6v2Qm%
z@}KsSS#UzU!$ZqKWkSM|uE_;=j`=aIO*6bU`}^4wvK&(sf_!W5Z|EykFrIyTU*q`$
zKl;8nT;SGMtl4a+a8M{haf5+?)V3Y6$$NR!)pV^=uOzf|>GB!Ina{C5wQrZr2HSb>
zZ^Tu6`r&u+{@S<&Go8*C{`<e`;33}ko|?B;oxg4~sWx`?>F74Dxtooj$bV&7TX}H4
z#WBvKw{^l7dkOWLR)wv<De_{^;+t=h+l0Pa_qE@cWBAcjRHJlZLaqt#eXrn8nVWb&
z91Z%*B;6Rk5i<nA;Q|UPBO}DJKXWWwe9S=$1PKP<)~K^ZPqqoJE6S@rrTju{cUIdm
zea1JwyD$AaxygLeoRFY>7mQ<g_sSGad-BGuPQcb#PJw?0TVq~<$rPF8lP)=iN=#tb
zwg2C**KGE4H}uRm_%Hr{{kHRVw!cdb9XI^5{noraJ1W1u72R$y$@1BclV{u0A2QY@
z9qCNex%~6w*>5+mhd*uK^!wSf>FG}CJ1<BryR&9~ZLHbqP2Ugy(|vO!RZo29r}dGK
zjx05h+;jT8-P`T1n?GD$dZuXc2i^Lw&SsPSECt(*?3Wmym0VkD)mJz%Q~R^UH??Xz
zzGpL2gyz@E&zpLVQ@p)v-HmC^H$(S}IbSuab6RJ#x=2`ki~O<gA9}RAx&Osndux$p
zbZl$S;`nK+cimloJotc;)%K6=b)iRiSH-Nb_;Hhe<(a~BsyE+k%gS?)ZrZ!$qJK_e
z@ZG#uy9?Ky6`8yxEc$)@y3>WiHm6087vB-9E$9fCDbjcRVeMwWcfnlk;klc?EcTu`
z`%F>cCKm5QjdHhtX0148t92v!-w{st-)U{$D=&M!J~exv{N5D@65SRa_G{0TKK9Tc
z%E0F7&leg8mTeS!Ubk-7wv%EPRW23YX)oyBVZNGmU!(WicRSC#{V}^}gL;*9xnF;`
zUh4$OiZk+dbN;$+WM9IzLTjp_yWc(s0V`Jpomr(Vp65*Y;`rY#<GX#vIDLnbh<*R$
zok~aksY>wZoG6G349`BaYRiY&wue@wu}l%H+Q6us8C`n&j^6G?J9SS!vOIS9g6RGR
z^V@kxrahWzWZ9H-d);ZPThpJL?0GM^H6bzWGs_N%MlXXozl#H}=ib?MW{0uT+TFiy
zxS#lV#=yMwPW!sMecA;K%B{~fXf94xTvO0`J$HK_cZ2?xL(O|NW-pUz+p)>ZuWIN0
z-uyyIZ$)v&f{vNxkqeZ$(~n=D_pYo|jQ_pR-&m&QTVl6}x=80)KDf-FS=d*c+V_K{
z_(4?L=W6AM2QCijetfJYvpW2k+ls2V&Tsm+RAZN&4clo8ZO%ABX}yV0yk#bbJw7x&
z(I+iR@+ZUb2mHPkb(gO>$BS?8?r@%wH$S5LSdL%vbm0@iOz~HL*Y~tFiyXFilx*&P
zMep&g2aDbs-aTV@;f2Wb$df!rndhBP)w)=@|Gkq%=7L<M$x6#iXJ|Jpdi<jOLH34O
z8)pS|tFOPywrvmBj%f#KzA;=+c5!X`-09!(-}uT6o-0cXz6X7*T=9{?bY66VM>WUR
ziYGSe6KXlVjg%$lEqQUR`$bBG@zOW1J+3Nkp4RkzkNhdQofEySe(io^<HvqiX-ZYY
zX+z${?Ru|PX&z3Q%$Zj3$+b-E0ozPJ?xx$mDuNs4D(LU8{rl+er#Ej)m;9W=eMd1q
zF6XiL8sUm}?-SHdPtW!F>oD`zb^(r^-IAv)(vJqX)CJ#q*th<)B2z$C6jzz3SkvW~
zN6v2Mw&mYpZ1s7G<-xm}xs2-j-$$MQZFtp4_oAJBO<!fNvDfL;?>n`UMI;`b(N_%5
zoL&?vk{x4QbpE%m^_J}dX9Ug~8ugr*QL<xl@%kpOj#(2zOj3+zb}RRHA8`qPx=r?!
zgv&I+y)n~ym#M9EP??x2c3jHnmj6i+ox;zDmYjWF)i`CsC8x`2FVsAn1B(qj>O>~)
zepAtNc-_0?TgelS^W8ZTd4@sYqr;aL$LBE|-VC!J8rbokey99VIQ9C8UbY8~>wX5U
zt>b;)#&OI%UeUAJVLQLiyz21D;=7YJ^Y$>ZHVIh#lik<Ax#;@$j41WOxdI*6Zcj`4
z^QU-AU-FWdT~+g!^nE%cdtYGbxfKi-6E{~ST;CecYWt?u=&7*7{bjN4GZjoDxn|02
znX90t|9j!BOKu_!JrSvS^8IOj7AtgLF0^lnDYr0AlXy1ss_Yu(jXXO)CGy>zc6Nh&
zq-W*Eynfqs*~+|NG3U0J#X5OU>KARPv|GHTHT7Lw#JjYq+e8CTSD0%QH#})!k9nZ?
zL|lI9i7VY5OYT_otSmpe>aXP_lk+R(EUUM7JWH5$>g0abOF}}YT#RmCI5vsbOjU*P
z=PRM&329SKGP(Z__WYC;=$`oauGaihFV~+g+rG1VDL-?Nu}D{{zhsbMZ^dJsTQ`30
z@l2cJ`I<?jk7c)!xQF*|79SmLiSCuLzoaC4Od79r2VQD-F%9Z*x~$i<^GVBv`--az
zy-jLoEnHct^(@J7zPD>&&GkEC8UhYZS&xqh=hx0u{QXSt_~!k8OZTsBT6lo7iR<@%
z)^FQ{H76}xFUe`nBghaCB%r@5Nmi4&OWghZec9(7lGSsP6*&ryZ47^S(&nZ;6U&9O
zFaO5<)Dw<(d^Y*PyC2En*OZyR&dxIb)ZF$x^U<7DokzGm-#XT^EKyW6J?WWaJ7L+a
z^glA;zjS{Y^)$qZmj|Bfxm1~zzTP#cYVOs|{Q>8`uJTIKH|1)X%V@d%kKB)fu-#Jg
zRvhhMZkWGScEyosoyjKCGd8~tS!QwP#Z{Si=ejHcqokNauOy#&HjCq_nnR#ffKb2l
zM;>l{)jlZ>v*gZ$_rp`Sb8(fM$OInq4mf#UIp<)3Nz8l4u=0uLrzq=2o4D3q5C8l5
zgx##*AEF0i19&H<wiRv7T;>1!f{8$Y{3N#{OE}X*+&zss3|RM1{AR(hOi(!CTe<IU
zX(p|MhBiwlzKwXcrL;PFZP&&xCsL0oG#|Ymo@;#IeC-pR)JY*3CpLt{i;9ZnG+cUI
zbjV}Vw{_a#SJz2t{LOx;%uu`g)|A_;<db&0{E*_i9?K>#J&)^g=c|Uv#l<?=>e}J~
z?+-=>=ksWJoLF;BPUGi)t9<6X70%P<E9F%B9paxfaUZ+viRaNNhK0;72ih+msr~oq
z)B5#`q>DV(v@e?NtMETrzPexL#q?A2uK&*JeUmMEb((Xx<Uzs1OP8*BZ|c)E^J|^y
z7eUuU0qs0|GhDsBJzNUE6!AqX>3&X%zy35}A<xx-pN}US=yz9(b}fApyQVW<p(m*9
z$492i+Y65DSou(+cUIN+nrM^XMkU;$-z8bYXJnh7D-+mwB{*g7y=1Y|stY`8Y&_#<
z2aA-evN-TF37<B6_<M84j;nRM*~>c1(pLV7Jh~v*!KLJzyVUVSttp#7So8&3G4FU_
z{d&>j%>ifbP4m8xwecbE%eWv{=_>8+7seA3e>k6TWk{bEe99}4#Z*+~Z|0^N75SAr
zYgAOG6gO1b${QOhH*W7W>9?BI$lNEpcKKctACIQh?J`VUr!xy5Ip0*z`hQv8c}Y{F
z|Fp{=_lIkoELybaynJ)%9Iw#3G1<CyT8ds5l>SRiZ`{Os#ZXjn_0v%6oDWs(I*aD`
z>~&*Vv-!#dOYL-_*E~h9%ARw}pZVjt?CduVr)x|*yrXRQl|+fyuP|R*8IjKv_>@2T
z^`{SJkH0^%J0Fv^VCfAO8K&A>ngZ$BmuvfXompm9-TKD<;i=HKmksan%)E26+2Np?
zipK}_*%L0;EWWWOLwMGkh0nE|@;?2UC#@|Y6z12g^37~P3;Rtq{zXexUvgD^;`Mg{
z$H&x!Td(dsO?=bYl(Xc*{M|{JCvKLA{;Z2nmcRT=$2DorO!@9@cgj0HA3iH1VxO9G
z<@cB4D}?G7#U2XM{rn>I*%rrjinmNY+HKWR`Q0BaYLi*(!K_fyrS^yI+`~Ct53c+_
z7yQcOt;DojhV#D##D&MN&FELinz4WGtOqq_*ZQ=k*@Wu6F1r3r^lSQ*^}9YF4wm1S
z6S{Uaf4PRQ<AI1%O}n?P`(AKnft<s|k1G@0(k8AHz4q^xS?UFbbKF%u+dY?b^lZGp
z@XVbj?=C4_e(gEwB4117xid;q7k-)4U9c$ebFF-KyIA=4zE$22W`x-M3G02-9wb?A
zIK4t?%UzXot9Io}zlpI*TwyF6yq;yl(p}FxQ_2oJygyYnsHbR&<GGdBl`i*Q?N0jo
z(R+$$!{n2xM}$^Qa%j32m2&xgS9HB{RO^NCgg|G_HS)KvE_;z2DWu?dVf8QBBOjNT
z&R{7~2on;uTkc<Da(iy`49=;YAI>Jc3iI=7ER<ZKHR+IYqR!-N9Y@7aEwVA4@TZ(1
zcS_E_UkmR%e=SkpC#S!?Re|Z(-Rpt5vU{wgT9N`+?G%dRD&yA-v8xn*uiyH0%c+V|
zpN8D_(sl1=F69?gdimOO@-tP_6**cjl_!|`JFuxQ^^?eG4e2{FeO0FA<is|Himv1F
zxA=b8o_OMy`tDVZ<K-1s>TI_kvsU;gmn<cuan;dyCChu&9jYa<Vuu61{`lG3u*mw~
z2eWh2W=?aNxBTk{O@~q!NA^h1+wB``Htc?#wL5oqX@mo_Pw?C?FW9DEGD=Xl<((n_
zujHB&lf;HAZL8iLkc>N}x@y<5y~W<0e;4VU=1<*wtnT8H$?Y8sce0(1?B0}l;J@v;
z?I*Wgzp>y<@ZuMydk>!|`Ezxd=IS3)dG{n6)i)k0xTO(&q-N=*?Wz;!^qQ@djaX}U
zt)gDpq~73b!*Rj?UBPiXU!2Mcf6U4!bHgrmTlot$--!RuUo2&h+TSrz$l`71q5o&s
zEPQczhT*NX)<0fxbVm!6bpCqA6KwK#-P<;gj{&lm*_q^%EI23bdy=(#(}Db`OQDP}
zBoi(aN|;TU@nrS7o*&O<Irtor<m7+Uey{od+6wuL<=Xn)%Ob=L?-V&-QWmoGn7yR^
z{P)=1+@F{#WVAXC_XoO}y1#t;!0h1Xr)P4R9{m1c#>n$7y63X~+?I%l>~|06cTX<5
ze?TpNDK`uAqa*IWk3_EjzI)+;WqZm>x~E=Hm0b9`=&Nlj`;Q=*I5U}ha+g`3s+_fB
ztn>(H`5Cz;#Mei{D0$Alv$GxFsH*nFNZXvd-<^BAwV3J3f^8=LImWKrCbG14r|rM3
zyU1h8ORK(Bb(Y^vZ!X!khpp<?f`ThAe?2y;mJgjMx@7XkK7(0BXTHD9x>4@i(YSH7
z_nR+Exwx4u{>1*=;%!}0{Xb%YctEM=?+;E-H?&8+-(JD0t#jAxewl8O@2)++jdGIa
zH2>T1WQAhg9*sXSUoKbmKg^iywM2vI&V$eQ&N_?oy|nN4nQy-3@2XX=JtvE5aVP9M
zEOet%c~XM!A@&PX{<q(M81dim@<sLde|0*Xipv~1HpZw$zJI;UIWqrQ>fhOmGP#1j
z&f$1rwYw{vX~9>Xqkms6*=i#f^{e_Zd%5R69cAuiZ9kX%6w6xrMRO7B7Qe0f3C7(^
zPFTb~+Ls%!;d9C5|Fxm-_B&MWlv}iF!WrAb>N4R+w+)?lT6M>-`}tl(!zulBhq**d
zTj1iPOFUj5-F`OhVn~1cW8;GxoJ&}~U%vj->i5gpA4BfPF?Rdd&5A2}{hC!HU$kWr
z*S++*XFt!LoIn5P{(5G6=9NxZdhei4IjHw;Y-wx?pM12yvMSXAG)+mc`@S~ncF`R(
zp|xK3{)krHUUDj_Lz{8G=Qg3^8<W<rd9zeYUxfXV!Ltd%lakkdQv7!>SKtMk<)WC^
zt8{Hwa5*<Qe1Ca)x%7|ED(7!_zWe{^f7bUm=hN%wZOG*LAG&+;=hx}>F@}fzbJ9$&
ze|qxkTVzG^T#0#+bwN)mmwh?;_1(?#^vCO@zeQiae)aqHdYfRI;L5xQH(#IK{C?fv
z31@URHyvH*T>qGT=7}v@I(%m9*3OZCu9iIO_`^+iea?$X3OgM;xOvxnw$wB(y+;pz
zzq~D}-xYIo;krz|<hxt{i7Oh-yDX%)yEl8*uDze_f6jgOd9K$q!(|2RkvAGec4|Gk
zusXA6<C%<wk8ey}o#=PR;b7s$_x$F*wmFZtFFDh7=MhtU+3woT)7m=6{p}v8CrTE+
z_<2feSKZ~^S=N60=W?Aij{Pt>c$u-W?FT6y2DUkMVy@GQyVo0W$IZDn$u&*2=lAxK
znzN?6f9b9BI^}eE-SU|;PU+NW^Zg6iR?oV<@ole5evQ+1<2L7YoZ5+Mk9{6_-8<%a
zaQdkSOP;rHES%iG^GwJ>akmSS^Ccfz?TEec<eLsp<ZSJ)9B$hJcFZq7yF>f7VpO|y
z<NW^<_MVLMiGMD+{blg&%*AKYcB<|F61&;x)?Fb7p5DJ#w;l{~RjcR=&@rsK^YTL3
zWj5DiA`gGn&C)#2BKc{ZOw(cR2)Q?EmUmcJA70F~@XP$H=xybf`JEWQsl2mmVSPOF
zij4Wb_p^*<*tXBC+<0VO>d6J>cNgBB^7n9NupNv4!BsoANt{c*|F++QaoTCQnM`vu
zPl_x*Sh!4s<y`PD#fCgZjSE%c$EKX(zVmeXE!XB~=L>Um(v4Fsb-4=}*fzH`AKdC}
zdrk1j8iky?Rma;qBBmMp7Ed{QIDq}m2_J5*=baqR5u8hnPkymk6PI^aulr9x#xXhF
zl^z#r_P6SX9RB>mYzFVkB^7dIsflG>X<s9sT(;Og^P$T;oAccpWYi*-@ysr6e(ip}
zg@1$2a@+lj70i2deiq%newZVz=<S!)LXmkV-SanXSi;1_AX`+*aG~|4<pj;+y|F1z
z)E`Z~o;}}2TET3-yEM1<#bf`!I3Mees3}pscYf21#7{04R?oLA|9f0w-+?}hTdW7f
z9pW>-|K9cMb!Cc5^S<4SG%c0+_r6O?*f_`TbEdn^o9iyZF=-S3FqBB#vv2EveW>fW
zw2Ai>2KI)}Hzw`7zVE+_Q(&as<4fg@UlX(pr1$;eQuda(^+;=X`R}>e$20rI!sf4E
zTEO(<MVsL=mjgQCUrY?s&vjZVb2hXnq_h2MFy9%HaYo|38%NR<|9;uXZ>5#O7Sj7-
z0?x^<GU{`Z3hk2Xk8);M{mf!VyaqQ%x?5-d^@UsvZI`MXbET9PDx}$QJJ;>pv3mM?
zy?gFGoSr_ich85cGkDTBlkLD{r{9ZuH5VI93ADdjd!20y)87wGH+rJa>^Hl~^l0mk
zGdp;fC>`|aVUgV&<{H#EeTx|P8`-=(nMXBg8yp1fx}P5Ln;todS%um0a>5Pc1z~IV
z8yq}6Q%*5s-`d&sF>}PHi1FS3I&s&5EkRu-Z%^yA?H4-Uz&g#d;qM0Bz~vc54{Hk+
zZfYv~CDSe>Y3mw!dikO!A7Tz^p1FUQXWf61y~|V&d+6H!U~9SQ^YPxX8_zYX+H7rN
z%>+L@Nd1#2CNrf+!6GB8LF{u?6`O9CU*egKA~VuX8=vjC;VE69V5@fV_~9G!t3C>R
zve3{EmberCeMZE!9n1O?7^XRT_Xf_<l(*b5ccJxxiu;R>Xlq=mdlhTBC}*owdgc8o
zrZ+>iqQbA1wDWSY_$GK?QJXyH#c5xIBo+3VUsk8@mEL|bso{mwD%O3v9frPIFLU<i
zC-pS%_>^MTy~W#n*Sg~s+gf@AgclfmcKPbG{+LC&z~iR1$1S+nKbUSV?)|xJ&92!Q
zTys5MiDo<#ND$cGc1STPeq+nucV!hFQo=$_Kb$7)=}}Cq;cejjy<unZV}aI*o2Hm?
z&a&~$D<~3emHn)exUXSlhS`L3Kgyz;yY_bPc^GLIzGKVV!^_^U+O)qhfU{HNO}fTJ
zwU~}2FP|;i?(yrtwj%$k?}kqrGc=pZRcoG4c{E-3=)v6U%xsgd96g%LXS*!fAxCKU
z58i|-zxzANldo`^`77;`Q8?`KER55e@g`eFuyIPm{Fv?Rt+QQEJy@mS`m~KhS;MF3
z)S<AYT84@d;!KyO=uL5v&p0IPV8Ji&td-%9PSf-0MYj{o1m-=Q7nh~;b?>Z2Yc{rB
z6}Olc{AXXb=bec!!`|+Ee|Oos2}TQg^e0*LZJ0O7@}fulzlW<fde71J$T;)0UE${2
zUv?8%j|d%MoXE<QyKIhUWQBQA(c|#Wu83Y8&i3Yx|8Gvelzh0PuI1{)S6un8Dwlq`
zc2xiLl+^d{!afxAZEf}AG?_GMIqTB?!^MHDaZ}rCBXj33ZU|i>tG98+2Fs0SLzk%C
zSg3eAcG|)j44VR575Ue({Ll<}S}MIZC-|Y^mEF$HC!M_%ERw#Ns=PT}w`TQ%=!F*^
zt&H5fvVHGs_BotaW+*Pc^1?gqBy;KRw`KF*#*}y5ly?${n|1u`cG*=MRNlU87oYfg
zhRGwrGYc~mGIm{f-L!x?=AzT@Uu8W~JQ`nCBw1=1u8NqbKc)I^9^cg2F<e`fPNekQ
zo!u_6`&58+>e7V;&yCHd=_#-W%~Nn@{GuVi*ULOrWX^KMV?U;EIwkB~w@5EjyZzRJ
z4O^ZR>u=a}dHafG2aMy6uZ-+zkm@MZaOj%AxFd#B_~T4Y75mdGs=Ra$GWBps%(kvG
zW&3UPWS^&Spl7w5GG9sTtEfFM*|y(LvStpMy=ZwSUw?LVfBO{M`@5p2e0AV&nRIXA
z3xTGVw_dEh7f%Jp{^GZP;=O5$>hr~#9;u89;wpE{Oxfn2?fjR=@9fK?AEce-QW@-#
zbfja+N)4-X_mA3$o5V7_*t5Iz{R++LS^NPPpGsJ_2Y>q<d2Ye;{NH)vOO<mj-m;uO
z?ZM7(dQK4smz;U9#60!u$C8<GCN3_1olD9^J?42HNS?{SKjX^#ejQfnv*A|r_jQ~M
zzV&)vW{i(n+}z2j_Z22{J72x$WbDwT6K2vpE1S*0q|Ies@MbTqv-8yh&x-F#xO`RL
zM)%pBe+NF#*<U&J`DDHJIWEijm3UIaij2BL`j01F4>>bQ`;6wIb!}hHJiVhk!A5S^
z3e&x(J@&>gG@P+Spwjo~q6wS*&c65+d)H0zdGtE9;~Xn~<w^Lxe=QI#v}JdgcIyK{
z>7yP7mZ=MG^ZiydX#6Xb(d=4NVaT-f_vZ(<w2ZczPSIz&<RG{tNMt%!Bu7nG{3pv4
z;X{lbLM^8kd2ZVB&FR#WPxVuc6lT|&CtSQPP~%%~#L6n-d^8~_s;$BJ;Q3q9v(D}|
zo_;lTXK&v$DFKg#|E~ldySVPfffnt`JDV>2+tcJ_bp0B$(<%ltueVPP){49g$a^}4
z+gfN}r1y#4H{QOM^SmTKrSRVi73FPzisQEh&MN<XuKcEF|B5Bc9gj}2=D(+y6zq8`
z&qnyc@pPsMl?UB-TzM$4OJ(879V=c=JFcj$o?ZBSLF<d7?!A9ly=$h5^zAIuY+ZQo
z=b9d;Cn8mCa}K$+olsP=j8=GlU1}r0=akb&fATQoKHIIW6P<Q;iD`}R`a?~oi$&v?
ziOmV0azx?E>M&2X;8GSQZ~4T+iz1cryPqZdBpniX<@D{_l<X6Gx0Fo$@vg_}a;xBv
zkMnQm^H*f>xC%sPDxJR-GW*ws?S|WpPY6Hi_MNlqYgB{W^Osv5uei&qs!_MllZp3G
zoTeGOuX#x6<t5K%vD6-UJDu<GtaW>>-+ugX&b{@*G_&SccHQ<;-bt_j2OTQh*A%T+
z%c-8sX8TTZ=84KXVl%HV;N1EC?u*6J{rwH!dbV{m@;`~5=yxpqm)p88d-v?PWOG$2
z{qtvwileuVtMhLTzAtacrQ@Dmwjk@&OB<!`btfmA>aU*v%cyRus?aX`THb$ijxCIM
zQgWyMUa9<Kjb+FFh0A@>Kfj|s*0Skf^1~&C|L1<mxpl)mC*Rxc;>P>QD{Z%?KG*na
z>v-;{mf^`8{)}<gkDXcF|NU>``|RfrWM5jZTA~r&H#07s<y%R$(p+x4Rm={Wnnm~Z
zc@sFV%Bk#r?CfzNUMKdlL(0Y@QqxU67S>wC&%L(HSUW>1iBBV~@OAL#@(uxwuyxDM
zOxw<`arJlA941?tI}C=K{{&il+7%WbxuKrd=kwjVXJfbW)Ajr87d8I&l-GIJ&$9jD
zGcL976UA!uBbU1QCI%e*btEIrV8<&nKI3*K%{hE=!41o;#gfBwYcGTb^3O=QncAx4
ztKq(w;mhB(ij!`?aY<SG*ZPsKa=nvF;iG)1-oVILOLXSzeB7}5<!x1!bf@2Yvv*lv
zak>?szNqX}>h-b>oqx@?wKpzMO^scb{Ks+crko9b{>?SnUoW4>$xxo1^?c6TJ!`ty
z5)bTNvMVh7P;l~d=kTk2Q36W7l7fL}&Mi2%JJIE!M#AnAn~%5KH<$eIJveDs*&Kh_
z&6W~!r<NVuqf~sVWc`Mj%Yqr^EWiBA{osC!mf6=mJ~S^XdYYBmcKziS1=s&x7vs&o
zE{l<QHcL66Qgf1n=<2e155G%)x5pQ3ENYvuqCD;Ux_gSp(s;MzYkfDrvThQeyjn+d
z#`Z3=FWC{h?G2XQDX%oFWhqnns^l`kPlI)8`M-?po?U%~r&0=?gRLgyFdpxI-CcjQ
zbIOt=<~5;wc}M)FdWZ+s<!#hyz53ws{<7J5{Z*F=vPAxFS|nTl|6J~?jj!wf*UdT+
zALadf)>^mhsI%?ubJy$e1@C4q3ZD4febuSOO(9pK*RNU^5bD^=!zwGgLsrz_lDD2o
zX~_9jtrNc-f(~nP?mL<~zxMiZ9ae3x@BMn|>pYixuAaN%*X&huWI0#3Pki`ty3*q$
z@ue3ReXSAi&ShA(P-II`cKpsn{#_<33g@Q<x&L~^aMQ>v?{8r5vJi%o>EZl068Y}3
z6<y5_pP2ah=0qRHi;dT(guHrVaMW&dMH_SEx%mHc#LsL#eB#c1o4Jucn^)(@m~3It
zy6h5>E&7gol8;JjU0(CKFVlVZmF!$9|6$U6A(1n?f2szZNZ73H`~B;V-ggZy`*$2?
zx;<NTo%_mjO$y52B2B&@wUL%F{r-1u(AJKB;vZ$_8I|w6Z~m1h=-)l{)W;j0TQg6#
z|6a#e`Keudf=X~4%h|eG?z#`*4UHNM{FQI|4gNnk`t{`f`9JsnXZke1{$*-jN^wb1
zYGN*;0}kqJgS+JxmPp-lENg--Knoa%?v~%Gy&V3+aOEV4JNk8#Wp8#}FWNJy%zWi3
zZd2w=iNX_{Cp+KPbnHvCFP2uhppb5{X^-bi$506YmJ7@M=f8WFe_Unp@gx6R|95}A
znD4${_Hv!hzvwmn@%LnE%UyXbx6KUo>3lqU_u_|~RXGu9H#e%OOn&tvt@exWW3TDk
z*ZuwW?7Fg^(b^S_o#v+(=V#fg7<p?xO?>hFuj2I|hF%F1j;NnbiY>{zsqblgawo5S
z$<bRs1KBR~iYIPaVRikBxADBdbB``n-c0-ZNGn*V%(mxWz}^?^scADhoAYO#4-LFK
z|I7L<lBP!gifnZpjhE%zIaYbie~D7_<wr-3t|~ZtOZ0GO%egfMA3N*zo!O#NkbC&T
z>xX(%wiWKb87Wq#wxr|qzfZl<+ivRL|28|#%-HGDhs%){k37y4Vz<ANy7O(<u21%J
zixQ2Mety*SG5Y&{`qxWS3$FZoYqD8L-+cWq>E%*>t-E!0-P<%Jbyk<f=bX)&-L7)?
zl{}A0bld;?a(MsYbu5pK<Z}Q2k)KsHk#%w8+<;>7chN$^^Zz}3wrM^`^R#2#m67?U
zpB7wa5IU+mcb|8mQmI7M`$LQFtmv54&sg4c{P+Kx{VRAjcs^RPtFl6nVY!CXE9aN1
z-tMY5K0jq5Q~#4&+ssXa|M`6M+Oe?z&W*_lLX!>sswb~FsMaHJ>;11QzZs<?U*8hl
zzV4;pq1{V_KKj}5d=R|zX>POeTs_O1Q%<(*QClz9mOINw?eyGK{idfY4tnogxBcv)
zxn_9}&0_DyZ)dvP7Jt3+y2$)PK~e6vbv_ks)D={4YBWu~^Yi$k=vM2gEORZsJ6k=T
zqMUK>>Gutne=Et088)N{>+U)^dtJnoy|I=JlV4WsO1+pDb6JgFph3!Z-@C2ljdkoF
z?AkomGbvOkExKLv@q^)w$rCDe?TKXjzMU=ijriF^i(HQ9&MSRgrJ(4a!XsX{wdl1@
z-0Vd!_N+diE5^uTC)lg-%Wy%mV`xm&CHJHLO4<gZ<?IPU%rj;@ko(a7@JNS%|ACh&
z2Av{Pj(Pub7nVJ_sQ=IQdP&B#q@d%>dGDDwzV=yge-4lSMYG0-sY}9-F1g95`{vfU
z=4q>JFEH&CICpIM#0{R^pFgR^TQg+O&N$6<{?V_-a*t)apUx%C;AmSWqkit_2G{T-
zosU*lG9UCfT{&l~o*k>vGY7-RGq&{~tErIDnC&j`W=F?49@D~KH(dR8PMK$OJkOwX
zikx;v(>+&#n3!JA+dEZrcJgyiN())NeBFlVof29zJ5EeuW^6bs;mlt3`Q7o=pEsZ0
zutrg$@&DuYh7}6`jwmj8S{9nmCeyq>@b{6F@VmRUl#XWzy?-aw@q+*Q6o&1JHpUN>
zU4EHfm>WI6?R2uhKli#4=>xWw48r|BXRT8b$~QEIrX{sxcN|SDc5s{1_0n>O@ADIE
zpEn1_R2x_De{YdB|7T~>a&C(U-^GTDVsbxo9|ZY*j4dy<>fK`ef^n6AlHi)#S8^Ng
z=ov5i@HAHT>Lj-taz!i`C)ds?eZQ;bgA&K*X{+^Zd9_^C&7+=#?$x~Gu$5_t$E}K8
zf~=c;1n*p{oO(fO{mbu*R<72$6`+1^u@*}{?=SI?*e0f{ZgxSr>|J92G;3J5Dop?V
zT;yZb5g(oXnqsT@Y&2iEDi|y-`?5&Z@ab;_E643YA64#jJ05RZC&c!)Qc~{wE5G9h
zw;$+iPGI~t(TH=7^F@Y5S2d*0?6KXyzU^~`wvkA*dSKMj&v#t<*miFE%y(4C!oHzL
zf=R5|Aupol;{LP+^RM)I9;v%~b+u8|jf{uJUxbfd@L%`&+*DN+`M+}=E^L=LHGN$%
zw~Osbg<D5z`H!$axUgZip+8Gtvil;oBrb`&p|NrEwk?><X3+fRFmL{;+!IAUY8{Iv
zPjAT1Y<v?X8XL^KyY;SC@5SZ+LUh`f@HFTMJSg|Q`#S8H!nQ?IcC3}2KK=K4mZXAQ
z@h2Qlcl@|Nt3j$k;=0zNXT7V<;|_cgXAx?Az2idY2cP-d4}MGjP!v1e^|DrX-r+MR
zZZ5mz>yazZdLZH0ZK3n$Dx;kkd)_Wya6asj?%q|`XXjq$ZapaI$YN+yyDuVVc8%a3
zw}L7E=PT<6`UItYEuVL3xrD3Z&0De7##0w%O#aXHVD;>z4Vo-f3l8tNm+T_xswmmO
zzLS?}J?9opRmZ8{ss)9WvnK@Gv8~noc~5c2G3PsC+fxIZe=$t{-u~ee>s(cDFa32z
z*XAw?)szm-c#=N<{?89TZ0g!{yp)9t#f*zqN7~F4{dG}GbaK_)cax*Coer@UBs5;w
z&oR~GfR5mY*R@L{&2z;qCZsBH9-3@nTKGU)M<t^##xihM)tZvWzb%h{f3H#Xna7pC
z@=6EW^DCj(53?85c`aM<VI{ABr9hgh%>3Hse=3uI%~)8qJtFi0bLx}G-YH?_?_3{<
zJ?N_VF?)e><9rd@845<fr~I0#e5N+=kDF)P&xfzepWD}Rv~b<bnNw5NTF7yE>uiBz
zJC3PjZu=w}|9-M<n?JKc^HN8*SCW#S(~UeWCwnq&4fGHzonSB_Zs7qIzp00Le+6e(
zUhvnr|5=zZFha#^t@%Msor3ATYBrtUC(U_uTxUT)_mUmjF_S$@ro8`LI(I$Wi{?$~
zGi=VDt9u)^cJ;fMoju1}I3(6*FOx7&nAWEiwmxn8-z+8tWk&nmPh6vSh{OecoRhxX
ze(@ed|J0Y_+n*ZW|DWdKkfc`K_xTf>(eqG_(*kjllEOc}UraK}+_-b&%?ybXj^4hH
z0w#+Gx)yo7n=wN!A?Cp@o*L!_sw?KD=ROjvynXbLI=g7Ap3G<Y`HL6D)%n?SZLxp$
z%yo0dr`>uMD<+vNReS9lcPHH0LqtJyW1G3BFUQP}nIA;Wo?os@w!W&!vF2F%p=9x|
zIiESQQuHi6OBZd7xmBFIpvGF5X{zgvIr?&8m78UfCNwl_gj8JT&_8tI|9eBX_tp#h
z54|v)Y;(+gkN$B7kFSP(HtM3%)7RZUekXa#Pqm!aA=<NC(kEVAetNrp(}RU#&Tk?m
zCTT2|+OGMzHQJd?aEtPV8MBlm7cc}hY%&zNm9$rKkzzxaXHBzyA=^h)gIkO4y;&-&
zV!hzE#v{q>-MIpFI*B5$!<v*Y1@WHHn5fot)V%j~kgea(DT+pXrxFeYY<qey-c0+t
zNOwWmv~zsbaXT0k6?RnYE33X;R%!a@$!4KOuFSWe%5Lva@UC6n(m&a}{^(nu3|o=T
z{eBx(NgmV^ncmNIC;eWmvu<Nng@+8^QMYqHUawgE<?FxYY0A^CzNio8Y7m+FCXiu;
zWs}GUnfA#g>%JLU9Y4D5RgII#H3s(wH(Y1k{BiV+6yNFk2lKVQ^4)K{*`V6Jb;awW
ztIiyr_xt6IzKVChn{I7eyeTg5*d7iO<IBnn>tc4w^>B$~d@xGO|FUM~D<S?vUs`gW
zx161EKFzw`Uu)aT&-O{0t!fwd`^Wm12iMq_UGhDsr^<M*LoH+X+fC}KY&lM6{9fMN
zE;vEAs!eig^dBBpGb0a%*?Z$w>aXqj!)38F%e>UMrSw8<)X}Tkb8pDyv`E}J(Z`n{
zW^1>>H%auVV0Y-F?Kc^C7l&wd_H%2oY<aL`L6OkksR^u1FPMzkh1pq`C~iEJq*>NK
zz4YTDcIiWJ%IC%0tMl)epE^_j>ygMaUy>axcv5F1{Z4jll6ZHzLz(CBshaIuE#0G1
z?9b23xYWJqb&Tk%cL|&y_FCAN&6?rQtFEF{voTpk^kVLpyv*cFS--f0k`jt^9QGgN
zo9dH$b)UQ4Thr&M8;>M#xToBD!{WTd@l#3q)17}6F3gUR&6wF_A@_9q44&`1<e9FV
z*io;idhWgBGybQp@wH(;6rE-s&v$a!HTQSKN+VB~#J?hY8X~_m#c`T6T4b*3JXa!X
zcW`I-ilq*_4^4f%^hvB;@U&mqi~h&#^fF+)IDh3&KPR1tLe|8lPtAQQ&#wGhk+4<1
zD%Wd{-}+DO2jtHzYT=Uqlrg*JOY(1lY1{4`^R4TfWv2Oh=9hne@2rcv7JBbmXrT~;
z$AyXWBac<_R{pi(Uu$9^V%jmMd#8BZF4HAE+U&>V_hmAeD`lx)Tq69<g41W=Ryj^4
z@n1_W^So1%@cvz4EH?GI#GaX^)?YVza>eM#ojUR1*rE-VH%vdSZ7+E*{;<vBIDhlA
z+h4ZprQO=Man02$c}Yvs548sf81mF{ls1N(HH~{K+H|@*Fmai8pXASg$(LVGtu1BR
z;Xm`LYR@#o$H8rHuQ4}Fn|VuD?$<PpUkQPKYhOFX9cX;}*3bI*Wq%=I-3eaio^}jN
z%GQ|9%9RdQnjo~#-#XKw#h<fg!l5p|xIBm1EwiOU8D86G$)qvqazv#uhFs;@d3}Lm
zg7}=em)VooKUOn5?E7!^F85PU8=aUq<>xr0Eo!j}@!0TKD)9r;*7=Ui3X|sMhkf0}
zn=8TCFs0(@{qs5>#hi7$=TDx~dcZNTLofEK*xlz3w#|CTs`qM{r0GwFYb)Q*-Sxz%
zG_?HDT2}iR{oD7M)N9;pnv{CE;x^l_2}+;O-V*GIyLLNk=G=X!?fLcE&d2V$;r&>E
z+2hUv)#7VYK26lJy)UuRaotb3$u>GScHA>v*8a`MGUdz5GnZ|S*KU5QIj>q!WRu^;
zhdLU8Cb`eQx!zp<ZreI}rf?3u`9HWG2FtBhdEi(e{zLYGkLjW{tA7XQ*NP|gZOjUB
zkQ8dKJ71gE#X9A6(q7%&dy2l6X)Iv)T;vi`d;3^_q~eTho^>mD6y-eZmaba(dCl?p
zm3^8mMoT7?{#zOGJxFYmOWs?*V#$;l6_Y+m_#Ty5k~+0(=lh2zRxj9-a%$Q6YjwR3
zRQ_rEwdv<|{Z=w_%;*Y>a965Y)~CX$b#M2vvlFVXUzwfwTF*jla_9ZU8lIw`o8{H2
zbC#Aotl@sW>qgFGp@+ZBj#bZ|*t!4Rk^+IM{WA`A{uSw)EX?@m!vEmrk}p-NtuZCH
z->*|pe*Kxn;O*JD+c$l@zjod)eled5^XeY`Jp0kU|IhvZ4ATA&>alcnK^<6dSJ&JK
zvHjH&%L;r;qE_H<MV^87S*6mpgSqarX<1JC-ffd}mVR<N8z5yh=V8l}h%!5u`@4CW
z?lQPfx#qWN>M9l1!h*~>cD1{t>*q{iwbuM=|8f87w|nj1{VhDS%<#|otm;o6?(Thm
z&mel<jzgL2o}S#@UHwq}&5;kn!P8nVslVU$ec#Wgx69wZzv*Q7(&Eq0yT9(4hwhfW
zb*sNPG~#%u%>O6tF^VF|KVI@5J^iTU*CcTtZ^?FXwYBZL=Bho|w83YC#UC!U9rnD3
zkGN&Yyt{Tbe05gNuDSmg2eJO)UH(e%kHq8FO=91-y}I_bYS!^XZeDZh;=f+qCinZ<
z`OI|(>l05oP5*NAQp(|l{EJsjnDubps;eo&X<Sq5?p=2_?zx&5>R;>~%#r!AKl%Cb
zb1jCgW$&K!ygcMrzhh0?E^D9t0*eZI7CyZ8clnMDseIyb*MH|_{Q1|N$@^Bf^;m^L
z-tI&x@ihT^wiNz3nPL$pb}Z`8H|NWTWtLy`xpU#7izTm7q{ZPvwqrWG+v;z=%)cbs
zcJa*_OIzKlW2*W)c-t>OEXhBfcX^&r-HQT#t{7LVTmP9tc5Un`Kjii6UDmE$i%b@&
z%$eur;N`ggZ(U~Z_R`|G?~gOLlxK3TSigL+r~#v*(TyDj>q0u(v&<d2{W5x-X77Em
z`|ZCsM@`h<+~;h+oqyh6Ibes<^GdM<J4dev$L761w(EX*F4L}t?(mGKyWa1v>u3vU
z>bAJ|;O?}xyeF$TXS29J@p}}vZ`JM684L+&GV?Y{J!0{S`ctyWk|Bh{<lNE3?N;0z
z*AkQu8?iiYdpLoq%%*(VCV|wVWwvwHWi9ueafnkdKVqu&rdJX9-(%(N#1kAA7s`Fu
zvd;Fwu1TWPtjnK=%-;2Kd1|AsYGByryWy)1gZPxU9DjUZ%dE%CU$dQm>{Ya=d)NB%
z<ULb@E-vkv|E-bv0oxkwyRvFO_ujl3z2TJBJeD6*G#0PFcYXE7*R!oEzRqMQk&I9+
z-XP!gz$7fY?X}H~_qUmTnmT?DwY?VGFZX_i<COVq^^<HS_D^_W9X2u6!s3}}dX(<w
z2CmsDLUk;=Pct~lFqF(bH{IfZ)~ECCu3Pp_Z27x<vbD$|OTT4r*bAm-B%RcVnA7I(
z9jN7e+J)_5%!73Q-&x<SC(YN%ymi~cLDXkz%Q9s?MhW@N%oBtcpWlC+m%;Mkjr$9C
z{eH25>*F^*-W0Dpo_lY-nH5?h$1(HCbo;Vo*|%(Fhdkf2_ooYFW?b^^C=_t<?&8y5
z?QL*3HTZ2(NAaOW3l$GA^)*LX2n#GXO|}fVes;t9-;8_3c+y{XZ5P-)QJiIYcGb@(
z_Uji{H~szim_2`4ZzmJer86wsE*zTD@sR(ak>V1gKU%uy8xL6iy(N~~D6*{cOJ4W#
zezULJIvyDQn;>X2+n;&Y+y`uD7bRsBP0Eycyg*eUX4ZpLp=sh@mT&6mW7*MUJ#D7)
zURnO!FDemE0?+qqa#*G;X%|V+QRk}I(4EX+c*l%o-o9x0Fp=^EDMvw_7h(>x{XRZT
zEWfdKwSvFGlV&pmmVW<>+Kk?s9<0w^-g;N`tCwk(F;}=o-mW*@-wH&Z2|6seq#!4^
zW>x9l-WW};b)Ip1?dEJhyP@&7ZSSrVk)KW-Z~Xe;hLg~wWRuPF#DDNCv;E;$kk>F*
zRI2{qoUISjR6I0UAHPhSX0u`Mi(jVa4ySf5=bpmr95eZ$l03)s9}0KmkEn(Tr5;PQ
zIaL_m{!eD_L5n%>E?iS^_E#?1so39Ca5emFp7h~qT8>Q@LOS=(Q22JsOn&y=)H$7*
zjmMQAE)-!*zFO8^+OqufO1GZ5^UFl<MD3Ac+~d&q;nxLrv!r>c9w&krf)zA4_ujvL
z_ug-bbIg1#pBuX8yHzrsJ5pM=aLtuxQc6=}c%s#+X0vrT$DDg#ayhr%BTV3%?!RY-
zRkOWo{yBd!n-F%ARsJh4%gSY4g-XH2;(`+s)V%u)+zx%+G+~c$(9&5km)q-?^*>?J
zHu2}meiJr3%fa^G!Q7Yc)ca%?g*!@^m7kehY?(86`jh6JTAhXtQc3ICmI@#7mXQ`*
z#I>k(vZTxLiquyTS8ICLC`(-Y8LDvIz}w3z|J3~DZx=?oFXVnHdFzkpj?#v{4_Px$
zumvTHsH^HO+p#;$tNlEq;Vd0yorFaf0?)N?sJU;y)z|b-rBp7@t_BH%v~5e-)$_h+
z%wSSpaWsKTe1UH4fk26=^X{i7n(Wf<@N}KAw0fq2oIRVUZG+2-Ou4SVq816lMeh<y
zSr@HXvb%cU?tY_oVb=dqZ_B<~m}MAG7YUdY%5tpf#r4d2mUr{-UwQp#d;apDwKtod
zr*>;*SnuhKz7(}Y)pOe$wSC-C95#`Lmx9(CRW}wlIvm+Qht2WG<`rLz*;cvii(Rnt
z<Xg`aoBF=l^RLDvy!V;4c*XNgS3U`<Ol&VSs=Bed?LoNIw1?Z7e9ezAqznD_y{I1-
z9&jM8Msv@)?ROLJgxvmn<E@hCuLEq)Pfh%-)KSQ=@U+sr$sZS;Vrr?E`&j38RO3XZ
z!ofAlrxZ6m+_;FxI5Jb2L2ixO<dV4d0?|)qHlL+U^u2>Vw$Cu**ninNsO6Q72gm+o
z_dbdDqD~AqYc;>!`}0aSRr}nf&iIhWp`ZVK=d|0Uv3B?83*78IGd9iK*Pp$bN7Dar
z&MgZYH$hj`7al<-!G9CyY0KC#o^~=>@jJHl0K@(no7FA4pZwBboIUeTrHyrqaJnXU
zRPL^_HOYdW=U84E&vALJ<Kp%~(qhh>(9U~-PfoMk3bo}a-7vFZbMvBk-3wx}UGt41
zC$(vD&zTy?p|L?qnWyrR(1hQK^%?hqC!P@ay<ba-<G}9@9Z$2FDzod>=DTfJ+LBW4
zm#OnZyslD`-|nc&u2~W;3d)-`JC>N7E!uSV^}cUU{Z>tA2!Cx|>MXipaqoiPRYfm$
z*TyDxx@Jucsk8VP!d;|w-N&By1Vc~JjpJ7%=7u}RF8K3UMXCPG4Za`OUrw3AkagVI
zBeeG8@ku*Zdc9W3wHHX}d26Hlcg?z6h0TwyE|IZ{o7pTgW8Ir;Mwwl56Qmhutw_4z
ztY_P4?DM!}*CF$-`(7X4vE?Gm_E`D741B8Ti;f$32t`D0Vx9YILt}ACU{v(7tFaTD
z7B%hZmtA<IA;@cKgOp18{U*btD<8fFaDD3h(|DSD=~Kg>=QCIDW?A}6{lv@-)g6;3
zt@$C*ZDn@x;O5qix4kz^s9p8ggf&Cu=WXK$ix#du^ol{Xz+X#z$t0n*UlI~aOY|pa
zZ&8<5(%7^q{;J%Gtqrpr*f;IoHto8Zm$v}_QFom`)2DrNOm&*dz-RDH#?CA->eLf{
zZvl=eYEu*v>*R{R&G_aOA2q}C`m~_$D;KmqzklWI)3l!5{!=AA61KIQiFY)xd2UQx
zB_NU>!WZD#(!cQ~!$JE{H{ED0bFWff@y4o4w|ts|PczzFGItO%dH>41aeuUWn$Y><
z6W6$OeK{wzcfZSu6;oJr(@veAb@e^7nCR9eMwguD9Jtx~s^_GN+xDYj(P5Y7Twq9Y
zmk1KF`^)t;b%&i>pn%K0j)@*Ze^z%NcspUa^eOw-R}W2}(NNXt%$f1ZB5{U)9E+gZ
zwVem8+GaE}@l1}CU%S^LA(O+XcFVh6FYU}6&6w8k8oP_|x}5APS|-+(c6&>x{LOtn
zj)%8jT5)*cNzG(S`GmQrer~tqmFed+I*}^-q(YEYj-f2>h~=u?<`L;k&z7AExqd9F
zO}}u;j$4cK%!3~IpFPL)eQLnR1c_atjay}uJyQxdKQJj+@JZ_5Qp1jjiQ?8tuTII{
zxHV({W3!#tl(q|+6-&G9@M>Ov@u|^FyVBI`oYQ`1SlKT8a;tQz$qN@dGH35r?bWtg
z&toIcztg<(j5jjj<ZRwZ{RiSwn=aa>aA|}nHQ(gTWuF=rRWQjReM;AS#%%Gf(=wlT
z9~ScwdHr*e_#zdFmQ8+wk2}m-KGrXhJ##e3dWLo3+pnLJT+i;}*t8%szv)cs%&^OR
zfp(1>CSJOuu_-lnw(9)oH#=-{Ung#LoUZv)wsz9eSH;K9w)|S2+t78MjUzg^{Mh`s
z3jsZweVt}22)b1WoQ$!RS#Wz^ZEs*$qmIwMvc;*BN*xdFz29$PY9-ttFgHAcRjXFL
z*Q;=Lhk-KJdS0WJ*sHnK+j8yvK5G^@blP+EYpVTqx%q3=?X{cJIb^=@Sw8>2TJ_}g
z7k<{Iyoc`TY*%r0QIa|F{A4|6r}yznpQ8-Q8aFFCHRt=xeDd^Z)9(oi7h+`BGyODO
zy4utC)|FFzp)W6Il&?MU?zCR9Jzv)q|JsnPtDUPd7%ID;JkzM~Zz|s?#S{GU_UeOD
zOox4$&M?e(VLQ-y?-_&l@4lm38tUB~T2F77s~MYAHBIlRJC~mD&gr#V^O7PZYYr{_
zb>Wd;T50B&c`Nm5zcCtSYKE`9op-h8;oYErQ3;Q7kCbT@)U9OkyJ({x#cMNL<-;DH
z-Uns>JTImvODm;i_C*J3Io}PcPTqLr<2Ek)Z4<;Ew1iilKV868&0iR_@}$5D0SEr9
zAddVCoeCBYo#bcD68W;n*v|5HU}8epbqlSH(dUDAESKIZwDe#4dKJ^WHGaLb_47NQ
z*yN<WJ#HN!`84U<vgMx?>-aru7#3*N9*p?w$|AM9#o_omOKovM4^Ih?<Y!OrW_|LG
zFLHdd^z!oQF?xH;PS2axs1$tjvQg3=)<0=KZ$000%P8sLRWS>;yhoc^*XreS-7<P;
zvT>2`-u<=FZxxt1H(i##KXK~0&tf&4$CpQ+|6H+_LvwP~Om&;?_sSi)YiDv^2;lAE
zOSIUUb^Z`9*R)r<p*w1J*lqg1i)*|6d!981{wYjN>c9GZk!WY%=c+xcUdQrq=!9;%
z5ES=h^3q+O7rwK1(eZekp<Tgzr+n^7iG5N#`{JejPF~+1x3{NxLhWM_fmz>b*>4^e
zh>5RUo7&H9C*ZW%>Cxiw{WiR9EUrOakvF31UOwV&iCpA$x!!SFMfZ(*U*6*SFgN|U
zq=1>$*5;399k=_Ldyemac*O7XzpQ5etoqWo#%Oy)*lb(ft2_Ve?^!p;HZpPF*#?Kx
zf0u^1m#!CJbl_gfv0=yb-Jb*RUt7TP@b%&2v*WM*;0V4`qoX10onsx}WtU@kVoBM@
zN9)W=*RV$la6Bo^UZ8eM>}^6P&jyCavAJQ5I~kt!#Dy-~F2ho-pu#Zg!~)sc`JA_o
zx_(n@XL_0FaKG$jr0G%rhZ=S7c5kzF2(owk#8&BZ+&Zs+_2Td}iL0(vwZ*auYgoOT
zwpi!Cek;(QERy(b6(=w2yFeGyeNUakR$pDXeuKUuYiSBIUt-I~#V%KV)rHD*<$imA
zub|S1v*>t@vSf@viO7Yu_3a^T(t?NTe?GZ;a{v3E_5ZkeVzN$RcKX3xd2pxS(!vrx
z>urf;*SIBUfjYtY?b<Nk{KsYjtW{suUohl85>r?I<eACKvfHJzkHv{Zym8$q8r`dE
zHA!a8e~<d?e%XmKw{mYOuqz*ac;>@ibK@#KjYL-2|CipcnrY)dk6SF~$L6fA*H54P
zwcWg>;7I1W)QvTBj!3WBFvlWJ!mIPr(M>aBYF_l^-p$jyuls)nhjUMejLh`cCyzGy
z<a=%?=Dg>n`n%NhmV|0w)ZCoo>*8`3uU87;n)t@PN6m9fVTR(xMIxaUJ9DlpE>fG6
z`dHU9a*9dDZoT%a-&9jJCX2N*TFK9`G@P>VqpF%wpJ8X+Vo%{?EeDR*>|Jr~>x13@
zUhiJb(5M_#v}ePeW80+`X&lzdTea}jtX;b8x3)jt*kr9`f75>1A=a%kQauV)7_B0V
z&b`iOsPQ<(v7K-7zlf`|-x}On?i8uCMQd3@FK>H&Uzx$7)duIjx361$tH6;XY2_iW
zcUJpfuG;6GW%^tEL0iOBM)vpZu~)xLRAAJ1Q^~i#e_m|!?u6|}lBV2G*6i|ZpY-u=
z@cysACj<zluC-*14{a#f{j%9hL|`#*TypS4mIYG}SJlPx{#*DeNQcvA(e`3BuiPa;
z3xDo=_rGgFrt=OXMibe<->L<n@0<)8COul}|FrqN*Mt8v;@;|PfBELq)}Z`V+cbAC
zuQ=2(`N}*|(FwDS5;=>X&#BeCy-lj^ml3DW+(x<LhAFJmT-Hsh+p_S_9bd-Ree+H1
zudI%pI?J(F%X8DG*ICnBR4oPHTv3}@mR`gv-@brfO+ns$SK9Bt>*D6J@Wo~nKXaG&
zNbD+DcVWkh*@yY`mh5TcSQ>C)^Dgf%R?{Z#|GfJyqp*iWrd9dfyW6sAgSVzKgcL6F
zpY`uXoa-ds1!-3;PkzqYzM5H1x%VA!%VN&1lg4jNn!enAvS(k{8?}W_Ytt9EF4@Q=
z98%D(zCCx*jfifM{a5DZKfLH1qUoU5GWGeKz9q;0%sLR5SAYKv|KXVjOqo-B<{4eh
zir)5BYlF^J3%}xEIk^c>Z%hp~<P&)CaLL_Pd!E~yZu0Nz?d@**|EKuJ{DW_jqvr2w
zIIg$BVDSRM^FMzwm9mr;Fsn5-+D-gfpF7j?OX}<^xm%pyTkcfck)E(1_5G)nZzh==
z|KVjy|M=^NgSO$T(&vAJwRopVS^al;=lM$F?2qW6$Oqe!t}Xmz_v6c*iPe9*PMH*Z
z$rR5$weM5A9dA+Yr+ZPyKeEWGPj&uw?drYnrSBAW94KD0%h%UPtj?}0t&mwuU4yOt
zp<R5;QoSo&hnL5`OxU>a<%MhaLmz%@V)D7Ul{@%E5A$h-MYDC>8${;y2VT}-DBT=$
z@XODDcds7Kkkd;|Tm6$gV#B@Me_}8C{|1<@l<+gXWGpQuUoMdodh~O{zx(sNi#D~)
z-t(w+pU>}GGxzXMF$i9oIp@)bzYjOnSS$_v_Wu3C%0trybF_cFnzd;nW5(5$OnbRx
zn@?Z-S{C`oO!EIfwp~IoOR<zspi&1^J{cNVSis6BBLmFKtc(l{6$}&zmQQQLJ@X%%
ziLh0DSuaqO*|bu#P;fe9)rT#50ta3`l5pkUc|uHf^#oP-Nt0*R+xH8tR1H#dTmDh;
zz~jfCbl*>``oz?-_rRYw|L+!lGpYVmAY1&u%>Di4v}fx#wr~VB9=exipRJbQFW}F@
z$hC93<+*j@=CkY5nF{$b4fb@VUtd1?+@mL(B@;IAFTBHdWoLwvr^vR2_rp%t|1(LH
zQj%#ole+Hp6@fsl&fZ)f4@JQh2XrIcjt8%LTOzjU!m-J3O4j+z;9v>d{)&I4p6``-
z;cM<@$Azwmo|!G&x+KT1;q^}*!8>yw1iWt*edM#_f#xc{$da6}G_F9lEn9!jd=L}p
z!ZgD`T}JTcVkYH7(ONm%_Ag6u*zGXI|NS>9c6E-^W#1p~T%*%w@Z^fyYug(R>(6^m
z=Gaj%eMZW+4x=2-6*`PEo$ovfgI>f=6_0;4mGjXO+e4=v#d~cSxhhsWt6MoPtkJcS
z;oC1}J7w+*&tBPt&+igaMMbCf1@2wp&?1!Ro~J!qmS@xIHpj>Ow{9IfG`sovgbAl+
zOEZ7^9#XfXZ(HiTdD^yW3i>*oi#``Fyu8Be)!oLJqcZE#g}Hi_qf);d?w#x3T4Hzd
z`(sn<!_JbWZT*{WOp|%dGkd=FY@StLF3f)QBO_N-z+dU8<<!zz0i}gjjRL{^YtDV+
z{~7o@@a6R+y=$`#K70<I`Xut@?pv&{!Y2Hjv)p>}&eNM$b(Gz*f40$&J9ggXRbReW
zeiRbjSpRvkcdh599cOEm_xz|X+#OXDrMvs1&-4VwdJ%~w|7vc^FA@5{6S_`n)(XS+
z?(>a%k4djqS-rIV)wDw^TkLOn9n|8fK5FgtCab04+ohk|+-5Dm7Sv@}KB+co_YH&p
zucq6-dndO4e^u!24yUVHmL-fkdO2Uk6l{%KH?8~k(^_LjulZc%=T=w>_;7?;D^~SQ
zGP!kYnwzGp&!xIfpGyvE83v^$UR%~Z(-6pgv|uxj;ogH$=Wj3j{Q1M}CB96xS7z!h
za6Hm`XO7eF8gcc%emnbjU9x;J*IsS+im=$Gy-X*g8LWD}xqFK3rmb53)?t-mKL7RO
zGPhz3zg<n9c*J)%W1*_h!YXl-*$jK_m%r4wc;S6Wy3j23%C%Mbt*f^stbdl4RLjh;
zui>GlfJojnO#uhJ1KF=cs^&}Xwa@qdTXHSZ^ji%V!|ZS7<;-mR-j-dych1ga6aUgb
zc{f>q)~ASXQLnztvs_You353$gaYS@+^cMUA5fdI;|O<8|DFr48Kze}+^=ZNFJ1BK
z>m9?+oYj~Ar1t3azPY_>{_A@j$|-NXb9NLxHaqjMEPc)Sk4vYAylwcNui1TmUtIe<
zLls|>W9EJ~de>HHEP8YC(*5;sKJ6(EU2sc1FQiX(9pA-@)vpXL&M2=8nNk(!wDihi
z8M)Upww-F?J>_=0L3vrk{<`v?N2YGR`r+G!$B$Mm>$ufyy=!gz-o^K%dc}7&v->64
z2e7qeod5Oe+pHB0o@!pNjT*S-3sfY?Z7!Q++xJ@W>Upcb*JN+xt7_i3w{JQ7rh940
z{61Pcy1o8huGsFG_gN`#)=vX-&E<c#`95HcsB!$Z)auWKV5W#;AN+Wy{Jykk;mMf1
zJ^Rz1eHTq!w>BK3ID`~(;NsBG65d=hGJq{oM4XajWB_Wy5iAb3MnwDH_7Is?ac2FA
zWbKKG@8(tdD6W{ubyxT1+Ayam$>R;-eZI1n-~Ib-D|h~Er{{`WhnQdVJg<5FPxkj|
z5oM#Jch~=&ovRkF7QgJsi97RijBB^gnp3+-M#Ur9ciHOSp7o7B!dAWpZccvTvro>p
ztlj-9-N|y1OQ1#kTJ?OrZln8BhR(CN^NzY+J;~wN^3(mg>*Vy@yMM0B7Iqn|*yw)0
zE30<W^z6l%ZU&A#JhK8jR~YfHkt=3y3Ur!0T_j6X#O_(|&VvR?H)db`mgUjp5wQ8>
z?LB#~Hq~it+VbYyQm3e2pBGhC<?-%vQF#%yJU43zOQzDysmpqu4_Fi)(v_IG-oMwD
zr|`@Y+k&v5t{LB~4s;pCmw(#q-*c>Tp_Jw!SCOs154Gl+w;QwVQ*ZK1cTsS7lXqvI
z<mFQn0zT}&TJ>$K-sa7I<zeBumt!w*sk&Glzr3bAQ2FHE?(}4}440M1vbL*D`C$4`
zNXa_ZZ^pf=ZW;po4Dr?z9YWZ=&xWSDc<MazaP$8=J8#~pnk)GX0(P_fGk-@con2!x
zW0I24s@F@-<lmonYgPD_=`P|Mwyfx3V|$o*<>uE5BITRc#7SGH`4k*cR1Hk?i;;Fb
z?K1U(w$3W{$J3iGRPJ|rQL$pn(VthJdtc`}9Ode^w_)4oN0pILqF%Cj>|(bLe%IX6
z91wT?S>^3p9|bHwWJI|rpLO~YcPizQ>+Nvwg8o$(JSND$cDtf~dt2qXThG<(w_ap@
zS`zS`_0+_*H($ifU@KhD#v!Yo#O$n)+r4X(VdG;LLGk-llfOMZdm!#@w$|EfVrHiT
zKlt=ki5)cixlM1rbx88Q1s4SM%BOC&<$2tEmH(<<b870w+}y~6GXhTaFZp%v#nKNO
z%GcNG{5p9?<ek^S7BQ(OCqmxqe?3|LO1^7f=E;doFZL#Lv_}?BpZ+(dp@`@5i|BYO
zm01ZV$_$oW&YR%9?2L_yghrR(0?~J`lKwrf`I-3d-QhzLs*2NYNp9V7tR-R9hArtW
zs!7j#I_9kxn!%^k$$jqrvAANTa?{t$vqG0d_GG2$XRCclJv*gm66-{kKsFD9SzCH6
z#k<UB@u@%cIR9hgO+!Bk&V5rh$VvVPjOJga{GQ7~ZmV+f#jjJHf{xaPnoRR8-Eb&O
z{Nb&s#Zh9}mrt?vDabr<$or`9!11_6T;g6izC+ROB?eiC57)0bmw$g&d#Fv*ohx%T
zwkWHX&Uv}}&Nl}kHs9;p{$@ESGB@tA+3x17*<v+u_s`o)olc~iJYvt?7_G&WrtyvO
z^>ZOFiw(V^wRJjP+p7~L!wzkm&&H(lC2jVP#v;jEe^z>Kz81*O9`o+tt*ZN{-zQ46
z9%)F_+0!QXS(1}gj+NzE!NqX(oP<BthxS?DQ#`+>_}Vkc$rmNPoE?|l4*wRgeM96w
zU#D8hO?F$`jGys--{<VA{x5SrpVWa>x55^7rBqJK-|qVQP3XkE$#WkC@!JV(7fj7e
zmG9Z5qPu<T-OsKChs>Eer52tGy3NTmZRLUZ%AKVb1rv46-!uPZ@_WqE*SbAJ_NHU3
z@UG2E->zRhb#Y$jj2oR#C;U<RuJPIbAA{<zUyG}?zs9v6P7=IV$)~@Y<yoXnW4uzx
zQUP__g|~7aB<+j35jvG~`s%BnPI0KZ9Ol-aE-!ZdbHRbRndbX-&rP3x`t#4MpC5lM
zTkgoPXv0sJnLoJe)~(ailbNyq-@m_CKP}sz_VnV~{cq3TTdOclhEwmT!@F~BJytfe
z1$kNh*u8C!+CG1GF!A$d{_We%TngmZ=e~UCVsZ26r)PH>f*D%7*E6TPAGpciaNDXv
zGDeP3K5~2Ayyw3-ew=XocKHCOEsx!{Eq`qa3Rz<Qcomeg#Qb$C@ZxL!{`<r0gWt{4
zyB_w6FMHo(>~ePT^_|g|cCEKP{NA)|`;i=vi_`2E<#S&AZIb>w<iz3V`2VFRi}s}b
zKHbT4{#s~Wq`6Y_u8k@u4jtd+dw0k8K*<N!kM6xXGr<4WcZap1+2zracfLlSjhy)1
zy5o(VD%+;=JJPj&ckG@<7GA18yqiD!AGg<g-U&rbR=?(z>YZqAVSo8}y_${QcaHuN
z`2`K@7o6H+nUH3t8+Q4=`rY^cRRlh7!&3QxsuXbLV`^rKXp6&^4IouMhM@L2!OCZ8
zlz0A}6M}AYX4f6Pqr^O~Z2yV0=K>C|r|xCjlI=c=!ICE-z*weJn$J?ra?{-S`B~pq
zTP$%ur&luJg39hyuRmT5zxr#>f)?EsKMVJp|L#67K3_a1;`4s9-$(sdcVFKgbBOC=
z$mXM2<%#wQ+(*T`f+j8LzWVRcC$Bv*f9npaKGb>qp=Rse9W~KmuI4)2i&B;D7DdiB
zJ;ovY@M`W&vDy1F_s?{nB+PYthx^%u`m?KUq@UDKX1Wqt<hv=SVo#M0o8XisA)MdO
za_i3!JR4*vc4lLr^1*_TQ{s{rGqsG0!!Ed_7tfj_<=PZC^GnmGvJ0J>PK*7Hue)KD
ztYY=zih1zdUCtXd%bVSl6z6nZ+5g94^ZR`_#jbu>7pNYw)Am}5*1J{Tq+JRR&zrPF
zQ|6d%?b+|`s|vVMeAM#xYVF>)Mt;r~9qw7CyCZ+=y0R^**cM^5`PUjz&51S<8)fcY
zbm{J?wB%nJdD`a%%XXWYsvCqa?cZ=*q($xFjPI_gxpM^%2IVi)PxBO<cC`QGpFoMH
zE*y*-mv?M%-&s}u_t~>o@8117=Vqcl^IO#3`tO(BH=X_ckTX=}Y1~Bq|51B)*Z%*!
z{QkQ4Vc&N56ukAXt*$MuWwoBP?S^P>U_P6<PV0#Sf(mn0<9^NN-~X@b>+SP#TbBLv
zk*~Ws)pe_^XS(N&|7X7*zuJD=TK^XJzTXvppY65noV+Z3$;3Ucy0@MC{b?mfdsvpv
z&&$byb~fLXS^fINms}S3dc2HX{>c)4EsfOB291MSJvzo36XxD9lZu@;t8|gQM7(N5
z`=bjHvVMn)H4l7^JSFBmIqRCv{sy)6Z8qMXlUm<6ADhCt&`70=H|vIoYg%5i!Nggs
z7M%FYF;j>maB*wxuFO|<`q|Svg?Ln*zMRVmlmGtR_4TI6?g?kjG8sEIujqC>_g;m;
zpYh3q{3#6YX4K1n+gP`YbM<_URQ>;D6KC=G`7Pp^=lS{KcR4NY?@S4ChB9p*MeE-E
zesbsVo1bTo?tFi_nEz|e6P857qIE2Z&HfBwlNc^6OXItCMMX4Gbm=dn##zgD&RXAS
z6nt;;?`5xJeZw{~O!@76`CH}P-4|S*zIA=Nn){aO5p9Lp@x`exzOH?soHU`yF3asH
z=b7w|DH8+(b+jJD%bh;ESld`<+0_8a_#3zQRHtjbORlLsc}>5)Ht5h|v3*H>A+JyU
z-FV7ZRO;JBl|aSXoNGJXy%{UjO^!d!u8o|sVYRP%fvXhXrtDk#=Xg&ntlZrj_O;vh
z^{To>M)R+H|M|@RTeU{Mk>{iDucxn{qdZab+Vnqv8bhV#-1u6Voy?e|n>X=#w0M@z
zzTNvo>~l^e<u&iSBknh?ukiVXw30{ZbBtxI7<(6Ied@_NU~0jz@W{DaTaP|h4(U1=
z$<SqWr2BF8Neu(jMu!D<@?q~pw+6UqpK1#aQWBnQ<n0zTyJq%If%6=qQLkMqPS34B
z;-NG*S!U_l<;7=O8o!4Yzu`Y#XV5u8rTgXPeLhWrlXm#tneA<=Wpe2X+xsTVcUPYA
z&wIR7rFYVv<oNr`MCOZ1sPzYYonCo(({tX{3oe{^&U-p&g|_hFB4^?M`qEl*eqzFk
zQ#AyGvLiTj5>Kh|t%+2NyXK%fFJ@I*RNLFtdFS#T7)TxcTew^Gz|+eI^SrXNr$m<Z
zCK>H{!6Bt{w2mQpeFrb=gg)QE@40d>s#p2ko1a^?YvIHjd}iinr?@q&b-Lqab#UfI
zJ;tB~DaXqAL|)aXHh=2+cF(d#HsO%`YX*skJgs(7%`L7aEN|{E)T+LJcg`=a6B^x9
zKe5+bJ^#~7Xjay-z@GEl9oaq|(q5m`<#s#uT-h?)IXC#C%$_vne|@$w_thqDQGdgj
z1^eW;uKToHa3fRll!?51_U`=m-Q7J!fO+38*|@0|o5H?nNIFSNOS(Az7ZvpV|KTND
zEz87=<98-Jvt&Q`vB2WIB?pVz%z$H#*M8KR&i7ooMIq(>uK&*t#GXqLG;b6<ax958
z|Fq$<BZpQls@}EF;zlIf7eSjho9)@krXQL9o_jgRr^xN+S8H9UKX}nZas6ByvF#nM
zl8Fy}|6O?Y)j8ANgXacYwenWM<hN#(Po<O(%(Zar2=F$%Vw4qoPI1eT%Gg_vTw~vG
zA5TzxpL*i71h3CLx5GginOP4z<XGl7oH}E);{ESqhIX>y7Z<QEjhxcDBj|dF|GsN#
z0{oLb&wF%A7c^dFk`U(S`MC0nv#j8K)_cN|>jL!~k~L-&opNz|l(v)6A>-Y0U(cSU
zzRb0*Z|5+{a+RFC`T3JhYV(Z)kp(&LZMD0SXC*)V_H0=yXXJ;aYqlQ|{bizdyqZ5a
z<B&vPYRQSOPh~<J3LTgiMy{CP?7n1vGna;=@`?>sJ->^uCmS-`#jW2}@S^+2Bj$=L
zjtlyh%`CpGy?x=lNpA%eYs?mXF<F%Jd1}M`rtajI?$xtzl&zl0aqHHVhD{2Kvf>vk
zoTbL2_x?hM<D&Fm)&-hhcw%NP5{jOCc3I~3x&))F>bopuA(xZvPCVCI`ER0^*RrQ?
z_R6~j>s<S2m@y&L#O0poK1QF*m%WVMwZ<51IPu~0s|bsfRO7c2lkA)lzvM|Ue)y4h
z@7{E8_SGjdyLn_T`mN<z*ca)U^Thcn$5J~!y#V$v>Thg(e_K9H-@98s`-RPSJv)`T
zTWkf=Ie$A_wKN&L>X6NxP$6Q!UQ+6VGSg#jFD4hmNgq}f9pG|2aCV0TSMD?Ih3@<&
z|Le4VU%ESWNrl;teQ)~u_AmMIN$q{igN}-Qf$0fy%VpGsMS6O(Us`*oHTo=mqn~re
z`Nt6n1Lqs-cvy2x9?rSVzwpU}na;xOHXkGw%<5H==P^-`<BK+~nJ2mBP4_y<8)p`9
zIw<j8NIcd5n<3Wt@7EnK1w)Q~+dOyHxou0<H7U*#`6L`4+E}M&ue$GL<{t~LEM>3l
z4)5K{6ATYs*pOf(uz2G%7T*ci9!tqq^sm3je05ROyacDaGcP_?U_2+v>9nMU<HR;T
z#{*k4KALEi$lO`0?`@ytczKC^;626AR4d*0kLRA5ZzJ-({zkapts29UT0e=o%A6A>
zdd&aoE#&)de|2@v;VTzYY8saFt$O~fFi&Ndu7V)LwVDT)GKw0i#1_Q8tdRZ|!J;WS
zjY;#}!??M-#C%zEthg>etUUVtY54g9)xHl8xqmZ0km_G_YmxT$e`W5o=IKt$YDnr2
zm9(E7(f%qU@%D!+9PtZYyg$6Qi`jO;Dx+7s_VLW<+Q6~nZEfV@jqIEIxH+$iojupz
z^<d!{7PEeJ_r+>z6Z&}K19tuJJ;GvrmqT@-%DH+;`}@X<)3V>k$e!77lJ`Q#?8la!
zJN1(k7ZiMQtnd(Ye!F9PZ$Ml0Ned10*MV6QRv&lru|%$%kuCPTgio;HTEK~Alhqcl
z=|8)1^_%_DGx`jV-1v6mSA{7T+tS5NJL;_^!<>y2&7QKoeEe?1%J|#D5_XNNehNe`
z{#h)sO+oCw?0flJMXzfnA34qL@zqR!Z?|hr0MG88{4?bfn9glD5&PgrO}@e6KlwJ3
zjE)L#WKyeLqFpR*mGtC!|FNHEE?y|eh~AM_b!3v6*&PMtmn~2GqUIH39$whzGUMmH
zg(`>Jy_%L^`0w@SN1=dnVdN=wb=MY+dI#~`g}W^d2u683u&_int>1RZ@~<1?ytL&X
zWnWv)s9YxNe&+v@fBmmst;_w^SA5~dWSLtGVK%##w#+H|ux8OgKL%A#w+#=q8D8Z)
zIH2VqEmU<+QL^ZSj`_XkbKmm>x8ArFo*w0ORVG!|=ZwPE#P3TV{5u!Q6Mp6T>ZA7h
zXU_j;=z8}Da~ZA?xa|yTWgA%-8NplGhM*<4AW`I2wh1vK-ghIS^KYLLWc&0Ye&Kej
z)-5-sci!2jxowiNOtfF>GFx_of&(5tXTqk41ZDaCt4)7@x_d6m-US+e6B5dHT7RxJ
zzR&ZuvPp1e!q@cw`L95YY;~90clP_*R?dyz6BW!Srm|6G@}I}8m5n|ub2)kfC;5H)
z^=Q+L{P<_}yA>oSiG+PnxgQrJcW(LPpC+N)J&F@IUD30Nne^u2(oMll5}q@w6aT;Z
z5I9@YtKiVu$k{B1RvtMtldpH5zN4hryRVm%SN3XpH3{E#jt%*Jv-|G4TlGPwGn;0d
z=-B<KVijNYTP4RCACBDoy0k^<m{Iwa*|U%8zyA_ep#S;Z+3Qu>?wTK?i&L4NA4tvg
z4Ngv)c|?$}h^O7j+C}2g!y{Sy*P0zYdE_kT2S+3M^1`5NlEOlq9Er;+JbZsVU77PL
zD}LLrs-}!bw!c0_Fs1x*n8rAH-uzt|U(04GXfav$wyJP`aJBY)RDSL1d$F8jj5+*S
z!3;O5tXrm4F`WPXD#eeHr+H_F%v`0fCG)=gW_iT#SEHdDqjck3?#`{|8z0O#$a$~N
zNFl|y#JAeQe0EWm^NETnyF{u_O<Ll9vnQ2PC_q?{x%Sbe5(k-y9iH_e{YE^AwvLkL
z+NKn$JegpmQ>)bbzDFZjW3uv;K$Xpbr##G@B+oiUTAivWI27#Gd^VWP{N$8!&BG6_
zaHL)|^|jnAVxS_)&ZWYzWV+eYi;w(+j|jhW*sQ9#<A~>j=@E5~pC`Saq;_HUiWO^%
z1XP-eL~iFUEm?NsrHY4RsLj&Z&b2ybR$gj>QbD=Z>-vAW398?^@sW}LOf8o@|Jr@Q
zmyc*F-FbfZhUD+!zYBACm`^!Q2q+J@IA_(_bvetwsfc|Ne6Wa3Pe8s=Wntl~dixB=
z^N|zYUEHAHy(LgVs>g1D4kzQ(w<lW;FYw*C;LR>=-naUv?rw9n5@B-TIQ1yNjpc85
zrneHe+T53tivpMbYOkE=ra#U1bw%J&v922}AG6M8EPq^f>iesA-^%vwGLzoDc4m6v
zuPaBxwSxn@YgWBm7IwsOwXAo%-0HK7%}(#QU28E%PIqZw{*4>cSU2{^xHa7}OWn9N
z&-GRCTX&U5uLG{uZ(&~Ek<b}?>;K7si9t7og)Z=PT`3fNs6VUBWwv?yU(REl*SI!J
zFq!4?>QRbuU-P!KeRo#v^|cW2mOS;~;U*{5Sy2X_CypFa5$ld&zxZ$WQVq`HrqHmp
zy|$^X6-;6Ve<CtN>sqb8xVpDHhoo=X<mt1+eO<<?!#lUWY;@jVp%iAEwsqV5PZK`v
zV@;czSCV(vW%0zG&W(&kGg91`d>$WMbjyCvoG78iACI)&m^fh@OWyWtj<bF=BptKt
zD=iE+G0W!s>QSpz9<RGNQltO#zR7Z(yDAwZI`UT7nFpM%&{`Q)ohVYpTz9>6=lxlW
z6L*Q$2KqXR{rdB2%6ng}uLrlhe`m1VH_L#V>D%v(Ijf5HZ@ic=Blz#F{%IO_<i0Xq
zSaht2IeB)q<jkmLCSP9ODOzE*?D+G?iQBDj-1Bw%RJ(C<uay4L&4r?03&U^82rN|4
zeJAm-p;|*u&RU?`p~>KF7sIAazLPjjyc;{Oy_Gah{*=OYS&L=uw*Md5<rXi$z`o?O
za#TXr6+i2;z4BGAvudw@JK?vlvhU<tkyVnfQkF^eMqW%m(4ru;|E53hsb$+XRp{SQ
zzjJNrdchrMx${z2Fr6{Fn9lkt_EX-m)rA2Tw|zgZ)ciJI>+&`skI?OpmdTz~Xzush
zzG3aH#V_yt4S#ib+nvboF3b6zWzT)g6mn9$ro;Maro0kUq4#{__hqSx$7Ff;8*hKQ
zZVPjA&OfgEI?N7A4^=y*9$r@bQ<d@h;D6p#Fa8Hk3i?{z7^ifiOQfV`_wViZw|E@n
zcoi-7JJssMa#ho2Wj5U<hO1p}JEmD_))nuK(O*|oZc^(0`mRBqr(*1^{X3)i^O$eP
zKYyKV-4eim^zWx{f6v;)-&?zE+gXEW>B}W0S<K76z5aRi{JRf+|Jo1p)=1nENDw;c
ze*A%Pza8(T{?F%{_N!F$-9GcZApUYnPJEWdgIAO77d0fEDfGJB$RA<frjX39|Cj6h
z+qYl8K3F=xZddHR`}{KXdn<Owtev)cdlf5J>u!_%^PY1@PgDH<{@xBnH=dKmi78$t
z89n;H;}1`FWk^rqFj)BCu0ectc6Xlp7p0Qs7nLQ<0ktKqzZA|TmHZTb@#|MT-ys#P
z{~8{Su|I4XcZB=@f3o}g&)wgDDjYc)FZMeA_ucdI7Yy~*y$iek{h0X5SDS?sKgD-`
zn91<@>DviwEL+U$cT05K^ysu<ym0twk?DyC&lxuDk2oO0JAauhr}zKTjwQbi_3WG`
zrr7zzTyWR?`}=kmY6-1=|LdmB|MQMhoHAdXyyC1fFHDhNc<K3vD!Ez*YjhsROnPTH
zdBU;x$9AoZ{p<Yw!^IM&_wPUd)RI@Qxc25s!?r!UB6()ZZkX^qxyY_Bg(vENx@1QP
z?`E%4s;AEAPtpmt7XSI=y!fm4^F>M?_hF8Q8G`CxP@QaOVFtf(!N?HvYzQMm&=?uP
z@vyDozM!=;dw++&xW>}E<ByOk+l$7DD`%|LsZ`bK>}IIGv8bKN^2z^rudXF_K9w6?
zg?}d`c=SHoJJZ~_&R@ZSb4&dH-+yzz@2mE|kil(#|NbQQy}vIdPEoadVCkZ9vHtxX
zVU3f8hq`1EX1&;c*OxKxtG%@g<HIvDulJXk-+yyFiknU0quZw<^SCDr&#v4KN%Pe_
z&v4kYi{rrJna(fXG>9#pX;GbTKfUgEaj@L3ZGn3)tjc{;c#gqUpmn-QRGI&xZR%4P
zP8_;@TdQl&s;8$tORDyCGcJGlZgt_~!|pZ`)sfrI?yKJ`yZGpxJ=111Z2VbjaiGOw
zkAiRTgk{QXEFF!{&y+OJIkjWv3rB6GOFR~B8X97IrtadKxA|nZM(OR|d!CF2+>JJK
zY%6Szeya(1dN8VxG2&fsl<d<C<%VLJhV05u$CUVwJ-+bz#194KzTb;iWZ(SRA;4Q!
zE8zP@tzAQP26Nwy6S>b0C~+vAx-|1vXM=8*XyFm3fCs4$EB7%*Pg<*W^~A}w-#1K8
zRd>~2FMjpR>!w39XRx*!-&*x{QN;X|<)J$R_Z>I8Vy)P)=}}cuEU$~XdcsOgmjm3p
z7K!Ixu-^D#@vhK}FP#c3BAZ!vE5Dp~{nnjq_S)awpT#*O<ew@$w&Z8cPzgKbRz7)`
zBs1$G$Ghvz=f1fbH_Q8*!QqC#6Ta(q$-DeKzWK#B!J~ICRFvwgCO)#`wVEa}ubDr!
zC`5l%<(!%Pf&CeE*YpePGUt8PJh|5H&P9#I%d0+2n9lX?$ooxK5=wlE0}Nyiov3r(
zziU>y+Wk2?RpN)_XVkA(dBc6+`Ts2%4Ga!9lGZ0jzHNW}@}H1oPiN*WfeUw*1=jdV
zh0fi(d(QeF-<O=*Yk8)hwZ8Dsav8I)ma8lmDtn$vdq3qkS96i7jgavFxBof$*S3a#
zKYTcO`L}t$Gmo);PW>zSV{XCY{Hq&MLuc;l>JBJ*q;b~y)%n29-|Lc;&s_N0GbgoP
z{OjSfEY|lp*j4nyj$Ayi_->h*?u(NOTmK#pbW>A2@2-4CCtfbEWHalTopuQ|=MNvb
z(5JEMO6s>pjlFsgy{2!inDX~z!z&k->oTr&fA9YG*euU@Kd<fe&Lei5`(L`R+BwHv
zZEuvR^PT>xQkhqoDl=Cazm-1kC9l-6t@h;KX(8*jSTA(F^6sDV{ODC1@2W+wR@;9_
zokbw+j?b+eMUEXux2Rv6J$-g?bm?VgMXRT`*33K{G~;OOwSBe@7F*eOM`cQGe0uHh
zRlS>h`;zr5SB3m7F22tu@Kr`QFyc+v-F11Vcg|gV{Kb?Ry=mJbpWU?5HQD@HJbKlh
zA6vB6zk2vI>D8>ao3>olvE4GqZ_UipoA&p+9b)&mo%7}9(I=1Rv)uYKdFiwLx(_Do
zw%@d~^J0jWV&48o-zHr-d42BRf7}v$Uca%FKb8sx3gGg`z!Xvb7#TrDk$MV7pxy()
z^5<-1ZvQPefq&=LKZt&>a^pt!<LN6hT@P^P8OCf_S#-&BB6D@S^oGuOr_1s8x9&Z?
z>C7bMP%TkEtGgBDar0)TmtFh5bG72$)mP)cRd0P=^RDLItKOdfQEzvxUwp2c^%{Gu
z^v-R|Uf+GO@$$P1yVv!ZEYHrCl8U&SaeXJ}vCj!F&foiS`DN~x^y3#NCR%)bm2r1x
z=KQa(+yA}E{d?!y#N32`Hc>qFpWQCj6vo?2Czu%AocuHP$@z5s?2Qi<aw2`!T^ACc
zx$Ui$Ps#h%y-{7fPj=1VG~JPBmOt&K-lf<)w(Y0c*1f&uBNDV+>57Eegv3vGix=O_
zQ93NU<IvxU+gCiTJ$&$l$?n>mg^YQj*&Q=4=j6R(ZqGPyb=LdpgsJygZeG_sp|)*T
z?c86Du3x_R|GGY9-Rxfbmd{U<p4|O+CF3dAm+*rIJdqsBj^^s7*Bxmn%Ha#)S8BL=
zoB6-3_ac>L89zU}t!>u%eMaOcv-0&xjTh?`42<;J7}6g0?y-)F<dHgj>Hqo%CO2lR
zE&B5~+ih}|TE%vmwtpo*rcLMJpL$yS@XhFYi|id<cQ2XtMH|RhH>6#hvyticHBQYs
zd;XbeNB$p{*KZGY`=Y$?eOvbldEdPso>p>Su>8Tbs9Pjc$+cPeVzk#TiOe?Tsq;R{
zKdd(XeCUL9{S5uZyHk&3pL=qnb#mfuIe){<?G2L>way(~Z`<(2=*zMFMr*feFD_f?
zs8zT*_0ERi$7+Go47cUg-Km)IW>s#CT4dF{?WL0@hyGnqZn*f+v*c;aYgWDyc>X$V
zcc#MGNBqC63Y@q8Pu}w@M4RFFWRZjjHS0@mzTvl~@Ge?ub7#$_Ei1OAE^arv`lQNf
zQjJO_C*N|5*k<8pzH-awS1HVmxa>1w@_R0|^_Lz!-1fEhfx_KGK}!$!>{avkoTc_M
zc=4&cMX8eA-b`}>Sr1>FB$n2HAf!;I?^thRt(6E%XdsiSJZHeCDK&~OEi*+lm#ldE
zXp(7&bmR>i&qua@Sq@h46j{t<sk`yX>D0qS=c1y#t=E`h{J0)`+G`&3<(xS?V?_BK
ztwkKqHfJ!sUh?(N&a;mn+NS(SDXLs8;QNB%V)k#<xe*((=Y89DfPI;W7E}GU9-9Zd
zG!z2QzCHOf#$uuQtn<e>o}`65we(bczi+~xgkFzH;i;Q^|EaNh{4<hLy!d)UiJQa(
z%eY->TP8Bqw3#Wrl6RVI5T+rxRo|I^a*D!5Ew-T528jopyE6W`NG#ZO^63`Ebs0>b
zjvYVNW^?|yZt0SF8@slzw$j>UXV1s6_0!imx`}@+#l>2p;>2xQ%JjsOFEh9a<Z^g8
z>$s|(dh%<<JWoyIfQGo*GhaP>>y^(XFEi1(SQz_sk<}8ucZZXLqyi@RzIOCl<|?`T
zOM6P_=7XCiXfKmgjhpuGtk#KDMe$R&a76IEv<<S`u;z8qkNl$0BfI}@)3w)pe?PX~
z!FeX5MgP-tMNcAZ+?OiNdHf?WVe?Kd8UA%Yq_~tg9JXW@>xe#^_r!A>TW*rNUy|V^
zdH*EA;Eg9gO?qPR$9E1>w35%nzh)9wUj#B=n8vcyWIxZwNgG5}7cPpmU3T>=*R4G>
zmbYmCw$Pt^bs9sT*zeq+X;<7!?k#_JV;WP%`c+@t_+_GR1x=i2m6H1;>Tl3dOW%LW
z&A)G*deeC0WBl>2LFbn6F8?_DdXB}`1yTas9vopyYn`u8c<ObX%f0YZ&h`eC-!{<`
z7wr)Hzy4*`<aABjAJYF{$VQ8A|L+`>C!)Ig!5PnX@h1x^Renyd;66~X<L0%t*S`GQ
z*BlQ#&39}$ug$7<@2IIPF}+EycO;hztzcRjJ%>?X;oYf+&17v(rL137cy!L9Bi)OF
z1n=F|wep--wz=~1KS$<W9M7*#@AppM_2|giD|Rv60oG}rQrlJZEUxy8fA}<E%>mX&
z5i&j8H(dL)=ho{zIixYGY1WQwx8qA5tX(CoWvJ`5N#9}dPw{jI<;TmGeH7lyWv^;j
zpQsR`F?RvGrnS^oM%LF~f}S6K611l7+Jmo}>r_8Ux7SXc{5E{Uq+i?4l{wUOY@fd%
zU;KWpMxOg?oz#4Zj7z@mRu410zuf;}{Qhdwn$@D=FS1Tt?7Ms|d5_lZGoF35;bx5+
zv~E4Cc=)wB!1JZ+c{^5Teoya<;@nn?FImK#&HWd6p*$l>r}x^n%#YjB&GcvQS@C;a
zaQ%PA($i1MFsm<cr39|N%#01;16@Y2NoM5g3$zH7VD+^&3etRj9xh>-dU3|;{7CLM
zig&HnHkM3Qi(Amnz#X+HciW^DOP5q^-@k9l3jQGH-F#9{1RNHfm}#DWk4OEd+2#qh
zn`g~`S3W1UX7>-X&9~G4uD6)|chA0x|1WO*({TyRxcMz-@7@XVH#T3G**dNDPr|ly
zdh2qe*S_1o=Kk9My9&fla58O7n;R3Ox<tulv8Cqh@O{lS>#H}Xw?CUGt7!dderWY2
z+s%jmNv>YKXx**e*e9&r?+SMw&%9+*DyG4)yIuO{&h|Si%oPrE{xpac-)y5+d9=_q
z^4^{~){oA(?wD~lSA3`6?iW9`?(aQ+=k+=D+po9(`8m7d&!2Zv7PBwDH@VLkd^>rW
znoYc@>(``Pt%VPcw1xhD{gUsnmHM0OqM36izO;JyEM8@u#Q%$}30tPCF1cIw?v~vr
zu}ihjZ@gpJs^Bp3_07Al=g)E%{IuABD?atSL+3HME4Px{`8MU~%B=o#_RiG+lgr)H
z9+=E(-ZA6Hu2h?B{zBG;bN)@y{UNqrps$>zrGCTwNkL5yT^K*f<eQZrd0*E1cEMHW
z>3Q?I*DSFAQ?X0-n@hy$gN3ZmM0+n^<2&y-@p^s0hDm0PdF7v+ws2IX8`w`<D(ZRQ
z)pI$EQcFJ}t7r2*oR4J5+Mvz$Kz^g#*QDc_lTH|K<+(cJmX*LQjS|`FSyo+sb57j-
z^i$U2&<59YtMn3-)D}9_ol$$8d`>|#>dXR$8%7iN81#rOkMv?`ubXrFMNGhB*5%g~
zocMfVrY*N`*t>(tQL&P#$*4f~$hzJwtB>tm5;?a|OULd~#=Aw!nb$tDHJJJI{mru5
zKVMWi2d*&ZRXru)?ZnPk^k+f;t`GB*J>7JtD6tk?Q{nrYZjhSDEiAt6(8C$RF_X?s
zx^UTe_u~zVf0eZaRy&pdUd0loV)|seA}^2Ltvmyv*>5fMzM0JHy3hSAWLdMy=R1W*
zw{?r<#!Km(tCYR7Y>LRr?@CWrHwT6)2%jmwJ$=^VSr7NON?P=aru|ebx~n)x&Geq5
zuQvBXj^pwTr-Dv=kYBQgjWgLO$2;}TmR9rqdiHnk+SuyOPchw=lj7P{lTsSl*x#0x
zzJ+Oj!mLNVHi`F|<lUsUF*4<?Q;=HSe)W03S%@0XRL_s<T~(L$X0N&=HetP!qFywk
zm}hQuEz7n!sSmUdzhhO`pK?`|gK>RgU|@ih`Ct7hCQY7&Gj_*qj=7p2tkVA?$7yGd
z{RI<7xhp}dt&DZIF5cC%w9F>_MF7(Yhs5$0-di;y=Q{<=|0X14{=I%du-8OzXWYd-
zYMcdMC6?=)SSgbgbAR%IYt9dQgQoNJE`PQB*43Upl8%O7jY~CebKR75=iaK-+9tEB
z^<US&HxEz$`u4A|^7G5>$DiK)^epq{x=l5OKRVqut6a65>hNrNncC^|`|NWyJtt?r
z-tcyp)Yp`zr9#;gmg|I_NMb!PYr@k#aX$+gQj=yo2J<+Ws_uMsWBJCPWgn7lvYQ|8
z=bxdT@bP3&;M=D=XMKM<@2Zf^*&I#N;_DwLUfsI++-jySh72`#mkCw&TU@MOx)(RI
zOyIh!`Lb=9Q%%acPVT#h<n&6^J|1+Pcxi{=`G0vyiw|6U{r%A%sp9JIPtR*I@+uiO
zndg}|nCnSzN<30L``Z1b@li8)uHHZKaoL~p9WTVU*rtEY<Cn5Xoh<n1@!1a(qm)>V
z3prk}I?4O`k3c|YRb9;1Dy}bGYXTp1*0taD;1-lAJknDfB&OrPODt^vE9npCCD(uB
z)nC7S>jIH;z4=daw|zeUvO#<G!@X+X*%$4X<W7#|v0QNMTF7UivJ>q`!m}GY?<+S2
zo1eROY?&=PfAS^Y)ek}v-u=4#`jPgn-e)EzzKgdyX3tJK8_D$|=2}g6GE+2@@WHMS
zoz@NWHNVf?vDQ1)-dr(Nc~SadP6dZwrW=?`!VJ{!NA&1uxLL-Oy3F_4!CyRg$>h5R
zE`8D&o22Ke?%w~u=>PAtuRgzh^^VW$$m~<=e||f>TP}9)txfMAbcEHo_A@>AZ1cNb
zvHX?Qy5$qEv+4hh^F3a-{_WqZo*HcnW}KM2VU4`rii<XHIN6Q8c9!YA@w2YI`aJk}
z`V6m$(?z3q|C_xcnPb{RzbPHp1WVs~w}|~xdHgWLKF?~xvqkd{X#QP(`GP>@zXKbr
zmY;11@tbbq>You=xNGI=hsLcl&WBrwnXX*#rlpkL$7R?$H>B-!(62XDN)}lc*t1zK
z6eTPQcUb%=vBJ~-P*>uVvRT2>n-*8zvs~Nn<o8w7ON#gUu55|!jS*VSk$xg#D@<2r
zZ*%->aa}a*Ip?#I89x5MHPuXGb$2eeo%JqQz%O!rf8&B_>rX9CmVEN@vwr;icl&MX
zqWr#V-DVVN{C=EwC11-EhSrw6?MfFvbGdjK?0Yra{IILH_67C!Yw1k7w{+!%TdzfF
z)$fbfcbsZsbbY~Q_w@nE0bVn9FUxtN@^<;kU-$PZtWBQQS#&?IFL*}Btu+hg&asRt
zj(oU3@%^1`hL>kZ9J{S{S>LkLQ*q1BBCqgZyP0Jgg<)TIt)F=M0*9}=;;D=mHdZlS
zb}@a|P5tNU+>);ryyCV>E0g`oyy{!8l214rJul@8ewzH*MgDY#$opp(wkb5c&sHft
z<2Lu>^Q#B19c<jGJL6U6^}^$3-UlCly8J1z_CLq#Rch>7AJ0!^e)=fM>0ABDgPFU&
z<;d=O$!5X&`nsTl`Ks=O?x|5W_l@e_%gg4gtvfPNbnE}R2d2zPfz$Ua_<kV!f84g1
z^Z#~a)cs?%m}}pTrG)`%H-K6gMh2z^@D_$KXmJ`y6sd(_Ow{I)+9@aVZW{=+y|3bu
zd)vJHky4P2T1TMBi)n8ABsD}j`)+tG(hcPN^i6eZMR3dqhlI8{KhvJ6^J}p5IPE`X
zySmA_z+uOB-{`P~zg2#G>3+b$IYH@&gzD~u9gPzeJX#c8WK=^pD6mXBIiJCsgSGgd
z3cuKWIrDP=_<i?kzsad7JWKiV!s>ctR;YCq%WRwc)=jNhd*&W<u#kWId&@>E?S6B=
zjklC^z4KKK3k;>^hx#9G=+Jb!8+v|KV5NM6(+Tx6XRfS0Wwkm!^yj<1bDEd%^uK${
zls|p*Eua1!iv&wQ@T@gp^=jkVqFW`y734Qzo!Z?PXR}oynXA*bPCNG1ZT2p8RRzi2
z8Vl|H8$bT=kjR^E@T}+P6l2XR9lcLQ5|_`u7FRsu@07PnYqD2YW~Zm!UUD-&cK@6g
z%lu~Ey&x>sT(aqdt>W>*{jc_T|F(2x$?N;7(y~src+TWo{9d0Fzb(63CU&T#?EcM2
zMr+$=(Sq($l|hFTr2=Bv(>MRySLbz&e}8?>r1`T`^d`ilTFEQL^?aN*MSJq<nF;wD
z{>9%3kxO2-a~7w9ZnUxSJGQ5BTMWL6ar*dVW?#MaaOoP2PKBQHZIzo>uR62db9?tK
zld0MdYro~3pLddT-39%l>`eI~*{9BRmsE7V^G|v=ok{Z4KkuT;i!X(4?qXp-_1n7V
z$K=;6wrq8Ong1WL`GJ|xz{v-cq)d$vEm>pO@Gx>Z1Fh62*pj^)5ncSqOl00o_qta3
zo7?7W)tk1a-EKlc#QA`P$jz$8l?xMstXS0BeA55ds@|NWuXJ*m@9vqiBxhJYe-X3q
z^GlCs_dYXL?)x=m|Lfc5YM<Y8j!LV$w*8*#rJn}JL%bY*Fjb!17OdkScU<m!Eys-M
zcgl9vGX1Fi<ldg3z^Hsl>1N5U!*}gMgH##>wdd+hx@aS(;i~VT!164PKX^jn6sw<i
z*DW;i*!V2=;fup_9=I8;$qOmIb8c3fK*Axf!;fQk-P`Nke`=B!&xA7zF3dUgfalMt
z{BH%jsx4lAN;%lVw)BtM{oDmTZA|^m59}^Itm;ta5cpW7!Sd2Q^8be>cgv$%wTVS5
zG&vYgML4f}>zttTNA2@08Qa(H-#ZOL+usOJ>eVy3#s2&Nb9T&(X-27DueKS<nJ@de
z&?Usx_(8t+t^}rqto5^>s>)7SuvU-r!_JAl;pRVI6>N@{ouYL>K;rCOE&I3ETC=?l
zq`Pgr>8bSOc<eKsooCHn?(^yAKK!h3%bc&zJ0}&hi3BgtbBmN#YSAc2c{T6t<*SBU
zKeU%R<?YX^<hZfzb@sOj)*V+~M0{U(V+FI<N{1V7JN^IX{r)F@=BQ5}!&;|=o5_2=
ze_?**{nCl8qeYD=_MeFh$BJ+2=4R?5R~NiFSycNoBhEwDbdQAV<%@gld-Q)N`x@{q
zDYBa9=T^8$!e!Ppq2jFLHv*QsH*%!)*7rVp`_`zht<$;h^vjx{8D=L6k1d}wZL{m6
zh+7wZIvBJv=5iEu`rJMesxUKX{qEl-uXA49-_(9MZEAL0FwY^S$+>e&&b@v4R?l8)
zd6~4-Jo8g=%YW}xzOq(CfJ4v6t^Lgtmz#6@&b34?Zx5aqw_ktaf}`&yc1$@e^Iw?D
zkZqBtVw9nWrsi)owy%@B9KP;Mo89~KyQ%=I+99*XU!A_oIww8}_?AA)nlFB`>$Y!F
z-Kzq>TIsAx(G}xVNUY_X=<boSfK%(!5l6$CC%29XHrIs6xi{MGQR|M^oA)Z=DA(mx
zZhJRp+IZSopMKoQ{Oyu!n!x$Rr&Z?p%~@G?_wUU@gOdjizVQhTjqZEP_Ai2E`5f-z
zjV^4NmA8cxBbq&(Hf`Ax@=&UFf&Tkusn2W9<(xYEga1bT-S*Yym)bwX$h&Oj4e#Hs
zSdq1C8^4TgK&`@2hoeP(SGKqASvLK$Ncdap?oSH;=6q3~{!U=4MR;yi-}_J3^xMmu
z#hOzK)8?(8vG;4&{N%8`k2XD6opfxz{tWvdgOID6R>ibWcIK<P^VNlc$F#xiQ|uM}
zl7RE+GPRw@-fFWLwXfX!yRPTaMfdMI*5#9~$=vcSxEp&WE&bcCqa}utU!I3QZJUta
z`6+cXpU0114O7y)o7pRw1pcHk2>usSc%#aqc%Qxh+kP?IHRi?rx2hNU>3Hq&m;L&a
z+q~?JCzj#|RH}fAA4BAUU}G#3QO2MlV<O6**!)LsB2&Ljj6ayXZSC@T{O4~>{pG-P
zGHQ`SXQr@b&{NjQrK}c=m&*Rvu7585Mm07!EHhh9>F&>6-{%+~zh3#KjidbVujT*G
zU7vgWT(bD-89$BV%g=8<_dU32@j8c24#Rh8r~9HBcQ=)|N-XLq-(32fr~O6lw`z8E
z4H2GWn_ZvltdJME@^OapnH_zbXTO&!)@MCbYH(nK`r$Rw30)c!lLfc}HQXh;o_0t{
z@YPB3yte3^=yB#<se(|4+s3{<(o4eMZ?f{yOuEx@e7X^LTZh5SpVCDOo6FNTpG+~x
zU1KkQ-tF(bFW=s+_2Er$Y6x(!=qkDQLpx#7HZ@<57o0we>iN~4tWI>Y_g4E;s?hlQ
z$b+VZDn3tgiv$jeJ}z?HHIY3@#NF`X?2y~88>gzfX*`?gm>mCd<q_Xlk$kh(IkOzZ
z@?Nn^9$_#LPkZ-wTg-`-iVqH~?9<b(6j2e|xw2ALsN=JWiD-V;-F*{YXLdYTazf?z
zmimfY=8yBct~wccNnEM7+HAhs=^*Q-Zx5P05BW-+-?TdO*8g0S9p`Qx=w+0clwe!^
zcgti?!7icjH8yQ0clDV3(<-lC8RR5T$g!-b)FJtR=n{bkHw?Zh-apC3qI5>>`6;g0
zg6ZqIeUm+E4_x2L#G~w}n^1L|S+zz=;#^;2=HV8`Gc8i8-c}0YOf@eqREr)u!?b*d
zO;BX$8xxm1qMKHJ+m)t2vvTXr=SxLQTf0xbdAOG2@4`NHIr*by@#j8Iy;kyQQ+NP}
z$VG|c>eo&$ZD2fOe0+*DYgJ@!-30^Leb1OyO=_JjnJNGCnX%l=9Ny|Azb|Y{>_0T`
zC=||?UcS7#@Xs4NuWd4C`Z@lGE;JKl;(Xm$wXV;Sd+T#fW8=Fotlw2X*c3A5fM~bw
z;$wb7Et4NxzmNWHu>bzE*}sjZ2X%66GJmhQUUb2>G?CUjJUXZDI&Zwo*m>Oh+Eu5E
z@2dYjEhsR4>AN(Xqfa8Sca!B~-VTEq`!_JnUei?*ZjvJ>G;{jtej~Z&KRogBtC#08
z3!PW|Yuh86+@UtZ#F8_zd2+qm{r^ro<HR4%;@DihU^hpFk22%B2UeZlAM|fZu^p&!
zk^Gj)SCD(+Lq@90nJaas67jy((_gygXGpPae_LR)%WHFFy+SMJg4?OvG8c5_N*&w3
z>fM3;28R!(UJE#Ww8APYQzhyf%l!FgX6bf+tovY45zg4}$GL%NliBf8Wv9RCuTHwT
z<Kp|(%g-v^_lh-c5=vVZe%j3}cY0N1UU^z@HGl5yhvByRVXNH&ie@g*5bS(w^~L&_
z{n9({rNoT&&3@-Dl)iZD%+t4pQcCfQ6wd`FnJn2}%(RL<SGYRLVegrj$IZ8GTlP8h
z3-jE-q7Su!+$*NvOyM(R;tj1|<@Pn<@br+0Ywre6{Jd&<;KXj(l^TvF-&|en6_uEM
zpB$O&7H0WNcJbab9>;e5$oO{or{=#oYCM7LSN)E?)YzS;<L}P9B7fG7FPC3FQ1U*$
zxNYg(xqolmNC+|A|13<>;bI%iq^p&EcFlLuBK@nMWrD`Ij}E?46ogJ8w~=X372*
z)?cqo?)+oV*r0P~+lB@D&Lx)u=Pv!k?A^M|H_$1e<Hs~E`K4c#I~DK!XN`LJZu#}d
z{E~}Xg1C1)er<V|J>rU!#Rd2OZhNh6dq3BYv+6u^`-!V}y<hg)rT4WiuRq>zufDOt
zhoP&(>Gc||$@wQ7ul?N_{Qn=D(v_}kEM+XH<OG+oMiwUUzJv*u$u<+BCfnYI$L2o{
z5t#bTaQ~rx?ptSm)!pX*Eii4#Dv?=2Jt1<j$1{2Q=34Pxs6YRs?q=uiyXyoL1Wr0H
z+4*>;rSbDKrE<*z9s*_Yzh}Qy@1K0UA!GLMliv=SpM3InR?!v*nPVy*+k`(eaEkDT
zNHk4w+%$jBT*HKTReOI4Ry7sp{uJZN-5RI%Y@Q^c^7-1=Kac;Iy?kTC;<;nXx2wO}
z&;6)7`@-O%$ub3JAM>R$8>ZQ{)IZqc)M?tHvMI2?-A4P~6ZhHrVj(vtm!)@2UZB!u
zeoXEBC+BE$DIXri&+k&_F3k-LR}*UW_$3qlxPPM4JLSLIv^UM=6L!*It=D|5n0x8>
zE*&G;*^Br0|MgB6a!@_AdD)(opEem^KBw1W`u=lScz%hSj!Qwh{kuy+yZvVh9oWgW
ztcCGv`uAlLZT}`}tJ%t&QZjF}aGA4{aqHGHwF4n8YjnL&zX@5kw(l@!!7FWl?#rTl
zYusmD4V@OAn;gYCx4Fmh=sekz=K|9%%&+}bz0v+{DIe#HH(sm!e*fMhnY?cMwks=+
zmzv$;a5>+Sd{L??fUD(qpy;i(Gg2ncXKWV>xzhjZ-^nfJLJl0VTei>E?mHS%;hE#&
z^gB=SNMhskC1Em4*00|5fa7!NUPG_lXBtf=*UojFI(4~kU#RVBX~sZ*qYZj4EL=&V
zLdtGkCs?}!dR7=Qe|oL|<AqweWpeoC2MvY~g67@aTF(;Xw!TRI#>w=@GiILT5Rvsd
zbR>Xl%7=4dw#Uj|cD<bPdCxk&<=0e;zudZI>LKY;Czh9f#NpBDyA9RumbZ;+GcLVa
z=<)ReE33c1OmcLJnu$AWbzKfuOx0OI*0P@`_T9U2wsFPXCE}-l-hG?1)_l{X6$y4t
zx`m$Q8*Va~JF02;-@k3--@h~e|IKfA?IKSG+OJ#w>q<|Q(Ubp@3!Gy^)(R@$W7Ls3
z?|ST0kzN(kx#Ewf^6Hnhl#6-PXWE*4U3sggVEWJX`!3F7f4<v)`|O6KD}koDp8_Y=
z?a%vDF>mI%42$(o-q*YC6tiNq4-l`d`uI{tiL>RGbkF_0vjtZ=zhd@dlZ_I1IPZhf
zu9>yw@`dGF3(8~P1nr(K@_U~^vG{|s(%QvW%~XRPKDAh~uKI-P%(9GKrP_`X{J%6O
z7#um?_Cu^9yg-)selN#nj@-*u>C58p?Q(v1tHv}wc5Qn1>;BD4?<qxO$QSS2wR4wW
z-JfgII=miU6gYZU;I{<R?_hxstPOK{JIg=nve<mNRU>&wXQxYn+T!{1njZw${b)KL
zVcFbltjY7Iy{G=>-@_4>^ZP!3*L<EPDWos^E8MgF|Kdx63l`OHFJZYPWc_o0Nu2uJ
z)8WrF57vkLuxEX!`D)w5eTL6GKm1+t`yZnyXJrIt`2sFAz~zg95mNbrWj4eFG^#<c
z4R<y2e*SF>A+}#L_8-c>e(%^Ck3gZ)19mCjgBCb!zn;ze#*RfpBzj}%2G#H&vy=7p
z&V?r=BeSIR3;3Vgut)?x`Sa(Q^sC!SLPdf%?f>kzi>cZDW7~x0GykLI#rCh!yH^(`
zrJ~edv@_yv><;lKO2OSaT`rUK!rHs9hi|-)ANGG|$JCC=CT*gt&mMhUes$lLpqbq!
ze3#B&mtVJjUrhZ*|Ag-zx;-Z@o0ygTPE~T9w>oEI$WDW_cdZkxtOO&MsO0U{jK7*{
zuEE6RId{RH`<Avrf|&t#IByrli^X<k&DQYy=vc0E{p#w{i{ZX^Ie**uy39$t*YN%8
zhM6KOO<wI3j@ugB|4rTKM*P*|za7^I39fWmToHfu=~IQa-pdN}?(W!Ue`ng-&+bN_
z+~;sOm(|ZHo*D9B)1BRGcFvXxmRq$?-~8J_p+{<uY+`km_6q%EzdMIxZS&(*eBUP(
z-pJ-SxgnHCO~rBR?CV7lYh3)gS4*W@&8#pJ?vgR+F!{mR<8(2(&|+7Kw0ueQyV;4%
z%1JY;w%gs=Blsf6_jcUQg3QDhf0FipcZ%APZ(!Tj@iIh1Qe<Z64sE{XkfnPZj?L={
z{qW@BzR#LUnLl%1IwdK*yxh~yQe0_#W69JBQBpOTTR)p}yl-JC+QcCv%2WI1xe(VP
z$#l1W3JZI<IFDYAUb^^;98c&3f2)q|Q>RMKHgtS!zxKpFpM$bj&bp+1I<b32fzoUy
z$*ya;mrGA?+oOGZQyl;MB|Cd}l_%U!XwowJJ=J>_r;y`O!}i*rC4XQ4uH@)i8+S{-
z@Z}VLrAuED*?;jYd+u~TblZ~RzTL~$MTu97zfcjk+|kOqYlXRlZz_|*+VX&nKZIEB
zr<|&Oa>MNSrniR2OV~d0*&RI<uC(ySB)_(8-%pw@$>igd-1hwEYR97!_PbhdKJT6U
z)<Ho`jo)!sqtTnT2b#A1eQ)OMvyqu?w!?X%^#_xc#geCXuZ>aVU#++*#PXbDK%VB2
zC`XYZK}r4zvEp$}r&OC|*qq)^a;wTW;JM=ToN?B>S&WBOZ^*O0J)N{ynkRHm=7Qyd
zTepY=p3>gqc0HxC;_<qh)(?U&JYD=?V|yOkqZrMj6E@eKuWenc{jj<%ZK0;g{rttD
z@m4h~M<@L_8g|_H`Nn5oHmtrAl;IoTA9&{U;pfgumpuP1YU50OSrxwJ=q~+egKbg#
zeV(S@s~R3gsQl#Q>E~X)CUJJr=l+KRw=<p2P4wcN`tvQ%zr5AE*1gg-YrYa-n0Qv&
z!`|zYrT6Ko$K?!CQw9I8-0-_Wee=rl$C?ahEI$|tFwOQm^ZNFto7;{SJ~!k@&|ccM
zA#ax06|E|E5l<Z_@jAJtpnLhtFMNC;F=30%M6qe*wq^I{NU1MWYrggS@x`|b65?NZ
z<ZiwDb;edf#k0FIUvHYLXsf@iarwfpjyDcY=KPYMv}W4kHFZ|MK0N(oQo~RXB2!$z
z^`XD8Q#o4yrHUT&5{4ZYy&JY~=iS9~@51?<_e_f;r0;DzTl@B*o|4(F<9hS{F#P{M
zeIH{0mr`0!&sVKm1ud=j!vzEESKOG&n#L)z$|`*SZ1d?qwk^x5vU9D}+y6yk&AE<9
znF$Kvmu=#XNg7C7YMuSe*WIF&FrWGNx}Ev58=GQIaU|r;cDLWH5>mD~!D(~1t7TSO
z@o`!1*?X!}Bo0)rc&Rvbb5zSF?gMi!iG6p7(X*YpOiSH=lbXru{QF<lRUIq7x$uRR
z3#aE=Ms@YZTm{uvA2$}3K8xb~IDOIa3yk*RoA>6J{M?vq+I!_f?XBf2C$6b|x;*$u
z#fPlZ$&n9Em`iHD{o+@4CNQD9PK{yTTeBNKbXNql6uvU3d6LAo@yx*<w%fv9Ukq=D
zuq=4|@_3u(l9Sd9JO2LToO&|zkkh<*nci>ROf(YTY*@C@cj9i@<IG7JE@J(sczafE
zJMp!_N9$9xgzb%-GamkK+xlN}1^>JeQfhx=$C<>84rO~umrI`yWIEgEF6{ZCJF(=e
z?52DLwS!H&w^{la?`!ocDw5c(s^~Oh0(-bd+%Epm{l%02Nw{42UvpwN^B%_)XEQ3|
z^Arwec^_cDe?s#wL-z&VGi!EoH_N@aBxKpU@vv3D$|sHPk6XBl8IzB0c0SQ9$*tDb
z<TZ1rZ<2M<J|StTHRp5GdE(CJEa05Y&!yfKx#m{UUGcBiUM^0SC~dYg5BMFtWA4r5
z_%He2^K=bv%vkYj+gda8{5|haR+&XH9!%rS)TqonzBV|Ft#q~Ddw)O49I4KT^M(=Z
z(vtOFPbRUx-u6b`%X}ImUxw1>5^Is=%ddRM-}fxD>cyOXqjRxU8ksG;ll`o2dGMYn
zX#AntY56bD_2-LA%kKMH$6r_Yk*cILFF1F>?G4&o$?qFxYO9~~%DMWp`HiW-$5X;(
z>WqFXzejJG{mtaKL)yAC*Iax1Qoonnc%5XIzVmf#3TxD7&t3Ua?dwmOZJ!t!E^F0s
zv1U%n{kp!ZE2R7KO6vYz&)*+g`{#Mg?JFA!E=}Y~zBEI}n0<qUeYq{)x$_z`Kdd^P
zILqqe?3pwDlh3W|%WXDYDiP&im1E!;5!sZ^*Sg>N+BJ<`p&xzbS$^8br@!NO+3mx&
zzt+^;WO8k4JJtN@kLiYOcYm^9KQPZF==Y1Vdp-*J_s$e#Pdd+A*)xBxl-$a6$DLb!
zeG;CeY-(6(+Wkae*U~NJf}8<P)f26B{{NP=KOUj{+mMw%ng7l8i6*iqH*Q?Avhre)
z+VqEw+>_<<Oci_#r!232bcnHYa_il~wUcjdP1pI`eLLz5r}q8!>@0_H`F`s^39KzQ
zKTK%b?*Cr4c!5*gw}lO2LHXL@{+ud1>K|E3m>ttta(@|<fmG3hFH@a27s}o~cI5i|
z-Tc?<Yj*wG!)5E?e`Z>yRpCULefE`y?LS6y$R4`u$Q|`v_@l7UhKcU8k`u~=!h(ON
zy_4tqx@N_{eBlTGx0KXbJvP5O+g3vJ(6!>d^W*<r4#`)KKK3n1^W@Ck?fKQ-9=mPM
zyML?s`|IjK`;fjbFQbntUj93AwL$6TKk4D@HtrvvIq=`tjO=%xmXKe!XHNaikj%90
zZU3G4`LBN9tj^r|H~z}6+P#|c{#*YotkSZO+FyU`39s-48I_Ie1HGrFI$0VEEq{AH
z{m(MX!*V^78rD9y{QT$B{N<L9Qx?aRXRYS2ieGZ3VbXy|OkSr{x)z-|dhF!OrR#sp
zcF^wRHOUaQJ3qtwXGP@F$zS(RdGk-U?_|l3rr0l+IW|Z?y})ot_cw?3@{8%r|1{&H
zPo22IAJ(nf!+5GT=Th^g>#L9M*MD=rp3!c?M=VRn!EHEDYtP8U1hI6}6wAz%DN!?1
zcf);)FB=H#{T=?pjeFyT>8h`9DT<^OF&vwtak)@f)%0=yl`^iw>)od<J+jTmn^~6Y
z+d<>iQ@7;bf0bGL*twzR#=d8}&+L_cf6V<>n*HfJ_T77@%Nuaj^0BmY{QP+9b(+Hb
z<oT{L39pXtEN@yU)n;MUyT4*eb4TD)k@b6oMVve$v-x^#9as`<%QEF`I~jJ&FEMcE
zSrOW6*_-y_woYo_|2+{)k1jJ6X42UFZ}pOiYXyY`Ru)(%2d#;c7Gfx}-tSp_ePc|v
zJy%D<v5=EKYFo>A4URWVI>B$ioY?Npz_rrPalx|QiA>#`iHsrZ&dka-^?onQxb1#*
zpxEp!H`hL~n_u?i^6H;IpYQ!|5ppJXMdZ)Wu;l$d>!h25Id(tVw5IEv=>aB2w@i8A
zUIz}zD~Fj{oH{%nE4edy&thI@*V^B$eaInn;W1a<P%csVpi-SB_n&2Lzq@P3s*>Wn
zJ-y89W^_sP?{rFhQt);9ie2Jj;=&sw*qV5~1YR==G1{~hTk@)l{*KMnS+RAC<-<d6
zoAk8ZIf}09?$pYEDsgm~R{7DaWuop!kG?V6G27o#eBx$aA^y9|rgaJ@spY4d6>sU2
zna1;;VaM8(*!QdCR-RB>TfniWZhFa~vmITT3Z*_P?)K^gxISsod66`Gg((Z8By+6K
z+*j`#kG)d)dFWV`eDUlvg~pmMyMJ9dW3}7jt!C1dU_Ldc6(#@t75`h5ddy=fI>(sE
zeCetxzx9K+r;f`X+mSOVr)TGlr{S?`Y^An^-1(DNc}}0XruRWn*7q#0<3GKuQgib@
zhN^3KiS$Lvt1;=Gt7PBWydywhYuP!`Bk9U5MP9b*hR-}>t!vxPTwZ2)@xeBi3ktKY
zcW-~5|H!+=;Ha8HlG3lE?yNnD96EoVmIkSwb_+YdTPv)on`5)l2A$6_V!aoWrp6qq
zve{p8U~!|CO}q3?^97b^%)5QB&HJ_cZgtrf`4<{X1r8JxXuZ$#|Eauvd3w=gvDTLX
z?5x%P?NvJr`(6fcx-baaSRJ%K%iPpIw_W}6GGUK@hs|nNef^z&yX5(FufH8Z`=<(P
z?D`+DPC+}~X&1|jM{|$=t6pDQ&oHsG!8kP!?W#{Ba83i|Ned&yWU(ohNjy_iV)k90
zo$B3x*+8J-{ZG+-8@W?HXqVNvPGMci?(p!)A}!y$>|V3XJjFZX``;ePofXpBW&6Ox
z*VOpi8FS-#Zv@$zHq`Da4`cbA(BConXL#6x?VcZ=ajObWTA-rFqI!D4UB?MaJd$`O
zI(Q1+IeUibck%o`92}tz2Bv8zm3BmHJqYtk7P!Q{{At<NOg`>h(-<e6J<o3MK6&{2
z;#zf`>F;9rLc07)ZoDlq-Ll$jb*ZsPTI$wZU*}aU23~<4tS(nFD|sd!I<#`?&($G4
zPKSDC2H)qIW~Q#k7V+Wvvq`U*rY~5~qka15+(}lJ-Hm+(Y10eMUcI<_+-c1bHCHY9
zlbcH9I+=8AqYTZwpFf=}7qn*8rwy@twk1i=_>h;ed%kyOk$s8tm9=?UbNigme4TtQ
z`aI8$4|z9Uo_N9aVBMwC+7(r<s&<*T0~xQ+pYwYHcUn@{@4aeCk8KaFy(Mz#d(?Wf
zf}K}6*vy{HnPz`{?kDY%6^mu;e+B#x*%4}I^xEi9qh?`h`ds^a<=cB29z1`db?CtS
z?mw@WT7Qb4;LYhXXJT;9wBTEl|35TROP&18`Ni9XGq$g^c>VfujOEe2-mB9lKi&0C
zZQYZ5;lX`9&#SInn|iJ^>b0wNxKF5x=-x`_14VvOSNICE1n$0>BXLBW*{L?ODlSFm
z(k)hB$s_LGu{pDrb+_G;Q(QFv>-Wq3{PL3|6;=9nb?j>RS2VLiv+uy=^w(RwHoJxE
z-&QmGJk8+Ya)&Un)_Z1mHOzLVF1mhqeO^T0<p&y19jm#*lM2<o@3ad0x2w|Mua8UH
zcz$Kyn)o$$!tGR+xo!y3ND*XwWIy#<$)pA68*A&B|Hr?N#ge8$Nfnf)&5SJJgO;XP
zCWcHw!<#|+ZkahHsYMF<ZaIl1sV=F>`6;P(c3jXqaVzF*jquLD<Ho~Qbtit~b~RU<
zi+j@h@*avX_9*q+ewom{X?5)C3toLH)}HmXD<#i4Yg>9StJvLG;3o6w@$vo;yIgLk
z?MJ^f@BjY%?DDhAbxXH>$gaQlZ{O`bHOE;ZI&^jJzU!0z&vZ9y+f`S`CAZ$4o1K1r
z&WY!{>&@l}>WQ`s?>_wO=IUK5)wH*|e9YK8&u11#nr76$JwG3R`}Ozt?C+N+Pk(Q5
zT7S<Zv2#J2_a=22JdTaoW5^#E8Fb;$qR+qg6&rFKYT+}qxz?UF<IIC#@t_5jdp>{6
z3KIGFCSv}_HELImY(BoOJY7`qW@O2N4#SHP^Y&a6nC$m%cF~78){7@!@5}kd?`wH2
z)_d7<p+~}kE3U6CKGLzNt@ib)_+N=7=N3AJu|97v(wRF|C^y-5)~>a27RJigVv-7v
z@+wQ6s&Q3)c*-_Q{+#^kd(Qgl7m6D?xI6W3ZGClM{+<rWQui|_KFtU`blT`_(ViOF
z9SxrxH2yih&6#rO=*7bUz4}euQo_2onKuQh?Jt<A&#bOfxaAGAV20JLD~BUwCvY|$
zGkF~#n(#6;G>xw>_Hs#t*sO@}JM;Xr6O252`V?!~X9TOVyGy4rUXXZjj-7eClwkA9
zTN~Hcz6+0Ge4HEi=;6Lw*N?B~%i}xKRnUG!C9pG3R4LmdG3=Myvpv5AJ_xxiIqbak
z{jI|v9{&8|A;R+LN^w_!(zGS>T`z_QUrFwD-2CLx#jQe#r`#e}?BViE<d%JH5%yR4
z+mek+OJdBJ+13Q>y06z_$n1KRyfx>1`$DTd4kBFJ0;FbUJH3cX(C}`3e@m-TTGDRX
z-;O<vpB%S^J^8Bb&f}jg{NiK&)1?Bp;#I$Q>{;BqV2Q_yy&qRZP7au@ch`I)uVjC_
z^KlKQ(4J2h%D;c#m%5`d$W=`C_q!ekam^_zsWbZ*+AUVt#o_3Z%CkKCyQtavh+Pkt
zcyzsAk;Abkdd3{4rWHM+@!v$tb}(+!S!K%oCZ?|O!nu7+lY|b}usgOd+92RETW#as
zN*AN(+#q#5(+y=ywzm{JGiT(sXP#Ud_G-`8;<YU6bq>jOsT8N?DyBZsn6H*|?bV94
zZ5=ATcWYO$wm+QY@{IY#jf!@kaPMWSS4w?6XW_Wx%v7y!yZ&7iar`wu=i1Gl1##I4
z`&PdEyQlJ7>h3*;X60e38SfrDH#eOQmilO?_V}hV>#L%5wZ_~GRkt$tF<#8NwQ;R6
zSIxfF-^&%*1Pk}i|EiUf@N(ak)i-NvOWzf6FUV|-4nF7nV%?OOH|aA(YnIO6TpeUD
zJST(o_MtgpUDDg%7uv@r-WOh|u)p@c{rx-xq1+CIn~kbInp5Ab`{C0Nar)+y&v7cv
zE=+M1V!1zW-u`rD`rDP?S^}9~DgAV14A{1#!)HaJ-&f``!8O}`ULBZIT)twK#CpzG
zzg~TN_TK#Z`!eo$O%vS^J^Oc!Pd4m&x#GERD4(88#AOC<$>?Q`8+UH0e=ApYXJT(3
z_w4L?cP;KRwI4=8i|ZsV$Y!0h`Kw&#aYm_=*Hocrio3+b$_0BbeOj~F=;n@!h1@<@
zjc(YvUEF@rthcylo^$nUhq+Dv{>QBMzv{K_#vB1Fp7jF1R@Qw9PO1|#Um4l5xpH1`
z>h`vi8;{LRerHiP*MdK7X7|1fsqOtg%pD{`QdqgJ@q~wLt86Q@WHjyL*3Ek(9#Qh~
zvhKu(59>OQMEMFE8ubgZi2sh-)^%<ZujCWKAH6%*@ui$x7y5$nQQ^Z>(b+41Y5PQ;
zRlV)?Z0d>Z<7r-oy05ftc(|AJGJRUI=;1sA=lb|>A8H@IVpqy`<w@z?vU+8VPuI>}
zdY69+?);fq%sOSt*=QHmC>6&#UU?by{cJOt*h*SntluJcRz&jpV#$)#Jts@vb@~41
zbSRbUey~P^Y1zuX^Lw8E+H&ar3c=!g0p*%or-{Ton=YkVcWddJmEM}0Pu=fo+0QyV
zjV)(?-Uo>p3&PIKoOh6I>7Dp)|6FdJwu8r($sS*vp}yaI_uJcNzkHV0s_IO}QfGjw
z0#Kb{XkrP!2hPY0%S@LUQ8Qg@qrLlYy9x2t%-O#|{O&cjv|De)<r#}MY!<%ZAok6Q
z`HdWpj)hSA5nk6*Dx#I&uIHQn4)xt;vdNrdg5ip=&AVT%UbSBC*CsEHSk+hdpUd~|
z{#Eof)pdFLxARrotE$Vt{t_1c&?4gL7+%gF{)@Y0>c-G%DlW@b@4kEWwE3JR>)-t=
zJ}UXp=;?+>dBtBpP2aVW?dy!fAP&tlkMG;v`}gPHH}kKJ6I29kOy#G%b+cV!DaiEg
zI)A(K{|%bQC-uBCw(vU?W~q5;%JWw?=2OH}w12#66ID6?k^A4>ZEJt}6|_zfI=R&L
z$%ggUzH-<4@kOWTY(Abj>!rn<4K|xkf4{waVO+WS>)frYuRq<Qr0sF&&ew0X+t>fv
zcrE%6Z?}%-nRNbG`&`WjOz+wrZ<{6OHR;!Pn`^Hk{WQ*J=FR)NP|owvr9-(9zUE7M
zmbjk#(7US9$NW^s2lHLI$M4PQE_Mpm|0yS%Shh}jp7EsAqEhFncb4~WOZ{x1X{Oj?
zU2Fce`JS5c&iY?JpFT6NO)K#FU-4$y(kV|a&E2DKUK+mc_$@hG+v;*%#hD_Vv8hM6
zHJ;=JuhCrC_u$CJmDiqLeja}P^6iB8M@~MD@XcV(P?hVPopqo0Yef0vGp>F{@6H8n
zUvMin(|$_Rj`g*5D;+hM1&Wl4>!+F<&S}b75}lZnysy`8;nbJ6Uzqg-d_C`QIcjB0
z!qO<2Weq&#zdX;%m^|d?=6Y3?d;P;*9}o5U;<=`CCvpGz^Y7%0z-dpvNnD-YEIiG_
zz^&CliZLhf)q_nh=ksi7F`v}xHp6DI;PTk)R-rr7cfUxslt`a?D0i-D{Gz@4U#eyr
z30FTm`Y$-7lHp&;w$3wQGe1d`L<O#}tze5%$_x{^wRf-adhhU4+f#}@HEU)Vdaj6?
z`NZ?k@~Jx8mMi46ir03?>Kb!@sIKpl6RerZaX$Qb0EfUVu?MZ!H=5u7;B?@$p~2%t
zKiwAYnEJfskyvd<l+d5atmZ4&A0Juq-TYdQk<-lYvR|7cIX$+2sI}nP%9!LB+`Ys8
z)yI<$_J7#8rP^TL+7J0weh1rAIJ%xjeD!{8cy2P+d$w=4*c6NwmoA^%^CjGpG33Jz
zoBa$Nk`L8WW?Zn3Z}VF2E&1&Ho|7&YH0&z<EK2XaiWN~m&^9M_ej|rPqCow!50M%t
z{QEv8N`9Bu5*C{3sdCPAE>|aO;+gg%<)OFj|CW9_#o4GIt!|;S`1!8v_Ki8mU*2>2
zX;I#C`NWB|jY;p=FP{v(wO!4yQuN>?jtJe%L?)Kk@9N`wkFP3HRC#{T`;f2h))1MC
ziS2Pa-UaEIMeK@jdC+<&EIzW2`Pp<aKUI#cTV^aSyLHXe<?!+a1q}@|B%jPum{a9;
zIovn%9%mr?-p?xQgZg#O$VPf^d^%;Ciel9BoSvUk@7C|$rqovI^{(Tf{;#{NpW^!t
zEL^`m_O<FVjbEy3CMYjeTBx(eQsB~eCJS}VO%}-?89eLTpWNaIs8Fqv3R1X!`AYxo
zjg>}oOtj~$w(Oj>S!&C%p#Ec~7v?NG=y;I(;Lqj;?t{sdM%hx5=VJfJ3iZF&jX8KH
zp~&)+bw0yFrb_i%<_kI-JS6Wh_(<3;J|f_uu&HvJ!UWB2ZzLPfcvQ`DI5hF-n`@3z
z+w~P+M#~>KV{%1B`O@zV-W4hPrySm9EtnuM{g~t%-swA&E*r+_d(K-hdwX-Cc>;6i
z_QrFpH&vH%mPzn^*NR%RI%5V;>dv1@K1$y|*k>%;v?F>#@zuu($=m8buhWV?d?oPP
z&XuQQQ(v5ad-s)mu%q+D;Lr^_1Xbccs(6cBT6$u|D$zCN;raLD_tyRYe)Wd@s@2#3
z$6Q=}{r#2y_v-#g{@e5a_N(^Qx4);Y4qalVw0NuFJRiGcRmIk`M?(}gUNlzlosd!J
zmFh9;o8iJ0m-T0C=9zP6B?oUFLuTy?`Q+c{gNm2urTkO)@^Haq_XQ4>ECw28KP28c
zaj+DodwZXo?^H2aWbrrs!cN0Dky*cXvpkz~<j$h=>pL13JmG7aU$EEF;fk&NeO_*d
z>9e#rghfJ+6rMTa%5a3GE!lS6b}M@^uj%JDmbZOMo$+a<`^r=Q=KL?tEV0x6YGZTt
z?UK-ia~AuvZsFFwAeNhYZt9O&rx!0|HD;>)^oz5rWE;<t7eQiE8gtmr*WNsTEu<(W
zIV$DD3nmSlRFe-G#*vE@D&3}8MxO|JFz4|co&WU*&nn74(un%cIbCA%c|q;ZrW1Q&
zRW3?c9xmmVY&1|ZysukU>Gr06Uxs>|kFb=c;+fBU`$RTO+Bt{wN7A_mH48tOt*Uf<
ztaawh<?9l)GdV4Hp76ggWB!79N`HPjwY9L_6i(9nwncr0w}RBBBVT^A>rN8sXsW$d
zc3L`j)y6f_!FfJ~H|tK`-W2&T|J3ftL`Ei$PANVuwPQ;zm1KJ_Xn6TE>esFuHL;BQ
z^M8D|UhE`3^Ujt7A%>F}uKQNr&sfftqx)So=kXI`7nU5c{0DBTtIF%&^NQ~=-Ldg!
zUYAa-aCwI0rtRnTuUiY-1n?eA%QRVYPIT47&5wd@{iDC|S1H=?{%F+M6TV2j!*LPE
zMc#XFK5OT?TU?ILp2V53P>U})zbIbPzN@RSec`PMGuF&7@_!y)9-F*K;k(`M9XxBN
zs%1UUo|%65wqcpF0Z-1g`yp#MZs`}^yKXx5(B~9OCJu?>+j81dS4(j}uv>3G-D$~;
zyN|7;B?_M{th#gU^;?mtTxS&59A??MTW8zaRlOgX9ZL@`U*>UX_pjBQ9}ZY96%x9Z
zy?#wumG*I~*L;uv8N6b0yP&pfL&L_-%KQ87{NU?o@VV~ZTIRXJRLt?RhRpk2Wm_t@
zt-A0l@1Ev#A%+F|^1U~%B+k8Ix5xO0%Z<7~)5~5S!YZ!4d$)_}8<jr%=y{l5+=b^O
zx7MCi=V`Y(3uLCLghZ<cAN5);+^-%o>smT{H|wLBX%U;}FT2z{(d>xAd&j-!6xlz;
z#suGPs=4^O$8#~u$@8znx*6OL&*#mX`2X_{m%HzZ(~|bsr`9}M6te&7db4vcch7OE
z&h2Zly4ZeA<zb@u{cSzXlcVO_eLubGU*waOg%7OmecDkTHdSNKo39B$+oi(_giLho
z-%Ry7?RL9CqvOEeORDKB%Dx&@2zb2DTV$G^KJUS-01?~E5np~elqxRgm-%9TER}J^
z=Mqk<kh`5_soLh6jaD<xy%jrO^SgDS(5m&1XU@;R@AuNeLG<*lEgzdILu^ZY7yGIo
zeD{e%?wfnDW!EvgS7mFTGc>Wi*57~c-|NMxfp-5ZKA&u{f5P(Kq~qtNNC7Le)yb+c
z@wF@q;-nWYwTt96SZI~!cm90ozM1!Ly`HQ4W`ggVI>lszlr4>`mo_`qp3mQ_d;9n)
zmu)QT=Y9VW`#WPz+3$7bhxs`7%RHKN&ZxJb=g=}kH7+p`(Pgu}R3{$UBcf_i9xc1^
z@UKaW4;n4-=Wl;@i$U?M^4TgEuUBGI<ql5ambZ;v%`~xp;XU8d$i*qI&cA!B{54tR
z@#TAbJq?;mTErc{CNh`Ah}Wvj`~C5<_lpI`SN+<%G4$FM_nTY!E^0DepDd`ixaD%H
zJ?l!Q6Mwh8|8_U|>b1*m2T}sUQWe*VDur^rk1JaKel^cE`J!jy6SL0Wc4+jR-_Ne}
z^PJ`~g$-6>Q$FrA@8(^<C*#fQ$bDZrYF-L9KkP5P{{8BP_qTcz+gBcFw9imj`OWlH
zOGwqr1HaBZi9FV^A?d<}xtlVy4?W)YYV{58D|33wd)3X@?<8<{P7zxae*B5j4)5w4
zcVA~&&Dh=3`}2jx#3WOTwF~pM2cG>CbnDrhMgH6O-`n@o*Pr!VzS>MJhA5vbbK|R~
zZv%5LDtK`3QeBqjATC~g{J?!(PKLSOvhq)6?-YMka)z&mjlb%48dKP@J;Gcbs`YaF
z7C0@8F~0Utv&PVd{iQma;EQ9Q%1_(=y*;;3+3wX1macc(@)8eo2whi~P0U&FiRDL&
zNR5qK>%|#ext07+1&&wUnKfam&1IpRW$ks6ca#23cyZl)SE)eX?q3>*_P_Q?3!ck-
z(qX;cl#bL>@;4T7MO{C3SUE0y-9g_dc1;DHuFa0-yGk$5Ja8(c?$zd<RpOF@y1DmG
z%(E=$|8UUI?#k;abEAAj<$|~0*kZA6rLFjv7WqXtW!o;^ar;qx|F(uIW4+Ak20h7~
z^s~yl7pU#<cu*SXBq}nuJ}qhILZ?*=6}2ROEs$NwB&%)v{fx%5lX<FMdYhi++L&{F
zk>0rXS%OaZqjQo%8d7(<mTp=0dTn-|Q&RcI(+k;WeA&J3I!mC~DwoF=6(v19O6&Dz
z-us{v_)j6B=4*hR-M4Fuh4D!>Uksh5n%8`MDao_2qHEn8w{<;Reyq*mGUdvR;rQh6
z;o;Mu%ghO>xg3sCJe|95YV49>@N8E6x$fGb6rttY)6$a`NoM8NWD9X@3!N~hYvv@k
z0>AdE8?zXDm<~(%cCS?H@i*Ax?s%khj@KqD;qsg!&hLj4?kEQDz2#BJ#kut5v|H9$
zO{_|;@AYPHl;fA4ovCYe^ufW&Pg^2Cth=DN==8nv_<EC%LVp9885!63xilygdWoHx
z&_4HOkp!Rh<vm^=@9J+0`kr<>q1k)ey|wALSGU(uhxmCGv)&iypG;W(?9~d}?VIIv
zzwUdsFM84<Zua|051(y(&-d2t`6|hIb7ykYWJ=e*n67(6Az-4RiRmBj8Frs;b*FgG
z6{zLm@?Mx_b()8BxkE^-&g?TrbJN_{X8(E-DAF=xo3wVn_<8pvSDp!;*?Dmy8EZ9}
zQVve|e6RBIgW8QLZeOF<ojs<(y}!hZXWa&q*$26VSS=?s$ewcXyVPN`;!5t7FBjKc
z+Z(3%aZZxS=UY?bU*An!{#9k=qrZ&2$A5<VO}{JpMC7?`+LNSj6K>49AjVg<Gf6p1
zb4Hnx-0tG!++B<+9G}@9XUx`;it%XpC=<SYrIfJ1#P4tTXRSBfkl#P!`$WcLbKlx;
z<l%Sg7b|j9J$m(VkxdQ5GxHfX3{wtF<z(GlENFZE?XL2&iHXl7LX9~t@Gm?2dA)#I
zL&x62&hA4MeSe#+#k7JX?gom?+q1I0c}AgCT1wv|rid+~Dw{qp-uT&|&84pAf~?PN
z4THIUg`1PtK2;a-E%|<2HF&+!)q9s^8Rl(zsUGOzxNO1Fwh63Cs_NXAy_boezIoc?
z+^X}^Q{L>GwtMf&4zAD%QQPF2&*-r=e2_hVwcjCX^C~Y1C5BmN4=&9(z)-vSTXmLv
z)T<Dm-uYK~|M-^9jPy&saCyqoU+?QbO*!p_**gdKxk0^iV@m_X@sMU%)`^)Bw@xhL
ze*SGUfx7SU3y+t~koYIyS(yKF*22SFOHRj>957;;<8u3s&dG^W#D4OBOYawQ^)y?l
zly{;1C_kIuqw@QAYs=lAD>gB>Zure}KXPMLgssbp?K{`6>4;k&K7G5y#SZ3!icS}+
zHg8f7I8t~-k!6bO>!i|;cO~oBU#nkl(B#08GvV6Lie1$X93B$Zo4&ta-mvjY<ofe(
zGX5<vKCaTpaLJ@gkdftf``_PJEFLUo{{1fD^}V@!yPoI&i;<JNebGw7ylQ=wG^1v@
zVcx1;n-v)+c(6t94sPZxO0QPmzEx*?)U><GT?ZxZIbK_PPN$@)(c{j<7<2Ye^If0%
zL_*hnTmGf4s{HTo->Ywzrl(6R5KQNqE!A>aq>xRcv~Yi*bnL6LBG1YCtns<OEQB3e
z7EgN{ve0<v_eF*qQ=&|#Z#~2NCwbfTomp=_iac=W&3JY7#muLF{&#)*<^1Qd@Am+Q
z36mZk*)?tEDtDFVJEyqDPn3Abl3;k=L8pb`(8GlCN9NH@awnhEJlQq*cW?OZz4v%N
zxUoHou-NFhzwhCbgQ7ndXYI{9adlx<)2y!FpBuRJ=5(yDny$&jGPB25aIeIVt-Y<Y
zj~OVQ3pQ2l+HvFl760^#-Mep`ax*Pozvl>_jnKKHHxj3@zgqKoN}coc{Ln~y(|L89
zR^>z)Otnbdyrst3O8NzF@9yrXlWVTdFZrF~n3UskHt^BPJT<FtQ?C{=mp|~fR8Vm}
zeQ9O+)U%U1doE5-c^Py5=i$Y<HLriWHd)>-U%cH}^$c^#C8OZ;JC5DmzDjTD%7woU
z<|-KR?fs*(Y5tXcr+P%zR2O@k*)#hkcQxx$9*5_9SA3g4_1?Q*ih|K`=VykS=iBPu
z`{uP}NuOARZuEA><++Nt85xS%8&<Z@T>bX@y@tQa+W%CipPfJXPJfY&+Kt93{YT>)
zO$BZo+?46_kLT_mlg)pHru}2vv0LM+*qnPBr&fi8=@w@@Xs141_PONY#iNPqxk9bP
z+^ecLJ+@IxlUx2JW&4?@rtj9p=dH70Wo`2g%}-rvtbf31TdqQ7&~>?w`vR?4Ule69
z6x%Bl?29k|T6=lc^{QS0hMCs0L%(0@*%WA<vq@enc3a+V$rF|Cj>pUQ+@2wAu~09+
z#DuFU*3&(?XU~xt-zMJsyW#4)eF{F$RVwC{h$u`rpukw-#c=coD@)rlz8~rx?0=H;
zqUSKR^{?|&VQ7rhU^(NbsN*E$v_Pq4g5HD$3oRlv_%=B-u?n2YHEwVylxVExIKgu&
zKw^$w%fvQ?3DdokeZ&q4G#a$T^ENx^a;DUks2$f4DEVu8?phxkcY}cm^UVB=7AA>~
z2?B195-pT07@B5Izr@#~FQ~}K^GJN#VUOtslNi`|)m?PhoS7ALT+;;;8F|jx&Xwlb
zGbdDz!LyKqMK{fqH?^f@6PI|i;KEnSELt9ZmS{StxK>F>i}#DMQ9{cWF5OR_&$+gF
z9J#(Ka<R>oe=mbBC&aH7D0pM)Yu<9{a%qESPPU!=-}rm%f16z06Kld=&Ho)^S9`T>
z?;ca}J@4FYMZVQXPmo*|=+hy4srJtG*DtPze*ekeRTwfKOR)zk%s|DSp`p1cd?w2r
z%Yq4Wq83aX4LjNQ*i2yWZ|#yZ49ac4Cq-LH7tK(3S!j^H)#tWXiso8Xzvr)mm0We5
zw<a&(ziej`pmKlp)6l8&gnK-i+VB6c-~VP_`FYO5Z6EaatMLE6d%b^3hl}E31I3g7
zc6`?NSd_8Iz|BeR_vv@qpYr}6?=x<h+IIObqYj6+O+>4c&l$Hjy&|0ne*(hW-=uC>
z#`1<uA?T36;&)T_F;?EcUB-P&d9%4f{igOT>FSc%`;WdYzJKRK^d81v$Cp*eMz|f2
zkgSpaaD2_{+0s7)q;LF+dt=AJa-}14(Zq?9UOM(_J`_o04B`2(WB0$${`~tFIbZAL
zx8RUEWZ<_qMxjYlvhnk-SDO}Pwa@lZc3UCkziYE>k4wY<1ts}9n_pen{;q+S-KUS;
z)%1qQB{yN?TmQ-e6|@?wOm41PEiKMI)k9cr-v005GtDe!G-MjbF{#uPt#~_InPt|(
zvk|P#N-IP;-G%;eI&OP@i}mEhMP0qevQ62}wes2cZ~J22F5@Ye_iI7tJY^YW#XAoI
z_5>T=Fj4Xmu2nW)$I-&`{l!`(lhS&t<$h^CS~Ki<Qqlyjy%U*ri7~LrVzT10OJU33
zy*YhG@M-YFzEWZ18#?yZJY7>}7=|4+FaG%1DEoGPT%fwCN7mFOA&hIocSu{iIH~(E
z#V7FVDpe|+-F$A|t7RW<3bJild}#5Sjmb+6ZP2vd)}robeL<ql-$O4~(Ru-oZckk5
z@l=sTPC^ow6qPT{UH1KNWw=3-n!&j;w}n@N?j?VZ)8ONr=B+O#$@KiHOn6+p-i7c!
zx#A=0rT@BZr(Ni1I<>FB<&uJ-n@Gunlm^AST3;T&KN}q8YY?S-<>6yvkJSdd4T6#z
zMAAB=*gTS7<oo+h{H}WD#TpsEgYt(Ze)cqKbal*>JaLBM&^MkLXHFNN{Wv33y?X!e
zC#K&kdH(J_+wC0xUHVn4*tXo~%Y~;zwW+h{&Ux-#Blx&JJpAZIv&I7oTFdOBg&3}x
zF~$m=nDM~*WB>b8rFm&N%MwgZABYU8yeZ%HO5}L;*1I9=66KQjDRwkgJe<%a`->%c
zQKh`G{na`V9_cKtu-Q}ZW|&O2af(d5v?}wTjH2B4x*0Vov))Nu`xTSF^y?<!k~epq
zubFJ?+B<v8mM`yuw#WVyinqIQ&1_!*&l9_~wgqb6QqN53to^xkUCqoIMpgGF&TWCb
zthYTrd)(jf>&z-CmgCY7L~B#bZ<nn*P{e%aofGdCojj+4qPNPOwKZ!#+s7w8`K2Gf
za;t^Z?5!W~W^Y`$ZqvSFPFAL0ORxN|Qr-4^S^cbQit|_ThKd#&B$<BX>|OjbqIb*x
z)i0I4&sS_~)Va~NDDjQJwnw*beC+?Q&~m$V>sy|9tJQ&@etwVETIk9mqP<kc|M2P7
zPlxS(=9>Tc$2{?l7M5K<;KBr4>=>AsBZ?g?i$csnGwlQ?(BDS+=HIpu09}v!VI%jI
zH9s^rb=#I)6w$bF_uaB%Vz#1PYc1kV1Zkbry%fJ+WWUeMHES#~%{d>*F!i(@emL9w
zu)6yE<(v(dm;5%|FFyO^^OMgtL(G0>Z=CthZoZAZt4maa2g{su=hdqi=Pb*ZrN+4+
z$LhY%ynRO${-*wW&!XI*dH7QDzBx9vd-Xn@<6=#?5ji`zcHbF&?F(h+=gm)ga(sRu
zM~lPDk~WqHHoF$h7Zg@#>@>I-{`y=ybBE=VW8an<2R6(o$g5l|<lMm7*Ryu-g_}k@
z^RqUu{hW4pOXSWA+8IniX>wC5_nn#k>IRE|<BE;*!?$)emlZBLsK43j_LJPW_4`xb
z?$WaEpVBxbAjxLcXM^*pwM%<sRCWi*+MT_{rYO^4@^G($@fk^h89wPnOB1BluDST!
z$tdzk*;e%h4HHaS*p1R#B5oQixbZYR<!RAvjr21PP8(Qr0#kZ#@+bdqj7ji&^7gw+
zcyD!Rw`fozn}(og7U#5d-_W$yTgw;AZSoh3Tz!55Q_D=-x2slNuVm(_XD!M+tA9;O
zhGmj${d^HI_HEu}n{!1h1=*6WGo)T^TbI7GQD-6FrlYQ5>rAGn&ET4l^ltjgH>Y$G
zO%k-HO76ZP^zD{Rz_*3A3I@5%FHPQ7FqSSC^ki3>ozkYV<kZKjFWoP%_skOCZ}s!_
z-QVV)&ENkExj8f4cqY%a?z-K_+#RocUAIB9nqNhoBiVNMr{@iZcBk%cKFnNba;2wv
z%WTt6Ccg~y<Ins1t=+!#Z2RQz>iPC|!3TGy%)cwbr57S|%~Y&<!-50n^cX}}ZkVuT
zsuCCDiC$-pc!^IAi6=i_lV&Ya6MlU=E_T*V<?ox;&Y8P?)?V8;pVjo&)$uAhqzD~2
zG>d`5$2YRJcANaAGdlL)Ph7H!o?gWFY}fkqj*}N1<n=!OKiRcb`s|UN>09?6EEisQ
z_T0ACIZLu)CWiQBRI63z|F~zO(r>?@b53(!K<Vd5|HtB0H<oxztC`=qYMR+W`)jAu
zcHhi+^kve|U3vOvJf7t_h}~8*sXG~7`C9LRq{}3!J>gj*Z+;iu&NEMK2rs#uTRHJ+
zyvk&g6cg5#qUhzWv9V&$nC3WgvU|=fPm+1_=UPnCUfoR<Ru`vPtzW&YR_w>L&<o75
zzhCT8`K{?{r=sHV=J2j5yIYelxxG|fv+>>AZL3zVJ+`o(O_{GI$n^H+&sOL6uRT5W
zoPW}+p!u369{F+UOT#>7Retgi*j<*Xmo5CJz;<a)_VviX7}hz_CzqV6-7~v;Ro?gB
z$jH3Si!N?%ee`bEw@v$xFJ|Sel-zV>IoFmc1zR1;<^^XTY~<(EG1;);z$CVbl@F9-
z4DZ}!7Pju$^ZShMn|Q0*$zC;XOB?)Fgdg<3{-Z_oi`*BlM?Zg`;NM-(rEOuxx91((
z{my!WJ~lz;h7})H2Cu$udCOP+we}PC8|OB^JtCCQyi1XBqS>T(&$gXdX6T;N6PtK<
zw(q0LMSu5B%~n}>Wgp9@8+M*K@=}KHoXUE(_$E)&ezxnWl%-PqwAx=+k6vSRZ<{pT
zadNbglhqSTo>+Y~+1-L0-Q<^L_+;3ohwSTpxNpMh&8<798_KQ`?GiI^o1%PR($=Ew
z&D*Da^;z}pTFc)84n9GypR*U#op_g({QG9coE`N`udQBIXt6Ms)2&GAc+ZydmJ1Sx
z*6gZ#z;fa6<V)|H+XGUBAAQ!;DBuaO{HfR=^R;jl)0__(a~7#M8_roYuVO-9-Qo!|
zmN)zR`er|I)_kjf|LVzDo!TuD?@RAHomN<-`t0$VA~)mJRd=F9u3BtJc$08k@~-5f
zd5;fTB`sDyc&K0L4TqrEstt#g-dL!;`O<5idf@@9VO(46=@%N}Q)3QWovBxMacd8p
z@Ia2;UE5GFcilxdq1VcFo7-%6{N~#$t+g?mYvYTflA=ikUmDt8UUXVhZ*8q87A!I0
zkB_2QI7hj6hwIdfysZ-ZmV2FvKlgZvRaDnOjfBkjn4XX%^Esi1nO?p-v&ym1Q0FM$
zwDKDj0h2Z>@0-`LoTc5}<BA2F?lHOjeAOXI_VJw$XKQbq-MgoK-H~tap2%u4ofMm!
z)ZRKH_14!`i7)C;`*utexmak_^ZsP_|Bu{;-v6S1JH26lv7uV)@VnFEN#-&k7T0Ru
zyyIOJ{m&_9kIC<gS~_|kBXyRqD4fEh+;8;eTgr_Nd+&RT_@wLf_dK@p`TMu-|NPSQ
zP1RR@jSjE)?H^UTTk~j{(foh5FYEp>@4R{k%alL3@&Z?LX6A;7Y7WafF>}!30K(N=
z#KFAV20WnF^&7rGU#~?=UpLeq;JV+gc({v~x69<kfB$K@u0@ir+sbcGa&AcPTq3vf
zdHWn!ZO1K#%YWI<n^jyaCa~e>^9rH)zn^{NJlNs4YaOe=-}7mA7#BHT+`868<yY|M
z58pohTlxR4#FS$h|M&dAXk+nzBJ-*>N8Y_}xbka`@Qc^8!qgs2b9wVENoj3LbPwm}
zQ_YN%P8An1sEW3==il#dT%%{xA-!&*Vbk>kR>v=Rc^N!oIWd>v49hRSi+hZ2dRsp6
zHZxAi6Q7)T+3K#R^v0EGPZgu4nHxQEYg22Qr$7CKfSv@`$+E@(apO4*`STfeWNIus
zIqUT2lUJH2YOrvc&0g~S^lSD-D|+u<HtaAu(~-mc*kGgf#AMfet(9{!7W}`ZvFX62
z)J;3B_QfpnIh*=s>dFXKuXHifl-d-}8`{AqPw^Uw9`szMq5gVnpH5iajoSx<1WYwk
zC&)hfBzehYn(vXVr;66DQtZCe{Ui6NI!9-?-}7fBCz}^0EaI8}bY9NYPb}?I3lnmi
zq(8ntE}0pkaB)Y;v$~_5i-W2eE$3dDGvl?3-y^TXYfE;k@pX6~;hnDK7b8`CPcH7;
z$GwI{%ja&f+Ag|P&ZqeMR=Jek)?3dHzDsL=vhUre1Z`c3@6)!;VLcqR>{{f82`yru
z1-@`Uk9IqGN9}1$v53u?ORaZ}6WeCTK3F&Tk;8u5OAEafAA4roM$GudR2*YEE4!kX
z^>VqbMD_8=c@dolO7dPEQ3+jJ#eZy{(7|b5QF;Eh65irBeZ}6$2d-SodN^m>wdxHf
ziq%_rZhM?-F8ysIk?PD7o@RG#%iWfxi~ikjS!<ry@4w>c0q56;?pw2)Zg~5r+o9Sq
z`>lmhRm88Q;_<T|{$}T9d)|oIrv#^EP^vdGGlD023oPqgEQng?ayHUCU)o$iujtB7
z`-FbZfQvHwIKNz4qL;OR_0kmw{hcQ^<*eSQ;~w?(<NMzey^A!n&HJ*gb$MJ4WVoDr
zJbPyTjDFtqD<3{gw|l<&<nfco+ZO56p9w$v`tr$()<qKx&fA(U7oYr&{Yu2eh;uW|
z&c4k0^y$mhm+yrSFZuNF_vOzgPv5-xHA#Aj`}>yQ-t>DMiw|*LUSclVS1CC4@p)6@
zAnx$Lb{?$>QJzzm9NDFO^5ZX$O+FHvJYT-OdjIy*nljmtrOB5(Chog=SLb%dlz^V<
z*}1XtERvqbdM|rki#z)I<bmR;qSMW{?>74vXS_)%{)b$=OX}G<1wS{5&t=}=TctSp
z!`+Ym$M65G`t$mC_{G#3b=Q4GWyNy!4<xU5WN*s7zRX%Rz3H^f{Lhir-O~hwQ$7od
zzxLe}#rd}S;rzf?GZyR2$vro@v}2Bb-yV<1*<RT*$~Mh>r1SXE_UW@z|D64p`I-BI
zlJyK9(c<3XX_nU|)`~iFH7>udK6&xv`LoM5NBi{EWoHz9N&fNt>uvKN7C-m>%qpr8
z>X&4`Th}D~%EoZ<-XpGD@oq29UN`?NxVpoGrFh<59j3B9MO!0JoL}T^B%rhBQ~9Kx
z72iDVW}me`BEostLcBbPCA=-DrC9a4WW;=rz6p$0@d`XnSz@aeaXIgf(LHwNk{3&c
z?fyt9*EN|Y)+yd)X1izSu5#4%&M6L6Jh>+%G*6)G<vzzhf-YT={!6^XroX;xrh2_#
zI{#h0TV<8SlKUqz6<*%CCD{7W8JTU1E28h73lfZWjV%5BeAC?cr$%NU`jbR=UpeHK
zy~DeC;yIgaE14)G_IZVZi}hr0f6X&~e`{~@D*c8a?Q_$kB+DD7s2<zjz`jJ`Nl5jE
z$TQ;GbK8YO7$=^*sdLydX~NWp1>5r0FWN70Fo-Y3?@(r(gNtLz%t=!wZi|f3F}rQl
z9m40o+wXzm`Oh^`XSeN4W>8z@bpG3H6W*m8BBN#Qgr1vn<nF_nho&2cpWff_(qwIq
zc5$_F_Vm|J^cU<h@4vr4Db%Tz$?i^E&~7=sGsfzn!Ef9&3`K)~{T1?Ty=hp@<@n9-
zZnvXjjFD)6;lmxzv$GBeUw!t?v?b5U=}!JCw<SlX8(dY`6cf7bT`2b@UGJ@5c(`+V
zxDKD1%NKOu`2=ZBZmq~2f!Fr&2i;knUOLC*jA-vSg~+*&?Mqz3tMos~oP6SAoZ6M1
z`DOKi-KSsl`!Z-8)ma?1gz2!(BL3-?tClq^(Dt05xUwr}>PgFIrk}%-t{f=2U?K0(
znxd9fJ9UfA`mF(-K{IP6$vk-y+*rAM3ETPpH_91yTYo2AsqK5*wR-#Z++EHcMR#uA
z*HoLDl$RB}!f@g1oj)}$AB}h>pnpqz;rr8ZuN^y!TTcAv7dC&eSK_1HmBRI3^*^;0
zvV8xwWv||uTS?)j<tw(f1l)~}Z!dF7sXmi>Mk0;(s`O>$eEIH4Dn5_?-e%4!dAMx#
z!6)n;4V9uDJj?GVRG3^|b9w4z##;wi53tBJnMxg;#iD*)_S%)^<Zlyp9oq3H<&0en
z--E0rS8SeNv+-PcP-kC!R{xiJ9%JT?z3Dbu-IMPI_Z+w8cepA%DJWI-_YrA<SsNQ|
zsx3aTu`qOgV*8S|cjZm#j`ojFC#tXsz1*1UKD)Um#VFV0{H)z?AMM%j<xte`(ty>C
zr4zb0@tsS*{`v0LHA)lNZs+AKs64A|zTsKu@-t@LKdw06=q>qwW%EqY{|A2Tnb^86
z{_L$S=8@qZ7Z*kQs$T2W`SrSNW29c*v%ALxo0fP_$P?W6^zEkJW1I7)hd9`1)ZUN1
zf6dFVUTE^F3g&C`=V@Kou;jh@qc=+guU@`&;NB*yT}-QelPA{r9r(9z!5O=%y*w*e
zy=xZLI#yVo$!hevsxi;=t!EzdvOMO*tz7<A!H0al-g9SP$1W&yK;9(l>=q{ZsKz_D
zHVOB~treNHx4iUk*s`Jrhqh_ie!HeuAYwM7oh46)bH~@6lG_rZOfJ=SB_4kz*Q3<I
zck<JZ;6*R8WlO3jnZ2&L`_d!ji{JZ+siu8@r*&}dzTd>ZZu=Pr)y2PVhcHA<pDdRe
zSlZ_!7HF^jq{DTal+4XVr?xNObVByniNEZIt89dAzWNkB-MVkGtl0d7Y2Ckbb}e`G
z6c4+To)fUdP+uxjIh1>8;l-(K-$T+aq%A4bcsk|hoO!J?TMn)MD!?(%EI_;H^z#|3
zGQ*2kiSJsm(sJ@L@n0H8)@<Awz@Nsn=cMs+U*BEw&!5$t@!c@B*8J*(*;OZet)DED
zE}2}<SCsJea>>;RyAJ=q)qK8jO6HXb2X_f9xV%&JEm!@2hL>v$+%fA$aFqwD8x75k
z;Nz{vST343Chns7yOFnx?i>?5`?>DuzN0Ho@jb7rG|{}7ICael5!vUWcUY%;I5aSA
z2>T*?l708{OUwzJYs2)^)^SB1T|0}ls>*NvJG;w&HY{sdyYj#9{M*N`wqI>G<<9=G
zu{I|D-a5U!9aFR2=RAvAm;XNeBkwk|nzeIPZmr9g55Irs-^*|E+OAsy?i{+lefL%K
zqp`8SLj5`?IxP!z{B!Fl@8*)Use<V<J^A;p{B_X&n9jtuom+0*Yd3Y<u}y0&FMlHc
zGLFTQmLA=eQPyr(qsSuY^YGd2T`zub;*SqlwB_21?9JS1Jc4cyldj8s<M+MU{(PxI
zjAY3Mz1e?12=E#vm3))g#yicT;-rNC>hk$brG9gs?D%$f_VxODak)~Lz}6MD)xvV3
zEs@%nqL{)hoIl=SnZDxC()xH?k=V<5|9{T^AgdY_Sh6~+?CLT7{1(H4g5CEFd~;Zq
zN+_w!5w=V+wGm-XN@CsBUj4@~fysS2Pdta2Nutlw!zHP)JfXM0@LvtCI4D0g*=F^J
zw$J$mwLS6^+*1CunN={Al>YR%z386Yff}C8iq|sAUAPj|&o7zbK3Vv6-y%tc+S=X!
z1dSSt75Mml?t2{Q%=EIo+GyD1@ml!Vr>fGzzlW<{@I8I?=(%Zh?4P6mch;1%%3oi9
ztv+J!KE7?!HouzjUvss^^&^gHnw}57*ln(R^{z|JfvNF?#nlrLAG)oVFf@oYooQj8
z)vEAX;%WZ(Sk?;O_H`?m?Iji}|GzkA>pUi<*~u4Wa&lGY7d%^*@h!FJRM1KBJyM-B
z&o+d|>|7bX{#5Q(>n-gPBCPsPH{aPFE4jMivWsNrIwPT8M~<Zvh3BukwQQHZwaK#D
zs}IljYAReaPHuCWxgq#`-HLyreoWQg&33MNPOL^jcHbvE3rhW6Gb^|DM(A0)3g(I@
zhkk675ztWXyx=3#?yvc%XWpE*&jn-_%_yl*NvNA1Iq&o5^NHq<ZgBjMwYFI@<&ou<
z+Ccu7HBHZ)njbR1Ic8MB|D2o6gt^GW$7l_Urql$n;zO}wvEgPb4|rzZF?5%?==CsD
z?snY@`=!fG&-%YVweL;Sa<)}-7bq{!P@4Khz;EZzZMjK4Nn09TOz{0=`RxG93cm9@
z@>n(m%=c$qZ7kZgSZ1==fwQ5REZ28!JpROG(mwf<$`cmw+-R*Sxe$9~ioCg|fIxDF
z(2nE-!mHSt<=-sy*Hn98aW#UWd!0@acf(=hM*jLWM#VR79DHpyEA&E~(b8nq@ILE1
zHTSpPIN4)-GwBR_hUo;Y9~u8I$iCa4xBHG_EwAU-<Bt5Zjy|cqylkJo%H{drlO|rg
zYUYqPmA_x6+}VrKLd5D<%I?{VvW~f=-)XyLyjC$jLnbJy;hU<|@#jxxu<Ud>KQUS6
z+T~S$dSsYORW`3^JT=SViJtla{fNwna|<`UUj0L(#L#xy)ZgoBT`q0(*>zN}_V3@P
z)@znVKGB`tlPi5#cY)aEU_aHj4!o{9N<wVYSX_&LZ@OuFzDM=x#uq<AikUjEuCSc!
z!nn%n;f3bf+o7JNjHZ=sS&{!!{%W}WwaDb$A$sLhgtM^ZQo&g#CiXZvZD-R9TKjLc
z65ADtEt-tmnFUSHB!%2xvZ8I)VfS@Qcda^h#m0D5{;4f$tW(_sQ;$uWSjGL;BzgP8
z0@Dp?YHa`7E|r<YTxs7SD`Ii>LTh;H{<o`^D=uX$Nqkgv-YW4Zllbu~R+}~nUTL;j
z`+Z?R<0Nst@Nd`mt2}VX_#o-kmSH^YRc-h(u?L4I8`ecn+r4Ye=|^^+hHE$5{o~V@
z*314L!@bbC@%amv71!C0Y&}soSN*gZ(>9j7#;$YOll8u=pKkdi^}5*Z8n+3B0k6(m
zF6J+^Qx;ZC+NWB$<nbQ+9EIY}DQQ9*KJ+!_$TV6mtewxw+;TkfU_+WV50moYc@K75
zZe1SN#k#;PePhQqhx03n|NLKTQLU{1#BO%O`XoIj*G*e2qwmfCbp4Q>@*OJ+*3_&s
zC;y*SO;R?wBlc7$?x19Sq14=+t8QP3S#Y3m)y4PU<7z9TYpdKZ_>@kIF;c#|Tg7x{
zBVTK`XQt72B`@Ree=mCp=hk^<7HwZ(Vjf_%c}35R*3;9A4_vG1*#Ah8MI>SMbiwA=
zy#MD4S_jYG&yuwH_wL@APj4GoZMzVCyX?DW<TR7wf3<?L&5tJV&$imj7*f=oGpnL5
zqkLAM`S<_TS$?<MyH%N`9H;Gy=br!hd;fjueVZ$+E<OqV@#W_S$8D!(HYA%cacEg^
zzj(iU(feYtYFYDhtx4VC^R87)(C^u^;B|x6#LJB#M{e-Xal86&-5a^?WjSm)Vn*g?
zRRgV3{xA4$rT1Y=BmXU*zuC`{`8j_bDcEBBT5Q8wugS(O?d}{7bDlNFmcG5rBFndz
z{o=!w#{NgnR6ah+d&j+Vo_6HKU3@HT+vDUa_0IY0@rT;x)KxhN=6>GMx>UgL%Hx-T
zS`5t7^=zN}3Mke+Tm93}Ks>*@CT7B(kQu^G`+H_;&N#7nSFNRp#z)o`mLQ%~=iA~}
z#Z3FoPCs@c$?~`Pq2x&t1&c3N3T#p_jH|QQD#)-t<nm2v?;viySBv-kcolf|Nb75h
zRfcg7p6o7LqP;@ju4q~QhLDV@%iFnCpI&j`ka+N*$woNHXZf4i1_@@j=J04o@0lVs
zJAdc<`CWYLrxi$VkBqKm^-Qub{VuGfvwh)bEsZnEd*8cl|HEo?dq$7{loN-KEbi2{
zv*C+z40CF|x_P6tu|#~bIGf=4w95exGrv9Fba&~@_Qx(6y>+uorgVn=mAHMl#O`zS
zv%5ZXtl!TI&^y0dKW|5jvx#i$nLT^sb0t39{rSI{L*S*A%^D`#Lwk<?|Hl=3{e2Ba
z`vlVJ0JTqy3=QF(cVh$4=oCm4apbNs_&!yFBUXE-oX-<B6gVd6Zr|Gfbi&CqKmJdg
zvSp3SQlYRfbJ}>hQaUe*R7}~Yx9xH4B`rn4MHx#ieyzQ3eBb<Wq&Lf?8S^%si`pob
z?K!jb^qQ%Qqj=QcY~>NqiPn9+^G2QHrHxx0o4;<#I~w_S)juVkh}0X$uYXl9G}{|%
z)@j7#9=D?LNSpAdA1^{!7N4Bz`(AAJ?=8JDEeBZFJ(E<lc)$DdGS18e3qr)d9T(f_
zuw-{^cj|l}29-B`Im_d{C4$^UZ|sRNo85AJYmIztqP)(JHB}29%O|~7T(#w%K*jts
z(xFKau_u4;e%~u`&qL_&_Lu1;wQ|#6_0}jJ3$@GMf7pMo2H){H4O_SLJ>LE1)6*qV
zsiJ04UaI$>J~A_IO4u-YPkH)AH7n=6H+G**`l>5_o;mXV$J5>XoV!98HnH}dU!SMv
zS9q+-=k;gH!<=5(JU<Q}GkL3ZJ<wg6(|Mshr$I35IjQ<J!Vf;zY?l=IH|?||`-Q-D
z8|S<`xcTJM2L~*+F5W)*SYG(8M8UIb{#x2AI4{-uR6k)M6LaQX_hSvo8C}I`4rcyS
zoMmekEZL*G(s)5>{H6Am8WWF=cU_soMA$?7zP1OfU%y(W^I&3u|E%K?4kpKI_0LZ3
zIr=YeUcfTO<FDT&=gS(W)KB{p9{KCa+1hFR%VSDh*nj9psh!(tag&*?>dKF><<)tQ
zL^gTsOznC7+3UPM?~^Lbt+bGI1WH?`#s;v_B4aGq@*0D$1tgf@e1lH+-8SH1srnNB
zVu!2XI*rar6?Yf0R=qi7|KQfSYq9o1w=KU|-{N1V;+^@Rx#3|!o6Kh|l?4+%p3b)p
zz5YteAn|FY`p2N~^Xp$QGwDdW)~@Sg6Y=9zSDhgGHN>`7_FmrW<G;d}a?DZWnzC#4
zyk8ua8>THiec}1DP5h_#96j}U^(Qxj4WZXuK2E-taAAT)<m?-c=0btZpU<Upb_g(T
z-XpCjQ}yEMVmYY^T-{%{7w*aZeaq#)hdJLAwaKebTUsh^`0iTvf2NrO(|Vq?4`%$&
zQ|Bf*3JX-v=6>%fA|Y7HnK1Xa;Zq^8<ioB>uXnewnfI>Rp<BuH*M8kL$=kPYyvgKy
z+jvrJ;`Y)PyPVzIZNJ9ujeWLlzPy+!`?-6Yvz}dP=DQI%bMI^Y(`HlJf;&|I6zcnB
z9Q<|U$A$j8(~`pYmOQ@{`MjrT&hbZunb&GFjwffa-rD6<zlAedxaef5hxx$<k5wC%
zr}?hbl6(}bIwkp~z!c+U7XN<CHDEoqO6bLW|N74}XC4>k`@FdP;fanzYgf3a%Fm3?
z`nb32zP-za{hKih9B{0HqTj?2eqe{OA#7C&a(M$9H76MTXTyC#rvtF|{p60RiD`LN
zb!>jIQ&fZtzsH7EM|N(xx%5K+-7Qlelpo+vdvheT?CR7LNt_`oJLi0y{e1ezCqKh9
zIGv8hm(N|l`u3|Z2dUH3e@4ymU;R;)MQ-8}jw4@IWvMrO(AX1n$;vP`JUxH<_4a2+
zzht+DRVC}T`-oqS+}oWj9{h3Q#b%StcN~ne_nQ^9Lk09Kbe%g?&Z%Fm_!ReMwsUN+
zJ?DyJ?;qX&*?zrd<{m-+Roy2&bzD+a#11JPIG$80z^V6$NkTbRAZ%jy4A%`!n=VZ`
zSS0o(Kxe&25_f7!$NGtjeA=8Ob{)CQx?GUOv*?A-{znF33%e^*qDvOX75>!@n&Tn#
zQf~Eg+pvjVkFH!|_FYxoY_Mfh+r~>Ord+Qpo0F5C{!<P!%=TCl=Nk6dd-*R}H{pEO
zXBk1<mABd=F7qpLc7?pyb>@4phVt=~Jolr8<Il`j{96&B8gk9Obk4Qr@-wv>4nDKj
zvxIomE@csk@_4(0VG3Kcm-bstrzs6a$EIA;x>lgLc8z`*kKga(S*82yg_h>`lpfw6
z&F@$_{ncug5C`im!L}TtE2e~{_$scQ!=$xjYOvzfa83<_eG|g?qWeQxPW@gOB{_HE
zB1xxS&s^`s4X@lk&rk@Qz3ro>>5Sm~%99Ia%N2gPTi?1P9%cMxdhNpVT?^UtKgemf
zH67n%m1{jg_b}(}gX*G(TW?D$+O0g&Z*x0NzUJS%(-tW=Ppo`=ku@b-Tw#Uv0yiy|
z`>eiUs}JYhKlAPMTeY@gsVmn?{I`c|3VWC>lq~zd)UP>4En|VSP0qCN+i9}$8QME}
zV!uC#W}3>vU?snDmhWCKb=|ODp45)my&j9__%c7sx!uPYz2{7&UG!Q0)i>=vUT_rp
z{^Q-n(#<hCQ8H&=UvdBPv&?wC`QFw|;-B8FxSBKhS;O=vxzF~k$lta*b)G>|WQs|Y
za>1U;<O7?lw%$;kYIsfPY3F4>B{%K~!FSHg`dhRw%X9ISbI(82iKXQ>Zd!A?<X1{N
zyIAp;s%t8Nfg7u4m}Xu-V^x`4bnN^|o}$@Ce4FRl$N$S(&GdeT$20ze(T11og1i?_
z>x(n`SH~>8&2B4}ED6eK`AJz^7Kj5oK&vo7LN+$~A(aKG`T>dQsrtUDDVd2*`4tM$
zp!H&AhDHkJmPWB$`a$_6i6yBD2KoVsMX7lu3gBUWF8!d?;{4L0<kVst8~uQy{N&)&
zl4$(^7dHj{kkpEjST23niW2u=uvSCRy4xTweYgC)5(RK+5X5C?$EEL_pI4HaS5mA1
zk+-vh)fk3IEfg9!&@(qNJ=F>BP_VO%K!p^Vvy4Ci0TxTmO96$K5iBfe8gO9u7(;>?
zC76sr!Gi1_<jWIi5KhpDgt!Mw_!xuI5sG{07d|H71&pZ42y$*aNDLZZ$OjM8IDAat
zVSz~2;L}Qx!^Z@a&_M}__UQ+_=o4%=l6&BB2n`?j!Y$gk2U|V^51FF5%N#VD2o{67
z%K~ZX7!BeLtGnP~g9tARc$~uAMced^&0UsQ(zykCIbaD2K-#4%tnPw`4I;cO;bj&y
zyew&(-m$t19yUnsg2ye?U4{mrlAXQ*W@rEp9fZpa4dBrWcN+cEzM%m;fRLRAk72me
z=%4%z4dDTV>@;{J!<=SF{~Taw2oE46r-A#r$Yq%!xb;Klv<7ZKfn9;@G<Yn-LJi!&
zp`Fu^+Yg3D*pj~yJa*wuqHXd=brL*4kV44_9;<LC4M4I7-<5?Pff(&SL*oHR_J~#=
zQm7%CtFTZrrfu1e5|N08AF`9+u?usO$pDo4h&CXS(-4hUxYKBx?6K99hT!8>(bE{B
z9Se8b03?4?P;g*44WrZtpD{_N@(X+(Ai9%GL5UnJ2n#Ln5rMRG64r<WpE?D01yUL_
z10{B_Ak1m-O|i6T?W5#K@K#%}?Z{4o$12=Opgc;u&_Zz%wjPn887Ogs-3fCNjr&BX
zPJ#yrQYc~ch792gkLeI`7VsJw*-0459NdkgQ^Z-oZAWqvxQmDqaTat;OP27=h3q7Z
zv;^+F(J7QHv85$&#}FlyEJ4j1dN~OmAV{GE?h~Rq2~@7r$4N%mI$=iO-XOA*j0`}5
zNiQdX(k<9_L?{`7*N}k)q2-d10Vpu(<RomJE+g=?F^ZFD-04CtDviLsD6s8Fp@h-d
zG6Ih-(<zj|y(bJOfuad42#YvyABSE}0;OB9?MR_y1nMM!1>sJjUm;)w9y15qj_f3O
zkq&nf9SZ?)uL<2r;0v$8f-on6`!sZlIB;(XY&%jYfrt0Of^a8+$_hF;3EW!(+m7rc
zjN}dO%h1b7*pfGRkRR+$SSW$}F!XW~JV1~_2|Uh^>LfZQZ&P@FM{<%Wyu|_wB~#FV
z44py=(N98l5<E8HPNHM-M)Z%6odl0fn3K#v?P1!561M)Fkr_N-ker6-<iVXr$5I^8
zPeOJQMk#Ja$7GJ^Cm}fr(aD2_k~tldxj8&QkevjNO}LZjn9MEU`5xIx7|9&m?W1op
zH^$l)2k$IIE;@~A+!n`{1C6mwh(PvrpgIi{j&u$+Y;AMMl1>z-(XnlAjBO$Wvgi-h
zNub<8=g>m5eG$nYvLFq`X$l4k5Qiy%7sM!lSHu)6=zC|T6e~n?feP9nF6g8Rv_T7P
zoPqC;58{G0LZB5tcnm3s3pz$&0ZJu7T+qHawEqj4f(+s^1SfA04N+wXj<_H$$h1)q
zmm##5VQ2&?Mhv0WLx%o?xD25!M?+|H&Cmp@&ID>6c#JfN%Md&;8N_7>9t8x^ph75!
z%Mj{T$RJY?mmzp$2Sh{V!DAR8&%*)%RKy2yLAuBw8e)$T)ZLICSP+*HxZ4AwA^MD<
zlNUzdR&@}Ukuk)4BXIjMh|37vXamtu^TExNATA?Qs5)>(9K>a01~m^{)dX=Ffy;Lg
z4OIs&$%42b#RiCmxX&2sK4WM{GFCy~IlnZoM8V7eX~76uWv`&`oLG{Wlb;St5TLpQ
zIpKi98j^6p=?1apN#8FqH&s8#L_Z`*-!mmOuOzdi5@~%CQcegm;R2Zwgd_{{3Dnde
zLsKqD_R<eBG~$AILO;lo3mi%aJ>ca_Fg-?QTt*-pg7kxoOt>HkM?c8Wg3Ayb76@J7
zxPa+0HsXSGj0oyNb{~EVz>$m10%BbVP8HY;fcXpI8F1APQ)+6?1xYyiL8c~Lrr;3P
z4>C360^eU1q#uOcw`P`HkaVRVWM;+%8N}8PGBf6a<Qn}TGXpM2!x3RGIKxnAFFbDa
zgDi}=Aa$UAkhvunc=vsfevr8t7o>5aAB5~i{0>8oCo%&B*)?Q10bF?C4;!QegzQPo
za7G@v48ram?2$?^aIr+HB`ALp?QjZ139>W<zikAQF2!!3LTbSg(qtqY$hwaK4ia#|
zOQ9Q((=<}yf;ZzDf?FE+Ehd=Mk&6k;%mi7E0k?u+xd?MFqS!M;sdC87kI0UMS%I~X
zH3Tn+fV-Ex(j6&zk`*oBl@DaO0c&+fo*M`kOazMx{Pme3c*z1;-h@@kNR18D3XPnS
z0K7~AzjLr>21-jraI1kFiw#YUxeOugSIWH)UUz`s6$B$3Dd8jMIAU8khTyR$xElx+
z7Ra{2GBr}U0d7?hZ5TYQBAI~F(!(D2a5o@p1GNHS7Gu+fq!!$ZfT=}lq8M5ja2Z0z
zRFD!mvPLs_UlOeyZNy~=YuF)~f}|BZsf^!FWYx&NL2)5ri$L7~Vl9G9nZi{Y7;zaH
zfCrdywV|;Dy%Bgkg=jMnzBB@lcEB_uRWe4%?m%kcV~bX-6$)fR5oR)WZAONsTt?tV
z08;PF2;3ouX+#Qm9IA0d6AsllVg|cvaCePpmw*QfV5&*+FnDBvERD#1C&@;XU?3@~
zv4<3RN(ANwf^i0(tsq)8xIYM2O@d>Qk~w(9A7%y-$(&$`Pjv6q2t2Y6vzlPgfCt^-
zs*ycQSSxbLNJ?q|7q@Ub5p4{tQ4JYYhN(6-Fyb<X6<0=<mRv^QjvZ)V#L|q*2r?F@
zA7o@{%w+`Gy?|0^8(A7~8G(!CAW&(KRP-BJm~$C{R~&(5pd%~#K}HrPTt<*_KScCG
zhLd4#LJBCPdH|PJlmd`Mt)P)ILbk$7Yg`ThkD$U#K`Chsxr`x$d?;at;wS8;V=a*3
zTZdtb+(6sTTvCgZi!uvJ@{7Qm2f>4CzMjsZA&%N1nYpROx<UE5iFtLYU|A=p{EBE@
z(2_n~BMU<XLjz+FVQCQyx~Mt5Siyu#-?2Cuw1v^oz|w+C-#M|sBQ-NUqeKD12U!M^
z1?lF}_bf@w$xL?4OV3GFFyPV;E=kP|Q!q3&;nMfbEH2K>OApUXDalYUG%zsW(s#~C
zEDBC7(a_J&OVuwa&(|->C`wJ$glu_q%gjkNR)DNkK_m(=9~!Q~rAZ~AeVCxVPKM6V
z`=vpyhFveM?~|IBUXr0;3|U2QX9vG*IyogFF)1M>Mda((5<cF-D|{!<`08HcJ$2sq
z%xZ5|PmMnl(*7tO{^C6C=k~Mjx9(5-zw7v}2gk)1zGr9M|NhbceW4AFGba|F-6(zT
zC+k$#nJ*<(xuh04KAd&ymKBGfv$wZ*>k_XSJx$(Og=tmunxrNKPMbA3e!}co;Yn*B
z@Py2rJbC7t3G;#@Cj_pUFk{lBSxlG2rp=f<Ywd$+Gbcv|Oo(5$;NhB;2`LE)8EYSe
z&zc=IW&Pp_GpA3RIXyCH<%Aj27d@Cid)B-a6K2nt#C7TQq}h={AuAJ-Cd_2N{$l#f
z*&$JD7``oTir=@isoyCet18nkNpKktGc)t%g%b^#n+2K;nmH`iNJL23NIo-O^?%jF
z-xn|1c7J^A{OtYh`lyb7-wYDgrp~uZjH<7Hf5)@<*YdJrof$!sb^ohR+H1Xf=aOA3
zm#y5Uys>-nv)^5jZ_I432JbE}{!?+7&*;goe%Elx{qrkM{89eDdrijOmMsf*E!&ZI
z^8VSJ`?>pe+f;6RS@qrb<o7W1Db9zyCtrTD$vAt{>KL&to;h{9>%O+;_5F5lI+L6H
z^-S-R`rUu|Qr7-gWHs7a_P0O%c<a9PJEm4e#{4)`e)s)%m;O@yS21@=HkAYiY?p4Y
zoG?Av@#m7GnMFH`SF44V7EifyWm;;E_TGxe*DmSqeo~$rS+(VN%=dk-Vk=jl5)bp~
zpMPBO&x1qjRHga6?tZjeBQF_0b*|p@=z!peSN5x8lTJ^S&GsuTo^w<1{p7gGaUm-6
zXU~p*9CzkmxZQvE8-Ly_e!dx2Wcwh_a%TJUgE4Y(Y-|j<X$&(#TXCU@3_5KINqe9a
zYi0mHOa!@j0;OJXMg(Of^jsU}=M(B0iJWV}N(V!pP0r8FP1G+)Ey~PK(Rb8$(s$N(
z)pyf(*Z0u()c4l+(f8H&)A!d8&=1lN)(_DS)eqAT*H6?>(ofb;(NEP+(@)pW(9hJ*
z($Ch<(a+V-)6ds0&@a+2)-Ta7)i2X8*RRyCLM;lwbFxT90f-L@SQ{IC5{d#)>naGT
zD9DYdj0g_Dx6km&yxU<Ly^MvnaxUJsEiZI==!(*#OT%1T%3K^e-+11bJfWpUC8wQb
z(gabC*>9{lIu>1v-TfkC?c!@;)_0?q>(-|2D}K53evP`-=d<5yjL#pIx7qo8PWAiu
zwe|0R|I_RKFw1d6gwFhq2Ma#PUOas`$hg%~+xh6sPNnnb_b(UU@S@fDh4{@g(LV3j
zZ{1&aEHmcE?hiY^T(f*}`sRxtpIK%feYLa3JV0k+>T<Q^Pk!wcl9T%R>eEy0e_v0}
zYG`2Ce|S@U+{fE`XFPqye(vr0e^NZHLv^N8;5)Yc4tuPWmA`hx7q$6Jn)G=3j43KU
zpK`iA&Il~~{nqEK$5f9aKkL@B?0dDn?CUF2=|4@MjaqL$60KXgXz|KLS7K(yFVZ-f
zAHU4N@}j=6q34U6yKRk4&7+@v|Me>5;{QAzzq2-Tra%7vMD%adQN}vQx`l_H?CCl3
zrhdPZz>!r8)*4-$xcByxM@t?!bQavdI6?O2N$cVur}C%E<SMN7b#uz=swy1al8($f
zb9kb5nBWnwBtb#vH_F?DS9ctB(GhfdqY$S&P2hLu+#^{@;v3s4W?DGx@zqg1)N%KS
zd`Eak!6Vs6rH?|Dnr=Ananw;(>QqRQ6?A>0x=rwPr>Kj8pvMp4%^f$7WJ_ot;+C)P
z+S+*4y4hH{`|atz)a})}A6GrtU|Dp|)@Y6lllB40SFW$#pMPTW`SxbZ^Z)+tob`O)
z%%9KB%-&pf_SLs}&*wgQ`|aQFoZFwDd@enIe|E6J^J8}`=11DCw5zX8{K;)yA6jvl
zW7ksWFX!Lwte-dMx$?sNMY%CM17@zCuw13}<R8VaW;=aTUkP8B$#Ad8>V0@{-ZFnK
zyKB}{3fN6$nQGV`@GVV>=2T^^sFttf%6(knFWZ_YQak5gEpxWkp|iFrS0aM#(s;hG
z?_*V&Y!bVry>jOYgKcxvT@CXDq90^zm!5l-@1R9hTXW2lk59`wExENS4Wifeu2`_-
z1k<w66Q^7mwkmgJKCif(+LJNK?rGA+B&(*=Isp^zZavz%RP>k8+yu$X2N_Z>S$oS~
zIM)1C@AHbrBE$Bn3$||Y%bln^Y2^pgtk{`vFK#^<aIm@SjzZ-!BW?dxEmaXY7ec(x
ze$ujBQpC+wbZOUS_jU7kHB6f$ydd-om;3g!x00Sb{Ov4m``_mE-}a2(&SkoLJF<<U
zv~wq9tq(lHF~f_&`Rb_^L0*kPF$$}^65IcZykcGMXL7Sz!Sv#!jnM}<7<qzDF1GES
z6r-?g*9ks#4Hf45N8@iuO;^0Xxw~He1&`sTkkSaneaRiqlxJN&*i?S=i_(@^(z}%{
z)kT6<f3Imep#MDI_C@)M{wUUEHr+eou5nbZ^?mn@+uCnkf2Wp*olZxe`1_{(z%%dP
zt#^7Oe0Xc@-#^>L%A=pBp86fma5p$E@7iO-U3HUexAyHjIk%7P!hVmhV#h?j?l`zD
zYpL+PMK1)-Ftk5T7EW`}N!YZE*GDn;fq`Mrr^`a_f_L0}^_dGggI=va{=4f=Lh#f*
zlK*@zdNZz?Wp}c0(!Jo*1~=I*oG{qL?{T-deuj(c<a{NA^XljAw)VWftj)^r{U&S2
z)x+95LYIEh|GYtq|L@E_?D?jAU%r)_&uLixU`CF`V&%=gN%hOWtyz5W)+LXhYpkz5
zk+QIpuUxzLNX}DsgZLu(!yhNru|8GaGvjiZN`@WJd4H=(v-Pak+~r*<k?OmhLH7Hh
zqu(O0XRIsyc-(_!-LZ9dB?R{eHF)z{zx+8@r%E>Jz|_#pMPFOBEd4e8b^Dq`4yy+W
z|J6Ev^bgCa8R?c^Q_kj2f6cW-V1CM-%j=6ozUVakT$s81`nJsv!cY7Zm6m+TqW5|C
z)zgx8n;+bself=6d;5MxyIJ3FeLus^G<C-B51)#jxwaK&T%WdNvF_oYOdoF^n!V%6
z{rP*!y5C#A*0GhJ|J72f;)GkjY0Q={I?KgQXq`%wTrz3vwnE0gb{d99P6eA(KiT7y
zu+qeldkI^XNjvMAEQL4IZuC7+XJ0MBx4EP8;knlt$661zP2SsN%dm0J0>AJjfv34P
znJRhwY_DxfQ$Ba(czsp*qlA_Rp6dUb<?1DpFK?OUZO&YA)apT*#oBYL4r-lgQ__^s
zDW0~gOL~gw$pZbOHLS~aZkcj8XWFF27goyJdHBBn+kYj3<3)lG@B5Y4rzCHwSLTvP
zb9C9boa4@wqZ;!k`@j0k-OZI?7$PCMY{spO(~c4he~rJjy}h9w!#Y#4AoRI(y3_hS
zpL;*JcUXKl{&6+GM&#dXZ+9F2Rn+H@%kYrknSJ61my%g)S$+3BNBvlv+4U(i?$3QE
zwEO--8>>l??M}Nh-)pa#%^!I0`5UQUu6e#oC9gTGy1vFzV}>82LC{*hi@`-9LHyf7
zR^@!K<yy;Fo2ffXkmvX2`wIGBgsSR}Pe09fB)$DO_dBM&iZ=GHqH50<rbh3WEB@=a
z{k$7z0(h*`ydNCA@Xv4G@|piTT<&sw+5AHE#C+-9mX2H4+YYtxU39&<VBPXRTCM9Q
z-QqWqy?J-$-@@LB22yfUID`4+rscFV&S;k3+j!u6xt?-T%lSLb+B>#Y?_~~u7<xmg
zY>!{!g(-i()PH{*HR+3*%chI@!T(~OF>Ia?dFaU6H*vLj`yT{dnC=<>V0phA_eA-w
z-+^B=-gGIv=zsltda_$(@8QD8`d>R|teZNalCNz=nV5@M`svNZ#lb;*CzTRpY(nN=
z61AN7%~(%oPENf|(IhFUxfxdcn)zQW!;USztFdwJ*PH1%C1;h-Zx(coD=OzTvoc*&
zRhK(0Hkf^7T6t}8ea-8Adj%)$&~XggW41GiS#-ib&EmN&x39Q1%EgxKaA*k3Z7$a+
zk*$2ZZPtN(mrQ#6s-HZ5sG{YvrqYf-fJf@_wrSTxw;ZbeFsF3OQ?K&>p+6L50{OhG
z`g-=>+b0xc*FV$h(sRZ#y|tmt%qw5YGOW9vW%hbr)}3g#R^fZgUexH%Kc1UbEFD$w
z_Q9l7#fv-|0bx=_KmBWq7<%RQUoK$O731@oFO??uSN7Hk(a9HiCQdl4(>A50r?K;@
zRdMIWJ8Z8tST1UP&@5Rg^Do3W=*gsAhnI3~4N?`)=6}=|)4J(o+2obI{bCdB7-t;t
z?b>B}#c&gk?lYh5lkE=wzn=O3>E_BW3@>}-oW*~=)L#?LfAi~?nst{Wf-~E%Y@Btd
zf-#xJAZq#T;1=%{#f`CUJGtYQ1jxORv%Q<PO7r54A6va<-(y@U79LyeU+0{)NTa;E
z=Yh12l3?Y@RRWstI}gXX6iZL|Z#cy)<gT6gJ(1eBvOBri^PeAH@zUhhbn7jgA`gz~
z7(9=xQ4RAf6<ZRP%NrwmMeUD)ufo)mPkv1@nYfBU>_AQR#g9y<o|}LD=HYqk;!nZv
zkM{2`USIk|r+&lgb<%u?vf16YNlC6dX?|!zEOU0Evw!^TrOOV*B(}UOa&P72JCGP2
z9__z-HUGReS=F<r^13eio`3%Bh22GehgYxVLO=aG>&f$+|F`wAS!equUS|3;;p&U%
zcTd0V`?xNwGEH~C-BCIA$t#!_P1#Y~DgUQIu~vNY%UA!Izf@bXixwFMEy!s0*~pmu
zWfJ@1EPgj`&-wBHWEZdh-zxZQ%KoUWKjruBT*>wOnY)P4!s!Q?BbIO2-}$v|dFCQ>
zvyBf-MG7YO<}G-ACuqxr#cHQdcbAHaE}gKvU8;GP)%i)`t*3v6WrRFve5c%>#5(=b
zFRoWb32gdyu`*L<J<OQ&>2trR`D(qO)-ze`ncKo7-$ZPl^YrYmvfAiO+a>Sz)xUi9
za?ZTkzf5fv@iD6{*lt%Gj(z)B+&cKW+2{FcGgzP7aH>h{J|*>qxjbdh<~)v|<^8Jf
z1q=)s-d$Sp?e%=O83n8FG5z;g81doyk>dO|m1l3dA204+aAZc*l(n`2CnjfDwk}w8
ziDR{*Y1TzGj%Ak(<G&vLy|tpgjr)yx=9`NDlUW@8KYDr3eX_^Xm-mE&yYIv-+;~9i
zRVttI<oBiS%l9r{yZfpwlmDT>s}5o9A9mEQUf%rPNOsA2PR$*Qx2}5lZTZz}BDo(U
zywul~Z9VmHWtqv21c#$%Liwti=kzVLfBx%E?)J#Gi*vj=wHJRDp1kzWjx{2GKYdcy
zvh2CH+Wn2&mYg4*VZUtC{9PCSe`F*kX&IHKzd1Yh=(3m@4u-ECsy3)hh}<tSQRBz%
zZ|je%{YVzRek<<)cY%}DlslU1rpj<Ho8_tN_3X*Ss+B%7`As)m&@h%SIvUBBC?%UB
zX6!w)CH(fb7!JXh`#+ln&Nj?<Hd&s(qu=QxL)<oNz0l;JZw{r|Z=PK$n4EO*)=#5p
ze%Y;o=dX*t?k<%|jBv_HTp6|e`az+Hu*f`}<@Zw0O?+)Ftmn_OZO+?=t8;$dEb^6m
zA{)A8ueyV?J#&qU+poQz*J^807N~dZ5jz(6peMoHLMvNg{nO4Q4F;YoE6S@}!XGp3
zUcEKU-%zl_>1T{*-nxi8Q*Ph8c<0K+dAD^AalVYrF{qZl`04SQzVj15rJL0<So_#T
z&RQLI`eXOwA32t<Y_dGtISu0Gsd=58pnAw-N8%fXPh3AeD!zR%Ozd4{CI2iS-~D)Q
zv~-DFrTgdNlYVNgmtDekz4a46@+$JxHD0Z@t%q+cJ23rw{ZErO%*Vb@OSri7h+##a
zmAz5L+anz&JNxfXeRpOR??Ks@wxa#kRY^R&J0jzK7I9C`Dd8}T5n+7bZgxA?xKArK
zs31H&`2S@F6IW^5v$vkIMf=RK+pbX}5u2d&|FWq6pTFOOXLP7Xz85;XHaWJsqs%Vl
zvgPufsws1%+Ks+2Zw}*IH}$5e!K|b%29fC+Q?oqd+yd2>OuAI<&ho<U^CqD=TE$uk
zGDkz2xBI!?m6KSNoBg=Iujr3s=+BpJb+;we`IAp{R4w<Jth0rCv4r38Lhl~Molc=0
zJjeIG@|u1yG_!TjGbzh=du}r1>75P}e_`siR!D2XF`fJ=rrOzDA6=9uKVQoKe4ewh
z-hWPAAs64=fBp}WRxkc<bjV36#^JNb!MS?O1#_d`zSlg#Y0j}C$jT-z(~@0)b9Tzv
zGd!zWuPpYR^K$i)c{h(_Dn<*ezS+CSrtrb#`X}x+V%!^d6m+l3u<iT$!o==G#E&B-
zg{k@0vi!DzpSFnDR9P`S*rX->Qn%vJ=}#^kjPpL6ijmT2omJ$!@|ozdcfW;JU9>(u
zX9L^$3bW$*g6As&xeOxmuJ!0U8qZ9OZ@#y}ILp^)@--IU3vUW|7l>atzE9TN=b4}K
z*AT|Pv1_dPZ$8sB6E|mGr+76v^eES|&xJ3vwYk4YtT@HWrPVJ{VE5wjLWPDuGir|o
zInP{pCgRxUjGn3pCsFa&-9Lg@g?65(NN%(K$g^3<^+(y3yT3l%s%US0zN$#7;K9Zn
zGgwqDLlU)Hy;kUkX>}Jo`~Gd|U&ob>5h|D7=|4%$vfXTa?oe>vweZO=%;)S7%zb{y
zv-<7wuo$^kkvo^KKRdWoq&fJ9-rNla!9u&$lezEkB}b{Kr{3Mg=x?$2Z_BFr6)SG(
zvwr_NW7TbqXUqq3Y6Tk16tB(QC++-a+QeCf72i8~?ACtfjY(&HaW%3ufKT+7%+?g%
z$!~YdJw0_?v4u}AXVXmoS%p&{izY0%vM!Iq-1}_M<Q!As*T1=nrbV4zd*M`bZ<%+#
zXx!IrOeWK#O?(407(ee_Z+m%>Nn-g1i#Ka6^k3KPPrGt%acGtBlbMO7zHbfW+Uvfo
zl{XACe-LdWs@tEm)6humQds8tBh0?rLpzx(#Tp)Zg$8gQb9>9=80s2UF>lfS!=XJ>
zxJ|8}`lmhh-jaVh=Eu=<`WGItf3A6V>7abk(^HFtSl=<uE%s?B=%26qGGNP-uj)IT
z6}A>-`vl}UI~IE<I|qllmbOL)#04idrmb4LJF{YuugE!mwlk~t7Uecg`1I3ky~E5|
zX7(96|6bkrcx-d{&#M!^{yd(jU-xyNV^`%{W4$vPn&<RS1$K3RR-CHzPF6G|vDN-w
ze_C%P*SfqpRqH02ZWZU>>$7NzO?=q;wxoy^lSNXEyqDkHcc$n|>8;#c<C2dHZfCwV
z3vrBIx>@M(%V|xWMazpybXU!g`(8RxWA?r)#rM;!Q=e4&w>}6<Hcxo8;U#PE=N;d;
zwAVDveOjjLmr%KLW@6wOzGuAgQ#x*+O{;z|^D(<k&8F4=UM_pJ+_-+ebk3KW-W|RR
zYZq+&nBV<x%hNk$GY&U<E%l2DWV*WH#OJ_glcZh3wAQYcH}*>T;<`}d$uah=)1<H3
zm^U-dDSG^_>f@U9Ra~F`Y`ptLY2D$Bk2NZpYc+dB4b=Gix|l^Jj^~JX7--}abU4*A
zNa=)a{u%K(BUXONu~|U{5+_+cG(^e1DqJ2T&apP+%E4@rRcvz?+kSmKVONCyM{$Fb
z3~gCkf0tHFyurGOXC_;yt<0l^hZ$^Vm!w|)w_?rThc!2kUfEV4!GF~2zrriN3zCbL
ztbAqAs{TG}*URVkl52kmh}Il*(_U^?<jvE`)%k5fm-?qA(!r^sCeB$qmRSTE#Bv+S
zEv;>;QNPHuMdIweKX)%Z_<Pcj^$*ATg_HlLzn^>WM1}F28@7xS+h_HE+*^OQPjLRz
zw7;+3JKDH;&C@*C;hnJ0&RaR{nZf-ZM*Cju{`Bh6GA`xyI|APydw2a(j_q^DJ&s&@
zVG-Tc=3iKT{4%UPBUH6)-M%g7KBulenQ51N#QW6J2R@zNW*dZB{l8avZ0x$%5I6tc
zfx?OX6E5HCYyH0D_nNiOVzsX&C&w|rUat5p{mlEF*Q@<vTEkad)^u(UDk=)TJbUS1
zwc^yJo%v=C5uL23mt0@g-QOlJ`XKj}o7k++!sf=-+Ri09yBDwi8sQ!umc8u2?gfo~
z84iiODbF|e&wIV)%$%Pq>YnK|{g9uu=)_uV!?U3AK+q_nsUc!~7Cc`75+pRM;_V&o
z>l27PK3ivKt`C}n84N?TX_@+IIr_<oMfrK4fm+Zcj(%Zjeo1N(X#PgO0CX~CPHI{S
zgasAMDJ|BAjO}Jr7G$J?b%KU?i*pi-GxV!ci}F#YYxL9dON;c=GRso+i!&?qi&M)|
z^Yp<JMEZG|d8zuz`8oM{`o*canGjZLVQFHHeqsr9%-98K)YuE>xN(GjlzviCVsdtB
z3E06<HpIzbFM)*#4KEj>3@}%KhL|A%l9H4IHUMl?N>UEQ;Kbz864dD^@U$MvvIfMu
z6%xjvK~s##W6)D8D?@_A?|<zz{C+R&Xrr6(R?gC#t$n2oYmLvXXz1Y4TGS$W$VX_>
z1cyT<3JwxNOf8l3(gWultz5M^Y<1bTubJ8NAI4O@_+Iz?k@24UxA)c8WN(a!-1+^^
z!|mVm-~Y9KD6rUFP=+u4)4937%Pn`FDd*;z?4n;Vwe4ry>gj7z`fCpOJT|!OZuq|V
z;_?+ww?DeS@4;06`I$40l=!C{>u;|W=Fn@uT=VgwT4sxlmWG1Cv3G}S*ZsDiW&i*2
z|C-H54jw%CuH#R<`x_b6i;j#B%Zfj=TX?Q8QSuRz+k7ie*v{I-<i(0uhZQzT2Di>#
zKkxtOxL)yh-l;7&ayhwpyE-NuyIH&ArSk5j-QxO@x!bMHe1ug0-q6#yW3OSO;g<JY
z`d#{VbswPz+2YS$t0!K!YGXa>a`NpoT|Tb=-w)k&Omt6L{MPN>rM&G|4xT%CE>uWB
z`jzz8<H{@x3rlY)@Y}!In7!EP)%NP(mLu8y$xHTsezu}P_hRF^=;WqvdELBax8=k)
z<-6CcSpVBE^2Wr!r|qKl+uW}{`X^A^{+ZmC_y-#bt}Z&fTKxRGxJ_v<@9gonn{yyj
zF^40G(Xjc0(l>#=7Uqo;W_VTzpF5J4Bxu-Optwz7b?4C|Iftg+@X}FyCQ#j(dnD#i
z?+w2iry7qp%4GtlJNh}wlhilPnc@CMeNKnyk(xuzH(Ya6!i407=N-vQ5>E90&{^Ke
z-*M8#=A))ztAuxpAXAczpx+wRmLG!4gdTTh9$`shHk>=dV?s;U43`d$=q9zMj_)1i
z9VSWo%h(O2?4NO-%kn#|aZf}0du$&2_x#1z`|VE7KB=vkds3sQVbk(mFK(6y+5YK!
zICuY^>g+Si49$<_NmXahxxd41c6qMWF@MSV2LE<*o>pt|-(h;O{!z2%BG0>%@7+kd
zUH3iiP4)ky`Lk`(iXJ}64nF4h(`Q3)f!l}X3&AVqSrxvTwbJnNF~4ZLw?DS5z8vm*
z-`qC2>gX5t_vdTveV=H13C0TV6<RNRynFsl&o^0b_5Li|lBlrZl-11mHIw(%7#}rj
z`pJ{`L|bK*#8RaT=Y8||U*tY<E6rOygLCnLxr-L5TW%5EdTPb*s?A(E%i8B^-Y(k^
zx%AEqr_&mH_Dr>5H2;*-_NP&_s?1n^N@3fbwSS!1avdMkPB|JQeq{2Ae2YT$S(9fx
zn5#F%QD6J1Z2mf9$*!U^kLrH#@kgC__j4IXvPuA_;}oTvw$0NH+GIuWa{rjnR64<}
z)J9s3w{?G_UxY=^l)~qWGrcygw9r&Eb)LUW_`LJij;5Wz7KIpVh%^OtZ#3`Twm?~H
zmD*O9$;%s5P6<d%(oHO#ca+gVljW3zy6X%rqp)R6RTHKxJv&iS^d^_X@gv9G+09+Q
z-mxi^J7=Zc#yzwDtZyr8D4XIw`wa%c=L^@_w)dUidGriV-MWPen*}bE{`Ar}Jhh}@
zwcFE)UfPKZT0fl#o8=(Q8@)pKxR%e^2DuenclF$axGYwR&U@ooCw59({UQrnhQ{)^
zpL6aP7=&yrUj2e|>FH0C*fZ}4eUP2IwOlgJmfhx&k@171eczuoWQ05D-}`B~q|Ubd
zdFJfM$MFj1de2UtcItHFhGmDMD(gOfoEj(hk<tCgJiAM49|TMJ)@>3f>Ms>F-`1J6
zdd*f|@t1-t+T5Zoo&B6Y|IqMso9C;4tx;mZl@o`V1^7Ez_KBD8?|8>5>J*T6GW*<`
z(;^WUEhS5B*M|HQS80>k;?po~L9MsFhv!$1qZ3xGnc}_8hChU<d+Dyd@_mi+Ty+j*
zXXBPS=4^e+d22yW$byp|DHClom)<F!%G%C8QF@K&0n38pUyr9Q%f9I}`~HgU{NHx<
zYt|l?jXGF!O#a)FhT28Hf_=<x<SaFNwxa8R?5x6LS4?KVf1Z?86|7NY!L4c#Y4b!?
zdH&KF!Ux@|D&$zxR;GNb+M{>TYwg*vkf!*IG(FbM?fsv-JZ3Mf+`)Y-(O=wT>*+O<
z>uQ*T@2zRNB62%IcwJX+cTd&4q)QFFIu8%BZM|jJyR=&8&!ifjcT=`+-(osdmRa3l
z{vPcuc5BQIZCU(d%g#LuR?XQK8yK6I`F<XkyS}W8v<u&h?0?x8=3iR2Bv(~@QFgzT
zFYE6|fBKHKoak4{XWueiYriMYZuexd8|yU8pGCXWsw~l~){lMsZnHy=C4<zAmAo=(
ztaFY{PtUgf%9+&~u$05=6N8D+#0^b9JJKEPgEL>m#%a#1KcBRdB|}4LV(Aa%d6OjF
z6CY*0p0Tu4<^!+JuQqPpGl_Py_EgvjEzG=szH#z{CG!9ITnkPulD|-$v~|k=KaXm@
z*gcZHwd>yb{j0S7bZqB-kktFhe|-HN!Hw6g&iWj^Ud8!%e(}R>UHNmiXSJ6-k$kDZ
zdx7y}>))hjQd1{AUCVLhT?mKpialpyCa}NwR`XWSFv`bsmJ(P0BlYECNsG=pytj>D
zbD#TO!}^}mJx|AT84E6}W|@Bap^<B`;O$+z_Q#6(5B?oCW@f*0^#3#6WyjTPW7;l$
znCZn8qm{9JRySAIChJXx(n6^r?oolOR9E^;m1iis_(D2s#`zN!8FPEyu)3a%Wq<K7
zw%)7vrO0OK;KOMd6Ib<b)NkjDm0`$yC(w9Rjq}*YM;^5?PDwT%OkT}K*H_;#e$P<A
z@NMDlJ7(`E>9AyoMBLc$XUglPviCjfm?p5-z1sh0%CzZu1$X4q_*?uE@^3!m+unE~
zpW(@+g5Tdi$Xfh9^m51I*hR|(y07eNPGi+u!?MfF&}_QJeB1Vo`a6G~`TggQkMarj
zlJ3B22OAlW#=la%o9Bfcm=cs#yKI+0%+iNKt4w!z-EK~-|88v|b*@d=tll<%z5f+E
z`H#w8^SA2j1-xA*aH#V2Pu}OZf4%2l<81P%YVG}!16$WR9$9rJSK=PaN;AIChFhLj
zueX-jC%mKS@YjdpPh@vJ`*PZ3kB?gX^=s~?ty^Vv?(^FmWZbFp;=n`>_XiD@73G#o
z>M9BZg>03+NYtItueo!nPBMlqH0ZO@tkT(h&${{eirK9`iB@kd{J8OApq<v5<P{Am
zGBfvo);T;i#3t(aYQ@j&pH6w5(th19diQ|7uqR)>{6FhwA5vFwS#9E5oR$2~U)rrT
z<(ktZ?t1x6&lm5_u$tA%r<V~`bIsM}#h0!3!z)&*&*6Lf;Nbj2@jGILtnbF%G?Onb
zF0p?xeS7PiuURn+7bG66xhJ&WUeilZR9IM|!s8tuUz79F#@^q*o9hn>G@6&LukO1%
zcQ3Q(bB1YWl-EQV=tr#l@ru{k>72;zN%Ixk`OQ>UUGKF>)W}g+<o$Q8=INiW-EZTY
zuRoZ*;dtKjZTH;fn0>LUyX$pnn~R(6#i#0tp_P}<Z0F6@IrF-%(pK?B%Zrcu-aTay
zWY}As@^lrm+(W(2(+ssHg5HPsXB5tyX>zHIbI04ZnWlf5w<i9q`>{&+`QnQ^7$)cG
z)S6bTd*(7<B6066?QpAQ36nCqG|YpG<X$YCDQ|Mc?F*~C%kouQPj1}w;7EV~mlD^b
z(@w7*uWOc`VV(YN|Bg!%dwf%v<CB)pzRgnm+9JN@U~729Zdv}!q6@cf1ja4l)fW|Y
zpS4A`VcnK#VcULQd2{orT%kdb%*)9#6E@B&<EU)Qo0PCvtx))NaT@p2gbN}~>?V6S
zb2muwKA015k=1|G(wcv4Y8#f;aP3Wy-><e;Wigu#TRL~uYCY4fv25lJ{i~E0{mZz&
zX%}n5w%Xo;2~}N_J&GE|au&6l2PdR%Dx3Rmt!YhGfLLR-iLm*tZ>4K5MsP2WwKT|{
zw^@DBqtKa=hKsiETrT^q%wEHqKi$hJC7(G!=QG#3hu)t4E;4;?#*DI#RgCv#<{BQI
z5Xa$_!STT9mE?vMXTO!Gh8&x)OL?VNuh-fMYVrrZ#&aw_vFpyAD8V^yx2zuQTOTk@
zXW{CTCKi*;W880*{r&#r%ltbcr?*Tt`(V1^!2JJ*c7C1{eah#lxa22e--dPP{67dP
zGqc*1?wZ@Vqs5AQ>(vDt8n{h*md>j3zxM3e@(ga*qpO_uN?r(^Hfh(h9h(&He~@t3
z|5zSTeK(o;$~mKl9!a|x)TcWB&XTw@GuWK7M(iK!oj)tK<#p*^GC0`NaDV5tuH#i=
z`8{WaT|``-xG+^cZ1e4&o26>rbkt~P%tC)ozVPGC6$0sAZ~B(!)?c@H*U#~7{;PjC
zp0~62XIJ@kTS<A(a$w(4v>?5i@nbRTyU4(w3nZqPZol^IX}W|l&w*Ka=T5M`U2ytR
z#O;{$OjdQrTCb(6I^A|XT=^&M?(<)a4)wR!@D)TpZ?BlY<I49?sk64~M}H_5KluKq
zyL9c}Uem4(Nr9OQUMhT8{Jo7`?#|=tzwSIQC4H8i{?B|ten!TO1IIlAJ6AtFbyZ^V
zO&vE&9k<J#x8whJT-^TuAV=}3IO9tfb(UXCd%UA?dfUSSv#%mkG<;WYSiree^vo<S
zz8y@mc8?E5e^9d*^?ROq;>#D6ShhY(C)*2YnMFyTlQtJx+LwO4v1R+q7u@+D6AH3x
zJWV)6f3<knHaVRYH42O=4O;q(X>NnqY|muJvT2;&wSiSj_xZ)oj^cXZex1$UTJr9m
z<-R=~*_V=1O;?DPnO^%EpTQ9orCBxGWBJ@v;g@-9xV#_q|C#r%ZIYkE{55<xbll=Z
zZmbI3{o=mcrCQcsHU+cW?p?WGbADaXx88fj0WA6fnr#b?ta!4Q^H4`h9MjafnGBW<
z@6LML>B#XNthuVbQ|0m3g<_{v!?O>)c5f2?tbKd0{yhiN+k20<rA7P{a;|Z#;I?8a
zW;H*{yX@JmWm4Jv7JOA#-%k8GDet$`wr2T-RhPca=&70zvw*QLfAw15nDbVJ%<Ibf
zZk-9cJ=tnL>*Ncmaxs2<)yDcixAni``n>DGk%Nc1Z64P!rz~oo*!b(`%bZD}r3Y6p
zoe<6UytG%M`EK^R3F?2?<)5BBdCw$xmgdb#Q>2;sE@!ZcZn91ij<OV=RPcTEuKeF@
zF15_zS^15h6CAEdUQp2OTXD}fe9}pS2669KsYRhO7n)d_?^K*9GI%er>>{Iy@LAV(
z`&F^^_abYGPxlL1aP46!NXib^=B?EzxR@e$W?^oE@;Q&>*%smkYLyYz&l6tioG^Id
zx=W>YlAm^=^_#g9R$Y8qs=&G=b(!>~m&Px2c5Zt3;b>#us>^4UN)uzII7xH2{5y4P
zb<&NW+^zbZ6ZidU`^*wwBs}}R*v^krETU#^Iy3X9Lxkxf2`{dkOIh1CELy!a;CAsO
z?i)!?r<jj@R8C4-a;a;^u3x9Re(joZsvt)@eZ%Z`TJ4{ATYlAF_)1)Fv-s^ynVC|H
zFKT?~eq5+=e*X!3eHIxuyRHWx4g~Dfzri2&{cY>wx$nLF<X296vby+@gUQ~rpC24s
z>i2v>?{bZ{9EZj|Tt=6(v^FuUnYS`5wtbWKPVQ=>uU{v}&)*sA-emnqvUy+a1D)D+
z%O9WGC>QCldWGQ<jZHTs%a@#;!2j+=quq_Xr!`;M=G7l=ZC7~YT+VezSEnZB2<Q4h
zH``01S^rWQZXGer*=!cI^6SnScI6orEc4ud|9`__ZTjb<)`?mbC4QqnLg%JFFF0MS
zCtN#ezLVUQ2RhvKF5aS7rkYF^tGJ{wk?E4iR4-vc=~)tN8T%(plQXPodbVPPaHgwQ
z!2~zUE6dew-fb-xyMC>!s=D%9NZGHGo3<Sac6I7e<jR*kReQKG+OX^QjOITg&BZ+~
zZ*`7qTB={3lzLK!;n1lX)^~e8ibPBoTiSU&JM^U10+y)7i(=wdp7K8+yedXe`jTj|
zSl_N60_Oy(dDi|mF4%b0u>R#k2VK1dg&hz0mj@=ax+R|%dop8c(TT8`k?YS`dpin+
zoY20gv8(IK;jMcfo?ari_G#$E&<Vkrt&0o4HJ<+`x%=Z*i<~Es>-}P8ek+?$Y@pIJ
zLvP)iy-J^p%^K%V3Dm#m=eJ|cs-iU8c{h}Aawr}XuAb$}o#HTio$uAU4xgr*2J!Jz
z!dO0iJQJ6ZWBOp`U1!hICDL2}ZhjDPMfJob>5{f5F_n2mdM8-jHZPUk$NrxCRsK^c
zX`V09tXsAh$k{xXYTr?Fhi6AyNpa(?Xd9XK%|%hS)UG*P71Of&oFR6OeXY|A7f0(Y
z$0y91I&Es2hw!sZ-l_>s>Z&h=U5!+EwokBY3t0VLa|^>R?pN9G@9ek~KVN-Iig@b7
z1C!Go+e1^*-4e9|8lR|4)e`LYGGjV6&+F_Yl{WR=DjbI=xlhWHH%@t4^O@~mAG_#@
z89yHMuKW?nsMjClW_wNic+*Y`fu!1No<fI|_LR4+WA8h#TI<n{J)YOkrTwZ_4*5H0
zX_ho!Z<Wv0UXxvZ3wixzA4Hv~yim0|IOOW&`}}enr!9Gv@bC1g#?=Ncy=Oe_c7#X#
zm?GO(_^aYu+1n3+uL6={mUzt%Un`s$E!?%y-1W#Ymmg*AyiSik#ac|1-SDsTx^B<(
zNm&;~Uo<dje7!iULsi3TgU~UJUyKZCiYqis<jj+{)JzGfUga6Q?YxHZsiLRd6SqHb
zj+hcPA&!BoWx<^(*C+L!zqM?M*5%JzMCA&kemN#^oeqAQH2tLU?5qzv775pMo4EeF
z`71`jq-oBdM|w8B|5P;I8a|owFnW)ueb~=65)WfG8C;&y`TXQECeeBAN}3z|mzH@Q
zl*rbZ5?q$VXyI<W-azWNsL)%nqbKA}DJZX)#j@|#C($`SOS;}Fr+w$$=QMT3q9c2k
zXulG6UL(3Z_|??Vjk)b>&o#ttICxrfna;jVtM;r>vQ}0<tl@Y5{0U~aUE5YJ%3fer
zGe5(;RqS1miu|+-+wLDfwz{clxz*R7G4EdM+1Ex+*}UImo%EIm;rVYDTvU?T;T$~a
zk<jAMOG_*q*uA2wj^4bXx$E|W9d_6Dn>=++K4s~=`^H>}c*#n=wIR$)6dc7TO0+%W
zD`w5G`(ySau1IwQN8{EN3pBN*MbgAllQPyCWhw0SxVl>;jpsYJj!I7w+wA!wV)G0*
za@*z<o-R6Vz_|0wmW7%%!ETHv*mz$qOPTW|Df!SHn+s`MVi;;y)*COK`*f-2U;XfF
zd+ruxZVk%55xc6|<c{;zDgSGa9sZgw>$pW=MTk|V8`p(~iMn$gwYS;_hi>>`8syl_
zu*>Or^!4t~c~3dko^blR+dJ`bO2q}Iwx%DCF4%pM`yx=ocswdwx@)#ktJszhPtzsh
zFA9@Y)sDHfE_)&T^i@UZOov;_`HX1+DQ0FVNqVxO&w_auMBJ@-AUaFcL8XYpdeK$Z
z<(yLswzW=Ddp4uESFCvE4^El?x|>d4OMlrI$MIy>l>{^Wh>w%^)X$P#Klg_Hx~Ve{
znoEDWk-KNsAC`Q>Q>l_m@62wL6ir=tXY-WS1(Vy>ikvv5Z6LK;yV^U7@ou<a$Kz0m
zd7Dk7!ms5g>rBaBwuvQXVItqv3%6r#@xS0+D)=o)#DVeplN51TJI}0zN}CUDy0UaZ
zFh_sDhuHnz*|9cCvEMqMh&N?@XOve6y=i@sUn6!}yN<`>WhugYwslGtPc43I+4H}P
zTbyU@!{sSIwUj6EuV{Uk6L<RT88$bE@~7%QyV|=~UJySx-}#`l1=qQj$Jh7H+I?H~
zfOgyyyIr3vZofRPeqBNO$k%%>H~bGs-Fo7gx%-*Dg<<FNzv+D6lk#Mx$eFzy0?Yfa
zcwKb)GM9n#!Rjw_mUQtn8?21UKUx<T8d)&yY23`7T@wN)T-mhirei{T)J2`NHS0{a
zw%n~=t6?<H=t1zM)GI4Ry7$yF-Z8&(=u)xbW+^@CxU-ul=qCg^%5IzV_}b;xpXpp~
zDSKqj?L4+d^YMXc?lEd2&%fX7>E`du<J<kA?2y=&UxG1z+njE%`#7<$#p;JLzyHdD
zx88Z|x6bUZU$k)9-v8&OueE3X!PoHq=l*|B&Q27bDEfQ0kTA=9>#J<n)~>%5wuA2s
ztMS!ug1eXcB{I&A$(Vg#Y=zas8F9}7l-X_CAHOqrylaPZ-}fKcOtx2U7u<>N&UwJH
z<Kypb;o^E->}+}0?j6=l<DAoTY;pfHtFyP|R&FzqGA=eMK6-uO#O<wDypncLZEbX@
zkYG_`VcogAecj<*udlo`y->dATST|U_2ssISQgY*G47neFMGk~hup2!nhRW8INrMF
z6-fRPko)^)$<Fs%CDta&{3v}n?M2D{lKj@<CybE}6*(*m{wB}zpRa3s^OEAa>@3~Y
zUh*4nls!8n%vaNsKJo3D=QS@J#hTyfG;e&I?Kmk=a=C9Ovy+OVAbY0qB}X<7@ntE?
zpPH7wymD8`<LCUFtaeMDzmMCm7MHk&L%22Mm`K7xu5eX1&pvniin{IJu6P#y-}s69
zf#MGB*WYbkUVa|cc~AFvd70d-P%}=4jq%UFzuB+3EnUxG_D}QK{jqG*UrcVC+s?E&
zxyeZ@<?YU6XU@b-G~{mZv0<L_{OPO7&P)FN{&O@y|MBf-8?^O&|K1m0@;9B4O;&fE
z+^O}?8rowjq<kOht2YaKMICiMy~1ttPR}pCrd&V%D)A`XJaoly@o&oq)ieI`PA`;=
zI`6*Zn(MZU%!1i-1vxK-Y*_Pca@={o`I|3>8*CDe``6I>d~dJ6;8Wq{lPx;4AJ*jf
zv%~~BFIHYL`TwUUYInpI|0&D=mvUcw$BU4-*qN>|ad&3)iymy-*`xWUwwZaU`3?i_
zvQHCBtfwsMkTzhdZ(U-LWPP%4wOE>;@t4)l?o{!8w|Q=6bo%G^3(i7suB`aJEV;L1
zLqPTBtFAYWKG;0{O21|1yQGjq$6A)eYW}yGv)HgX+hj|?0;Z6(xt^vRH6;%--^_b8
zDNg8%q*Sq2SCzGNU!zq*XgF)6@|ibbzB`vLS#*4J-dn5b9_twjZwU78uQT1-svBHn
zS^V9u{bqY;!VHzU7w=4ZaxZ%6vtkF1!yZpe|Jc5_;$&`5d(dZmWLja}yC-#xc0ZWU
zOx?8YKl|4IZ8uLupU-V_&$8S;-}(9TJ8EgH|IKzeHaY*&2%QwR+?U_~|MHG!t9%yB
zZ@cf9{za8_&lJwzk(Im$FK2Jt#xQ5u%<CauVMT3frh)oXR96N~`oOc)RHJxF>%*NF
zA23)*=zit4Uh~!aZ%diV!__BG{51J_{nO-H(Pd9Mf+mJ$`K>xqHFNIN!{;*pKN6br
zZNlxQog%EvZF-9uR!k2m-l!Dt=eLno$WlJh-hj*#%kqROI2Pycww;sooBK_w#y|h`
zsOkf{ziuw`E*4C`y6vd-nuqn#Do!oVIT|;-&R1^|{p7Ok{^5=Nd4IIF{bjY`l5%*w
zZ{gF;KfZqpXKmQ~rO&y&Y|UqhKcAvp&p#-<ctH8zrGpK11@q)=uGM}GTYp|G{H0=e
zr-mwT!xfWnnG1i1`l;(Yus+zcdd*6wTz%tRea!oscU`~Jy|KpPR?WGp><8=l^$&A0
z_$^*|Sm_7fqs4~a&lhB#c=k@qW6o>McXrBFO<_vwWPe#qY7>7bAb(`JTIQrB7yrFt
za9IDjj^TKW#=ej^Wj)Q+dTZFfOg}ztv47!nNt35C79Z2=B0^F!DoR6YlYL8TlT&;p
z?5?ahIB6Q^P8o~2AAdgP<mmmk*>%;Yh2J+mD1W%ISi1Ac{``k`m2U1m?x)w2zMtD}
zi}ag?wo$6bqgHE0OC_IT`m(Es$Hr|rvrcl!COh->JJ-F<v98v&eRrAX55tVP{|~&`
zbN5p9%lmJ7c)9+~pY=(;tjwVQ|C3&WN2bn`vn(FCXZ)Kucfp&Vc?ZHD%D>nY-lWlR
zkFn!&&ppe1+wVRP`J!OKTIGE!iv4`4gVcdSlP|G6_71@=nG^p!KQ6%UIpN6hyq`t$
z>mBSRDtL<GA1$esH*pB|E)?cjvo7mE7Te-g>+M@6n%-HcIwPthz5Sk}@bx(#c2uv~
zyJKr;&9j`(!5?PqQ+;_y(Wvc%^(>~En8n+?_&S{X+O!RF7z0gZ(_hWoI$!L1+106L
zOt-}A4u4nvUMUm$hRNNr$8eX<Ca1Z=U7<}|oRcTKeP+DwdUgNQt!CZ+^E0cM-Zd^N
z3HHidxz1#*+?PhF<Z#truir0u!19yZ_{jNQbB)F>Hyd`BwOl>x@?LB14y_Ifso%DE
zsUZ8$H9dExC~ehTYBzJ~%L_6*t0tU$cDQx@>9ar60(5kOXD3bd)GXS`an@D-lN*!b
z^RwQ1Z<5PDY}b9ZQX|+ev8*g?<wg~0{(`4JPYD?QJ{@0B<l{8S$aCtm(`=inxW8tm
zIWbxsJjD<eWATk`PF3?^6QjvL56`?k(?`fx_U||5>h5-*r?q^0{!BXU@$h#|Y2W_U
zRxbs<9ZC_Z<C5L~Z{KId3Y|ZdR~OIB`<>kXtJ|q*iXzwXPa=-j<8RH%WB&D%_4?Fo
zKE0ToAwAm^#N(8VrzYLcyVk+-@2~%ycjr|MBBTtI8qX~des}mt+!yyG^P>^}&65si
zy#9aurcU<l8TtCYO<(<0%9r1`*T(%o{7?4+qrF-$y>gao-*8%Aa(APm(!GeM`dr$f
z5;yPfp1NwsfqOU3%h|4cX{Tp*FV>hNuPK=G_+jbC+9_)C+PS|Uef#+8+vec;?`-y;
zxa=+{q`=i3;CAfY#wA?4-pgk1<9hM>c+DK9DU5-Ek2V;rEXp=H&DgNfwlTi6xjbUY
zf5+pgjm7R&$F}`lygseG`udT1e1@XjVewP9x!H8=TUp6b$5wA_zj|*_`O<}N-#y^y
zOiK{5m54gXuQc(jj>)_5H~~)e1y}cIFY&FBd>qGi_tc5D^7x+26Vle-TwmTOWcgUn
zctboZAKSVN&>T5v35L0)u?0vT#0H-Z0%8zaml5dc9^e+D?d<F8X=s479>ds3LD$IC
zK*7+!#6rQ`)BtmntGOv?V=8=)E0_z~nFrb83X;UJ#nl{bi>tA*G13m#q|}l`{VEUv
z!X+6XGCQ%LAW=WJRKF-AU%xmrJvULmB(YS#w4gW>v}6LhwGOftBPX@ESRb+kBfTg!
zu_Uz!v}mIwGchM6Gc65eEd}!aJJ{~KF#T}-2>nR?D1tliuq=^4*@Xu_698!i1egzv
z5)xKGfOfSbuYg!vSy>aDdaKMyK~6xhbkW*JmaHy~f~>NxEG%o@gq%{UUbyu4y)Buu
zw`6WsSKsOXZLjb2lKfqlg3KJbM7k7Cz1q>U<H70&dyF5ycx`j=vgH2fTRQqq?=imr
z{qL{W^0DVm7Qg$wYyDHZntLw-ZS3aTC*D2vbmM8We`Z!{X;0_eypzA^5dX)+ligb7
z#Zop+%fFq!>i8DFSqpcW?|CLy@-A<R?Zk5N`TKLuev9>78M*VP(b|hLb7!lc_V@Rl
z?Bd%$PtY{|-kzO--kT<WzAP+Uv?xhPCG+G>PN6@}VOQGj9Ql&c`KEJ)YGh>K>z&$M
zi>|4Qt2`H1Rqw5-E6FR1Tc~1bucc<LX=%S)CGt?LzUK-5)4Cr1N56Y&9I+RDCb}g3
z>9Z%QPrNS)Z<=%|ILJu&(<h;_$Mzp9PPt}JJ5eOG{m7n(Nwc?nefnb0lU)7I;H2r#
zmg{MIMC*Ir->}Fa`SGbmXCAF-@m;<2=5F)z^>q)M#NW-Yc;C$LyX*PGqx&W8*LA;t
z^K|yNPit#yZk#WddGfRG!_4bHo-MBNw!eSu@!3bd4|5-{eY*F^?Bmr<=2N%N6+az)
zs(RjcmG^@8tnL}ztGQ=#uj*dWJ(+up_weo!-E+J`x>CE+|8v~KwU7SxnKy6m+&=3&
zPrh2daXxQ8w|?7qrF^~jh4;elo!*miuXxYyit^8DpX8ne+Q{EO!ftoi{IhP2_Wfhq
zKg-sr=NslpzvqkNt+)H1zxW%6oSbcOPl3;DgV2gEeI`kIACGUWe4N(z`OeP+bH6?o
z@A>~h?`O*nPV;xm)YW|cJdu09cUSe{?~?VKUAFjqdHeSidtA+ff+KrQ{8nCXyW`ct
z{Wc*+Cx3i!`o#K)<>|t8LHAv4#Z$Yg@;Bw4TBdn?nVq?*!PnXDua?<bzWuQHXus~?
zKKajHZ(82FZH-8CexYW6gukErf9R7}n=0}cF1~8XS}*iP@^i+C1)CnadYcJEv5IKN
z2IQ_|OKw<Yw96-ek4@ND`v!Zvl~RbO+gT<BuaLw4LtR^iTfZJ?u>Bx+s%t~l0Un;j
zrLtLDJ>yrYUY>vFDA!F@hciOc8U;&wx)w?nG_ju9rj>Na*R&-dMq|&Gw*G00tz9~`
zC!H$0$TeBY!Rtj%ReJCVrn4#5C6{s?Zqx?64K$AOO42KEVy<{AxBULY)CamQ0w=Ug
z#DCuOT%fec{PNM%J3sd%+}nMgsrn?Fg|qns>57HN7B_v8DA;o0%4zfC64?i$m?kbw
zxbP~3MO!vX(<%DmRkLreW^msBxIZH9v>MCrbzfNzZ*KbY{ah6r>%&POY?W5a+b?Zi
zp;de`bg9+OSthScBiUw#tvP%7>D!cW7l|hyy~CL{y6)WnJK@3CzU+{vaWONc9yz3a
zzji$MMrPJj=`(r9VltIy=Y82$#_*8GA#I=6nyEpZlT%+OvVXiX^G&d=Y~!=EO*Na7
zq93UhRu%clOgZT1?dh-j<G}mU-FJ4#xoDhUH7R9E-tArXPrt6;_lu`DQ>}3K_A~Fp
z_~uL18blO^6}+9&G3~X=0`-)-($?*#A|ESAZvH-D@4<_&a!R+{YW}uh?K!D}Z3fr6
z0{*ARGZY?}I!SPI?_b|co2Aoch%8VkD_JJH>te55>8`5|s~e`hKKbaWr1Z8#gN(bS
zyz8pMC#-t+-g$9CLxu4^^Qv>(u1*pPs!uA{;CtjSYssXk%cdV~YLuv~Qp-?h7SE1*
z%e3fN@Vr15?bGJLJ6_#AE~eeQ;&D{|1pe@VbES?JS~h_pUGw*@Srd|{!>Ah=uyjpc
z=BoF$dlvsz{ibL(Y3?b%dBsHsuV=h!zhCjzs@*T&B&*~}(@PzB5r;J=t!;K}f41K`
zZn+cl@$a(jd^dvMomW<?QIAmg`{G*2i9`Nf&lbJiayf%lP3Z8>UFTn=-Qi*3SkLt0
z?ne`q2|oprPqI55_wA6bX)X(0*zNTAhMCz^-D@v>)#ln2-CicUH2TFSL5|rDPqTBk
zJ9NBhliQWe(wHZjyyS|{G|5>DH!ZsK`nUEY*Dc$=zgfHX|D>xf5mS3O`@7ttCZz<-
zx}v6`C?dDPEdGJoLPo!0hq8)~4^}xiuTAKgHtF7y*V-3yPCkeh|Hpp!=CwOP`<K^U
zc$6H|@bF;6ZX4_7HXS3@NxCb4e0UnLX6r>h;ipEeJrlT7PZjmf(mpnGWw(3R$G5=`
z*BiLbxSP)$_*_bErchU}K-WPQu9pJ!FV1$fJ~S?wD|kfUq@B(bEyq;{{y$%BG;>eL
z(u;o0pTv^yn5Xmys7_0<^B4YAG}$M2`P|&OVj0V=7If#aA9{9pdwA2dsPh`x3;1Mu
z&OUOSe5h8i=fmUupU-fy@fR*(e<L?r+2-%F*dN#5Tv^DitRfP5sCI+6&e{Bjw*smY
z<@c7)P|dQ*ny~DN)6}VpC3#i_)(3wwxIBk@k=&iv#@AV2l)vw)JC*WcnSgEUv4w^8
zySBW0;=}*7^y~kaM*R+L?em)+dwvUE81gmyhzCo=<`<<$c37RARx8lyawvQ2#@+Mk
zo)wlc9nDKv-&uFA_IY45OO*Pb<gb%{y!1bta=h@weuKJgpM28=Dx1%l|J3-j>cx$d
z)7sVv7_9$ZURqmd`$H>&)27-@H#g+<$v1CZm$C*hba7QWM1==UW<2s}hkDl+vAL&H
zx7|D&^7Y{49^tHoQPIm^POV-b81(qLo45D&cP29@O`5*mBf8(cbGGa9n{PHwE}gs9
zH+KhXUa7O+f)%T_uy)wbclmC5lgF(0){4uQrlefW%48F1J`?xE<NL|Au0K|KIr=7l
z_+W3lKt@r<X0z;c)`ulmG=5dRlrFx({_(m<*{Lt))8pJHzEE^o<nFnxZLPr3_gs6c
zcL;vG6}Px=k8!|7o+Br(z0IE7wOnQWqD$9uefpVe?gzHml>OMJ!Rr0T)$vAo@x+e9
zTmBSo-Pm&FL1%LjQ}g;qp_{{8FCEQ}oVvz(d8RtsvxqXK-x9xHta+?`f30QGUJDOP
zVJqXfR=*XiSLbk-{Pb&{DY49G^1>c9@350e<;)Y^&97aVEqje&>n;6Drw?f8-`rYQ
zo~b7geY)?vOr~@Bb=f6O%lS&aGkt8UpXZl;W#$)|Lvg!wH<%xK?owBuon3uAdYcEo
zd0S{paQ@Yf;*1l@#tLUAS=zJ(ExnymyhWnhOC_m!UeePYI*Ts|$}ZRQN%@;t@cXXB
zsTs9J(=Sb^o?Uw?e`9~>-2R)-^S&{+ZPRG%W3if8>!z=LKV#AJ*&Hj=To~Fbo3q-y
zOFkRq^PF!B<a#Ew>ckr3W^tKye$lxP<}6*5bRq0)#2mdoo@HL2-Q=FD$<{?bdAF8p
zZ@ywq+_G8Pb#7A6#V>uFoN_14S=}_@lZd0@1-G4@Y3}@MyAzH+%<`SuIq^Z7jfPHG
ze^38go)wzsym~%3E%D2ol$F~y|8rCHS&fyYX}$tkc^{ozb|@ZN#k|<J^^CK;yM>pI
zn|K9-&YbB#@~+He-q^Zu_GYJ=XT}G8pFPW(c=ScUWwpsco_e*8Z~Lofi$0hvvY~a2
zgm|@_TAtmkuP5JE^M4DzZqHG}CU$5old>3p@5GSj9&u6I@@}@7s?KhlVf<5LmTf@y
zyuaL1-gEa=JU+49;m_AA+&U9IlG~Pt%$Qf3ux?Z0)2E9y<aTSe$jQsKeOTt*#QcV3
zqT1aRcUfDQK2K${&kE+gKDq40gP5}htg9B}Xy>(T=RaF&60mR1vn|&f99VX-+jhzA
z-uUm%qP4e!CmU&8-T33yltjbO(<v{XW;g!ZIfL!btQ5|*CQ|~^rz*Jz2N#FBrmr|E
z$gpU;ovxW#^Iqp^K1=oQ&YQ?|<kY9tWyUjf?<M|P`84t2S?)zYE4uU-I_zdx>$-H2
z*p4K-pz4KJ%eej=`S)b+=?KQ(w`b;j*%HkC?~8WR?ts6Ev!`>0&RO=xF_6FN&+0BW
z1wPZKOZ-#o*>~^E<h**^+5LySM4YF&ys%-|X5Kd~-uy?OT=;y5>42Bk-HzTVf%%u3
zCQc4qfBMaa87FNs?p!R+Fk5#v=HZ3T{r!wKyCr^Qv4>22_;ikN>YJ<L6D^uHM#;?3
z%Vo1JThykcyR&=l7Ta01j2vYX1s+%b6W_Z1!{0mVOkck6XBjL?y(;o6pkvYoNgvmp
z8J{+1m{?DKWbz<<Y2S|nDpC*YALSpikG*@uEk`?Te)Tk2*QZN#B97eawXZm%U-jVq
zkM&EB|7Vcwd$O%%v1{0^b)jl%&!$XhJw8dxFnPn{8@q45e6vMzd6M4y*DK$@T685-
z@{RMBsL87ha|{HZM$EI=|FO6>)bV8*k6!!Dys|)@R<+J+QujFb+-myKXs1>3G~<3;
z-|2bRUzu&%xutQ^^Sp??jmq)=c*}Ln4qUx{s8Z47?PaZ+9p^7b&*whW^g(%1f2--c
z=xYxw7d~Hd@`YvQ+OP3js$;J<c13MS+PQMtTcZ`19Q-_1iCpc~J!s4R_*L2R^%H&1
ztChNLS=F$2dc?O{*VQYF4;^)$l9P7w%~^rWhMEasvRiiSTF|s&a^=!Ta}GV3`<wfl
z+<V)t%e!){gWKOF$ynIm=?|^-SGH>Yed6${I;Oee3&mS9xEAemTYNvVvbDA$>Hg1f
zwx`D@KC3n_oH+Yj6vwO&<}AHiXPDPN(R`C8oxJ=)^F!wQ-+%WXTK%{3^rWu&o?c70
zy^C3WaPm37V+zt=Ps*s;-A~}yTK*wF&oNbLGw<R{XJ#6)P79ekG3KbBf8;^EL*h2S
zxF1w-o4Wmp{2?gvG~03E*<~LrE>t}E8aDTI=El&7lZ+vD$JTAn{CHNxByx*~TIHnf
zsAiAnuTs|h-Y7a#$3-}*_?c+K#R=|>eEpN>U5MVI$3IWlII?+K#H=qnZcKDeOZ=!?
zfB7zt5wpZsqc=a>r0R3F?l5cBZY`}iB{NmV!Oy2Z{Mw?+^M4gwsQCO#{}|8at<1ig
z!YpsE*1Iu#&Aw;OUmce(URo%B%)Pa#F{d_>v7<AnU&J^xHatD;^|a94+n#!Po^8Cc
zP4++A)w}0->m4d3*4*p2<7->a@>5-(^U%zPyIpwl#Ls0hw(fSBy4=@v!lrjyj=99-
zE0(bbzEQsHe>~2r^u>hZzJ|*dEf?8+P$Dy6x&M5gpc4s2v1|4GmHQZ`o_e+CkWb{J
zckdqAFRIqtYaQX}bun$CpUz4BDPku#rC8pOKhgi~(M+l9U!<;<RK(}Y3q1dG{`J=z
z@)8!uF8dt##~{nKuvxaI=W@C0f8Cnfk+X_-Z`|>y<yhW^-3OampIDsQRuFkhDAR0L
zh}N8?yeSu*I^RSpq;a2DI{y7_uRxOXq>oK3JSB3eI>$K{)$iQ<^uJrR;kW2@5erzg
zFNgNo#8{+SY;;Y~m}S_+l5M?jy5(`F=t2h5=DSe`6CV`WPwV}co$>3bv*SN`whKLs
zjz1QDun1hYa)$sHr_7}0gTEZkH~!e$eWPPa=5DdLiQ8YCSiEYn*A0&j)#95UQ}rG8
zx7=BrpV6AOXx)`)m2-NxcGf9;O#YI?zw5Qb^ev7LRX@)v&e<Ka@|+91j6&2a|M+Z+
zMZT*ZY<l<T<=ySNN?e77;$QC-bxsmDbu%pM^b$T%_eSVurt@^(!=J@8S6<w$rM<UK
zI`Z%Di3T#3liJRfrCTR&-{GWgHLGdr!YrE?zinQwT(7eEPt$bGUYGvb^ZKbtKbM`E
zZuZYYIQ*S;!@HKrN2EJzyRYY*@A7`g*Bj<0%4VqWtNBI7i+dX${q1|re@C7FzU05K
zl=a(ptk%_A#`|0Dk&@7XFJCUDdU{TY*rQp@=k_i`(MwOfR??+Bu0g-E|M{F$d4-#{
z+y7qOfA98*EB|x2^^3M$c==az?_B55<adXUi`9i~RrFnV@{*@U?m8=0d&AStj}Lwi
zd_KKyy^v4V;;?L$&(n`g_h>kAfvwu<+x0cMQ*QSAKWr}#Yx#6X#_f{&(}!ZNZ2={`
z_3tGaZ}qZ1Irg1NY4JR<vW1%4q;eQ{SS~I0&CD|DtgSku!?z`<RXA%!_Mwbzw*#7P
z|2Q@8NpijH1Fv<A&9_{%zoz`T;>-HdL1bmkTjhJQ^-sjU{uB(k^I!A-)`PXpOjl})
zdsZx46EtbM`nk!!ykEVJdL4Dr)%mgOJ+U*|zUQQ7%d@BDxf^T$yk2JFdP}Lf>rzMg
zCYQ`TUNQ3+U61tjZ3#DITeh?AKtqo2vD49ci3i@Tw>~TA@JU9sZ29KdKVR(Q_Na3#
zF#a^n`RZ(+RIZ}mRUa3g<z2nOac{ru`FjWNeXXg#lU?*Gf9Ks-kBerATc+PzBe^=#
zQNVZ2_N&HalQtUhh$n2}c_wiu^-{u(17070yx#D9qhZf|Z#lUe+uyC-G<k-a+QSIx
zPPKXd?<f4$^qhO=S4iwa+pBBMp6|RAy<q;2!@uQg3%{1wSX*6IV3y5f+IszL1XEZ~
z$iYQNV@m35TdX#mh|14p(__B)LZ<IsNuCLxdI;a1l!GcO0{<y-^p^aLn%0-#&*iV!
zy885^eJm6IpZvO??a_Sgujd#35zCTl_Tv)1@m#fE`pGJvm6~iEKkJLw@9bfnRQHrW
z+TqJp&WY*e%Pa1$Z#}t*_tH~N<p!QAeoJf3@aem`?aN!M`?nqndw#EZ;kmW^Uz37&
zwN2T#qq{dO$4FA>`F@TgX;&NH37>s$I&b-&wc7=MPF|aMSiO4J_k^Z(CaGc?#U({r
zsa1hIIm&YO^XuQlTyIQh@K&0d|7nB5E_=@CwswZ<?Q@KqKBU;NUQKOe^4zAf`$l}!
z^($9yxNIt{pRYYh@7BIL<`)ipM&YZOqrc5cynFh*rkC#<-I}k5zW%c}pD@4O{h{O6
z<U}ct7k8|3|E^8mDY5L9r`a64ieDB2|FoPBc`zNE8ZFrWP&jS(&xfuL*Sq$mt-hOG
zIP*4R_^;E<ZLLMllN^0!^0=|G$NKF&bB@dSW=q@=hT~BZCoO%7Uc4yKxZrhtlfLVW
zo+_WacdBkYOv{;C_DP~@(?%{|_C@YDc-VUT!e(UXCAMAB++xI~6kIyP#U>#?%gkB$
z*&eZFk{_n8<cwNywd3dcvs+`BAN?sZ=w2z)eT-@9frea{2j6xl=dV9!`6c?!d&WTf
zO;+YlbQUT;|MqH64a?qIUxlm97dwjIIXlPx5Yf`vI7#qCWRza9&~2{p7uOOugjSmd
zXk2dIDZyUUEc!fh`OVC-9-UA-DaX6N)9*IFXq0X$h?*fFD;$366ZetUr)G2AJ+F!V
zJ~F{eWzU&YH#SDA%ysuSiRFt`m2Heq-aJkJ`_-*A`wP!qKD8oNCs2<4<BXf@r^>l-
zvt4L+w`^7VV<yAS{{OVK(wZ)F|G5ACtyjYze!As3`!z$?M)Q&j@>33ZT}WEL$VjW_
zj+f;&^N$(X!KvjFa&El0{O7M6@@G*Bx7npjMgHLjqSDtcS;Hu!b?3veS<}*O7p~g2
zZP%~x-~8{adCKl+Za$fPWL;#sS>wr^JASJtI~cyvEPVAMbLy7&XL>K6=~ufvd9u*t
zr*~F8cq6`byVmcv><{bH19jHD&HJ+Rgjh-W{aL=PKEZ2LGvD%+HHWP^Yj(<^Ex38&
zMQ^jzbX7(}`E@L}a%|f#+?}%g>bvLHeoNlHUAODr{(Hi&WF)WDq^{e>B3?a5iEmQp
z&HQD1Wi435t4<!f`n+`Q2eUW!mo095%#*GXh*Rx*9y;a8^T%ShOZ9kP2AXvwS}%Ei
zMj&4>-^=?p+mXIK*BaB@PrQ1*BrnZIZTaj)cKal~S3iF)J4wjP{GGt!YX!2q$~%@#
zb<>^Vw(kD?vK4z5F4J}hd;4+TpOa=jQr)pdW?O!~mYltI*6b&pa<e~`xyVY-Q;>?>
zBKZG%_qGK$U*7bu{B<Vp`n&^?*`-Gt7E4Ndzuv&BF+p7Hl7&L$|HY<vK7}W7XXpDJ
z3vz8a-^sWCcKS=RYDqPQGxl#ET*`m{AV!V-YRZ~0N5K<MTN9Gl+n)%YKHQtkRJyOZ
zj{nLIleE|*8{XZXk{*(LtU<*mKV%!}353o|xbjo%)!v2sqr28_;aAc=m{t61hv=<c
zGv3GR-8g*NRjs?xyVPgu{l_jBUo7m9eqOz1t(f}vzJ*=Y$;&j)EMM5*)2fo^dwy@L
zbmV3BUOn3>jXKebF7w--_~yQ+e_fA9K}vJ>lZyW;3um<a``;SdZkw@k!5{b9zxx(v
zuqi1?UEg=`Tt>v}vyao}oai%OIrWsF=G(WM9rPtzl1n~(i;MStn|3PplV9GGXRkN<
zey{Bk+OehM=!>)GSzid3#H8e}`Td9K#sayl)5Twp{tPg%*?Dl=s(Xt!{`*pzIa`Ix
z=>Hw<ygxa?*EcWv^Kk0cqi>9YW$(|)K5%T!uHe0Tt5aOLq+O>TTcY~rkd#`ZQhc*+
zL^rc*@WSAEbM?>lSO@L-A9I~`ck7pBC91qkAFnb9nHKB_k>-t3o+`L?4@0xk$}MY|
zf7kb%=Dgo0b+G!!>i_NK89#5u_?j)fu}DAcUC7cIC9im#H(LF@7VGq_%}o8JeWP&8
z>f?`IyFV7JS4msrpU`@Awnk~A<IntKJ+BtmT4?j|9Pc?AU6$*m=xeu2dAr?yv&+-?
zixY0Y66&l|SXlb}`$DU=Hs7W@m8Kr;cPc%8=9c`m_st%ao((4dy_mMVDybE;?639T
zcr}14b7KGZ<1q*Cea`Ed>uz_uq^|DHyE$ueHvM3oXxri2{QQG7`;My#;lbZtMR%X<
z5iMLfBj&R4taTyIrB5YmI2^a{s83mTSlV8!##*^1?8=7y`(F2)ZRKUUX0iI<Ld_FP
z73cf3PkGq;<wVTwl~uvZ*)}<@yq<CD#;%2DI;L#67LuH^=Zp(m!M6f!N#`Uc-p(m3
zNxGA6uP*&x*Y20K?2Z10ZwqHU*&w<n;Cr>&rMHszj!EzIE(^|_kacjTv%OL7RCkHe
zbu+CDS|lVFe{@!n)7`zANtVl6X;=H1XG)vzaZj|{usioo)m(k4IVbi7b&J&>{;#Cr
zuv_Bd&Oh^(^gQ}=XOC3j?(6BLJ3YH+9^{*!AQ60X(w41~k|J^@diSz(*=9fgTYe#;
z=!xA2Uip233wr-9n%4Ad&YY&EIdgtBO`G=XmspY0j5OV?_w!afG=9j=^6;v8dB=x@
zC`0k8D|$=AykBQb`g__w>4USx0g;s@D{bw%l@p%l{J(Lq({t;?J}JAFi4UIL*%0?+
zt98x;$$eAInzqf6sp|du_|_{&K~Apa_ZIU%j(7R7CGAXc%kih5Dz=!l&XwX)N;`A@
zea8}|{<E2fkABU{@w$B>`-FVpy953lEkSF;R^?jlpT@-=nZ{8+J@czo0RQ|8No?)?
z#u~S0RG6(6Tg%xtf6c?iL0`6>2<x7^^{u<&q}r4h-%au)C6u4axh}XCooYBaZ2J2b
za$j7c?=d>_#x%@h{(5%Z+`Bt}|Cc@Z>;BoApJ6YPDtnSv8!^VOyKncqQYVu2?eQp?
zvwdlKi+)X+qrG2~|5vkmVSL|WUEXzdj8*D?sspF4>FfT(o340eLWW<+vqmqUmwVl$
z%}&=v>)K5T&cA$0p-*q)i8)0@r_{b_mho<w-7xo0<hP|wVM`^WLbl%8o4TR-#ALOl
z9iR7vx-Pkvm&7BnvZ^_3tNzaaU!Bw0zj<Vv`mI_LmDRs?=KYW??G?T^n3)53UwE1@
zy4F|rtoYoaB@_CfxopF%RbQl{mfmkw4dOnPm|o>-BRKo;>D(7a&ps8ecsxg8kF8Jl
zxsw8>y-RPX-|!1FTiq&J)26ogc%c5I32zjBZ_p^%_U!MyZr}FZ{xS@YHq?Iol{-t9
z^|EH^G7rh{FF8dew>~||{pgS)vNh)Y=J`2)giRIS?7y1a*Dk+PB_n-$hntnxp9_Jr
zxo<C1JF?m{=d?8oi&VGEkK**2%|#E6&J31IR!<4eP@1h174>W1>8#Zof2>F|xpi0c
z&E4{!9tJEf<<aLh^;*7pu_rg=*sQlRPaf8nd!C-W)9Js($@c4kpCcW2DA|NPdEM0a
zOKC#jnvfI!ripI&e8YOa-PSLgAC}aLS1B>9PkX!kM$9+)MY)}^)1&svm&{xA>m2{D
zjUKfxVrFh#ToLz6OiS~dXyK&~b$j1$tZ>bpQ9h}^GHDHmuE4!t44Ox`ad#_nmc2dU
zarSOs>oo5tew(jms`KwRK9IV6^`W<K-V5FQ9rBW`bsYy!%cVf6ob9IJ5f)KDE-g5c
z%Ds6<TK~h%rvq1?2uuCwczJ`B&W$~mYa9Nk>;8xrU-SCLCBd)Vf5KmV*S0pcJrU9=
zqAk<)|Dr*gjIP|f4U5%u=UXh=Twih6vg2BkdR%w#xlWt^=XDG=7Rk*%a8LW}hHGLI
zT^*gZ*SW+$y|_1H%GqT8KSd#VzZPwOdhL_jnp67zi-jT@)dV+nuAKiQ?%(=@{JUPA
z;Lg~>Zp(AWt@_H|`L!W8Wa5Nu%HRHFv)gm|yXB>Qx*Y0{G8R<Te(!AkV6;XncE^XE
z&$swHhzV|<uNoi{RNrgo8hr7x|DV>qv*(H(zc)YnnNC*j`rNgz&ol)U{h!)hCbL5?
z{>GWENhQ%;^Oi@5{@&Oj%NoCPwp75CdycEh9~9hvEwQ7<*m{>mm1*<|JIC7nH(liG
zPPzZSUsR`OaaCFBT-dF|_ZPC(AHR3-?$XKcoVo3m*lRY1R@i)Xo4WAI5|*<C+p@CP
zyjr0s{j2WLyQQa9q&F7o2mP|rUi0-DLuy%KLB#_$Z!5DIw^!eqHR~1Mw=Gw`v-MQn
zF|=J+;Ng^ea2nh6g@#|B-dL--`^3}NTu)YVbsw)jBDTT2ivRAiSdY+R-`Zu<j_0j%
zJ<oEne8$TOyvi3#+%BBa6M491{o(CTtWu1P#key!n=Zcp#`%2M8f&R)S#d=s+m8Lq
zV$R%|ALc*z{p+0^%R9{<owGT6?|fgPe46|Tg^OQ8Cf<Iwp~Qi88vlI1WtuF!PntQs
z-muIHP(D?f-Xzu06kc%oyYt@ttTnkI0gui!`grKfo4Pr0(uSu`GZg0CDth;~D!X-c
zcTs8k1>0}CoHf|){yezcVavCZ;bIyQ_g3XzX*u-ZtgGX;laD`g-efs1yRdNjJC)<T
z^P-LGa++)ZRLH&m&#*A#mOf~e2KwR0pm~1K>HrHvV-t`(hz-6}8N?v8io-F?Eg;BG
z+u1ib(gLxF19a@Kxv`mosi`IA@(oi{OXMTU!Cct#4Fg=qlN*ATe8A2k&&|v$E!Iyg
z2Az^ooSmCklA)hpkeZiNnv;`SqF+#ynTvWPgbC<sA*2NnU_R7$!Ni|XZmwXUfV?0=
zwg0|<P$9$7{qgJWoIbUpBxfS)cSiHmVyCX1s?uP4+?v6+ecLNV!F7&J)AgoLIm(|Y
zc*vY3$kWq_<!;v1Yhk%-wnzEz%Y3bW;N!K|-#4wF9sBz2oXvCRer{ag&8X0F{LJ>;
z#pj}%#g5;YtKHt{_p14lWNXPZrxnUx_ESV(dh>sqbL4wp@^4ND=Zwww=km1a))*-L
zkgISlJ5baoD<`@0%q-?P4~lm$i){D)Qp7l2L)zZ@*zVdn5<5@K`dfFc@&?C7KfNQI
z{g&tVhjPnvw7L2v$nI$uUKXnu`P(VD=>BQ;oi95#+&|yxcu@QS!;IHVQ>r>vHLhhl
zQ`f}NpgW_LV;_T;B)i6e$`7)u7P!_r#LksDZtUA(RU48nay}z0J0n@SC+XMUSSvBN
zMG?-ctG+fa`p))agWlYAPBm}UTkj_aZkD{c?|w&)TTzDKO0D&A)3rO3jMmTBZt-&Y
z$Sb|gU-x-<*Nfg&Gcqemm((xlVK2`9ENyeiEkI|NK(Ojeqn!>W)gPCNc%9CC<XKXt
zx^>RA<ioy68`Lj<6q$8(S<xYP*?0eiRh>^g_xW{mQiOZ7M*QhDEC2ofb?eCf)F!om
zSC=f&+_T_d&qm)2C+Xf6MW5RpnLgWZ&$u{|v&b`f)4Ofo%F3eF%64bo$TB@yGC@}E
z{~kTtRZcCJMb>#WsfBAy3Gn<nZ9V&)lkJ_AvM=v$Pc?oiaVqQa`+56xo_${0<R`nT
zeBJuXOVTH1%4N#tPTRek@dvlu$2T89ISf4qf)W-eIhvZ8gQP)BGtf;mAO^t<80;7p
z;IHlM8-$eqj0_ZXLHDm(7#k~?8=7F|L32YB<U9!G!tx+UC$4O0WWt4dOMo%x-T?R|
z0WPUIC5ie4pz~?4okEjY204HReCQ11keLkqV*L`7)k~1;Q0?sCAz?_?`7NM}R**Am
zZAfKEaJg7rzr!b&1cv9CTfgiLv0m%9lGRpr`bKt5-Hx#3U5^fkq;RwGa2`tT6cBFl
zn#67BbhBwjt7^kWC&rt10#^IIPO!duEH&!2*%iLze%WRFr+;4DUO8vw=jU^NU$?!V
zzw`e0yVahDZg(qqUeY(xGy1pJevj1F%G<AQ&Urdt{ilHbKh}w*ozL6UZ$4iv@bPKF
z6rq-TKSiSiJt`)rd^y(gL?d*am45d2Ig|BzqttlgH>XWCF>;?aed@ebQ}X<tKG`%U
z#Lq+Il0|6Mw4Px7>26vgmvT3oe_DDw<>#h7PLapn%nw{O=MIzKH1)e{PEB~Kd4HPb
zj*zAcKcAo8X<qmJ)vOI4%){5Hc(P}zbi8%Z+1Nb8Uq|6jhpUT#ppU^3n@87~L=*xP
zRb1qE&UvzD-uG8uX9<Q@b?@C?Y5wEK&nv&~%v8Kwm(4vxF<P8;n&r>%TOJb5qRC1}
zKCgb6w&Heu0Kckg&%ufZ4RSpR4g7pluV}xX+;}L+^~ijoswrx=x2Hc|A#=S?X2;4#
z39aP(ORx2{^XJ|^A7UnTHfn*_f;}^iHck@K$hL_IE#1;;IQzBq*=Gy42s&E_WZZl3
zb$^f6{sYBtb1F+?VpTP=?rnFJznUulL#}f6^%bjTuKFZZ%NuYupm+-JjE}cAEo6_W
zSs;9p&2zi-(;cpV>`EH<X-h}%G1AQIpJlk{c+wu9=aY4JhDA?2;b-nOY3qj0lhfvy
z@H(-V9AcPrC0OsInl8^qjWDCq=U1j`Pn%LMx#nNJI_u1+u(qkCpa1D?x#eY7w0J_E
z;H^XY%Pty;$F<!H?dVO+TzLBHlvjdz(;ry&Upf4^cKZG#J&iJtMWQn|@fNI~Dadgq
z+Fzv1*Vgf(pG*Di1l8j)Ckzywg8m8Jjkp<Zrm#ZjNnOIq^#-yg5)U3Qnk_c*+|7Ki
z*`<5Y!ZSGna~6DS_B;D1u~TZx*{#c*x27#Sc&YkX^bQ7DPkAx<o3V3QBqwCvS$HdS
z&g69+?Y$dT&flG7B-f_3V9vK`@8nXGCsz4Kdi_{ypyKHGf1XQYN7Ps4Z@v}#RlJYc
zX-|%S@#nTnyfx?K7Z;KRlP<(c?OVCC?vdB^m&SkRH;J}=<*VGZ(1^Pvq%S!>+dIAX
z{nIDG4`&?JfAo9<)AmIVcqcDTm-go~td*CSZ}=?|wV{Nmdr{CNAxpN4KeVmnHdTAg
zy))sV)R!RtV|jOM?rsgQo3b(0$>>jDN384a?`kKn?rz|kA-MLePh^twe7?o!*Qo5W
z)_G*UKuM~%WA>W|1tJY?N0l=|?y!{gH8b%xyMJ8a63ifz-mWIbIWvNpm5=?#?0@O5
z-=AFfvvYayLt^HC#YfH;G<v_z@VXnd<MNfcr+MUzb}s09^{DU3>Zw+dXIi&#eqox`
z?-XE`bwud9_l@sIuYY9n@!!{0^RKGtg^zZ#_|XfV3$}=UDX=x*N`D~4Q}Si|T#Gc>
z#=;jprm|a9!}fBzUfDI}g6R2I1ywb3Rcu`P+Lhv(_bqv-e)sB|^JTUX+4uP@BqqgO
zUQxC`HG<1p@!FS9FW$E+=Znl2mfN3h`FF{4@5|0Ryb}51mu^<rwX?vhTu|<C<PVvB
zE9~>Dt5&b$?K}MZ_nJiB+ljVEIQELH>(!2tS$lGxXz91=#3g+@*;svV-c~Ys$GOOw
zCv>MzR8>u#M!?NUd=kz6Rx4gwc`l2SK6PUA(Z9>84OEWQz7ThF(c`>o{$;~|Q;whf
zi?<$DsVM8R(JJZR7QveTY2lQ=m3=!*;y)bX61(=e|LK;cp$=VX6BP<GCpK*1I-$>6
z+gmr|*YfTb%_Ft?PVx&ycHK03kd^oA^HJ~T58sQ-`hCh*rseOo*0mmgb}Tx1E%&AE
zY=)?1pMO={)?BbpI(B>3$!NhF;=earNSwd^s^#m{?Gw_E&eb^Pu6Rv+s(MDZy+(h7
zP~vRY?)j#NOI4iq+Sgt3E3<XY{4ccd@C&=z-(RjBwRrLN%#XLP*FJyprqitbwZ!uq
zlULuGF88a%SZHzUecwMHeAoOoFZ;Ib^Ci<A&UZQY?{L{wmhF-j?ODD3>b;wrm#<vV
zC23KA`3h6W?%jWumQPtZOUTUqpyaj?G3nF28|GiC;c#z>6A*o}rv0|fwn=*qZJu~7
za%+HMi&%;4kLB|Z&tE-5HEF@Atc5c_KI!bg;t*>Z5`Ja#<@^u)8CR@p@1$47$OL43
zcDYfon|0-@BNkiZ9(^i3pIWmwJo4`|i?elg@6zn+n||=`;Ptr-s?CZ^ic%AEK`c<k
zZfpdqqChM|Gc!||DEKmSkRYLY-^bfI)ECt74nkf%Z3taFZDD9k-L=z3hUgVP%Gzm2
z#UBD*GwqX@o0O8MA5feLTK}Ay2R^k8e2^XF$TpnK1N?{7rGgKogPtk}HWSK*n3|Gb
zl9&uWJ}*%}RX-DYVM&30g?>q9P6}#&0DSW#Qhxx<hXy(c{Q+pN0vfFqbJm7ch6JbI
z+OIgFy3kQ|FY9(`tH(ZfxuaG`$g<pF4V<`Z!%3mY#R3jx9M&f%yL^kC<Z$EAK2cYP
zLd|QZR&Mp1x^d~%m5(&m-nzK&;Pk%YW~=)z%g=qkZvNa>{rR2Q-|gOi{xk3X`|o>X
z4&CT@P+(y^x6E>v<@>m2FZP^2cI(3-FZ=n6;}e#|pU^#as`FrH$mD6PY4@J3$mQ#r
z(Yo!Nng?I{>vf0S|1i1s9Y36O)RD1qVpzBA^oW}`Zmrw8Nu2YjW1ZdcHFIi}m|K<R
zdwf&8a_Z}j_z4C^WlN{lW~{hscUW97?01Wx(?`yQ|F0bEJMNkoIMHe2)X#<W3xCX*
z+<)Tw{d9kq3u%cNOV0muNL<42=rJQX@z8>R`4Sh~y|3-4-;%TTxm9%b?B3Or!t}pA
zn^n})v)bZQR-e=9i7zc21oV!?C24P*T%ab?;d~^oNo|?ndm(8K?j*KE&p)j*yw4~<
z6L`kr{Gl`Dk?f%<9#2nL9GF-v($dh{rqEe)uEtL&{m6^h#bS9gK1w~dd91Fs+~-%N
zb;Z#=_fNE@$ZqX>wW!Xx)F9Wq*38%N?Z=YMFC~r5&YzfhvhrwQ+3n<Sr!r<<k}9d1
z{7$3y=ZVneuRSX6Hr;ROxnR+Ib;)#=ZN>{zx@#N)xlIfFZs{y8c~ZtXM@&Ke(|mKi
zy27m|a^;(a|M$;jci`E?#<g=&fq2QnwVk2|SM7bkAm`p^9sFnZdCx!dj;Kueqh<eh
z!-G=2AHuRx>n@&uE0%rMecj?uf!zPLpAfve{5AWpSL_YDDpO6(4jOM?v-P|1s$GXz
zI<qD;ciqaLBYgjD8MlVX-}&~6QXi-P>*+QBRpIW+{p0armADj(XKrzA+Y^jF<gPpW
zsklpOMJr?G>Hi^H8%?T@zT~#ozo;}($}+>kpev|-=dVhQdDk=?|8Bl*F|T<gzu3n8
zpXcejsu)@K?wHz|*>xr)(`{CWz>X7aK@S9en7VB1Ja@=oOHh&N-0o>L>vP#&O?R@n
zKVNsMGymCnO|oZe67T&@I=zAQzv8V$_kEMKotItbGUDUj@GN&(?<YrB(=86CvqQ>L
zo|bU@@b`ap`=#5)Ulkc45fwAkV#1e)nj7Ui`xor8R6ZQDB{fO?@2+2(6V$cu9m|<C
zKRm;cyY|wy{~`Iy&QHsDRHES$Tm65{F`2yG{R_8V&(G5R@lmMcyIAd|_1Bh*YkZx0
zDW6sR=(;Cyg>5PpuS@uvZ9HDI^);CN?{j|o&f#X>*BgpKN3UL)8+279-K_Ey>sH-b
z*ItLOv7h2qExbPcR%PG3J;l1yjJ1=$!F+37Oik$zpY(jy$$i%@zMp(rws{ZV?`>b=
zU&y&`+nE#SwmI(cQ7(7==ZpNN_?U0m{yp^ii>TeFs-EUBJ`9?uBjfU+Q_0h>by8Ml
zozM~I8n2+Vw$E;-d;NpC9T|5PFI=<6!E|f<HfJe*^#jgw%M!lVvld0JKYf12wl4*Y
zE05cK-&?&zz2Wa-w}q3hJJ^<ZujaLI)x7MzfXC#kZ}`4--_K7kkvTPe$`NO_CCk)W
zPTu&-`>C6Y_w*{h$mS_`-?MG(I#G4%jp+4zx##~2-I{VO>R)u!@BgccbSrir;S_#<
zQ@rx8`@;Kw;uikOxv;R(YH$B3nb3RpY7RI3-@<qE(uz;caSb6!=jU)dE!8}~(dR|m
z=L=JPU;0h>c4<-A!M*A#{};Zi-D|zF>CTTUIUat=A1<U!;Jmc2dvm2mbbi($A@jfQ
zh1P`ZF9|K2a5z=(m7AB8n@YyBx|ByvX=`^*V+wH#3v)B`&`xHx*WK3=&Md~X&AQ9{
z@y#1HnvzQ<_@>S|b4qv5f7M6z$9NPLCmm^huW9yqg;mNI;i5|l-GRkFZpOAJ)opq3
ze^t5jJd;^@zgdLexj$lNmMCcmNi|uzImC7IzN&ypv*%9MOJ1DDwJ4b1J)hnF!<o+k
z%Qct22@K&{a+JG3UXnX=X(d<cJI`e+_T+wuwqTDs|L4Z1#a#6kE+6Ba6n41$aQPw6
z`#q)cZn@n%<E1{D+DxlfIz`9IF6Z^*@%bK8T&rp1c4hPNj{nExHf;L*^phW7Nl~C(
z*rmDN@p|&_k8uB=>fjf;_`mbj7tMZaE$_JhOSXO={Xu=A>aS_*)B^Qp-L(q1J6CW?
zqR^iM+FPs~gYN}gFnm&5CR@jT{<sOB_=or;(M4wVE_dAjC+vT`zN%;E?LN7Z{<I4v
ze|X=rELzyJ=|<cR=H)9U9#j8*`h3IYKFd-OzC(!x?aqaaO5*3wco+!WF3I?2WomV|
z^W27B>32_Fg)gv>GX3PG?YOk7(S<S3#dlB8ik`l<87^$*57mqe*%mF<UKrAFLp@IE
z$cm7F$Wszp!LQff)k{-8EAjZ%;V=3xnv%kHWO1c`+#u=Uy-7>cP+#Krtc=Q2pPE*y
z9<AJ|9B^pc>3;Rj`wf<X2hA$#48#u1zwxhPt|jww?wO22dK&sq_~)(B+I#!6<yY&P
z<B>Jt{!1=ZEWH0?|1|xt&fJy3Km5)lZG7AR#?jPv;$N{pw=>q>oBS>3L{=Nut5aLw
zNt^Gtc(CLA{ky6YE~;FJ-~M%Ob7EG`Rn^zuuiswZ6IxMPZQyz`Hz`-<=>Nj^8%@`B
zKi~U3=XY_+r;IPx!%k)<nhP)P)4y}obMJfS>qozKool;x^h;NQdFuX`4R586pLf?c
zulwlyUPP{RZSwu_m*SFEdy9E~-Z$Sctvm06qKe<I#n10qn7bBBT%H^szpz`QyGwlO
zuYCD0e;Z{R(=r&j5~X`hX8b9-`tR_@ICqKo^&av!Tpn81$2aw?FDZ>*m-OMy{tF);
za4rl_zP&*HSAsy*)!eOr->T{su+3`H+SBFiXVs{_RWIY^tCcM#!qbA24eO_@wr|S2
zRG|LZ??Jq+{OxJK8@Mf6ey`)XIcuk&U7N3Z?yfg>vGvBc1inn$^*r$L*Exbeq+6Lk
z_}-HLmXR#)-Il;(*Q}plQNKaR_x~~nZeIhL=$$(*h`u?%X?D=;<hqupzg^-Sd~f#e
z^Syp}(&0zzW3E_#<csC)@;Fv`J&VJzVrv&~>AJRAI?BwOCg;wW5D?e>Nv>qmYq>2O
z%0!%QrHF6kj4Kv9`_@G}vetLa13!yJ)+INiclp^p+q*D*ro(@ZdZ+!0MNJ8x<oC2}
zKVq6vENxr=Z;Gtv`HA0|^|Dp@w#=BW>Gj>u)5HHZW1z#sw|m6*D`X$x;XO2YXGeN5
z`|L#F-~3@azcp`Kv~<U6wQXt!zFeDfmc6=_a65H@T+Oa~-yS<lf3xQPP$#1^af6+(
zVYt7P#mfJ`6xlDtuB*G)VyY`#RpH)sn(Oh54WDl8u@G?bx#D>J6N`6cb-w>pGsUG%
zD|_vy#xcGPSSh*V$1TQu1uorHPM7D^o!i7IS^tHn)+X(HH><qxi{LMF{;m7=DLkio
zUvzEZ&G~O*-ZYsSezlsqY~OumA&J=g1)kagvEqwzCM~T#yq8t!`+}T}I=*6xzU?NF
zyLf^${w;Bt#4hT?|9<zjT<;G}Yme{g&sp_DC*Z=Qm6si?uSzYm5)+*CBKL0r`y++T
z?ELd;pPPJgH~nn=n*G|({l{OLXgCUnH$GSREU-oV0+$2d+Y^juor=A9+7>MNv}uZ@
zrrB+Sdj4VoY1L#s>w{)u4`+&RI4Ll%v^-rgV5j=j%KSSa_FtNq_ZMBP`>PTw9jVOK
zWv9otnkzpe>}n?O_iq2g=QmGZCi>>5@Uj@&{3P+Yfio9Q*bvT<8I~q<&)za^rc&3p
z`$-ETCnq_?9f;#R=Uv)X_)4vRO>5Q(##BGes8#k^ongLSMM5{vc|Py@=CC7?K|6m#
z?~8`Zm-r5gmra;E`_8vx){fuTi0!@fcgf=#%Pz5=MfMvuZMtl~boRn8f|r*(W=*MQ
z*!L!ilhI3SOJ@y>XJgYzTa|4YCtb83&f+=yW!)FHR~q_?tSU24or#&bK+}7+#_`Jv
zK|3G5`Np?h`}jVer7<TJJYvqVw10}4ntb8ty7mjFx|C+b@TuxHbw9bz8ZKpZZtiZy
z|I%L^cK$hja8FF-JQ=PPi%dGwTWsnr=I9-+pOm=x!FL0}f8YFyvzrVSlr^osZ@Y1}
zpZ>&WM;v85j4x0A(0u<|blS2_4kuP@iP1<`EBkb+STUZj>kQMuB~$+?_L@x2Rhzta
z&-DP8(1qRGFSuTdJ*J;|al*Gt7UfPI$1+M-^qu7&&aIG+YqUSI?*{wYBiAytZ*@*v
zc=bg0LHh^nUy}BG&^zVW>QV6iW3b76sppSs{@mLo%Csdk-?_W_L%?PU{Yz$x7b@tU
z@7Zc-&AV=`!||?)8{21G@!f4VcV^n2Fw?^!!3N34O0V|JWcirCQJJR;)RBbtNZ{97
zf;uXo?v1gL0epbj6gKTcsG}L+;S?AG>S+3UB8@QX8ks=0=~^0^QMadQjDMFdXjd-E
zw%cOxq32He&iWquKKh{hEJO6e2<)Ooy~PrI$hamKc>2mM6Lh7mDQIUiat9H_2ZbO>
z_gET(rooWMpw~vQmqb6kxo?xuQ#PZ8OuL`%zs~8Y;E?H|$r2PbX$p@}y2WMfk3oCd
z+fq+%Q_1cRua4f95-s;>g1g6?9Q71-rj&^$7sPI<*vl|&nIre>WX$w`^WOwS)xB7_
zd~4sijj5jB_rCwV=lqX|BTHDCjwbou-%<5*neJ=(_=%G?rFs5oeR88eVq?2d(*MI^
zM%VP^WJ7)5)x9{V{C(lOn;Fl2zFdwxq9T_4^wyU(qM}oS90MH}YW%z?$~}30)w`YP
zlc!Jp$l_XQ`Shfw<szrJ$Uct$fwT7PR9fGmKFMz8o;6!cEKUD$CKhS=pAhb-{P{RM
zHZU+OQuPt%q+qR2l}$zSG};wjJzqb0+H>9YC*$`onlyc1;`Rj&5gJ-iv7vihV}fF5
zZT1bCw)@LZ@wCm~Hu|u9OjeqE!{JX?#f%dQaY}VgXOztZwL6y{QA!fsI5WaGNAa3K
zbm#QW)+1&~x*v^`tT*=Ea9kpAx--4gB*}JT(+s~eDrpbbM>SMC`6#|wBQC6_I%R|K
z4R<w8_4BiB4ro5vW2;(zsxrvn>%EnGzw7LKKDnCv-QOZBLtCrlk3HYh)6P_tU7No7
z=XcwJ_}hQ?$X_W+FS=fIdZ#Ua&VOm`)Yr!(>%Dipsghr`alc#S#v?b<W6I|r{mnQ*
zkiSL8Eq?BfGZ{jcwJrFYFRWq=isu%ZDKE7+Hej{+OrD}yKOaWS?@ABRZ&v9{`ZM3R
zWX-J0d}*7tpLE8!N*{FIb+ycQZ(#89g<SK_q^TLMZb*6ee1#4hgZd5~z3%2Ctv>Zd
zVv}V%>o({MEmmH0&-!Bbn+OH7x!Kta+!iOlWwkr08-08_C2+acg-&yWSuT?mfB$^y
zu<SaIjK$q@?V4HNwnX0*Q1O5B>Rgq{^qGqTEWhgQzxi-ukZirgJ9!492Vq@DvL?ED
zJwLbdCgaQ}hqnJr=li;~<+jGnv{XC&#TMrM`-QU_($~JT%iAo=z<yKhYxiod>`TV&
zpY`h7mi-a)eZQ<=@2r1SPb*fw_}u+XJ7-Ggw1Tya=jE~&JPb8xUwl!y{o8)dCl1{f
z#ol~}CoZ}CDd|Gf93R^d!#^kOro8#SVy#qb;9`@2L(hvoRXSW-W&3c$>Z_Oi*uTAT
z4}PFhnfv=d*YoYmKcCV(+ZnspdI1B=qFX_U%Zzw?o*cP*(`wF?_Z}b42uzUWbDSEY
z9w>g<t@N(j-Zf>tZTh#DtiR0V;NRtxRd4X%v!&+h!&lSu589^3MwG-zI=+?v;u7&e
zI^?sU^|!}2{@#h1yGLZz$xnP+@7pC=m*@HZW=qp^e(3&5SUk=lXUmWB`cJ#3`mMc|
zaN*U8`SvG$m^3FuZ(e-;yLo-x3!A<FpIm&P{h+ydSzl3&<hMC@Zwk0RS6ab;_|3KB
zIbRN0-{HJ6A%1Zh7rSkH+M<>6@v-I41oeAQT(ggBpZ#R(Q}G$UHJ%ywh4kHj*}QE1
z!Rx0OzRMWx_<iPD?Sz(Rg?5>-vwxpi<a&lb!|lwSNB@)$=`DQcvZecT;`v=?x#i=J
z_$>Z-xBgd7_ok;AET!?u3xC!>;Nz*<Yrekf?sUKMvOQ)0rV2kedSYwV6t(2JleEsR
z3i5Vj;tDS{-oMu>g6YYnEz7lh1Ma`rcw>**t^1~LUbY!*$-Hgi{59{->>aBXJraLi
z#8up-_4D+!=}Vf0{Lei26tTw7`s$s#mp8NTKe?F8v&y@<OHbkdAE{YaA78t1<*VD;
zAb;;m+d`H-)DF9OI>s_i^-81AVfWmg_owdEHb1`MyoXt5$HBg@{dNaUqu10KOfK6S
zy-?p&!u3j8?bN_brp!re7;D-cS6^DyU3xX-s&Ul5ACaNKKR;CMY5#7-Z)EcM#o_$C
zA75XqyUl7YDR>&~W@E|mzR=W^-((J(^ves@qFjr^7A#GPR=NGTQDmjl#0gikzh2h2
zo3O2Dw}iQ}w@JyHfamd1-!I2L@8gkW`Q((b(@8&K#na25d<?WUKemY2UHX{idXHQ3
z^qu>Z*XD+=S#td82kR2OrEW<Lsb7L7M2A)g^L)+PdH>0>^O6gNQWh}J-8aosqS|ue
z#bZvd76`UXIAZfbR3j?p?gHNa%@dV+<G0?Lu_ScHlBnIclDVTFa{c9F;mK3TW#stz
zN>^&vftY6vbsM6k5A?|Ov<jV-xnf*)JTlv?N|AGa#%9x_zyJK~di?0c3*|tunj><u
zGPQl#+ahHW)aOR+c1t!`apj8l{(zs`W7C&C%6cVX8GPu9!Rf$9GGBtfC?xH#ejI95
zb);Tmaz}J_ux8J$D(0!p-(R@<8((giGrvac?~d!;(;iKo<r`o9ezWa+hR%1^+a7Sv
zlvD1V_WR(o?KhgXS=_ZL_^Y&8w@Xfb`J5Z?q~9c;DOtDc$cl5!L2c7Lo?g3YYo@)&
zH@;D<x%g3<bjpGg4DGii_uT1ScBwAV|KRE$LdF;QFT|Mqzr0m^THc8hy4uT+P7hBm
z@tx3}k^Yy@;1Bc8AMQ=dzcJo?C&D?kYGI&n{K}`dW*-pZcxP!Kb8JbK$&`J?<)KA4
z-Dd4KO%7L^usSQ>LRW14O{x2v`ty_Kx$IVcq3L7ve!;iBIa69y?u6|~vy=Pfy#1>V
z%ZbUitK!qtjP0Y(>@oTOM`%ie*xv8Q+wu*3cqg1*eQy4nGWiXr7uRuY7eD*s{y#y5
z@9$QgtL}+pviy<6ncsV^squ!mM55_p&zR|_AF{~53~g?ax_#tf^T{PsbJD`pW_@wf
zec`b<^5TQ7H)hFRN&Ir5*Up6bdzxhWo3$HfL@mAAq{R8Ya6;G9BC8GaES;tYxGp-|
zfAxgVEZ;iGb!Sr+_53)VawI-IB>Zhk-Ih$@%@XUcM)9@%ZgRaTVar_|@gZ}~f9G!*
z**TWtx``GVjg_+|8agc#v!Cz6Vl4VsrZa$7%kk@#h*vj^@BH*$x2Rp3Q8}4wmN&oL
zj#^$phkqZRd9~eBN)tPqoOWS$*uR|P#scae^}SzhEMUt!=Cvr}-C2frpJczhlP!Dm
z??%kK_Bm<tZH+QnFOJSRc6(m1+#TE1<_|ts$BOB*EV%d}{B=)M^SOY<K^}&$yPGy$
zTX*i;KWE8YN!Qm|^+8T6T@u!$OgbrUc{P6G*VJ=e8(mH|?MmO~IEnFy!bjOJhXmev
zN8AbsjnsSelqX!q*8EG=?)g#`$~|e(HXohtueMs3<LGYxA^Gf{%J$xEN?osIzwuRn
zo2`3JZ}Z((dH1hhym$L*I)9UR(=s;KZC<;jLsCM6W3$uCU*BuI^zTY&q_y_Zkgroi
z@AKYxzq;-3Igk0=@5QoBz9_v@_!X*htapQ7g5A|4YQ-P_Sv)FNDLm;Kv@*hfC3EUw
z>0_Fo8Pz%?4+u=(zOS|*zB+u$y4dHEYht74FV;M-e@^p3BZGZQ+QPk8pJz5MD`ZyG
zSbNTU??U_TXL0-L^c+40vV{i+hU!jRVX|jajKb$ri__b039c?~d1qUyu}l1fdGqOz
zEskcA*UQyKFaQ0=e_>Dj`_2t@<$Qm?*jRt_$dL+PBJS<z;8pwSnnVBh13#zV4xS<Z
z%w{8VdD@01F7Meq$EW<A73_6`ug0^mHD$ZO-H`5?#Z!GZlplF?r@egf?n^6IoDI#n
zSuyXsVw7D+8sFVGiCb@%7~T2lC!y5rn_si%`P8a91wY51`muj@zgpn@c-iv<--YCu
zB}#+3W?Fx1+sBtZLv!UaN3pD&4?kiH^)F@T^WFEFv%#<Nazf_Yx4-ivm!G}ea(mMw
z;V>SR$CuJwFMdk9<``ox|NfZzoD1Q*H+C2|JbTo5`{0}_L9bV8UJ7})X8DwzUn@_=
zd@Ag7sT2Rc-SS3R7V9df397jkK_!3mpI?xfAD(*g+Uzek?uDf<`ODS4D&nHR+zIYA
zPZuqI?{CukoALFRqc2p=q$KAa$z7W(^6_+QYH07)hkfg|<#k0G9D5eF?%?cilh*ky
zZ;&#o^*{Kr|NqZ8SMTCt!@Jrd-_Dt(U%2mFZDl+6-fsW$8`ql;mYJ-tKb~yqv*}Ov
zd+DDq64K2l@XE!uUQ!93_HfgU*6VB=Rjq|xZD(kIKW6u|DsJNreMZS+x(A<xX$wmE
z3RTHIFMLqH`}6$+5^BcREtXF_W1CPI-@4@4``;(?Q`q)~zU1E;c}DS9={eaK9p2Ly
zCno8!X+~saY&@F5YJNkPZ}VT>D>FOR6`q<|{b{DFTEJAV#OBVB6aUYy@64_~n5--O
z@9#6wvNv%@9=%eTsU7COq|^BC_Gtfqt4#{C>$lV^`F4aTRVvOkcAv`2`Z)8^t%IA(
zq_57Xbg*J*SJ-o1@`t+g(#P4Fm9tDt%MZDk?))wDcFSVhf@@-5cxK7ITe0|ZIfryx
z#l4B4D_dq+)cj`S^a<E_zkl(GFM>i3C(S=(z;(5?CG`*2J{5(`*Y7$?0(jo9KVR_r
z+VcH-<gyl?OEdY-k~8;#-0}sVyc`Yl0}5Wrc-?4TRvNthqIlT+qpXcfgm=f?G*N%5
zm$o5?eNM>tqZ21CcG&hK<){&J-I1ePZwPPCufKV^>urboQO3=zx0_zivH#t5ndMf_
z<UX@&vqLPVpSa7`e*GCo<VwFSg+<LwORn5_Z^>lP<hEyC<g|<{l2;a}UiDjhI(wtJ
z<%-}JFZJZBm`;RS+)bN&Yr%T6mzipXYeJ72U$N)$RP~xL!{OeQ%8Oiczx<xV5o6@i
zP;yk(&o+eXYQn?Is$qM1HzXU~UQ@W$bH<#~@_pOaEtq4!G5MCn!Mz)WzZ~MS+kb6o
z;p&wIrOvEVCPZd$$eleYR-*2$%XjPCbj|qnS6h$&d$n%fd!C6}igLSy9F`k@f7!io
zN=n4`RsIW~-*-^H{@7*b2k{x}FMfD?fF<<M*U9Dolvlke{%UqZ<9xvJ=l2#0-!fO7
zAZ32UZK-44k!v&V?6Cj+CBWVPg#T7vvw25v%uL`}8{&V`_~+`4ijT9St^cOYxAjR*
zzuj^4>-Nu0)^nQI*4Enn?+oYXkvrD=Su*C-TB#E(m&2=eulKi@ur2fVx+@`B!K)VR
z3lq+NE$;OD?zT8r{aDA@h3QXU#I9R>*1AS~YipF_w5Cb<*S%i_h1$5PO=&*2=2+=0
zt@-hjw{QOVR{0_K-u(-0Wba$Aer~UHmu>fnpYNx}XW6jjzgesl9UshdI9H-d|Hl35
zh4Qu>=_l5wX&0}UYjtY%8!-o~Dd9GO8}}-$-C@9cBG&ccb?Z43+a?!A)g|(kEnR%M
zpyp7Pz>nt_1Gum3=6#hv^VAwc-esGuY^F|`IBD_Whx@|xMSIxJJ#cwoVDVI|neVq_
zvtQPV^|w_{YBB_^;M`ujl!enjJ;lF7Z{7{LuCven9hZFbe{%cYv(_!EJ7-U`YTOj!
zzBb8f$A32$Z;iUrfICKBiGdL^*2itDYWuVG%|4m&@9<cCadp5Ao(*%NxTl8MPS|BN
z;lYHo<<`A*svZl&RIjg`DV_Ya(>p0{^6eD%>`C?l5+8pmrWjW|S!J`>(|7G-8`Fs&
z4Gug$B_LtAn#Jtb<c;UoUQH|Im^ABA<56k-v}mPw5f99~cGh0MT6d&RGMT@){HpZl
zjqTlsw`^UX`Qys2V|Qonc~m19T3S=hA*_8k>in5?9n7cFH~wBz^5fOb!^aJFw`g&#
z5{-N%6crq|H9~!2uI`D03mEM>r1w3H-`w}Xy^sIhTi&3xFWFt&3-uD_x^7mkpPsa<
zs`S-0Uk5Sn==NE%i9MR><*$9KS3HdP|A8?_*=m8SnE#%=;acixcE2u|^L4I~bDw=Q
zd851joBnU5F0nJtv&~+;sU<4#uV2*R^^t4WuDLy7#p;Vw9-jUA?B?0~e=lv9HT9jC
za=~k#BlD#EuioB87586G4_hX-<js;R@7M9>wd+L0?@n!fmgA-(%;l)CPE#mN>+*l?
z<9_KT@9S%8K8hLLOHe-i-TGj_vrN}3m(R?<;#$F*J?YurZ6B}ypOI#sF7B~vMcYQt
zJ55a|uKGpqesA#hO_5tntVK{nP2;|W%(l+=g(3=l`_Ifinv?B#T446qz?NP!mK`59
z>6ogz<{L<TWVxcZ_VV}L<rl78Z~a{^8WtWB)}qCBn~66q>(S;0`}X-cTVAtlU%zPU
zCYKZX`duNV-?o*O994bzPn`4EtxrdvrHLI8+nBuPqHK)&pM=X^zoyDnu8muGC79>)
z)AL)6bSAf{>~w#bzvZXR<BRiuM{oyU68dd??(hC1hvZ#iE#};qwcx9DAN&8%rvLYf
zf8}*}UfF%n#dz}ZZGGNT3_UNb`TBMDB0FtU=Hlb}(KGn^ub)obWE))derKV6>G>t;
zvzPn!-dN_V-0`28QS?kQmO(r4;1OuZ$;8YUzB<GlX&fq~vLF>aWCdEcS(I5&l3xVo
z`X%P3>N|QwhB~`wJNvpupezpo4cZx-S}GVCTbL`D7{uzk<s_yTE0}QUI~Ic$Pbipx
z)>*@k)&ucC#zRilGX^c(#(K1#k%0x?<sk*IYYdYz(;<sOz>79OJm?}0(1H#mE?l}S
zwW1_7FQqs$FFhv}q7|gn3B?>Z4<wb8nT}>hI`X}QU}>nOFk8~~i%WBJ6H7Al^HMU4
z3vv=G^@|cyGLsW?Ku&@(oifu=#t6+pw^AaF5rX-k2qSHb5VX1#d5kbOIM-)#xX8Zz
zXs@eHkKVMrUAi_$&p6p_)52?+VyRh=Rg|NQ&MHMO)L%OJ{I&%i3%8YQ(O<3`5v5hq
zx9E&~T30l0PF9K0$v+BNX2OeSpUWtbk8~1wT>CKW?popL6aMZvY5Tm+=6vP3VhI&N
z#kRzt@GNujXM4Z9#r=EbYuPO{v+~gCo&#MiK851HKj_TfVmfWh{Ha;#+_Ov?=W3ov
zUug16XszSxi|!{n)|}|P707SZ(zo#Q3$9<XwhsL>C3}?CuiAAl$7ovQ)%DMH1D<D?
zcwf=hw%EMVC4S|(>(QroaP6JS_ViV6sH)nzsQm$ZH|>eptN8KIqI(A-EsAB+e@qXH
z3w14BJJopg=hZxOc5aHwf2MVMXHfRWlRrxSi?p#FO{+Z_cJ5cb`{eZh^;aW~=WZ{W
z%GSN|Qp7pmomn+~+fSuzxe}&Q5gsb#GwoGT?caKZFBjIBt7y$SGVjly$XRg?97~nl
zzBE<z#TaG>M}2)Gb!3atfeK0a$LY6bl%<IaCs@r;5Kgk1X)tSMfR*Ib#iu<IR%O1j
zD0Wv7uRL0OB<^G7Nv+PuoRi}tCj4r#439W4>6eCf=F7wflOj$edTwUARU!ZWeo@Wa
z^;LV0R9&x>|HmL>*?v9Qvd&O~MgB+1!nA_hT=pAGHJ?wOQtHBegh^#}f6l?;lU);P
zpWL-o$bQ{0A&ZOSTCC9Hhd(k|ALtn0b9(kjwC}?%?XL>ig&)u6&0l_YvDLSSCpIZR
zS-ZEpY5gIminEsc(-_^au)fc^^`eA{f6p4r1KZ2_=f339e*bWa;2PGPiGg!oG-@2}
z^zAt+(a~8b$SV>du6$EC*}~eb<kA)OMYD5Ex28{-yKP6i;JrPHV&68V>}F~?Bjf1H
z^yA64y>}))s;i#S?l$4(+y@2Qch>HCHQ{5^Hzr4m=_PS$;fm`RE@i7Mc5(L8QIGVV
z{_5+V_U{eu&p4cRoMyj!*Q-XF-(H~0;eyXYx1Ajymva`aSu+2HSHZW(hLd6^`P@AF
zr%)`_{K%<yyoLrU$Lgds3sO2HGPtDMJX)?z$cX*(e#Hmo+?x#&;wBnO0&7>d=2}nr
zIPnSFitcYt=bxX_ynpd}Qcjv-kU%q^`;AQb$sK&sLbF8l_MYrJ-@WOQ^q1q>Ns4Fs
z(zR>WI<||a><y}KH~(=(Kr6ZaVSt@jprl47!yBfB4Cjx<TJW#`_WR)c4Xxa7d~Hmu
zr{0t@4P2{u%->_z)F(`lY)1?o7Fo34_$JLK?woz%-qi~a7u{0%dbQ@fUq#-=N!7<C
z!iwg<6SZKC_cQY5U4JIpdy@96D6uO7vL_xb4oaN<A$`H&=k4EkUODgA7SWgW_ZHtb
z_0jYPdC3#(uhwKA-+H!|SG=1~Z}L}9PcFL|M<yk$6pf0uoximz!TOEJzM7C}a_{^4
zE#F*VS}SSYyusblmAz&b*T-**17BU9A;v%X?2c`QLBD!cU)?(DEPO)d{My0|Z>GG{
z5lnPhah0Ki`%!ksoHvS5pX|>2&r;fQn_brNY5aBhq^qhqGDl|atuTBL6Zxv8*J=V^
z`)sMA%0oTu2VV2mD)MZawCl@(cP>*moqM)m@5#4!ZZ7J1UsuyMgGD@W<!<RZtEnbO
zFBLf3#2v8v^YbRpbh&GB7lP7u?kE=B$HlaE*>?H<Bwo8h-t^f0b`~DLr!g$3&CYpp
zFfDk}?Gy{`IF>@*BgXHKT(xlU`xdcZ&n}7QcI^e$P3s(zR%yO2G@bg&{M4-jef%0H
zt`({WPE-}VeKh_<pF4AWqqx<#RF3-_FB!kRdx7m<kBg{TdGO@unY-4yd$BK2|M}v}
zV&f^7RlkOQ%G}rx;}_25^q;|A_)i$N+7(pnf(mOxW5n7^GuVPmLQ`Vyp>83LPTHVN
zPsp{afr753nSp|ZDLHE|EzNN5eKImfI;9q}_X#os2CA`Bi&9hcb4zndG7EAl^`QsP
zrb5<ACKkc!G5x&6q?|;Q`pXQo>jbI(0`oyZLR$R=+NXkCf4K(u`Uocq{M{$!9oUqy
ziBr08x43Wz=foKvUlw&Vx~NJuGH;U!yYXT2rE9qx8^pFnXVowBj^4E<#Is&Q(ROA=
za+1lx#pU_;Y-URAot1xG_r;{FGjr~pnf?74ubZz}i(#I$l(fv-{dIK-6)AhZ9|}Ca
zaPGmV<*wG*t%n2u&eoH?ef8<(BjsHM>L=Hhr5vvKu&wykWBCuirnTIBIg{bG>4mf3
z;`ZG+{_XtdLvK``C${fAz+-=&)#pK)`<}_0YZ6wrzb)T=v)Wy{?wj2E=dJF4LJpT7
zuznxS@qx+u&D=+<=eHavR(m9`SCH2@+e+wT0skEtrzGQf&SIz3O{QMF$0ww<;+L4Z
zpwI=DTh5_#jx+?H$a8ZRE8)BA==g>C{_)?_rfs`F<JS$pWA#ZtGF2C+%w6?MTdx29
z`;Q@iu4XL_N|h2x-uoqcNyox8Rq@ikQ_hMKEk^~4E0$WabRSg``J{IFR#KPlb%Tr}
ztI8**YQ;As6$(1_{gRH(5NtZg^hB0-UeKjBUq{`Ht9mo{9r27=rFDA3;!saP<&85`
z4BJkx;d~@?wMB-}N@m&-536M!e2+}n{SHg=9bYW4^r&y9vHIy%rv$DCO0GLwU^b8S
zSEOHHF=u4R|5;M$*-Mr$*{fsb_eOcXrt03Ajp-XymmZ$^%kE_Pnj94czOukcN3Q17
zXurB}%5BxY<P$+YT?e^zwI<D)rnuVZmiFPV`j3R&_oi{P{&#;Pzq{JvR>iEiO<7+K
zmY<TiVwJqprHuE5g^EL0N$hKZr71#5-?o<M?9OWopTWQW<lkQbW-98T3*sB*+^bl(
zv+nMT6DwAVq`b*;iHz-Czt(ML+wmCB{9i3!C)Le6rJ>+_YF_uD<Yy0-y)6_`^7KeK
zlV5AQW79?@`@3va(ofDDn|Alc)!CYF=bpW>dcXa&En9V`d|jP7`{KOJb+Z49nk?^K
z3D3!0X`7$x`htIvYy28)MF%LwgYt>FkpV~=#55zeUG5a(8Q}_=Ob;>xH`c*dkQ<vR
z=o%R+m>HQVm|2=&w#m&bQ8sIVxrkP|A&$LTmd0pJauY){q;jOBJYT;gqbN01KLdRO
z7FxsB48#ZdlC*-s7;U#?ZC{{=a3aI;{kM1CU3uE*c5~`>?NcI#1&w}+F3Yd2QO%J`
zo5;6)>CT-S&o-`nIWy=Tw`!n#(CsMSIhP}yeOPpLHcBmR<4-i>S>uuMC85S#&tU0y
zx%v<PKmSftXks_u5q>6i+WWKqk`p4QzQiuO;Vd!xKr;X1$J;h2#GLrv`uO|eH4#&`
zi7$P_Y|$nv5;sZG_v^D)*`Z-pp3{7mr>3P{uw+}ib5~HTxAv85T5BD1?=sr1H3|#M
zUi(%3rOe)WVejm8wghEgoRu4Oc3oha$&6QPqKwxXWNmpC#o*vFHMEF}!BT^<@Bzbv
z_byCKTbfvPq@(X0o1=VgM((}EzUp5#GwEy1KN!~hB1|BC{zA)({#RWdP29A()K}z|
ziiIb4ytB^tEmJ%Hmk5dS=qxaC`F{84IZX@J`*&Y%om{u5p>cB36nBMt{hj9Te_!S5
z+WaS9YIARG<^oCi?%xxyG`2QreB|uQy2&Cq>6fLZ)q3F@s-h=5x1XFP@LZv9os`)0
zv}e~=Sl)G2@(*7;`QTReD}ME<O`LVE_XTf!NETqc@|!!oc7?|h;Sv+WPsgTh`=)b)
z#dDp9!JDXg@@2iexh!rra_5ie{Bc+m(YODQ>=T#Fmn)Y}ep}n$&VF3}-j`{?>uz56
zpRTa;>!*^idsFZHDNgEp$itJo-MQAL+U>*nZ0Y)L4i!1q8`ru6&-|7)RhDtToDsX_
zpI7Ca$0zll&+5B7d%xDV@~^ue3RtEU#+pm!t(Yv}-})#ZD8qQmqF*Omt5<}UD=^qk
zo*yJ`p(w7Yd2)?JZrP4@wp!)V=4E<WzkZtEU_N=X!8K})zvV@}b=zlKMJXodZ#?X_
zX(2yffT3Bs#qE<j-zz7tZwUS__-{pmiKytrhXQU@yIT)EXei)ksAs(Fpw|Y<%V-N{
zj6rD_l=98Y;X9)Z&0(u)2(=QN{lbF%{k20fb5o0TgYt6|^Xig}5xHL1(9A+X*T}+9
z!O*}ML|9s2W_?2gOAF+Unh-uB^IPD`{f4IKJ2edr3_yK**dFS%O#QSR{p7@={5<`_
z(tOZX>hz2fL=PLn0{4(18#*C}+-Fo4WTfWl7o-+t=BGeUyRS+u%Gb}&OVvk|DQWok
zawO;H<mc%->VsD8xahm;yXm{@d+2-Wd+B@Y`{?_ESMdbs2k8gvhv<juhv`#rGCss}
zDM>k?u>m*-;;+=al*Hl;{nT7Am6DlSlv<owte==%T9T@tUkqAUgwkX(GzYa1k=jfU
z0Z<Adt!xC9sK||`sg;!x!PoD->ocr=ALXj;>w87*O4Qb<<5{h@tRCuUDJV5}C`>d|
zIm4Nv!g;xgA<=_FKyBvpNRjlyjIB|*bFEg)T|4jct@XCqmyhoJzOHxq^P2D3@8!Q&
zR#Yfduebek@B8<C@AF%oedah6Sj-8(Q~vwi-OcF}{g;GH+HfOUjkoh^%f7R6mAx~M
zCZ_o(#64Z~J>d8Ir~B(quAXO`ez9cPW7V`%Ar=<B4~i^u#ozBb{p8e-6CXNUrnCOu
z^L_u$jEm9#f2Qo5J$ttIickH@db3qHCqCS$_xXeT$w?A3W3)PbV;(>1JKxvYY4b)%
zZt)a%l^rcDt)7Q&r0!ERoRl$LccS6MqMbT7QyYKJ*3+J*8@=yXYWbuPA^qypsz%>D
zQgTujT~bvsJCoWUA|&@niI;QohHP_BW#PwD^|YtE9{X4Q@SR6yMo`n~AJMzsOxwA$
zVn>Ddp~*>3kN(%RD3r{Tlb*7%{cl;W&(zkR@5`opGkweHvVOGF(yqqaspb2%BPaIW
zp0ucDo4Wh^+Y^O^AMFlS<h{H9)7j9Y?{#Kv_@%q<^`oHes_*q;uWhe6`e)I0aTCMK
zYvz<4>QoRDF79AR;@{X=pgc`ry>MfT`o@_R(<8jjsP5^|JtCDP`H}6RZ;t9T;m;j=
zkC-LdJ#@}dzo#Z9@Vi6yh}R?EL(^|~u2B*b`pwDzNH$6Eq5B&pGojU;+d1l!%pdyg
z5UNQM`p7lW>5PJ!aFCOOk75$1;=a8-Gdz7%(*!SfOy@8)oLiulp){#tW<{fcfUAqx
zMBj?UBmv=%%JUwqdAP;@fp0;9dg1P!`~70<KdR(gp7-)oHa_`&MQVt&?R>q(|35a>
zTx#)D)Zew=!lLr<lY^S?g5O!`7G3gr>dzWnKTFJFZRV|T{hj+u>VNgU6noBkZqoFf
z`t1Au%$Wb-)a&&b={~bI=C$P=d(SlUfwy9KgqDrE%-l$e*Ha@ur>&h8YXADon)_+~
z^K|Ft&a8cY_2_!9xW55g!b5bdl;gDR6#D+fK0V^_AmEFEz4fyCuQ_d-=lqn&d$Qc?
zO6RI89R~7CwHIukC~ev*o8;!zI6F1<J9h^AtAK#{vvRUF%#{1QWX|pbX<M_B+14)j
z@QLpe%bgR&QnpMo7xwp8uI(~@_4<Ll$!l*VJJ-rHp^jXghmLKrzG#yhm9Q;<ky$1r
zp=<5MEIsWFo$U{}Z8Fq<i$y-2X0br5=|@O&KHu5~*DEvFrhQOkl~(MPs`T>_>#99A
zXG5`s<m1!sn?q8vE32Z?`ZP~##C6OPVCD8rooN=J#WJ<*w1Zr(`@*bMcAK5Tr*L^r
zQ8ti%bII-hr-B7SOreY1SB1z<UlPD9>~a3GxQ5QkpDP>ud^|lnvU=bDe{rPJ;`<s2
zy~KN)woaRNWoGM-e+SN;u{r+p1LK`94bkV$JQSbhUF6MpH)0K!z~UILiq}`_W^Unf
zyP>(iW~yk(r44hf3fCOF#rERit{HEWR2DY0t6iOMt9izcRU~6=!i+YrSA`#b@;Vx>
zwBFwJF8J6UhSVkJ)Oqh;46g5fXj*t6R?nDS?=gEGpZ^E8FPrAhcYHOy*xdg8mY01~
zI=ClyrA$4QrLbmw;gxy!Yiddx;=L+X+^~<>Cc4Lcaris^#yiP-pX$zC)Mn-G{Mofi
zX4S<`zH=*%zi_hi3ZIa^`E;*>;EIw{Hwun8D><GxdY50A&7oHy<YxD+BI#mQz7jvj
z*t4rb{_=Jzvac0c@HFFo*L5SKzea{jve=(aU9ZEm^+2BeEmM~G7H$@MrRm!mPI+v*
zb;_hR#ZT?R(~QUze=CjqPN63k3O-?$W+{-nQ}{J*>es_H3opOF@|nHb>O_d$<Gy`|
zYtG1jUf!@e?6aJjbWU-AH20O%2Wn?4lCo~)%oj__Vhhs9)8SugSZO1&Kw<xh4Vees
zs&W)rpRE#Ir?$uM^@3~9mS1a{pP6RI`uTX@=TjcbFShRB-jz_Vzokr5=JI@-X36vS
zTCeatSJ7VARlK{YYC_`GMqZtV2iba$nRYL&7W&h*hdnQ>d~5l(Fj;2x0}D2pFY~;m
zu>GBeeeP<#m8+M{y>A(n{QlK!PW5#Xj?yl9FQoqk8%(*la?xB>aUm(b>N70ACmrTf
zchh#}z0D}QKrc`9@V?F&tmoc`M0dSi<R}z0ojH8Zd+9w9J(di!X3jh-^Gw#Fd;OW~
zzh_@ES?N@om9k5I!NiUh(=)SetbcW$a++K*HRYpv*>6<`XTeUH<or(|XGFM!!|$J1
zlkub>Kk?@Fn2a>Oj~BI1izy1u`g+*LLe{VTleEY|N$+|W{ccmEf6d+97gl$a7rg$p
zLAiAA$)uYvxAYgDthcFqx~yaGwahfNeb<y{d}`pH|LSMKzsxwxrDsmEMK<u6PvPsF
z$-lB^&w(o(f6s*^N`+2|=ICO$8@h&HbaCpGC82Ru684r`S%h=>s(ya+vUpfie)VJ7
zM?bD2HKxUZtFLPYKl-|{q3r8V9>3N-5B=ZIk+gfDU3V@zPn4Z6vFJ_ePVL|c%Zs&m
z6c}F^Z+WTp#mY-;0joh=c-|@r@up3WuI;G_VDc(948A3DrSpx^SN|8L7R*06F1T^6
zx$=5?YEoBBNr3jJD`5rgZTm!G7$)o2$Ho_P1%K*~J2<7LdctV~E4yItMsL+vzUWBL
z$hva7ee1#;OVg*O-nzW{%F%}j;=TKp9{bVL)P7C#1Y<zj3tNZ&x4*ot&Mlj9cSfJz
zV(+WXJ=vxuub(n_6uWb-DR^lxbGpy0Ntd^1D#)%lv+7Vo(f>uv2Y7cJd-Lh$9`8*o
z3pf)zKd%bDH@&Pz|EG0>&4=#`PtU)6>J;znZQiks7nt9ywYu`wSmv{CLyT13f5v?b
z_jeRn{VZ6&!t|D2@tXyafm6dA-iIA~DfIj?yTMDr?K3K;#?Q%SJlc@A{RMx=aV3on
z@ykD(TwH0ecv95-)tapG7YZz|3WhF!e>`ON7uz`;_Zu#o)o(7yFZi=B;bZKnDckie
zogPotYT>^AdG`5ozFMn2d>1>UH{AQ%P@cZIBXpaz!8XyLxiZgmU!3BPDc2}d|G?Hh
zD@k8tcW>^^>6sNXO=7N^AKmU{-Ms2MbA5q>W~YsS)_s;c2JiFNHeKo8uJ5!czUAG)
z?LU@&zqMPh`Sb$6v}n)GeAmy`+&r6@cgXk8mA${7Oj*+MBf<2VUx<^@>>2kfzHN-s
zVqN?A>g1z`T|-5$ZuLEWYTd)>oyy0z_5W@A{mdwo-F)M^W$#k{g{!-@rd)HH#Qop$
z)hYMti#aCZth#xzW!JoI9)0w^alK-t{T$xdgbVkR<$uKpRo{uYyOZPl;UkI$OWyR@
zNnh9`u|T|Wd7AgBe_wuF`Ele(M@O?)yZ{SdnA?^&@?F0qomu9Y+P$^+`_992eGYTP
zGUv$FB)LtWzI-)qYndZ?PSoC!Pku+X>FZ;6&DqK(PGH-=E!MLBYtnV|2bw>^s?I;Z
zb4|MAa%bGp_0ir|;TkJ`AA3}?CguFCALk5pm%7&WuUqCiPvGwD>)W{$m=<_0Tz%j6
zf%xmCv79dsN9nlNUwC9>T)XG$<$~4yhVMT&OD#E?_+yp6u9I*f<FfeZj}=d1{&qSV
z9+KJ_zVg<TM$bjsi)+@jDP8b4wtuyv_l38e$B8R1cs;u`a(Ox!KTVpl>cz4rs~<=`
zJ2%r`J}$HKmReC$|AyV?@>>;q=jiW$a!7m4QU6vG%SRb6*Xdn89@cg0@tR*;4%e-;
zvaOq6e}D67D*MsS$4$HsEweMWztF$nu5x3=<z1WaWo-`5ON-Uq;d{7$fpFM?#5ulM
zRS!M4P2rz+&}7?``G*-SPOLw_?!-#=?+0#9YTV_$cJB0prWe+~n`SO67jtum#D#PI
zfvhk8So+zw3E37bKW-MBu+?$@xgU4>?isH>bwJ%@vdzVxnaxKpF{H;@8k8?wZoeq#
z%FfEpMb9HwbMt+<yUvO~etL=ay!Le}&kSqk>nr~iEYx7!%a>s($>7A*GmWRXOmoEo
z#Rl&c`VFzk#Y?jnYE3k0OIuZv<-6)k0mJor&K`AXZf<Fp0<o8G+J5hI3*9)!&MWQU
z^~&VlCB^US{j>j{%<}XRf5|eR$@<UB{5iAvcT7FwQ#W&`#dWS1i;rd=OiEeSu>azY
z;BN1XEy2-eSC$ntwt0rUK5(+_&?BDOl`CRmvo<mAIv02G#<UnwNuk+0G#&ofUaP*p
zq@Z`Xlf}GCdIw&HUihlf^GY*g4xe4$U!lBxw=Y;6mV7xw!|lNPNbjWyw%!|6L^+?R
zermFC(7*X$-<idZMY>*V0<?mCB?C9k5}Cj>Y3;3jBDa3d-{t%JX`p-BuY278K7QN#
z>)+)?@1}KyUEp0O^WuJj+aIUK{J0uJ4ffDnSzgzpmeXX63sP<uaXE^=*t*?hi|H-v
z1D+SA1g_3oI<YWEZU5OHGczSF+~1mcXz#UF#e28oe4Dq5MgR9StUJN<gZY0_^6>!g
z+ErU(LL?J;nG(O;yV0@0Rxx~jg2(v;qu77)4gXH495AtS>$<cqaMiVho_h&~S_y`;
ze69X}O7GeCo8N6l@VZ?e`_e48n#sG*i8kqJ%@3I0%r*6EtWJhgE$`<#UiO&AJo(~>
zr9TAih0i^EdE(8Rl4QQVFel*)&tGy)>YDVa(DMH0Z^id-SN%v_P@%F)d8rcP5sv1?
zsdW<#w@I~X{LH9Y`;2LB+q9b=-kx>yM7?Vx%hs;Ecx6H)=ZoF)eKj>k3v>OKO9;xJ
zIu+{f*t}u;(!v)`#ZS7TE`AoVd95?MsXRF}f^YtZ-|e%ss~BoOW&B7p<XUhbZ11tt
zUu@XkYa5C-N}KR3spGZ$y)ND3&^!gfJr1cel(&9t+nedMvvIoH)914s85gj3@w6XF
zzBpt3vJ!pfIQit|d$_)a?Wwa_W4M3A-QOQ1uWYzmom0}+tZ%q{%8_l010pnjoVb>g
zo1L+?{7duW1c%F_*HvB?uT8i9p_ipJw_kI`?KUCV8(;R^s(M>>t#fwaR&EosZMXhi
z`DrtwPw(>sts<QXl}F0=-HwR5!W}PVx#fnvrAmw<S68=z?y0oPn|F!V1#s@XT9EjD
zhv5#Jr+vQ;*MA6{I7#NjrnE@jZ(k0%6m+<~54gDd>AQ@tH6DlV_Dk=VmJ#FSi_hG_
zcdj|n)xTo%nwYv0^H^`G1PlF66U`~FQWmghrY(KCz;?w8g=H5R=VU%x?3{15#{RwL
zzl_tuoO2lD7=Hx0=d<%RYZhG0lGa=>H-Y<H>f~rkaRW8i2<zvGFLh2D&UQIg61*!=
z|D&bIjA<*4XZ0vBr#wxYz4@i_3!R<2eqK2G@ZGM<xk|p7MK!DJI63-PNZAP-o;P2!
z#<S-O`+1A+A64((JhS6U`|?AD=Vqm!)@3`itMF(*;DOlnw-0r#yXTjyZ!l%U(UvLl
zKF>}I3#V?Hb>!HxTeFrOJ8~-`M>~DP?02i$x_?>t_AmIAuD4nIcBawHnJX?YeI$Nd
zIpX5PP0Fqp9|&;x^>+1k1hzH&O*s1?&f?<dX-`UC1bS{<rXZ<u;r5?qvvnUV*ysLn
z?MyN5dT@2ZPQL7!vI$?$lt}Cj-P;!T=HwOg@AW?qJ=YStBXVAnQ<5e9W%1v;;eB7V
z4_UkDUQ8`~I&X*aT({;zcYgjudhE|%r+@fktY^a^D9`R#uzJgvb*$=p#8^wON38mN
znBmK<?>EzO3j<zr8`kDsG7y>P{`>zc4(pYFerla4x0%*&@Q3T%RQ7_?%zBdxCe3$b
zds$G|=6|6p<dxU7Q2sxeOO`h1IIq2Sa&pp^AcuC>?cci})|&YH&OM<O+^8TW8t{JZ
zhu=$9FW<A!(Zt|D@zPJ5{liM9&C?Q2;t9<8o$=6^?@m|Xo#QMYjnB;M6zW|rr2e@n
zrh1<3b{3B8?%=}bzDp16T2m3*<+<K$MI+Y>-IZ5QMU@sx&Fh-F((~fp&h&>Z-Q^Et
zHr{`+Yd@2CwCv~Yb$nMIGex;^{)-S}y?60t%*`g5;()xLS<<hkx~6M-G)blE&T_au
zQEkUG^Rk&H3%BmE+Qe6sC0n3$&hA5Z{n5M{T|Vi`YuQ^?Z=T2BpZ9D_;pL-K|1LT6
zt-<$!y6Ba|&o4{qt==^&GXJ?jVNQ#{>J!&=cFSor*hSA@8Q-v`$vk1>N}bg_B9A{V
zxN<3R+1nHTuBGYGU!02{rd-iJVLY=p&3WOb3jrKljYreoH|ZbtXZ5|#t$Q}@*G{Hg
zw=B2I7w9gIvCCtNao)AoMOZ`5`&gu<_UXB%0ljm*PTJ0C|LoW<P!({2^{rw0v(%@l
zGdH)mR&C}?x$yF(+FFl=O&iOMZpb|5uxu4`j&}?`d^S70ZB|#yw?CU~WGcGeyqGZS
z%}LF(ELjO2;j6b+*c1yHtP4q-=OUf`!AsbS_pxW`1j*8ZeYI@=JK04~MEra(bL*dO
zp%}TTO}o;y{Fy!%DjfNhGi8bA(?;v$Yt6n23;gP0Zf3nnGXAUnIOK27(kykpUNxVq
zy(YW77V^&DeQ@i9;@yv{`d6&mU%_!FRoC<G*+2R0?EAVEvl9J29aLYsbpB>$OF#K|
zn|SN88CENN`+{e8^+~z@>f2KE#`n__mr9TMB`iYI^AAqHvG84dMeOm4l`G1UI|Y|8
zP1ST%kMDcLx;ioGl>oy5H5SvQ(;kcUgl*`0b!yA2Ro@~-#9S8^NpgwkG^EZ{y{Wpu
zg=5uP*S9}^tjX0{WwzTR{xN&{LV4D(%!#`McKb{`8`XbYbnyf0CEC`L^0io;xHUBN
z-X9hIaG!PR-)Bu)HQmo29oLedXa2J_C3Bsr`1uWMRkLjPj|L{pk9s_@(eT<$&HkEP
zP78PAenY9>!K%M>S3dr2rrfh2&+13j>FXc9o=>;9pIR3Gc=@WWl3I7Xk8N@^JQ7uC
zwb(Os`jyHP4>?~Pm1eRLS{;=2de!QzPsLnCI*;BwnxmAkP&z8Rs$DwiduLg2#>sUd
zhZQ;B{&5cKvNFnAc0A$3(}Vk7U7qgB`dfSQZwKqTuYGw^x<?zW)s$@`XD^txRGrz%
z>6)Fwx#NBpuX8Tv+4OJeYPs5tvy69j&t2dw@?_^4FWCu=CW~XVT|Xb+!L)^=PW)@<
zLa`gI2Li(m`CVALGxZJ2+kk+>6-{yxjK#;=SjvQs87t?0_xARm@o~wUpEXwhze!G?
zX=>G+e^!(6=K{;ySqD7zGy`8fZZ}&T$|T|RceZA%j{e$N_A!y)Yi2J$?6~**yPjI7
z!?q!{U-OIKt+C(Dslw41l{@8W3WKb~eK)DXfZxSeRZq`TGBx2|VE$!K-PS!Xsv0je
zzPYl0x5&0VOwDgncsw-wC0+EL?GH{b*tB@z&ON5#8SdI4A;o2#oaWQQW{b#APQ0XL
zs`*N*aZUV9zMKVT(lXB-jj>vzwQQE-&Sg&zB%6dccsx<#y(+zUQ;XJ*wz-osxpP{@
zcCYoSk@x${xAV#DPd*1!SiF+cL}rW2{P2vkJ==F(?hXI-gJ&MzKI8i4T4HTs)B*|7
zO+7(x&mQdQ+8(^Ga#hd;=fiwlPei9i=(uOIYgsYaMhG`Po+@%a(rT{x>+PLor>w(6
z8P{Fd(2ymUv08@dORLw;)e^122W}^PFnTmOrA$lDf7bGqEVfP(UI#rBr(di3d9?Da
zu%^C?*&F7A4$I2EF31l)W@GQV<ed9awTfEp&yU#WWb-GSx*oHm;!ACvTU>`%p2Y&e
zW1A}18koyRFx-uvBc~*%y*x?It(J}T`~#LBR&#c}`}pT>+(Sl9rTd+>$F2SETmQ5x
za=LS1Zr*SHYjUENfA?_~=XW)K-mQIlF9U0(7IU#b-z49{D#<F&T73tm9~Qe6_NpD%
z@mX(XxnchGtJCJB?hIeLK<~+vCEM3$77OoKz-KajX3m;3GWVaY)Z9GB=yC8S(JL!?
zc5liyykmat+@)g9&1~yrq7QGL%%2$Psl08{<G#yFkEVMaOWh-N?)QYs{awtr-xtl4
zm~;Pr!k#A2FBfNs=d0(qXTLjSdR}A8TW33?Nf$WgfA}zk>$=^evc+fr`1_k&FXz4c
zXVqhMhIob#PnG@e*NIgrtxKz4ZRY!7rn|Gt<6paSm%ctw^I_Mq(0$R*6nV?POO-Fz
zdv>UnZ%=#jpR#Ahc3+fFJJ!v+dFgMj!ret)*V0v(6(>#TX#Qe(Q-M8&+xXMwuBhtX
zS$2X;`sUnZ6}!+~w!Yq8^=go^sOxpLX%FQ3L$e>N9v9BD-*L6z)sl)A5novg*zW}K
z{G87t_hp^y<W(Q%+PXgv^JNc^x%Qd)cXr$7ncQd6{<-HK*K79va<XGyvmj^Z#EYg~
z>zusv@)n+$#O|QicmAqttD5tcHz)QfCuIbEn9F@bbb8vq{o*Nq(;0v7>OFHrk?#lN
zv-;Did)%*o7F_u~DCdjwktlx`CKKT`ITh6h_FMnRIV37`W0~zQLG6#HrS08A3N{5k
zQp{`U-Vi5TP-)xi6v+SoqG$P;$()J1&G+wpZx~axYQ@G=dh7J^HIL~&Iudhi23y=?
zhnuE)XPRwmRBrR7derfr`snV#_Vl)AS>0yi&$kk81fKiKUT~f{k9%`hz3g4ZgMM?<
z^3C$3cFw&ud%fo2O?>++Tx>N@d=g#Eb<O;8dFr3n1&!y}?3OH?%VfI1?7h#jNP(Q5
zvq|P=)A=VPT(}by5NLMcat)6OQ~NT#ON!e!R*PT#)-|i{|FNyF_dH@cbo5fdUBSyz
zRorz;bev6#UkCGT=HGr)!n118Ptmr<*HgC@J8&#j;ga~>SU$ByaB;B#>simxIrFP_
z#4o!3k0oyHqR;;iJ=(8a`0VFDuMFnr$CzLIY`A@D&*A-z>n1)}pcyxJo%yTH$(#Q#
z)oRVsmRR)g`vu`z*G7iWTXkXii#}RRU$4)&JoA~R+z(#MT|R3)S9pY{FL}JsDL+i~
zgjX`R@Bv1FDGJ<^<u0|S?(@x8diXee!t=~e`&aq%U5nuT<TcSb&3pY(rb+X|0}Sp7
z^e*=6y?ju1M#16d=Xjpaf5_nc@qgX2#qu%B_ZRFpkuSV=cUw-o^0(_tm0WhH9&K3r
z<<ReFMgJ#%nCH}dzonn_eEz|^ClXDbMn_pr|9|q|u7VBI?-hP{&{tZg9A6u8*}f>o
zq-Og5B$XPDIm_MqzSb7hDpYiDf3sk_%an<%4ryX%w{3mTK1VL%(Dw#Q`3=t)o7*fe
z*cdjPl#=@&Zhych=Sjo+g&#G)Cke^>ZJApfBmZx`_4J1(4Cxmy<Z9M1e!SSN{cK_6
ziI>-QPq4Tif3Mt4q$^B$9e0&>Uz_+t4f!Q0%U)kf<#acB*bpaPA-%6+;h&(=y*n1Y
z%E%O6u-|GM*IxBw0<TwDepovH$E6=TX53i((O37Y`|PMkua^D@=;kX*)O%9&AV=-T
zd36PokL$%&u6B<<YIVJP`Py8Spnt{O@2yT-mHvJ4rHZeDDcAqTiFc>IGb*lhSK9N<
zOMvwPH$&mA3*5)Qm$A<Gl3-kZz`-^B_=%l)9?TZ4ZHlKKWM{N#X!repAn{0%a}vw$
zHBq8}_$Ans`yAgX*W7ns{P{y{tB;+$US(9S_O`~N#Hq(-E%7=ZpygVzF7|-5dDgkj
z?lBf8-mS@tJ{BB&t?AOAKYP5qUG4a;T|K%g!|=Cmz!XJ8-Poz?&T%F7ZaV3=clzuw
zCch0iDf&h2EB{Vm*0+CTWb{KTKDgjW^yE4L@0E=$?+^Ok|8t?3{f_XzFYoSNul=Sj
zYp2xJ7vj1+Z`C=0FaOqV{>rvMKITK*-?|Hvu4*62;QsU|bLLEu-+zjaSHIo9U*OdK
zS6ekAe^jimY?9ltzMXsermuZgJEY$%{A;Ch-0D@<?Py`yhib`weDlt1W}H@jD?v*q
zEBlSjZPhl;zW@E3BY#-Ue6Q!*?)zPJdz!`lhVF;c|8y@f+pYK4E2!W6hSU0Q_cl7t
zOIm5IG%0LZ)Qx=e&{t178kh9HzqkIqwVvI*aC;^@rsbFVj&ECXMPtoDzFR*Z_C9vs
zeeT?!n&&^4{yVtx;zOmCF{0DA9G|E8;`ft?+w2Yds&sBB$B4?w>reAaUA2}o=QBgk
zJ<dO?q?wi$x;L4v?U`ZkC-;1v`Tn}a`Wx(CmTcJ?v*8(YWc#18L+-n*AE<v={kFSJ
zyElB6b$;&#@f~JXjq>wnNT{#&%gR`@HZ#Lx&D74s2io<&-qhDjKbn*7_u;Td{*lfN
zsv<6lTYjDvTXfU$+Jdak9Wi;qTTh!Si93o{iu%3vSbg@zfudJ`o`h@IEwr0>LDz5f
z<%s007cXr8sLj8Wuwk-W$%koQCw5+YRuNdF9be~Y&6IbczdwHG&7j5o*$L(=-Jd5o
z-IuFvm-kd!zBA*L{vHn@Kj-X<aF6BpL+e)@d#|-dN;9-4U-ZjLrP=DXH5+$ke0tJ8
zb@Fn7BmWr>I<FPSwz2>;0}PrsHa9b|0Lg>chR7GS<6Yh#72p^g7Od^;8xn%N01<Th
zqnU!Kk*R{2p&{mC0y9HHE`4YC;(jm}zLdZW$1);w^p*XlMy6c)@DraC^^^5;^z-zK
z^-EEw%1uElERm<m!2%#}k~UQiT3LlWRh~LA-$yuI=J<T=it=Jvt6hhW*q2Y&=$vff
zGFkA-49APQr?rlSZL(x83GjM)>(o{!@0I^I6u${?%wXkKdfQOCB}>b&jiGp-&9@{=
zUbo(l=Y<~cKk~xpadFkY8;y#aeti0U`uoqncIUr)FYu97;!w(dzAdSEr{(#KO%Ytz
zeEcI)ITz|&)jVyq%h@aD;ODmZy=RUsm4AGQ)uLYUltPE@{hIue_aD3Ys^?CR&-^n*
zUqeglN%vf{i-EbNAJtZGKlf})m8s%~wDPTopM9-ACeF>YzxG#a`~AGnH;%YPpS?ZX
zZF}+gxb?nIeBVjUe&NJ1ab4E=xPx5*l3K1}A$>k8SOTT=PPyp5;7U|qR${qphS2$-
zM+y%;Pb#I}pS;mEE@emKb?x~EnlDzSd7o(DXe#DdbZ3QC<WIkcr70yGZIhK)c6jZX
zY0_i2yX@bkrz>{%gwD=dA$foO<$YI+YjvM|&ezZTv+B^p&l_*uozRl+!E)k8vAy%k
zqb!pP95o6ytbJ)9ee3z{P@XT(k7@HC6P|I%J4v~qgZuhiK0XFp0qd`~uN18a*sl>h
zeO>U^{^CNjXXor}kDk>#du`vAc%db(ZO?xQ*`2Gfo^|V}U-<FqcMY8QmrnA3=Q5Y~
zZO)FL8O1^`iUnRjPgy0-Hg}%#!Na*ZscVF499B#3asBp3{49U-oQD@(Uazfv+MS(U
zzW!$FyIq=_?7zvr%wpKZCpCLVXb8iRhaUMBchCCW(BH1wa4b8x{Mi4{nGv<mqqR<#
zoY*Y*`@?Gy;dT9v@)v?r-YclIODmiReQ-O)sN~Sc|951gcCo(xem%d%SX1o3)86+T
z6Dl{QzdF<^+-YKcdAZOOjy;~|4(!*iH#Dv*eLLq<(LI*Xw7z}5-*~cAE4NI#B2y%`
z-Jxn3t7iD!<7&J+11~O}vBTis=gI}bg}f0hVy_RL`xeH>edVfb`Bl--odJ(}SlOzC
zCYH=-ef+TC|HX_SDlQHC{<R03l00_hto=&veW#=MJUzeuzo);Pci%?#4`ItDFzK6I
z`|<Xy=moAVFWWaO3)e3%%wwNky1@Hj>?%vARsWKwn8g2^Fn9jT^4IngzEnm27j*j1
zcxB~mK2Yg`zOD(BsX$rL!q5^V4PhdVS;t%U1Uh;<2Zv}o`}%q!tzk4X1f4jqU}0>e
zU}kBGrR=c;l^Te$2gHS!J)p}Su<k1|G(um+WQ=m`Y%=(u*JAxr{WAS>l=8;{diD<7
zdmui@pQM#OphJ?7OP}6J**TL#Wscq7F8i*bSnHC7$o**&dst))g&6-jOj8O>lMFX!
z>%O}*`gB$F?b0v1%1Yi|`+x0pRdnR_X=QiU8XV7UNXtpqb5b#C6O8!5P<KILg+%Z2
zv)N7W53G>?^Wb=K(ZB!CzuTNw?3596ob)8vx~uEw?y~jIxLM@)>@7HWc8^C|*ajp0
zjrviW<I}svdDouUxkV(uQfz&_l(?Pq2G1hzLd*DtS5~T&Ch@*E{r7s0xp`j9dF@G^
zA(LKtS^5X86zoo!D)mg^>D!<XZx^Xp#q}OqPv6GO2>4vqbwz1vSjcCO$?GR*N}DQ)
z`Y%`^xbg{$<CCz}s=c?=G#zu)%7mjk`#XXb^#}-bFsc=CS~hx`uWtFudVBKWIuEXI
zIp^z7ME(A>#<Vy2yKv^F$I*AbDq9Cnjyz_#-SbO8cSvBdO{LDKn@@e+yIyYnqV<b)
z*6y@2=4TJyUa#Z(rF+o1Z29GkCEqx>W}7kJQkXrfur$e}dUmyikzt{%jRB`~){zr?
z@*hQBR)6<s>h?>SpU$c7`K)9eJn`h?6S-od5)&1d_#a_AoE)FqmA~}<idxqn=f1a1
zY5sN0Cb_Zb!mHP>W@T+TRA$-X_+Xm6>_@j>ik**^b!=J~x4Zs(tJfZh>2r>}xDy!c
zB)s?)d)D6HHBbN5+F3MOJrJu~mw#uWN5D`1lOH!6pLNb={;|`Kf(?t_x&1FStDA84
zp-QQ()Y3hU>t314d4A{p8mRh3U#9%P{F2|Xb>$378CCB;+zWkL;<)(kT_L{Rd+NkZ
z3+jyw88oh?UNhM$bvrj^Z$S7;akJA4@9G$yev@`#@uuQZak-wyP0Dl6O*r>ti+s*f
zp43p))P@q>g(+vMcT~?f%~H~C|Ffg}&sR0;#fJm?GTRSl=xx=MY0H{;H0r(rO9;#K
z>hmq<<{i|@+pzvJ_uh<MIXmVgMy>lRewkmmwz+@imb6aSlcM{t#xRy<oSpOI+0@|W
zL7G~d%7g5=lqYn#wFfOfZ2Z8HJBMfgK}SiuE7PtsOxjX==neOezCz~X3oqN>vVQ*Z
z?axc1pN`D9zHr)(p!M5l<V-o7Hu)C+qCamI9sjWZY_etAM&oe9vpd5?O-@e@`g$;L
z^>x3aJ$thR76#eHI_k%<hc8ZkxH)-$@V*_VzuVV_T-d3=tox{T`JBV=&pkfk?=wH=
za@*~C@9F0r_e+-A^sX=1rR3va`+w(;dnupRUy?e@KI7=s_1n4@Fs|JfSZi*@x;b5A
zzG;eu)*klLg&&vyxVDm2nX5Hs<?C%_H+R<hE@Ydabha+aUq6<8^TsLlSIm7{kJ$#s
zTiL`OND*QEzPKkVH>i-i^o4`$-b)L!jklRPE8keKb#dr6-(_o=zQi3q+4;ErJb!$;
z9mC7szNpKQ*D5z9&+Ap+oNXbScdU`UYSx^yepbtuI=nZrcI@rBd%^g|)n_l3Es(q=
z%VzbTzt(Z~(!H!c8Mn7o{3_XGFSzX2@m==m8vkB~ZjTIBWeed}XSSVd7d~P3`rdT&
zqc1}gBx;((*oxez-Km=tHEFZmwCxo~=1zAPsArlxAw&UGprIG%pi&A{wiz0lnt|j&
zZ17S=5QES%)yVK5563WYdG3VVm^3z0(6vyoG&NQ*voOO_pj&`elOqar5EovcTi|F+
z8k!iPElNi%&m;89^ea%xadWg?Dqud;Tf`sLZ45O98gLbJY$wEe1Q$viJ6{<2-zSZ;
zDQIqSQ<Kt)H-{#5Tyng5R4G03o1(65o^g3!&hgyi%bulKowqhG-h8%yW#*-eKMf6c
zPta@OSv{L+b@#5591CAB_`gy3=C1|a&mYys$<^`md**m3dQ3W_u{%RUOXKeP%dgLi
zJd^vC8+fWL=;p*lZ>}8Kd;e>8>&lN?pZV0(NS`}>U}rQZujjl=@mD`?U350di2F?3
zT{|^%`~Mul38}f$xRj5-=xv(0RjTz#;NdABM8(1c_zhT1O?w`eA37%yVVzyPVe0<{
zR`;T!)i;>Aoe$q+)~CR6R<*rb;ZtX~%gy=oj;K9if9Ykp%kP!`oXhL7(>})?-t(z)
zUdTP|l4&~oW2Ze8*Wa9;t~7Cdoyi45sU5e)cBZD)CM>eNz-r+Tr~V;nzR0rUO9Jx)
zg1oOhdei*Fsr-1w2Kl0QM;|2iFW-Ez=m@)56vM&!A~&pA9OT45tjqXR%fCc!*Ydmi
zcXJO-v6{Y?Ep&gx`vRG1MMtV0L|Ns3@3Y}Qz@dA1lRuk?6pN)=)Ag4;B|9_jG~Bfa
z-K*>PRo426$?k^FKkqtEmS;Bb<UhP&ib&5E{{N@%GF3Yp|G2wlxAUj%E)&aaRr703
zSg%d-pS=412g5zli_bimAGz99A#_HMSltTEJ6>mRIw@HM#%?^ddUojsk?L<BeE%?u
zO7XNT<hRxCn}0ua*}DR>FHRPhST8Dw9zWt_!nR_yw2YJR^Us&Ahdj}1*Uq@k^`CQo
zO|!6e$RycYGk%<ATXXdNhOosx8r7S8&MsojS+VZEo#E68^L3{9%{2{)6_?h$9dojQ
zal)+1sIx2n`7eHY_31|UhP0$dzTt-}`#ZmdbhheleYaU{HEY!5X6x$ZyOSq>V7R+p
zex+G>;dF2DGv~#H`;!A-HGW)~EhuoVrqx)j>du4Atj1$zv#ghFzQ=H+YvYfA62&<S
zcDuFjFZuRW&$rj#F}>)Lqxq$4-`CHT2vJ_xn^l={IY-LxuG7+7fuCQ_UOxDxq<+^l
zg*rxwhpFM9;sKfqV8=s(GY2S3nVT7dq(Mw0OIQ<;Q1Rgx5+3Obx_`*m(;Tt5-OLEw
z95k^sC1Xnq&gP&wq1IpyO4(s#3F>7d^+6#5Apeop3bar_z4(i91!MR>Mg|rp21Z6k
zUgQt}3CR7BX8a+;^h1{UWaE$KpI)phf5-@ZHxvAB$p2kefPtBj(ak%`IlrJ1ya-)E
z!&y_o(9+Ue!7(?rC^I=RPr)~_BqJ5H9X&ZQM<F;rIWx7SQcuA#Cr2SDGd-iESRp92
zIJKxOH3ifLH+Rm@EhsHXEmH8!Pf0DxV_;xlO3q<maAEKTS;e0J;6I~pXaL`T#(y0R
zjmy6;dA@2nWB0x9t*@DXc>NF-O>eEq?=IyiSkO3k;kwzo&)d!m{jK#|{<qw3dDG*@
z-vz(h-g-B4V$-zd*3Qo6W;t8^-<;i*-5k!@drq#H`JHk91^JD8_AlStJ+pgv=aPI5
zzW<DwZW9`p|K!}w*mI5f`?{YxqCLHRGrD^?CbUnfFSls!ERt*Ks_p77<EWk4J#BY)
zOLI$SYiE<(Z-GBe9gSTL-HnpoM{;&AUO9QkQn>{iW*+PA=a^B~-BH`wTG=jF7g^z*
z(9KcMvSjhJzIlDq<oU|y|Foa~d&$(P)7gF}Ol4oqb%$Gyi^Y6C59jKB9v%jU<~1A6
zfs!?Pss}|XC@GjAj#n_UgzfDjl<LDAgTg}tz?G(<L7kzI2_ot1f+|iUQv(G<0}~7C
z9*t^>|7g^l)Z$`&PyICgBD8FPHWXuI2@(MLowRIViIxpiC**nvGfEtPKj+-#H9i7D
zrRDNmXB13Sj9WG}CRzv`?KzdRGq^qP^4=HcQu1F}R)2eRr!2T|_HxU+SEhYQ68p07
zg3^i;ue|R&9sG4``fk&Me!qVFxBoN$`S(A8DyFQCfhNzZLTiJQ?`E#_2@8%&(z1;%
zd+?~n?v(hF53P&NEqVRE=+HDVUy~;Vmy++aE{=&bQ*yfa>Q;1+uldr@ZRIaIm0oHt
z+OlZToE1S6qf%GL_?~$3i!Vs^I`^XPj0;<|JZ($cR=j$p^on1|YSFwa6K}-@ef+;6
zWbrGr7oNI`mo+@rN;yurVwUTx+7#m`H6dw<fTwWA#1fUZdCv07m%LfL>DVsi-!Jm(
zV}s7MZTtC7qP$4`#G(zSYwwAERQl)g&cE;mf8sH&zdtGsH-Ai+a<kyPPhKU{z6)Qj
z@a#yGa|$`#v6Y$4p!R~ytoW4h>$B6}Yi6%hnwqlXdfrvl;tg3FFEY7p=6Cwx{&A`8
z9IbcynN52HFEknMc=zdOBG>GtOvmK5HtyNHtoqlplh3jOHhoE)X8lIuILndkuI0MM
zcYe?16nkp-S133C*)8_AuMWvqmgH&)d}%wb>i3;1`~hFp^yYXQ!S6>7owmGYz0cx*
zjKUlvYX?{9k_*ju(|abKIF$1zF#XH1tJ7vnEl&C1`ukFD2HWC8Zh>BxO*bTm*<1YO
zV}Cu-C%-lRDC6vTGAh+?#e#+PHmv#iT49<)vc~+A|4)8B3R>NDwo*}K!-0-nr}(mB
zSf|Ho9cc5pkS;i{PK;5RckyB~o0<E?w{N|<cIt%X+c^(2>=4_(GeNNbP<ge8LB2zT
zF$Y^0Te|$c*D{67%yG-FS6*n+cpSSesV$y!@qyw+E|&h!*=!ysA4upqo4&FC&;-v-
z->ob&7qVv>Ja4?|ZET`1aa_G^&I6{Nk3S{SGS0j?_&ws>#Ihp?)buu;<T&ipF}X<1
zcG}Oc6I6`1+RT~y@xtV(tqT7c+`f5l#a3K^5<e)*m>U~{q(Mw03z#6G;=(H;(%s)x
z+u1h=sg5)?QP4FqP%t$#Q7|*Zw(Zjlb=xP13vXc?;o2>3j!{NffQ*4{`vPy%0&V+5
zEg~#Hr6F=n2^Ii(lB6QS1T@NmJYK@Mh0z;cQ}Q4M18PNiu>8lgpE|7TekcolHxc}<
z&;MN;Qc-$EQmLX0!d6cj8Z$5mF^GWc$<UYo85>?7;QP;HS$Lp({f{N<x6fz%u6l?0
z`{SPiqRTpa^5wjJ47!rKInvn|cc1M(w4CG5B=)TCI(50!bhf!Y-}(DCbg%0EF4VEG
zi(`E%yL$JGHS!SC%2!|f&iq|*`FHkDhgLAI`t&{j8}s+2-yezIJRGX<TfjLjFxhz8
zu|)Y@z0=loFW^{RyeKC>zbZ-hv)^~#@A9u-yuayv^EcBXxi1?xUh6)=am(P?Z|2|3
zW}()Z3oBNxn!jlIit+_Hy>jceUzoO`n`6hRQj^5m*uot7tknF@$d01U&hEA@j?U)J
zhT19JbKn)`tnYbK*?uQZV_(m83sz$;pUlH^Yc>xr0|Ptb);>@=N2@i#5e!NeCMNKc
z#EmRq{ZE3~z}+dr7nBWxBa!j}D9xB#m?#*TV;MIzGDjIV1ao1T09O_;G&Dz=p#UG4
zfR@@pja!t|4iW%)i?q}Zsz#AhdvZ!bVp2j%%9F1}<y{|2ua<q|?K5HLJn?rz+8@Qk
zU!14y-2MCcr1z&IpV#>d|H{+*aku6F?sW{z#>$Ilmrp6Kb4(3Pt8(jXYTLZ5Y2nhP
zJDZa8vI5hJlIAt#CwaPM<t1@Wn7mkE&ipwuqk>j0e=uY6VgZ&*folY&M9ql`nKp}Q
z+a*i;?F+W3Z1p&3Zm+skqrY)s<HW{7#luEy3Q0*RDVHAoJ|9zT{jmC`+_87_#m?Bj
z-aozbT*RHd6`r2uYyZqI&)KSa*Y#-k?(`F%r|SI5+~4wc`-hNkwlVrUzWY3Xn3%x8
z@JT*^0b9BN1qCPojf{;!(jca>5h!LsEJEob!X-2`z+2nL)6W%o1VY!)6m*ZNseyu}
zr3DCMjzU<XZjS|XVaWre9p^ZNCEjs}L?d(kL=#i}L{k&}L^ETQ)MIQ2D)o_44@3a!
zPvXZUOh9c-<kS;--q)KcP=xJ4_1_Z<4`i{4H!m%JxM&&wl|KhuTOyp6C{A1Icp<@=
zE4j^U!B=*##i^%bwp?8Mnz6pg{>a~*XCklgI10=;TUp7c-!3%0Ilyc0)5Ae43pP!)
zwzKVOdD~KG|1_I#-#Zsp(aq`K?z}(XdSb0pn&h|ej`mA2A3weNwQN?VT}kxU-BIni
zDQ1x>Q@!#wXIRK2zHGa;D*S5ov~X+FwF}GExTdF{&5C_pQXUy~J@Vqd?9Gd=U5o0!
z^)|oW&-VJMES+_3le3cidyjJ{u9N-m*mNQM)^g@wZg-|s9TNACzi$$+RdF^wr0v5;
z&)+srOsbjX+1xdxHO{fjsdAXpnB!2O@~7Q~rHg;5&M8rz7YV&FjGEc2{|Q`hGT6HB
zx#E2uRpzILY{vu)9OgBqDBJxHUhrY3K6eu96E>FC>8)&R+8XJBB6}tuJt?GUv(
z1xktN1sEvQL2+el0zbXM*Z`J#2_;l_Cr_tv4^TZ0ZuO@iTK%A@S5Twh!jPQ9UyMv~
zmSqGk-ovu@Iu+DOL`|{=pqz-DWWfTUU?8o)1MP=LPO^+{%sc<UI>LhJp#!Sp<>8&-
z>A(Aa9{kzFy6)#zq3<q&-!1vS8$l|0s`ZA03=J@Q!>kqthDOE=43Z3j3_=XT3?d9{
zObm<+><kkbc^ShPk1{1fI><jdN|*oSUn11Kw`BYGrQ1vPiVNTPZvG=yG<IeC+U_|V
zC(dlWbmerob5KgOe}>$`8qv!e_U!LI%kkXkh=ID5qh4ii+}0SmY4sb5mQ-;FKMBk;
z4c3rS{OIxJJL{`^-_|$mNZl$|v7maY_ht_DMA79{yK;BuEU(y=+wI5U=n!sc>U{Fv
z(bcCP?2_aA(NVhar^G_W?t9-S-(&uf@coKt_wBaZ8CPRpTh31G_V0EoOw!ACYqRaP
z?sn)m++x4Y>Pq>Z?t|Ue7i@pE`oe^p-M2V?r~kepn$jJxr1Evc@$To{$GT5<pPhVg
z-goY6Q<ikE={{RIPh)Cuw|%!yw?nskgLjQiP;Oi|2j7p5?o~fFtOB)t#IG`c-}O^O
zba8iYiJY&uad&n%M-Kb^?ql8imva1>#h%_#Zzz|Y!?v#PQTOKV&E1c>*L85L%4Rq0
zn6^P4WYCT8U%q@;#n}Djd;BxzAEDo!M2pzka$DjXYg(E;yGy${etWQe{q)`7yWH`E
z-R~v8vl-t0&G(ztQQs(dZ+G9Eb<?*jtz4SX+}YjLA-Cwv!3{^dIi78^vb2u03GtQx
z9r8P?p`p98yIArEI~yp>mS6hL@m*!ncdid7mk4!#XEFQu-TJxxCvoB54BxkX{~~&K
z+0l#Lw>a(^AJ$g0_qWelSg~T&{Dmv_#&p-nt=e;T#`<oKEr&`C>pKGr<K=UsGdqg9
zn!AcSTe_ROTDrO$IfVZ-G)(HABe$LH?gn?w-!g7_@d*xdj%CQNYg@Ijdn3pCg86yH
z*|qToFFe09e&>7k?BiXZo5~C1_(~W4v|spp*_`ir)7X9|O=n-lbph7kS~!J==fZqY
zgR9lP`USS~3Y6tQ8P&oBK2>XE32Lo_1PPT_9#L-Lq2bVjs_G1l5)lO!T@I@PjYxpc
zqCzQ-j4YwU@gV<#ya5pau}CY9pu>C6BEDh{to<eOsiTOSpZ7Yr{bjPk*u;ya^VENM
zBkXtliSyI#XGcu0xv&4_uJec8+W*U~8QH|#+|1{{5PANm>C~b#UwVXCdDDGaoxQz_
zS&!ejvgpi{BQ~t}k4);ha_5MUg1Wn+g}tTm)+Isy2MyKT6*-nHj!@LtYO!^Njwx%>
z=Hj|M$4t+xiB0)+URi;0ep!WuS&5lRe9X?wi#Z;b9n*uf$Fv^(K7Xb%=E3$i&)!#Y
z*R7d-{>I<O)}Q^m<<Gk=|K|Vh{k(&QYcsu^-P6mnoA1nL-k)x|&2($|b<eWv{<*U+
z{Y(D;K2qp%RQ2xPyDgXb&NRxc@{a%O^3$Gs|Mw05X8c(mQ}S%jyPu!6cV$2MpOdy)
z_r0F}{Oh*C^VXL<^#9$Ov!7LML;ka>1G>kLCfUtzFaE3}C&$LdkT|6QYt0D?ZBQH;
z8ymqR&Hz@OqDP#*Q(|$dTYg@NzH@$QQD$n9K73Juz8~m>(jX%PBYn5bqT&+JS|SBQ
zeV;@q)5z3RKRh#~B%?T5!OXybT+Bs*UXYzg`i($*EEpt?6LXmv;FMFql!N&bqzBA~
z+7IFr!eI62W<u=;$q}m`q!xyaNVFfr4ygSY;^^*#@?rMEX{h~hK9=yuD>p#;LH-51
zYk=$r+YJh<p>BUHmz^D~oG}Ge7@)ETcQF%yd`%g8Sz`(rZUFTRAtxm(fUiFbLN0*J
z5hakJg#o+-GBq+&Fg7+O2Xm3B4`vtf`V9;fK%E$neMs(w>o>PFS1>m<f|(1aEzD8<
zWo`sfV_{;fU}0zs*AFrmgv|`i!FpjdNDPEw`ao<X4AyUIYOY{nYN%jhW~N|jVx(YV
zX{KOmXb8q&bIc4COpMJGK<bPQ%@iz+jTOvH!1i!~)Pu}3u`mSdGd4F<0O<kgH#ai}
zmmDDfg3JV|L&ISE(Zs;+CsJ(C={GepL&+7e8X0%42=sIhaDyz?Gc>@cf=waQR>;``
z)Z9eL7Dh<f!qNzlEzAs%gOba{*iym7(nP_;9Fl}g%?-iwW(Fo;8W!ZHhGq&NIgol&
zV+)uZ-GbW495m2qqF`=e0Cq2kHa0fqGBq++FgF2Z6AJ}%LlXrHBNGL4V>1OaV{lSb
zurM}N0J$0D4+|4B1v3jn1xqt?1q%bPf4N}l%uOv6%nVHxOfA6TVA|5e6l@+y45SZa
z1{wzYALIrTBMSu(28ELeC~H8&6clF0CI$*72B7R?reI`greI-isQ?OJ6ANQ5Qv*{4
z6H@~S2E~Dy5hR=~jKTf^=?BM;86;k?*^ed$iyLBSu=@u}zp0r4iv6H?0{ayd4#vjd
zZ~(at6jmS_hCyKr4i{rfE>mL*<g8_Egft|CGNy-U*rJYFqE|V_Muy<d7E<Pd42UA<
zE+eE$$IKX>xhyR$(E}aDgD?*eqLIwOsUJxVx}9*orKKfG;1JR3M;{BqD0_@S&Hwzo
z66EkP00la7_#pKP49yXBvW2m+g1NalXlV)DjmTjEl0)Vrv2lh2k{YaLLgfkTx3Ew!
z24Schq55EEf-@>8vm&s8f~f&AHU;yM^&$C(u>JVkDkSMQGKUm?NHkbK$i2w!GciFe
z<YDSTYCvpIe3_b>g2I3cN`u%~F{ls(=|jg*JHhs&%aOpRntqU<K=EQ`iRyQlTg=VP
zk@Jj^C1}<Fe-jpSv<AIUF|xEoFH|6dLCBfL0I9~dFo6{+Tp-7SA_GK&hJ&$UE|{pf
zg%LQ5!T3ltTn&<#0up;b<Uu}zyMYT7IR*+45-y7DMg;>ZxDphSAbUYHakfB16**zx
z+!lqXXdJ`b0)jw?Mh8b)V3eb#7}bm^$St@Mgt<99L0A}ph7k=EKrLvH7IX|2r#P4(
zv%~0SBk?J=0m&@XD2DLpU_POc1SK}KwmYc(W}tw-JV0Jph!O8bmXO^yNcAUV(I#@t
zTUsKO1qK$ds8;~Bd|(9?PTI^6Ih`7lKhkGBWCr@+gD0Q?6eMf{ZfAqqkB~t{WWEU(
zL>xs7NiRM#!E(@n8g%_2K1d#&hKYg1!5C^khB(yCAaQ&c<bIGm*es|XlGsrDiPZzL
z3k5^{k0M4y_`%f^p&#TnxO#N6iO`QtFWgKr^~22^>H1^2^j-6k^HVbO(iMzNKr3;O
zXR5&h&~g&o9D=FUcgajkOD#&xOHM70<}x%j(l5!(NlA@Gj2aqQf<`l-dU15(Fc<QI
zEdkG5K<6nejWOF?pu!Njpf$ufOagB8!dkjqCdTIAkt`E4NDt4{95T8Hnh!uOh)oU6
z!QEDndQ%hlPz%*sugG>`V}qJCAPj1-fLh+5CJuO*#Ml6|q*(zp%mEoDF;_4*woouL
zfs7<t7=uRhpllOM1v3i+1xs@S1q%bP7?+s|WLU)9)KbCB&{)CL0@8XmwJ=t&Gyx5}
zSSXlU7$}%QhfmPl2KK)xc!<PO!Nk}|!PLk=!Nkl|!Nk&7!NeRiv}C4WY+|Bd0vcg7
zGEe}ujxEeBz**kJ!i3Azz*xb=#7x1kn=%tFD~%uvD9+(^O1!bHIwG;CuI8fk=>
ziDow_4#D<g5eLZ;g9lW<shKH?{h+i38aX8)EpnNf7$7$ajF49T;mBYi;Oh?{yL&Mk
zF=ogk@QAhw@)RH_xIsw}gbmFg9a2+MGX*1a_~@Ym=xzgW_?wxVLO385#uk=f4}(;K
zRgg)5Twr8q!UbC217e$iR_#K&?4Uk|Ig(32@*tOj90F4hqK(WgxIp5>U}Gal;Q%rN
zhD{9&xGaqfKnFWOu(^Q(XxJUx_AoRAvq5}g&^WA#iGrD_kpd_TKuuFKQ*)3!mzjYv
zh*mHIjlqK4Z)yhR8-n{vW}r-C3L1(xQ!uu$goLn#rGkl(5okyP9G0MQHIN_RV{FC{
zbzm_|$k-|<yg@?(AllprlsQd6W35~;y~dzS4_@$T0y0+tq}I&L9881QAiGTr3_uG)
z6+pD93FvwZ0|RgXg5wYt%3vQ_Sb|Lfxd0>%RsiFG$`r5woZy195D5ijjIk+X493C&
z68M%D2H-#d83}S6LYt|n8N?8fJ3$s9V<U6K@Qt|{$PZ><*MZ^@WE4mYRFH!F1r{?f
zP%s8z&^RS1PK=BdK<Ndf7A$TEahAC$tl$Onxj=D+4TGEyaxS_Y*gVA05Em$|fYgC#
zbPRGAx)_KL3MP=bptOkWXJj_WOi&!6V^CT^!r-Vx)`!dn*^kVJu|Z~n*d`_>D1{KH
z$pEe8;gvU{TLiAW!BshOQH0b=AUuoW?H%sx6Nqw?i=jDYVTLiAVgzb`pfnTk6mez-
z3Z`ZT3a}y$6wsgmgGC%T{ed{9W+sr73sPZXV!{O~E<h^5D##>21{+!!Ac{Bx3vjXp
z1vhBw16;&`iX|upiGy5g1e#SevQz-kM&>5qEDp-%gfMIx2ILu#IUpM37fT~h5oM}i
zW^Mq+pyC5Ooni(m?o1Uxe2{-ZMF@xulC!Xc%W;9s0wq<Deh?cZ4^juhplKKo4VE`F
zRREa-3O5i9sslmE8q5Y2p`d9OBpNIZ5`!0U;37={<PXpk64bwN|AW+n+z66~%7NVu
zV}pxN3j+ls0|NyU3j+n*MI0#6gCi9j<j|4=B47$>JA$%2SO88yiYGW1JaGlG5mv^5
zWk6AmT*!ff1uOw3%#Dm7rht^etcKAbSA*CfIZ%OS1ZsJK3NJGgaHxXBV1*ngX2As+
z$mvFqqT0lia3Kdu4In3B!yq4n3K~!jK*k{VAYpJJhfP074CF2ljSYheI#6l=g*`S5
zvKyN?C^aEryoDUdeoz?V!6=2CC1{unTFT*QY9Vc}!7Q9C4ZsB<qFhvfY+phyo=lL2
zi%bm>qeY-rmxYOfsTs<UwxI>67lhwQ$VD!On+z?87#IS@CoGI$Wg{qlK;aCM17UEA
z1u;N12bcp=G4RblNM8q1Hj>c%gI3cZ&%iJ!HA0$yCXnWz8MsNOU<TSehSL0lG^60n
zKVw4$c=OND1lrt#G)YWNVSE#!n}4ubD^ULl#0Jrzm;kXs7}RG3@j<x*#0KRqkhrOV
zDRkxw)T%O7Ft#vN0Lg>oKxQE4C{VKs)I0(;r9d?9vJn)^pt1m#K0rwT68)gU#u(D2
z1Pj0kNTCMjg4@U-V_-!i$T*NO$R#7laVR<<hJf4&vl&K%+zeuai~yB_u#yoJk1#P<
z$p{t$ITVCPn}6{31}I!WVTg`FX$mBU*8DRBAN7R47{Y!PAH1;$U6Be}_5~XFK`J8+
z!MFV(myt+Q(ipu|QxgSHrh*kypsER!89)&a!r(LnVt~qiFbAXpRM8n5n}d5>U_mko
zkioc{aG(iuP=6WJe}-UCP@0;Vftzk%`%R5NSrVE}LA@CK7?gcMz5{s%hCzO@G=lU-
z&CHAxKp0d6fQl(l$bi@&46+YY1c2BeISWgO9#E?TrVgYR#0JTO)Pb<2u_d?&1F=Ek
zAU}iL0HWbdIAhQd55(=Dq6JpOfb0aZK^Wq8a|IY1GRy_m1NT2jJ;;q9wIFpM46+wQ
zgD}W!P}2?67y{9_iz!gT1xG44$f3C%B0zi-4m4n8VyXZsr%V-K%Qle9DUj>H#)1h@
zSb`a#z=7Eeqd|@au|b|hE~h{d2@`{rQ(!TWt3lWp6lkDjMx!k_P`H2+0w^4DVB{8@
zA!xQ0e=!AVEji`qq+n?)5jj$Z-i<Valq{e`0K$kAVGcT>0<^pyGV%f*-2vq#unIB>
zkPV=bF4zbLXt4(@Xuw8-hRZ;TU>GcEZU8BS!2L+jkckDn9|i9(LHl0ld~iPtRCk&i
zD44=9Xs8S{P7OK-6+BD^={JJ<gy8<5xrKtcxrqX(e+IJO+{^^r*M#>E%`Ld#>Woam
zy>gIVSl<!s5f}&5HUN1B6mlTi)WQ%{k%2=K<XBKA6x8*C(I5xI#6g`y5FaE5VuL!`
zAhwC63AiH*YL|fYf*cA{2ht0&8$^S#v894Bs8ecW0H#3$;vfft`yL<$cvuwVO%MhP
zfEXYQaxO#wS_*+Vs05^?gAfDh17S!p1WiG3gFr1J5Qmh42s)Mu)&^Sk3+hIKu(<)G
zD+v-aHs%611VLh;LI{LGkq#QGGyx?Z=mZH^96UY-ouq(_nSmP5ASYqNV6TBBKoN<I
z!F~aa1wt^QF9}XPpcI6_pp*w1Apx0#jzLvCXv7c{YS=JHJ*a{}$Djm-gu(F%N)Xu0
z0ND=~2L%W+1_dODZ(x8r$p#v>N10>;2|&vxaH|OWB%6_b8tB$w<S8}_!YlK=kazuq
zO$RlyplvQA3yh`tkQF1yZ7$>$O=j?ZDVGKKd?!%97zd`q(hnRq({1SqrS@A`qKu^)
znu3Nbp(z2!Fazr0)94XuXo@ji3OUyrIYKRw*1Z}U!j~i|fENFOj;}`0rr_hOA!6uk
zbEq7c=0a5i76X}wQUxQ86yxxmucvcph$G5SZz^VGY>GaXVh9>UM)o1zZUSVAg`94J
zF`c>z;MrP4)nR4=pOgSq?Vu_iRNjDR4=v5WGuj|NHViAnz^x@S&>)ftXrhM;wVPnB
zU~ULnIBy8<kb}xZ&}=NI(gT&l=AdSZp`n5WXfeBy5vU8mWoinh!Ceecxd<v}!TOAh
zz%$7(Hb@*)xq#dOqEWjEhzTf=+d*Y8NDYV$!XP~$3}b`Jcn}*@p+ITyY%|D>Fm)ht
zkli2}gh6J4x(A>ZH;ATnHvt^F&~5@!{Y-H`!B_#ap8yfV-cK+FHG>pJM|wfCI*?Qb
zN)0$Lav?>;s4B`4+~@@`Xiyb(UA+bRvU-$dfrgey1HF(DOHdv_#wI3+O(Q0ty=Kr6
zN>I!rs{?It0rAaEj1<g_j6nGn*=L4?$BV=Kd_r9#k&9o<!q*6+@J09Eh$wt<BqeaR
zgUNvkB@o76_!>bAU(kvHNTCWUz>JLz!4u#hwwa-kf`uh$Y7Q)qR`?nzfaF2yK-kg*
zt`0m@4N4FoH-Ko=!WYz2GE@L1E>i;t4YCu&24N!$Lj@3qu_0qLU_D$QF_0fY>WwWC
z>OkTkH-O|oY>?TYLU*+A1y8|YSxW#Ku>*w|HVhgI2X~1K4Z$%9s!Bl^6q868(KUip
z&7kTTjzK98o7o^SP_+%JO2JhmXweoL2HA~G4wRaZFr;e)>gr&_pe6@4afBFh5d|LZ
z#ozozJ1-l(_%+Aap#eUL8@X+0VS!i%U}%Kc)&v@WKnhoI^9zX&9#cT#qstTG<J1q@
z0|zqK%oJst7vT*nc*d(Ni5#v1^-fLA5UU=B%5W8A!~xM529-;Ykq1cGgU*J?gF+dE
z!5wyt;VRHMkdSFTb0ZKNvP2Tp=!6VcL8k4%!&PRM3h;6kJX{4C-v{Xf<tj5X#5g&0
zgabO)2b#(?hV&x94nZ2O0u`7b&7k#>pxxLY8mz_u)G9{|BZAa`vY!QX*S4vFAs0wJ
zNF1!k5)?R~sSuEZAp`rcKmldvVLMy}+VM9!Tx9|3qC(1KQ07LIvxt@nDCL91LGs8L
zCI%X=LM+fSM;e^M(Q9|~hzxah(RTKAjli<a-5g`5j5%l^0J%s;9$_+sZ^Y#S@4yD_
z!ZtKlFo7O^0Ll_LF=%-dQsdav(pUk6K|9Go7&5K_ntwxduyLAYjClY99<|s?f1D*g
zk>=1`zo7|YZ97do051GM1ac*hG!X-@y%BT1;NAt&dO^^13?eZaS%5}*@V5}~REtIy
zCL^R`1WhKx*1UixR>704kohtYAGLynB}nWQBWNNSxneX2uY18>F`A%NjD`web%vnM
zjTv~f2-NfhVNkMww^KoFO^_o%6&r{~p2q<@+7vRd0;%L6n>rxkpq1#591W5K%@%_u
zxj<}C+ZIflf;Jq0CY&Hki@{<Bphb(|b=BZ<akOF_oyUR9V8SXv!WE+#;TF1ks9T7m
z6Z8N;jG+`WjJ}E)sBFYlF(Pj!2d!N-ha97Va|!}J{bFuz4nA-Ni%Pf}EOMYplmU?k
zO~%6A!v&g_1#Kn=wHe@|Ah#hf6<i5gMGUeRL=$HVG*ppmHZ#IaC8rS22v^W%@*p$J
z^nlS&G6Q)UIX#%7w3N)?Lx-RZY#?l6Xr@2{<|08YHgjpNAG8q-j~g-Vw?Nr7ZAN%H
z%`w<9EC6(YP7vnielv`@G&9f`DsqG%jddEDA<k#A03AVMYNB9FI_4rn53)TZ=?Cpk
zLbHzxbnpN&2Fb(tAT|ht_#hgFk<1~<ewcnFn&$dVEzFU_3!RN(zlo6{_{=9H_o1st
z=cDK+K_AQ<s_D0|Ks{3lG)xa|Ipb}2Lr)AvG`h_|1tL@@jvk<ow{xg3xLCu|0W`x{
z`)&%VI&ozql#_-`!8MneCH9#SP-zWnE@Htn?>vE*1%bBGfyNy`yVVdKPf%Zq_%&2W
z`jGrXd-o&R3#$1*VTeS7?FTJ!0*S*gcsUdneIR*|UQk^PT0#YynS#=wu)vBzopF#p
zbPTl<Y(Kgj34E&Q2l)vUFL=@*avQ+N5L9R5&n?g#hS2~pGBhRJJ%t>B0YAO~ytkT2
zF)AK)06%9H&3=$LPE6vNv>4_<-H#y-K8X_4{2_qJupbo8Ap5{Ho$UwNiGrc_qljS%
zf1L6}=*OuSWDlA8Vc};$rhd4aM!J5~RfM3We<-U6K?2Z%2VB8pUqxtWY^I-_S(IFw
zo0gMWfxMUyaRYfkQGQBka%z!=yI-h+dq#e7NpUjh<X#1HJp*%1J3Hvzl@&#)X<P;h
z#wHeA25_KYW@>6|s*t7t7Be(6GBq<-0Lv=mLBxzqER2jzQN;|+j0{Z7FvLI$fl>4t
zni?CJ8=$HKDFBtaAR1<efq{V~=xi@!F(VUWBhc+JsA7hoqj5n(1~9#bW)>DkmZ)|Z
znpv0{n4pRonHU%t8ls9Bnwgt})<uF0M3`p|+DQQtg4<zaYymnu07cBu%m}p58C?vt
z{0c?P$k+^Yjwy<mp{cQvF=n`c4*x(=XJBB2>0fgb&?q^IIzw|41JG?#AVHWvjEs#e
zL1((4i=o?VWNc_|Zj2r-MxY~*L0aKqU}$P=3|ejj5`@_Savx|>E2@~O8E6(4S<J}9
z%+M4)K8!5Q(c{R_%*et3Jzbd^gZeKZ<KS*FFfcU(oe>BUM7YJ$5Ho&_EI{pHWOat7
z#u)KtU|?woI<pH|oq?f|DQJNwvY4Tnk);88SeY7IfL1gjs{`pZNAs_Np{cnsMmjaJ
z1dSpg>oqhrwluXsjSrAsbblBaTAHG(Gqf}`H9*sAXlV#uB#dl_k&&f=5t{o9EsPCJ
z(EVm%WQLKhjLb|yd-ajcGqkiYGDO#FX>JKx#DuKQ$jH>(7(<<jsU>=xTbdZ5+hJs4
zW`u5@p{0?D33`}X8W~!k*<oa2YK$HqMh0ev=w+CZfvKetT3H9O0X=^h8JHS??&U!7
zn}G@FC~%MvJe?Yun3!OMshKfmIb>>L2s$Sgq#2%`4J}PUD=bjNjEs%Z!@$VE*cddp
ziLB1Zz{nDG3_OaMiIExT2pSYILkk1Ys0*r?xrGT@8Zt65Gz8tFf~w98bPy3p2;pBt
zGh_60YGiC_j$RHKni(4!qnE{|CPwIGgn^MUs1t!=hk=o~F=%@bNDvlQhGxd#xh51b
zQxnkn&mbYV`#^fp^PqvT0q7tF6m^DX#wO@>l%c5!Mt%e7H9^Zq2F50!4Idchf$ot7
z3BuiMYGQ7PUI!SP7@MPoi-EC)1?ZGY6uqEeM$>C(YGMHz@IqDx(u-l9iLoI@o-s2v
zH$cxvrltmlXl(%l6JtY6^URFU#SG1iElkk-VQ6Y<Xl{g7u9=vD&mBW?vx%hzdfqZL
zGqwcHB_gXcG&MCg!f>CZC3>5|z|`0rbh#diUNaLzL-aDo)YJr{eghR7=x#POH%4!(
z7@C<Ffo=vzvBT69bj~?Q2$B9w&5hB^5(6^>3v_!8%}k7qG2I8c_z~4SGXqQXI@G|-
z7(<<*nTZK{`C@2lYKfi)4a|%&>R$shGjn6KG;U~SVv1f48Je0IfG)QLIS`h{L3%-#
zN1%#XTAE>+XNI1S3{B09(9@8CnWZI$9p)y6nB{?qIcOyWvb~0;W}u^{K|+Z5FgGzo
zuip&J&CRg**8;Q*0;Cz{H$zi1Q}nVOq!+`#7KY%nMp5*dnHpfY+0@Joy^J-mFf_)<
zgBB*{=x#PLGzA^-2C@R~HzPw+BlPx=k+B6v8_v+o)DXQ)G&D7{KyUjPSeTe&lrI+M
z=Adi9K^DWq#mv+QJ&hZhnj3&_(L+{eU}28gZn884?|(s7XJ}?>Vt`gB8=9IMnxcsr
zSQ;9l*YO6HCgx`7<&YU>J_j|;(DMgKFM2z|z|!0tU7evBsNg^?*9=X~G1?^{z36Q&
z14|3cc9@wd=<G325WwTo(9|5GjRevQI`0vr5FYjhMh570sF8s=Xk!6L8QeT012ap|
zfyN*~m|i1eQxnh~&B$VgW~QL)ML<Fby~ZZS=zR!7Q*(3lykKZxWPp(e4a^KM+-zow
z*$*%^2OU&|Vy~frnE`s=)X>1v0<$bJHAipL7@ArbV3f}WmKNw`iJ_sfC1%}dYJpid
zS{P!~M~23h81<l`sUb#t*UZ!cv(0Y-TAhvRUqe%jG;Rp0XwchcMkZz$`NPcA61`7i
zXlh}C-Y)~0htak$v@pPu4lFV1C{qhF^tQ60p#^3i%*fEd0Ii-jG&3{6EORW((c1@x
zMur9$eS0G#ON{oeiMauWTg=Q1G4z^RV6+bmjf^ZY+Ga*3hM-F=KoJ7VABJXTh8XF^
z)Y1Snjf|qs$ixsMFBq9(w5biv%#6_coQ9^BnEfatQw#Jl6hk9(OU!W#Gthb*kW=7!
z)zH)uqdjhDWMP2O_A#;mtyM?WYi4GQUS1iRTAE_SrICdhhChrfG3p9KGf*QFy_~c(
zLocrkjVv+SFUE$3peuku4n&F%6ZH0<p{b<>=w1vIb;h7nj%Kg1kr8@bW@u&xI@lDX
z6*>GY(fdM%#zvTZ4Pz4v^mdq`nHgyN8mf6_pn)!Qx0qO<_sa~8O|i6D%|P3P(9JW#
z2p3~hbM$tTp|Kfg%@mqmGc$~G$jkt=Jr7l#u^H&lSTr#U1B^H~GXouRi>l7dz!ak$
zYixm0M;V$J8DP{YW@eyWEa>K$VdPa4BLh>kHo76GiZVnCXEQTP%yQDe!WgYQ1?fc}
zdoTp`<4rKl!|VqbSX!X9OF()t$_UU{28R304bc08hGvEs<5GquW=0rwiisIUnP_Nc
zj#*!tfl3ZEf0&qAg3e0=1vETwnOK;k*8!mMSoHA-BO^m|^mJfkWC*&e3S=BS9~l{&
zTcWpjjf@O1>J%eTlL39~#@GaNJjc)yqt9++XbGD1L$lYw61}`KGPE>A&(lVR7MAF3
zej_7G(4;4-c}6CN=<N+7BV$YSwkW8CKpz)10@X8U^`McFkvXPbbI|%q6nhQL%ndQd
z*USt}(A{ikVqt;a<~KAou*B?7n;T)aiw#ZD<J{2H&;Y$ZZD?v}hLJza%)$3HfgBA_
zLuQ8Nn0-1>PZTZvnHm{l_`}TH7(J~Sni+ylJ_1<*PgkHW4tn^3<{Z%5a7IQ(#^~e9
zMxexomZy!3%(3*3Fx&EmW)>#seFM-KJbD^8v@kNm5VJHiLQg}6mPUpc^^v8C5k_5R
ziP<g&jrF0=&lnk)SfICGKx3Qebrh%{fSEr`4bjtqk)avrtYnn1H!?KGsJB4*2tA#G
z@+Eq^7##FyWj3hXK=12<;t0JT3d%F+=>?PrF~v+k2d1OC*%;J|MNNN3#^xAv1V$zn
zhRAKMlA^@SoYW#N8yf}v;LNI2&?K6Ieo%gXi2`VyPLP7WXI@&q0(iL@=qAqMlEk7C
T@O&F+_RPYROI6j?-;E0Z!<7|y
diff --git a/documentation/flexpart9.2.tex b/documentation/flexpart9.2.tex
deleted file mode 100644
index 4f9447cb..00000000
--- a/documentation/flexpart9.2.tex
+++ /dev/null
@@ -1,2835 +0,0 @@
-%% Version of source file:
-%% Date: 2003 July
-%% **************************************
-% * TEMPLATE FOR EGU STYLE *
-% * FOR ARTICLES IN JOURNALS AND BOOKS *
-%% **************************************
-% Various alternatives for the input are shown, commented out.
-% E.g., for the documentstyle options
-% for the bibliography
-% Feel free to play around with these variations, especially with
-% the style options ms and twocolumn and 11pt/12pt
-
- %%%% LATEX2E: SELECT ONE OF THE NEXT LINES
-\documentclass{egu} % MANUSCRIPT, 10PT TYPE SIZE
-%\documentclass[ms,11pt]{egu} % MANUSCRIPT, 11PT TYPE SIZE
-%\documentclass{egu} % for EGU TWO-COLUMN REVISED COPY
-%% <<<<<<<<<<<<<<<<<<<<<<<<<<<>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>
-%% REMOVE THIS LINE ONLY IF IT CAUSES PROBLEMS
- \usepackage{times} % WITH TIMES ROMAN FONT
-% ^^^^^^^^^^^^^^^^^^
-%% This is STRONGLY recommended for the revised version!!
-%% <<<<<<<<<<<<<<<<<<<<<<<<<<<>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>
-
-
-%% ADD THIS PACKAGE IF GRAPHICS ARE TO BE IMPORTED
-\usepackage{graphicx}
-\usepackage{amsmath}
-%\usepackage{psfig}
-
-\printfigures % PRINTS OUT FIGURES AT END OF MANUSCRIPT
-\newcommand{\degreee}{{$\, \rm ^{\circ}$}}
-\newcommand{\degreen}{{$\, \rm ^{\circ}$~}}
-
-\begin{document}
-
-\title{The Lagrangian particle dispersion model FLEXPART version 9.2}
-
-\author[1]{A. Stohl}
-\author[1]{H. Sodemann}
-\author[1]{S. Eckhardt}
-\author[2]{A. Frank}
-\author[2]{P. Seibert}
-\author[3]{G. Wotawa}
-
-\affil[1]{Norwegian Institute of Air Research, Kjeller, Norway}
-\affil[2]{Institute of Meteorology, University of Natural Resources and Applied Life Sciences, Vienna, Austria}
-\affil[3]{Preparatory Commission for the Comprehensive Nuclear Test Ban Treaty Organization, Vienna, Austria}
-
-\runningtitle{FLEXPART description}
-\runningauthor{Stohl et al.}
-%\runninghead{} % This may also be used instead of \runningtitle and \runningauthor
-
-\correspondence{A. Stohl (ast@nilu.no)}
-
-
-%\journal{ACP} % for NONLINEAR PROCESSES IN GEOPHYSICS
-
-\date{Manuscript version from 29 November 2010}
-
-% ADDITIONAL NON-STANDARD COMMANDS FOR TITLE BLOCK INFORMATON
-\firstauthor{Stohl}
-%\proofs{A. Stohl\\
-%Norwegian Institute for Air Research\\
-%Instituttveien 18, 2027 Kjeller, Norway}
-%\offsets{A. Stohl\\
-%Norwegian Institute for Air Research\\
-%Instituttveien 18, 2027 Kjeller, Norway}
-
-% The manuscript number is supplied by the editorial office
-\msnumber{12345}
-
-% The following commands will be activated by the EGU editorial/production office
-% after inserting appropriate values.
-
-
-\maketitle % YOU MUST USE THE \maketitle COMMAND
-
-\begin{abstract}
-The Lagrangian particle dispersion model FLEXPART was originally (in its first
-release in 1998) designed for calculating the long-range and mesoscale
-dispersion of air pollutants from point sources, such as after an accident in a
-nuclear power plant. In the meantime FLEXPART has evolved into a comprehensive
-tool for atmospheric transport modeling and analysis. Its application fields
-were extended from air pollution studies to other topics where atmospheric
-transport plays a role (e.g., exchange between the stratosphere and
-troposphere, or the global water cycle). It has evolved into a true community
-model that is now being used by at least 35 groups from 14 different countries
-and is seeing both operational and research applications. The last citable
-manuscript for FLEXPART is: \citep{stohl2005}
-\end{abstract}
-
-\section{Updates since FLEXPART version 8.0}
-
-In this version 8.2 of FLEXPART the representation of physical processes was
-improved as well as a number of technical changes and bugfixes implemented. In
-addition, the program is now released under a GNU GPL license. For the first
-time, detailed installation instructions are provided to help users getting
-started with running FLEXPART. A short section on the new Python routines
-pflexpart for reading FLEXPART output data has been included as well.
-\bigskip
-
-\noindent {\bf Technical Changes:}
-
-\begin{itemize}
-
-\item grib2 compatibility for ECMWF data which will be introduced soon (new
-data retrieval routines available)
-
-\item AVAILABLE files can now contain up to 256 characters, and include the
-path directly with the input file name. This is used to gather data files
-stored in different directories. The third line in the \verb|pathnames| file
-should be left empty if long data file names are used.
-
-\item The code was updated to work with the ECMWF grib\_api V1.6.1 and above
-(tested up to 1.9.5)
-
-\item An important bug the concentration output routines was fixed. A
-numerical problem lead in some circumstances to garbled data. The header
-version identifier has been changed to version 8.2. New routines for loading
-data available for download on the FLEXPART homepage.
-
-\item Several bugs in the wet deposition parameterization were fixed.
-
-\item A bug which lead to ignoring landuses that was introduced in version 8.0
-has been fixed.
-
-\item Several bugs concerning nested grids have been fixed.
-
-\end{itemize}
-
-\noindent {\bf Algorithm Changes:}
-
-\begin{itemize}
-
-\item A new, more detailed settling parameterisation for aerosols was
-implemented. The dynamic viscosity of air is now calculated as a function of
-temperature, and the calculation of settling velocities is now more accurate
-for higher Reynolds numbers.
-
-\item It is now possible to produce output files for backward runs that can be used
-to interface FLEXPART with model output from another model or from a FLEXPART
-forward run. A gridded output file containing the exact sensitivities to these
-initial conditions can produced. To this end, a new switch has been added in
-the COMMAND file.
-
-\end{itemize}
-
-\section{Introduction}
-
-Lagrangian particle models compute trajectories of a large number of so-called
-particles (not necessarily representing real particles, but infinitesimally
-small air parcels) to describe the transport and diffusion of tracers in the
-atmosphere. The main advantage of Lagrangian models is that, unlike in
-Eulerian models, there is no numerical diffusion. Furthermore, in Eulerian
-models a tracer released from a point source is instantaneously mixed within a
-grid box, whereas Lagrangian models are independent of a computational grid and
-have, in principle, infinitesimally small resolution.
-
-The basis for current atmospheric particle models was laid by
-\citet{thomson1987}, who stated the criteria that must be fulfilled in order
-for a model to be theoretically correct. A monograph on the theory of
-stochastic Lagrangian models was published by \citet{rodean1996} and another
-good review was written by \citet{wilson1996}. The theory of modeling
-dispersion backward in time with Lagrangian particle models was developed by
-\citet{flesch1995} and \citet{seibert2004}. Reviews of the more practical
-aspects of particle modeling were provided by \citet{zannetti1992} and
-\citet{uliasz1994}.
-
-This note describes FLEXPART, a Lagrangian particle dispersion model that
-simulates the long-range and mesoscale transport, diffusion, dry and wet
-deposition, and radioactive decay of tracers released from point, line, area or
-volume sources. It can also be used in a domain-filling mode where the entire
-atmosphere is represented by particles of equal mass. FLEXPART can be used
-forward in time to simulate the dispersion of tracers from their sources, or
-backward in time to determine potential source contributions for given
-receptors. The management of input data was largely taken from FLEXTRA, a
-kinematic trajectory model \citep{stohl1995}. FLEXPART's first version was
-developed during the first author's military service at the
-nuclear-biological-chemical school of the Austrian Forces, the deposition code
-was added soon later (version 2), and this version was validated using data
-from three large tracer experiments \citep{stohletal1998}. Version 3 saw
-performance optimizations and the development of a density correction
-\citep{stohlthomson1999}. Further updates included the addition of a
-convection scheme \citep{seibertetal2001} (version 4), better backward
-calculation capabilities \citep{seibert2004}, and improvements in the
-input/output handling (version 5). Validation was done during intercontinental
-air pollution transport studies \citep{stohl1999, forster2001, spichtinger2001,
-stohl2002, stohl2003}, for which also special developments for FLEXPART were
-made in order to extend the forecasting capabilities \citep{stohl2004}.
-Version 6.2 saw corrections to the numerics in the convection scheme, the
-addition of a domain-filling option, and the possibility to use output nests.
-Version 6.4 runs with NCEP GFS model data. Version 7.0 was a transition
-version that was not publicly released. Version 8.0 was a major release. It
-unifies the ECMWF and GFS model versions in one source package. GFS data in
-GRIB2 format can be read, using ECMWF's grib\_api library. Each species
-got its own definition file. Output can be written individually for multiple
-species in backward runs. The output format was changed to a compressed sparse
-matrix format. Memory is partly allocated dynamically. Furthermore, dry and
-wet deposition algorithms were updated and new, global landuse inventory
-introduced. OH reaction based on a monthly averaged 3 dimensional OH-field is
-available as an option.
-
-FLEXPART is coded following the Fortran 95 standard and tested with several
-compilers (gfortran, Absoft, Portland Group) under a number of operating
-systems (Linux, Solaris, Mac~OS~X, etc.). The code is carefully documented and
-optimized for run-time performance. No attempts have been made to parallelize
-the code because the model is strictly linear and, therefore, it is most
-effective to partition problems such that they run on single processors and to
-combine the results if needed.
-
-FLEXPART's source code and a manual are freely available from the internet page
-http://transport.nilu.no/flexpart. According to a recent user survey, at least
-34 groups from 17 countries are currently using FLEXPART. The user community
-maintains discussion by a mailing list to which one can subscribe on the
-flexpart home page. The version of FLEXPART described here is based on model
-level data of the numerical weather prediction model of the European Centre for
-Medium-Range Weather Forecasts (ECMWF). The standard source code distribution
-contains also the source files for a version of FLEXPART using the global
-National Centers of Environmental Prediction (NCEP) model data on pressure
-levels. Other users have developed FLEXPART versions using input data from a
-suite of different and meso-scale (e.g. MM5, WRF, COSMO) models, some of which
-are available from the FLEXPART website but are not described here.
-
-\section{License}
-
-FLEXPART has been free software ever since it first was released. The status as
-a free software is now more formally established by releasing the code under
-the GNU General Public License (GPL) Version 3. The text of the license is
-included in the file COPYING in the source code archive.
-
-\section{Installation}\label{sec:installation}
-
-Getting FLEXPART up and running on their systems has been a major hurdle to many
-new users of the software. Since the inclusion of the grib\_api library has further
-complicated the compilation of FLEXPART, we include a step-by-step installation
-instruction of FLEXPART. The steps below are described for an Ubunto 10.4 LT
-UNIX release.
-
-\subsection{Installing required libraries}
-
-In order to process input files in GRIB2 format, FLEXPART V8.2 needs to be
-compiled with ECMWF's grib\_api library version 1.6.1 and above. Since the API
-of the grib\_api library may change in the future, upward compatibility cannot
-be guaranteed. The input files in GRIB2 format can be compressed to save
-bandwitdth and storage space. In order to make use of this feature, the jasper
-library needs to be installed on the system. Optionally, the emos library can
-be used to run FLEXPART with input files in GRIB1 format.
-
-\noindent The following steps should be executed in sequence:
-
-\subsubsection{Install jasper library (Version 1.900.1)}
-
-Download the jasper library from the jasper project page\footnote{http://www.ece.uvic.ca/~mdadams/jasper/}
-
-\begin{small}
-\begin{verbatim}
-unzip jasper-1.900.1.zip
-cd jasper-1.900.1
-./configure [--prefix=<installation path>]
-make
-make check
-make install
-\end{verbatim}
-\end{small}
-
-Parameters in brackets are optional but may require root privileges.
-
-\subsubsection{Install grib\_api library (Version 1.6.1 or later)}
-
-Download the grib\_api library from the ECMWF
-website\footnote{http://www.ecmwf.int/products/data/software/download/grib\_api.html}
-
-\begin{small}
-\begin{verbatim}
-tar -xvf grib_api-1.12.3.tar.gz
-./configure [--with-jasper=<jasper path>]
-make
-make check
-make install
-\end{verbatim}
-\end{small}
-
-\subsubsection{Optional: Install emos library (Version 000372)}
-
-Download the emos library from the ECMWF
-website\footnote{http://www.ecmwf.int/products/data/software/interpolation.html}
-
-\begin{small}
-\begin{verbatim}
-tar -xvf emos_000372.tar.gz
-./build_library
-./install
-\end{verbatim}
-\end{small}
-
-\subsection{Compiling FLEXPART V8.2}
-
-Download the FLEXPART source code archive from the FLEXPART
-homepage\footnote{http://transport.nilu.no/flexpart/flexpart/view}
-
-\begin{small}
-\begin{verbatim}
-tar -xvf flexpart82.tar.gz
-\end{verbatim}
-\end{small}
-optionally edit the file includepar to set parameters for the data center, grid
-dimension, and particle number edit the LIBRARY path variable in the makefiles
-according to the position of libgrib\_api and libjasper
-\begin{small}
-\begin{verbatim}
-make -f makefile.<center>_<compiler>_<system>
-\end{verbatim}
-\end{small}
-In the above statement, center can be one of: gfs, ecmwf, ecmwf\_emos,
-gfs\_emos compiler can be one of absoft or gfortran (emos library only with
-absoft) system can be one of 32, 64 (emos only 32). The system parameter must
-match that of the compiled libraries. See also Table~\ref{tab:makefile} for all
-available makefiles.
-
-When recompiling after making changes, all object and module files can be
-removed safely by using
-\begin{small}
-\begin{verbatim}
-make -f makefile.<xxx> clean
-\end{verbatim}
-\end{small}
-
-\begin{table*}
-\setlength{\tabcolsep}{1.1mm}
-\caption{\label{tab:makefile}
-List of available makefiles }
-\vspace{3mm}
-{\centerline{
-\begin{tabular}{llc} \hline
-Makefile GFS & Makefile ECMWF & GRIB version \\
-\hline
-makefile.gfs\_gfortran\_32 & makefile.ecmwf\_gfortran\_32 & 1/2 \\
-makefile.gfs\_gfortran\_64 & makefile.ecmwf\_gfortran\_64 & 1/2 \\
-makefile.gfs\_absoft\_32 & makefile.ecmwf\_absoft\_32 & 1/2 \\
-makefile.gfs\_absoft\_64 & makefile.ecmwf\_absoft\_64 & 1/2 \\
-makefile.gfs\_emos\_absoft\_32 & makefile.ecmwf\_emos\_absoft\_32 & 1 \\
-\hline
-\end{tabular}}}
-\end{table*}
-
-\section{Input data and grid definitions}
-
-FLEXPART is an off-line model that uses meteorological fields (analyses or
-forecasts) in Gridded Binary (GRIB) format in version 1 or 2 from the ECMWF
-numerical weather prediction model \citep{ecmwf1995} on a latitude/longitude
-grid and on native ECMWF model levels as input. Optionally, GRIB data from
-NCEP's GFS model, available on pressure levels, can be used. The ECMWF data
-can be retrieved from the ECMWF archives using a pre-processor that is also
-available from the FLEXPART website but not described here. The GRIB decoding
-libraries is {\it not} provided with the FLEXPART source codes but is publicly
-available (see Sec.~\ref{sec:installation}. The data can be global or only
-cover a limited area. Furthermore, higher-resolution domains can be nested
-into a mother domain.
-
-The file \verb|includepar| contains all relevant FLEXPART parameter settings,
-both physical constants and maximum field dimensions. As the memory required
-by FLEXPART is determined by the various field dimensions, it is recommended
-that they are adjusted to actual needs before compilation. The file
-\verb|includecom| defines all FLEXPART global variables and fields, i.e., those
-shared between most subroutines.
-
-\subsection{Input data organisation}
-
-A file \verb|pathnames| must exist in the directory where FLEXPART is started.
-It must contain at least four lines:\\ 1. line: Directory where all the
-FLEXPART command files are stored.\\ 2. line: Directory to which the model
-output is written.\\ 3. line: Directory where the GRIB input fields are
-located.\\ 4. line: Path name of the \verb|AVAILABLE| file (see below).\\ If
-nests with higher-resolution input data shall also be used, lines 3 and 4 must
-be repeated for every nest, thus also specifying the nesting level order. Any
-number of nesting levels can be used up to a maximum (parameter
-\verb|maxnests|).
-
-The meteorological input data must be organised such that all data for a domain
-and a certain date must be contained in a single GRIB file. The
-\verb|AVAILABLE| file lists all available dates and the corresponding file
-names. For each nesting level, the input files must be stored in a different
-directory and the \verb|AVAILABLE| file must contain the same dates as for the
-mother domain. Given a certain particle position, the last (i.e., innermost)
-nest is checked first whether it contains the particle or not. If the particle
-resides in this nest, the meteorological data from this nest is interpolated
-linearly to the particle position. If not, the next nest is checked, and so
-forth until the mother domain is reached. There is no nesting in the vertical
-direction and the poles must not be contained in any nest.
-
-The maximum dimensions of the meteorological fields are specified by the
-parameters \verb|nxmax, nymax, nuvzmax, nwzmax, nzmax| in file
-\verb|includepar|, for x, y, and three z dimensions, respectively. The three z
-dimensions are for the original ECMWF data (\verb|nuvzmax, nwzmax| for model
-half levels and model levels, respectively) and transformed data (\verb|nzmax|,
-see below), respectively. The horizontal dimensions of the nests must be
-smaller than the parameters \verb|nxmaxn, nymaxn|. Grid dimensions and other
-basic things are checked in routine \verb|gridcheck.f| (\verb|gridcheck_gfs.f|
-for the GFS version), and error messages are issued if necessary.
-
-The longitude/latitude range of the mother grid is also used as the
-computational domain. All internal FLEXPART coordinates run from the
-western/southern domain boundary with coordinates (0,0) to the eastern/northern
-boundary with coordinates (nx-1,ny-1), where (nx,ny) are the mother grid
-dimensions. For global input data, FLEXPART repeats the westernmost grid cells
-at the easternmost domain "boundary", in order to facilitate interpolation on
-all locations of the globe (e.g., if input data run from 0 to 359\degreen with
-1\degreen resolution, 0\degreen data are repeated at 360\degreee). A global
-mother domain can be shifted by \verb|nxshift| (file \verb|includepar|) data
-columns (subroutines \verb|shift_field.f| and \verb|shift_field_0.f|) if nested
-input fields would otherwise overlap the "boundaries". For instance, a domain
-stretching from 320\degreen to 30\degreen can be nested into the mother grid of
-the above example by shifting the mother grid by 30\degreee. The default setting
-for global ECMWF fields is \verb|nxshift=359|, while GFS fields the default
-value is \verb|nxshift=0|.
-
-\subsection{Vertical model structure and required data}
-
-FLEXPART needs five three-dimensional fields: horizontal and vertical wind
-components, temperature and specific humidity. Input data must be on ECMWF
-model (i.e. $\eta$) levels which are defined by a hybrid coordinate system.
-The conversion from $\eta$ to pressure coordinates is given by $p_k=A_k+B_kp_s$
-and the heights of the $\eta$ surfaces are defined by $\eta_k=A_k/p_0+B_k$,
-where $\eta_k$ is the value of $\eta$ at the $k^{\rm_{th}}$ model level, $p_s$
-is the surface pressure and $p_0=$101325 Pa. $A_k$ and $B_k$ are coefficients,
-chosen such that the levels closest to the ground follow the topography, while
-the highest levels coincide with pressure surfaces; intermediate levels
-transition between the two. The vertical wind in hybrid coordinates is
-calculated mass-consistently from spectral data by the pre-processor. A
-surface level is defined in addition to the regular $\eta$ levels. 2~m
-temperature, 10~m winds and specific humidity from the first regular model
-level are assigned to this level, to represent "surface" values.
-
-Parameterized random velocities in the atmospheric boundary layer (ABL, see
-sections~\ref{PBLparameterization} and \ref{diffusion}) are calculated in units
-of m s$^{-1}$, and not in $\eta$ coordinates. Therefore, in order to avoid
-time-consuming coordinate transformations every time step, all
-three-dimensional data are interpolated linearly from the ECMWF model levels to
-terrain-following Cartesian coordinates $\tilde{z}=z-z_t$, where $z_t$ is the
-height of the topography (subroutine \verb|verttransform.f|). The conversion
-of vertical wind speeds from the eta coordinate system into the
-terrain-following co-ordinate system follows as
-
-\begin{equation}
-\tilde{w}=\dot{\tilde{z}}=\dot{\tilde{\eta}} \left( \frac{\partial p}{\partial z} \right)^{-1} + \left.\frac{\partial \tilde{z}}{\partial t}\right|_\eta + \vec{v}_h \cdot \nabla_\eta \tilde{z} \,
-\end{equation}
-
-where $\dot{\tilde{\eta}}=\dot{\eta} \partial p / \partial \eta$. The second
-term on the right hand side is missing in the FLEXPART transformation because
-it is much smaller than the others. One colleague has implemented this term in
-his version of FLEXPART and found virtually no differences (B. Legras,
-personal communication).
-
-FLEXPART also needs the two-dimensional fields: surface pressure, total cloud
-cover, 10~m horizontal wind components, 2~m temperature and dew point
-temperature, large scale and convective precipitation, sensible heat flux,
-east/west and north/south surface stress, topography, land-sea-mask and subgrid
-standard deviation of topography. The landuse inventory of \citet{belward1999}
-is provided in an extra file in the options directory (\verb|IGBP_int1.dat|).
-
-Note that GFS data is provided on pressure levels (currently 26) which requires
-that the FLEXPART code is compiled with a makefile for the GFS model. GFS data
-are freely available from the NCEP data archives. An example for a retrieval
-of GFS data files via ftp is given below:
-
-\begin{small}
-\begin{verbatim}
-cd $DIR_GFS_05TEMPORARY
-ftp ftpprd.ncep.noaa.gov << EOF11
-binary
-cd /pub/data/nccf/com/gfs/prod/gfs.2009111006
-get gfs.t06z.pgrb2f00 GF09111006
-quit
-EOF11
-\end{verbatim}
-\end{small}
-
-\subsection{Meteorological input data formats}
-
-While NCEP has already switched to the more flexible and compact GRIB2 format,
-the ECMWF is only gradually transitioning from GRIB1 to the new GRIB2 format.
-Transition to GRIB2 becomes necessary, at least for 3D fields, when the ECMWF
-increases the vertical resolution beyond 100 model levels in 2012 (which cannot
-be handled by the GRIB1 format). Currently, GRIB2 codes have been defined for
-all 3D-fields required by FLEXPART, while definitions are still missing for a
-part of the 2D-fields.
-
-According to the ECMWF it may take another year to define the GRIB2 codes for
-all 2D-fields used by FLEXPART. Therefore, in version 8.2, it is now possible
-to read in GRIB files that contain only GRIB1 coded fields, files that contain
-only GRIB2 coded fields, and files that contain mixed GRIB1/2 fields. Such
-mixed GRIB1/2 files are produced by the current version 4 of the FLEXPART data
-retrieval routines (available from the FLEXPART hompage).
-
-\section[Physical parameterizations]{Physical parameterization of boundary layer parameters}
-
-\label{PBLparameterization} Accumulated surface sensible heat fluxes and
-surface stresses are available from ECMWF forecasts. The pre-processor selects
-the shortest forecasts available for that date from the ECMWF archives and
-deaccumulates the flux data. The total surface stress is computed from
-
-\begin{equation}
-\tau=\sqrt{\tau_1^2+\tau_2^2} \;,
-\end{equation}
-
-where $\tau_1$ and $\tau_2$ are the surface stresses in east/west and
-north/south direction, respectively. Friction velocity is then calculated in
-subroutine \verb|scalev.f| as
-
-\begin{equation}
-u_*=\sqrt{\tau/\rho} \;,
-\end{equation}
-
-where $\rho$ is the air density \citep{wotawa1996}. Friction velocities and
-heat fluxes calculated using this method are most accurate \citep{wotawa1997}.
-However, if deaccumulated surface stresses and surface sensible heat fluxes are
-not available, the profile method after \citet{berkowicz1982} (subroutine
-\verb|pbl_profile.f|) is applied to wind and temperature data at the second
-model level and at 10~m (for wind) and 2~m (for temperature) (note that
-previously the first model level was used; as ECMWF has its first model level
-now close to 10~m, the second level is used instead). The following three
-equations are solved iteratively:
-
-\begin{equation}
-u_*=\frac{\kappa\Delta u}{\ln {\frac{z_l}{10}} -\Psi_m(\frac{z_l}{L}) +\Psi_m(\frac{10}{L})} \; ,
-\end{equation}
-
-\begin{equation}
-\Theta_*=\frac{\kappa\Delta \Theta}{0.74 \left[{\ln {\frac{z_l}{2}} -\Psi_h(\frac{z_l}{L}) +\Psi_h(\frac{2}{L})}\right]} \; ,
-\end{equation}
-
-\begin{equation}
-L= \frac{\overline{T}u_*^2}{g \kappa \Theta_*} \;,
-\end{equation}
-
-where $\kappa$ is the von K\'{a}rm\'{a}n constant (0.4), $z_l$ is the height of
-the second model level, $\Delta u$ is the difference between wind speed at the
-second model level and at 10~m, $\Delta \Theta$ is the difference between
-potential temperature at the second model level and at 2~m, $\Psi_m$ and
-$\Psi_h$ are the stability correction functions for momentum and heat
-\citep{businger1971, beljaars1991}, $g$ is the acceleration due to gravity,
-$\Theta_*$ is the temperature scale and $\overline{T}$ is the average surface
-layer temperature (taken as $T$ at the first model level). The heat flux is
-then computed by
-
-\begin{equation}
-(\overline{w'\Theta_v'})_0=-\rho c_p u_* \Theta_* \;,
-\end{equation}
-
-where $\rho c_p$ is the specific heat capacity of air at constant pressure.
-
-ABL heights are calculated according to \citet{vogelezang1996} using the
-critical Richardson number concept (subroutine \verb|richardson.f|). The ABL
-height $h_{mix}$ is set to the height of the first model level $l$ for which
-the Richardson number
-
-\begin{equation}
-Ri_l=\frac{(g/\Theta_{v1})(\Theta_{vl}-\Theta_{v1})(z_l-z_1)}{(u_l-u_1)^2+(v_l-v_1)^2+100u_*^2}\;,
-\label{richardson}
-\end{equation}
-
-exceeds the critical value of 0.25. $\Theta_{v1}$ and $\Theta_{vl}$ are the
-virtual potential temperatures, $z_1$ and $z_l$ are the heights of, and
-$(u_1,v_1)$, and $(u_l,v_l)$ are the wind components at the 1$^{\rm st}$ and
-$l^{\rm th}$ model level, respectively. The formulation of
-Eq.~\ref{richardson} can be improved for convective situations by replacing
-$\Theta_{v1}$ with
-
-\begin{equation}
-\Theta_{v1}'=\Theta_{v1}+8.5\frac{(\overline{w'\Theta_v'})_0}{w_* c_p}\;,
-\label{excess}
-\end{equation}
-
-where
-
-\begin{equation}
-w_*=\left[{ \frac{(\overline{w'\Theta_v'})_0 g h_{mix}}{\Theta_{v1} c_p} }\right]^{1/3}
-\end{equation}
-
-is the convective velocity scale. The second term on the right hand side of
-Eq.~\ref{excess} represents a temperature excess of rising thermals. As $w_*$
-is unknown beforehand, $h_{mix}$ and $w_*$ are calculated iteratively.
-
-Spatial and temporal variations of ABL heights on scales not resolved by the
-ECMWF model play an important role in determining the thickness of the layer
-over which tracer is effectively mixed. The height of the convective ABL
-reaches its maximum value (say 1500~m) in the afternoon (say, at 1700 local
-time (LT)), before a much shallower stable ABL forms. Now, if meteorological
-data are available only at 1200 and 1800 LT and the ABL heights at those times
-are, say, 1200~m and 200~m, and linear interpolation is used, the ABL height at
-1700 LT is significantly underestimated (370~m instead of 1500~m). If tracer
-is released at the surface shortly before the breakdown of the convective ABL,
-this would lead to a serious overestimation of the surface concentrations (a
-factor of four in the above example). Similar arguments hold for spatial
-variations of ABL heights due to complex topography and variability in landuse
-or soil wetness \citep{hubbe1997}. The thickness of a tracer cloud traveling
-over such a patchy surface would be determined by the maximum rather than by
-the average ABL height.
-
-In FLEXPART a somewhat arbitrary parameterization is used to avoid a
-significant bias in the tracer cloud thickness and the surface tracer
-concentrations. To account for spatial variations induced by topography, we
-use an "envelope" ABL height
-
-\begin{equation}
-H_{env}=h_{mix}+\min \left[\sigma_Z, c \frac{V}{N} \right]\; .
-\end{equation}
-
-Here, $\sigma_Z$ is the standard deviation of the ECMWF model subgrid
-topography, $c$ is a constant (here: 2.0), $V$ is the wind speed at height
-$h_{mix}$, and $N$ is the Brunt-Vaisala frequency. Under convective
-conditions, the envelope ABL height is, thus, the diagnosed ABL height plus the
-subgrid topography (assuming that the ABL height over the hill tops effectively
-determines the dilution of a tracer cloud located in a convective ABL). Under
-stable conditions, air tends to flow around topographic obstacles rather than
-above it, but some lifting is possible due to the available kinetic energy.
-$\frac{V}{N}$ is the local Froude number (i.e., the ratio of inertial to
-buoyant forces) times the length scale of the sub-grid topographic obstacle.
-The factor $c \frac{V}{N}$, thus, limits the effect of the subgrid topography
-under stable conditions, with $c=2$ being a subjective scaling factor.
-$H_{env}$ rather than $h_{mix}$ is used for all subsequent calculations. In
-addition, $H_{env}$ is not interpolated to the particle position, but the
-maximum $H_{env}$ of the grid points surrounding a particle's position in space
-and time is used.
-
-\section{\label{diffusion}Particle transport and diffusion}
-
-\subsection{Particle trajectory calculations}
-
-FLEXPART generally uses the simple ``zero acceleration'' scheme
-
-\begin{equation}
-{\vec{X}}(t+\Delta t)={\vec{X}}(t)+{\vec{v}}({\vec{X}},t) \Delta t\,,
-\label{firstorder}
-\end{equation}
-
-which is accurate to the first order, to integrate the trajectory equation \citep{stohl1998}
-
-\begin{equation}
-\frac{d {\vec{X}}}{dt}={\vec{v}}[{\vec{X}}(t)] \,,
-\end{equation}
-
-with $t$ being time, $\Delta t$ the time increment, ${\vec{X}}$ the position
-vector, and ${\vec{v}}=\overline{\vec{v}}+{\vec{v}}_t+{\vec{v}}_m$ the wind
-vector that is composed of the grid scale wind $\overline{\vec{v}}$, the
-turbulent wind fluctuations ${\vec{v}}_t$ and the mesoscale wind fluctuations
-${\vec{v}}_m$.
-
-Since FLEXPART version 5.0, numerical accuracy has been improved by making one
-iteration of the \citet{petterssen1940} scheme (which is accurate to the second
-order) whenever this is possible, but only for the grid-scale winds. It is
-implemented as a correction applied to the position obtained with the ``zero
-acceleration'' scheme. In three cases it cannot be applied. First, the
-Petterssen scheme needs winds at a second time which may be outside the time
-interval of the two wind fields kept in memory. Second, if a particle crosses
-the boundaries of nested domains, and third in the ABL if \verb|ctl|$>0$ (see
-below).
-
-Particle transport and turbulent dispersion are handled by the subroutine
-\verb|advance.f| where calls are issued to procedures that interpolate winds
-and other data to the particle position and the Langevin equations (see below)
-are solved. The poles are singularities on a latitude/longitude grid. Thus,
-horizontal winds (variables \verb|uu,vv|) poleward of latitudes
-(\verb|switchnorth, switchsouth|) are transformed to a polar stereographic
-projection (variables \verb|uupol,vvpol|) on which particle advection is
-calculated. As \verb|uupol,vvpol| are also stored on the latitude/longitude
-grid, no additional interpolation is made.
-
-\subsection{The Langevin equation}
-
-Turbulent motions ${\vec{v}}_{t}$ for wind components $i$ are parameterized
-assuming a Markov process based on the Langevin equation \citep{thomson1987}
-
-\begin{equation}
-dv_{t_i}=a_i({\vec{x}},{\vec{v}}_t,t)dt+b_{ij}({\vec{x}},{\vec{v}}_t,t)dW_
-j \,,
-\label{langevin}
-\end{equation}
-
-where the drift term $a$ and the diffusion term $b$ are functions of the
-position, the turbulent velocity and time. $dW_j$ are incremental components
-of a Wiener process with mean zero and variance $dt$, which are uncorrelated in
-time \citep{legg1982}. Cross-correlations between the different wind
-components are also not taken into account, since they have little effect for
-long-range dispersion \citep{uliasz1994}.
-
-Gaussian turbulence is assumed in FLEXPART, which is strictly valid only for
-stable and neutral conditions. Under convective conditions, when turbulence is
-skewed and larger areas are occupied by downdrafts than by updrafts, this
-assumption is violated, but for transport distances where particles are rather
-well mixed throughout the ABL, the error is minor.
-
-With the above assumptions, the Langevin equation for the vertical wind
-component $w$ can be written as
-
-\begin{multline}
-d w = \\
-- w \frac{dt}{\tau_{L_w}}
-+ \frac{\partial \sigma_w^2}{\partial z} dt
-+ \frac{\sigma_w^2}{\rho} \frac{\partial \rho}{\partial z} dt
-+ \left( \frac{2}{\tau_{L_w}} \right)^{1/2} \sigma_w\; dW \;,
-\label{legg}
-\end{multline}
-
-where $w$ and $\sigma_w$ are the turbulent vertical wind component and its
-standard deviation, $\tau_{L_w}$ is the Lagrangian timescale for the vertical
-velocity autocorrelation and $\rho$ is density. The second and the third term
-on the right hand side are the drift correction \citep{mcnider1988} and the
-density correction \citep{stohlthomson1999}, respectively. This Langevin
-equation is identical to the one described by \citet{legg1982}, except for the
-term from \citet{stohlthomson1999} which accounts for the decrease of air
-density with height.
-
-Alternatively, the Langevin equation can be re-expressed in terms of
-$w/\sigma_w$ instead of $w$ \citep{wilson1983}:
-
-\begin{multline}
-d \left( \frac{w}{\sigma_w} \right) =\\
-- \frac{w}{\sigma_w} \frac{dt}{\tau_{L_w}}
-+ \frac{\partial \sigma_w}{\partial z} dt
-+ \frac{\sigma_w}{\rho} \frac{\partial \rho}{\partial z} dt
-+ \left( \frac{2}{\tau_{L_w}} \right)^{1/2} dW \;,
-\label{wilson}
-\end{multline}
-
-This form was shown by \citet{thomson1987} to fulfill the well-mixed criterion
-which states that ``if a species of passive marked particles is initially mixed
-uniformly in position and velocity space in a turbulent flow, it will stay that
-way'' \citep{rodean1996}. Although the method proposed by \citet{legg1982}
-violates this criterion in strongly inhomogeneous turbulence, their formulation
-was found to be practical, as numerical experiments have shown that it is more
-robust against an increase in the integration time step. Therefore,
-Eq.~\ref{legg} is used with long time steps (see section~\ref{timestep});
-otherwise, Eq.~\ref{wilson} is used. For the horizontal wind components, the
-Langevin equation is identical to Eq.~\ref{legg}, with no drift and density
-correction terms.
-
-For the discrete time step implementation of the above Langevin equations (at
-the example of Eq.~\ref{wilson}), two different methods are used. When $\left
-(\Delta t/\tau_{L_w} \right) \ge 0.5$,
-
-\begin{multline}
-\left (\frac{w}{\sigma_w} \right)_{k+1}=
-r_w \left (\frac{w}{\sigma_w} \right)_k
-+ \frac{\partial \sigma_w}{\partial z} \tau_{L_w} \left (1-r_w \right )\\
-+ \frac{\sigma_w}{\rho} \frac{\partial \rho}{\partial z} \tau_{L_w} \left (1-r_w \right )
-+ \left (1-r_w^2 \right )^{1/2} \zeta \;,
-\end{multline}
-
-where $r_w=\exp(-\Delta t/ \tau_{L_w})$ is the autocorrelation of the vertical
-wind, and $\zeta$ is a normally distributed random number with mean zero and
-unit standard deviation. The subscripts $k$ and $k+1$ refer to subsequent
-times separated by $\Delta t$.
-
-To save computation time for cases when $\left (\Delta t/\tau_{L_w} \right) <
-0.5$, the following first order approximation is used in order to avoid the
-computation of the exponential function:
-
-\begin{multline}
-\left (\frac{w}{\sigma_w} \right)_{k+1}=
-\left (1-\frac{\Delta t}{\tau_{L_w}} \right )\left (\frac{w}{\sigma_w} \right)_k\\
-+ \frac{\partial \sigma_w}{\partial z} \Delta t
-+ \frac{\sigma_w}{\rho} \frac{\partial \rho}{\partial z} \Delta t
-+ \left( \frac{2 \Delta t}{\tau_{L_w}} \right)^{1/2} \zeta \;.
-\end{multline}
-
-When a particle reaches the surface or the top of the ABL, it is reflected and
-the sign of the turbulent velocity is changed \citep{wilson1993}.
-
-\subsection{\label{timestep}Determination of the time step}
-
-FLEXPART can be used in two different modes. The computationally faster one
-(\verb|ctl|$<$0 in file \verb|COMMAND|) does not adapt the computation time
-step to the Lagrangian timescales $\tau_{L_i}$ (where $i$ is one of the three
-wind components) and FLEXPART uses constant time steps of one synchronisation
-time interval (\verb|lsynctime|, specified in file \verb|COMMAND|, typically
-900 seconds). Usually, autocorrelations are very low in this mode and
-turbulence is not described well. Nevertheless, for large scale applications
-FLEXPART works very well with this option \citep{stohletal1998}. If turbulence
-shall be described more accurately, the time steps must be limited by $\tau_L$.
-Since the vertical wind is most important, only $\tau_{L_w}$ is used for this.
-The user must specify two constants, \verb|ctl| and \verb|ifine| in file
-\verb|COMMAND|. The first one determines the time step $\Delta t_i$ according
-to
-
-\begin{equation}
-\Delta t_i=\frac{1}{c_{tl}} \min \left ({\tau_{L_w}\, , \; \frac{h}{2w}\, , \; \frac{0.5}{\partial \sigma_w / \partial z}} \right ) \;.
-\end{equation}
-
-The minimum value of $\Delta t_i$ is 1~second.
-$\Delta t_i$ is used for solving the Langevin equations for the horizontal turbulent wind components.
-
-For solving the Langevin equation for the vertical wind component, a shorter
-time step $\Delta t_w=\Delta t_i / \verb|ifine|$ is used. However, note that
-there is no interaction between horizontal and vertical wind components on
-timescales less than $\Delta t_i$. This strategy (given sufficiently large
-values for \verb|ctl| and \verb|ifine|) ensures that the particles stay
-vertically well-mixed also in very inhomogeneous turbulence, while keeping the
-computational cost at a minimum.
-
-\subsection{Parameterization of the wind fluctuations}
-
-For $\sigma_{v_i}$ and $\tau_{L_i}$ \citet{hanna1982} proposed a
-parameterization scheme based on the boundary layer parameters $h$, $L$, $w_*$,
-$z_0$ and $u_*$, i.e. ABL height, Monin-Obukhov length, convective velocity
-scale, roughness length and friction velocity, respectively. It is used in
-subroutines \verb|hanna.f, hanna1.f, hanna_short.f| with a modification taken
-from \citet{ryall1997} for $\sigma_w$, as Hanna's scheme does not always yield
-smooth profiles of $\sigma_w$ throughout the whole convective ABL. In the
-following, subscripts $u$ and $v$ refer to the along-wind and the cross-wind
-components (transformed to grid coordinates in subroutine \verb|windalign.f|),
-respectively, and $w$ to the vertical component of the turbulent velocities;
-$f$ is the Coriolis parameter. The minimum $\tau_{L_u}$, $\tau_{L_v}$ and
-$\tau_{L_w}$ used are 10~s, 10~s and 30~s, respectively, in order to avoid
-excessive computation times for particles close to the surface.\\[0.3cm]
-
-{\bf Unstable conditions:}
-
-\begin{equation}
-\frac{\sigma_u}{u_*}=\frac{\sigma_v}{u_*}=\left(12+\frac{h}{2|L|}\right)^{1/3}
-\end{equation}
-\begin{equation}
-\tau_{L_u}=\tau_{L_v}=0.15\frac{h}{\sigma_u}
-\end{equation}
-\begin{multline}
-\sigma_w=\\
-\left[ 1.2 w_*^2 \left (1-0.9\frac{z}{h} \right )
-\left ( \frac{z}{h} \right )^{2/3}
-+\left (1.8-1.4 \frac{z}{h} \right ) u_*^2 \right]^{1/2}
-\end{multline}
-For $z/h<0.1$ and $z-z_0>-L$:
-\begin{equation}
-\tau_{L_w}=0.1\frac{z}{\sigma_w\left[0.55-0.38\left(z-z_0\right)/L\right]}
-\end{equation}
-For $z/h<0.1$ and $z-z_0<-L$:
-\begin{equation}
-\tau_{L_w}=0.59\frac{z}{\sigma_w}
-\end{equation}
-For $z/h>0.1$:
-\begin{equation}
-\tau_{L_w}=0.15\frac{h}{\sigma_w}\left[1-\exp\left(\frac{-5z}{h}\right)\right]
-\end{equation}
-
-{\bf Neutral conditions:}
-
-\begin{equation}
-\frac{\sigma_u}{u_*}=2.0\exp(-3fz/u_*)
-\end{equation}
-\begin{equation}
-\frac{\sigma_v}{u_*}=\frac{\sigma_w}{u_*}=1.3\exp(-2fz/u_*)
-\end{equation}
-\begin{equation}
-\tau_{L_u}=\tau_{L_v}=\tau_{L_w}=\frac{0.5z/\sigma_w}{1+15fz/u_*}
-\end{equation}
-
-{\bf Stable conditions:}
-
-\begin{equation}
-\frac{\sigma_u}{u_*}=2.0\left(1-\frac{z}{h}\right)
-\end{equation}
-\begin{equation}
-\frac{\sigma_v}{u_*}=\frac{\sigma_w}{u_*}=1.3\left(1-\frac{z}{h}\right)
-\end{equation}
-\begin{equation}
-\tau_{L_u}=0.15\frac{h}{\sigma_u}\left(\frac{z}{h}\right)^{0.5}
-\end{equation}
-\begin{equation}
-\tau_{L_v}=0.07\frac{h}{\sigma_v}\left(\frac{z}{h}\right)^{0.5}
-\end{equation}
-\begin{equation}
-\tau_{L_w}=0.1\frac{h}{\sigma_w}\left(\frac{z}{h}\right)^{0.5}
-\end{equation}
-
-Lacking suitable turbulence parameterizations above the ABL ($z>h$), a constant
-vertical diffusivity $D_z$=0.1~m$^2$s$^{-1}$ is used in the stratosphere,
-following recent work of \citet{legras2003}, whereas a horizontal diffusivity
-$D_h$=50~m$^2$s$^{-1}$ is used in the free troposphere. Stratosphere and
-troposphere are distinguished based on a threshold of 2~pvu (potential
-vorticity units). Diffusivities are converted into velocity scales using
-$\sigma_{v_i}=\sqrt{D_i/dt}$.
-
-\subsection{Mesoscale velocity fluctuations}
-
-Mesoscale motions are neither resolved by the ECMWF data nor covered by the
-turbulence parameterization. This unresolved spectral interval needs to be
-taken into account at least in an approximate way, since mesoscale motions can
-significantly accelerate the growth of a dispersing plume \citep{gupta1997}.
-For this, we use a similar method as \citet{maryon1998}, namely to solve an
-independent Langevin equation for the mesoscale wind velocity fluctuations
-(``meandering'' in Maryon's terms). Assuming that the variance of the wind at
-the grid scale provides some information on its subgrid variance, the wind
-velocity standard deviation used for the mesoscale Langevin equation is set to
-\verb|turbmesoscale| (set in file \verb|includepar|) times the standard
-deviation of the grid points surrounding the particle's position. The
-corresponding time scale is taken as half the interval at which wind fields are
-available, assuming that the linear interpolation between the grid points can
-recover half the subgrid variability, not an unlikely assumption
-\citep{stohl1995}. This empirical approach does not describe actual mesoscale
-phenomena, but it is similar to the ensemble methods used to assess trajectory
-accuracy \citep{kahl1996, baumann1997, stohl1998}.
-
-\subsection{Moist convection}
-
-An important transport mechanism are the updrafts in convective clouds. They
-occur in conjunction with downdrafts within the clouds and compensating
-subsidence in the cloud-free surroundings. These convective transports are
-grid-scale in the vertical, but sub-grid scale in the horizontal, and are not
-represented by the ECMWF vertical velocity.
-
-To represent convective transport in a particle dispersion model, it is
-necessary to redistribute particles in the entire vertical column. For
-FLEXPART we chose the convective parameterization scheme by
-\citet{emanuel1999}, as it relies on the grid-scale temperature and humidity
-fields and calculates a displacement matrix providing the necessary mass flux
-information for the particle redistribution. The convective parameterization
-is switched on using \verb|lconvection| in file \verb|COMMAND|. It's
-computation time scales to the square of the number of vertical model levels
-and may account for up to 70\% of FLEXPART's computation time using current
-60-level ECMWF data.
-
-The convection is computed within the subroutines {\tt convmix.f}, {\tt
-calcmatrix.f}, {\tt convect43c.f}, and {\tt redist.f}. It is called every
-FLEXPART \verb|lsynctime| time step (typically 900~s) with time-interpolated
-temperature and specific humiditiy profiles from the ECMWF data. Note that the
-original ECMWF model levels, not the Cartesian coordinates, are used in the
-convection scheme. For efficiency reasons, particles are sorted according to
-their horizontal grid positions ({\tt sort2.f}) before calling the convection
-scheme once per grid column.
-
-In the Emanuel scheme ({\tt convect43c.f}), convection is triggered whenever
-
-\begin{equation}
-T_{vp}^{LCL+1} \ge T_{v}^{LCL+1} + T_{thres}
-\end{equation}
-
-with $T_{vp}^{LCL+1}$ the virtual temperature of a surface air parcel lifted to
-the level above the lifting condensation level $LCL$, $T_{v}^{LCL+1}$ the
-virtual temperature of the environment there, and $T_{thres}=0.9$~K a threshold
-temperature value. Based on the buoyancy sorting principle \citep{emanuel1991,
-telford1975}, a matrix $MA$ of the saturated upward and downward mass fluxes
-within clouds is calculated by accounting for entrainment and detrainment:
-
-\begin{multline}
-MA^{i,j}=\\
-\frac{M^i(|\sigma^{i,j+1}- \sigma^{i,j}|+ |\sigma^{i,j} - \sigma^{i,j-1}|)}{(1-\sigma^{i,j}) \displaystyle \sum_{j=LCL}^{LNB} [|\sigma^{i,j+1}- \sigma^{i,j}|+ |\sigma^{i,j} - \sigma^{i,j-1}|]}
-\label{matrix}
-\end{multline}
-
-Here $MA^{i,j}$ are the mass fractions displaced from level $i$ to level $j$,
-$M^{i}$ the mass fraction displaced from the surface to level $i$, $LNB$ the
-level of neutral buoyancy of a surface air parcel and $0 < \sigma^{i,j} < 1 $
-the mixing fraction between level $i$ and level $j$. The fraction
-$\sigma^{i,j}$ is determined by the environmental potential temperature
-$\theta^{j}$, the liquid potential temperature $\theta_{l}^{i,j}$ of air
-displaced adiabatically from $i$ to $j$, and the liquid potential temperature
-$\theta_{lp}^{i,j}$ of an air parcel first lifted adiabatically to level $i$
-and further to level $j$:
-
-\begin{equation}
-\sigma^{i,j}=\frac{\theta^{j}-\theta_{lp}^{i,j}}{\theta_{l}^{i,j}-\theta_{lp}^{i,j}}
-\end{equation}
-
-By summing up over all levels $j$, we then calculate the saturated up- and
-downdrafts at each level $i$ from Eq.~\ref{matrix} and assume that these fluxes
-are balanced by a subsidence mass flux in the environment.
-
-The particles in each convectively active box are then redistributed ({\tt
-redist.f}) according to the matrix $MA$. If the mass of an ECMWF model layer
-$i$ is $m^i$ and the mass flux from layer $i$ to layer $j$ accumulated over one
-time step is $\Delta MA^{i,j}$, then the probability of a particle to be moved
-from layer $i$ to layer $j$ is $\Delta MA^{i,j}/m^i$. Whether a given particle
-is displaced or not is determined by drawing a random number between [0,1],
-which also determines the position of the particle within the destination layer
-$j$. After the convective redistribution of the particles, the compensating
-subsidence mass fluxes are converted to a vertical velocity acting on those
-particles in the grid box that are not displaced by convective drafts. By
-calculating a subsidence velocity rather than displacing particles randomly
-between layers the scheme's numerical diffusion in the cloud-free environment
-is eliminated. The scheme was tested and fulfills the well-mixed criterion,
-i.e., if a tracer is well mixed in the whole atmospheric column, it remains so
-after the convection.
-
-\subsection{Particle splitting}
-
-During the initial phase of dispersion from a point source in the atmosphere,
-particles normally form a compact cloud. Relatively few particles suffice to
-simulate this initial phase correctly. After some time, however, the particle
-cloud gets distorted and particles spread over a much larger area. More
-particles are now needed. FLEXPART allows the user to specify a time constant
-$\Delta t_s$ (file \verb|COMMAND|). Particles are split into two (each of
-which receives half of the mass of the original particle) after travel times of
-$\Delta t_s$, $2\Delta t_s$, $4\Delta t_s$, $8\Delta t_s$, and so on
-(subroutine \verb|timemanager.f|).\par
-
-\section{\label{backward}Forward and backward modeling}
-
-Normally, when FLEXPART is run forward in time (\verb|ldirect=1| in file
-\verb|COMMAND|), particles are released from one or a number of sources and
-concentrations are determined downwind on a grid. However, FLEXPART can also
-run backward in time (\verb|ldirect=-1|), which is more efficient than forward
-modeling for calculating source-receptor relationships if the number of
-receptors is smaller than the number of (potential) sources. In the backward
-mode, particles are released from a receptor location (e.g., a measurement
-site) and a four-dimensional (3 space dimensions plus time) response function
-(sensitivity) to emission input is calculated.
-
-Since this version (6.2) of FLEXPART, the calculation of the source-receptor
-relationships is generalized for both forward and backward runs, allowing much
-greater flexibility regarding the input and output units than before.
-\verb|ind_source| and \verb|ind_receptor| in file \verb|COMMAND| switch between
-mass and mass mixing ratio units at the source and at the receptor,
-respectively. Note that source always stands for the physical source and not
-the location of the particle release, which is done at the source in forward
-mode but at the receptor in backward mode. Table ~\ref{units} gives an
-overview of the units used in forward and backward modeling for different
-settings of the above switches. A "normal" forward simulation which specifies
-the release in mass units (i.e., kg) and also samples the output in mass units
-(i.e., a concentration in ng m$^{-3}$) requires both switches to be set to 1.
-
-\begin{table}
-\setlength{\tabcolsep}{1.1mm}
-\caption{\label{units}
-Physical units of the input (in file RELEASES) and output data for forward
-(files grid\_conc\_date) and backward (files grid\_time\_date) runs for the
-various settings of the unit switches ind\_source and ind\_receptor (in both
-switches 1 refers to mass units, 2 to mass mixing ratio units).} \vspace{3mm}
-{\centerline{
-\begin{tabular}{ccccc} \hline
-Direction & ind\_source & ind\_receptor & input unit & output unit \\ \hline
-Forward & 1 & 1 & kg & ng m$^{-3}$ \\
-Forward & 1 & 2 & kg & ppt by mass \\
-Forward & 2 & 1 & 1 & ng m$^{-3}$ \\
-Forward & 2 & 2 & 1 & ppt by mass \\
-Backward & 1 & 1 & 1 & s \\
-Backward & 1 & 2 & 1 & s m$^3\,$kg$^{-1}$ \\
-Backward & 2 & 1 & 1 & s kg m$^{-3}$ \\
-Backward & 2 & 2 & 1 & s \\ \hline
-\end{tabular}}}
-\end{table}
-
-In the backward mode, any value not equal zero can be entered as the release
-"mass" in file \verb|RELEASES| because the output is normalized by this value.
-The calculated response function is related to the particles' residence time in
-the output grid cells. The unit of the output response function varies,
-depending on how the switches are set. If \verb|ind_source=1| and
-\verb|ind_receptor=1|, the response function has the unit s. If this response
-function is folded (i.e., multiplied) with a 3-d field of emission mass fluxes
-into the output grid boxes (in kg~m$^{-3}$s$^{-1}$), a concentration at the
-receptor (kg~m$^{-3}$) is obtained. If \verb|ind_source=1| and
-\verb|ind_receptor=2|, the response function has the unit s~m$^3\,$kg$^{-1}$
-and if it is folded with the emission mass flux (again in kg~m$^{-3}$s$^{-1}$),
-a mass mixing ratio at the receptor is obtained. The units of the response
-function for \verb|ind_source=2| can be understood in analogy.
-
-In the case of loss processes (dry or wet deposition, decay) the response
-function is ``corrected'' for these loss processes. See \citet{seibert2001}
-and, particularly, \citet{seibert2004} for a description of these generalized
-in- and output options and the implementation of backward modeling in FLEXPART.
-\citet{seibert2004} also describe the theory of backward modeling and give some
-examples, and \citet{stohl2003} presents an application.
-
-\section{\label{plumetraj}Plume trajectories}
-
-In a recent paper, \citet{stohl2002} proposed a method to condense the complex
-and large FLEXPART output using a cluster analysis \citep{dorling1992}. The
-idea behind this is to cluster, at every output time, the positions of all
-particles originating from a release point, and write out only clustered
-particle positions, along with additional information (e.g., fraction of
-particles in the ABL and in the stratosphere). This creates information that
-is almost as compact as traditional trajectories but accounts for turbulence
-and convection. This option can be activated by setting \verb|iout| to 4 or 5
-in file \verb|COMMAND|. The number of clusters can be set with the parameter
-\verb|ncluster| in file \verb|includepar|. The clustering is handled and
-output is produced by subroutine \verb|plumetraj.f|.
-
-\section{\label{removal}Removal processes}
-
-FLEXPART takes into account radioactive (or other) decay, wet deposition, and
-dry deposition by reducing a particle's mass. However, as atmospheric
-transport is the same for all chemical species, a single particle can represent
-several (up to \verb|maxspec|) chemical species, each affected differently by
-the removal processes.
-
-\subsection{\label{radioactive}Radioactive decay}
-
-Radioactive decay is accounted for by reducing the particle mass according to
-
-\begin{equation}
-m(t+\Delta t)=m(t) \exp (-\Delta t /\beta) \;,
-\end{equation}
-
-where $m$ is particle mass, and the time constant $\beta=T_{1/2}/\ln(2)$ is
-determined from the half life $T_{1/2}$ specified in file \verb|SPECIES_nnn|.
-Deposited pollutant mass decays at the same rate.
-
-\subsection{OH Reaction}
-
-If a positive value for the OH reaction rate is given in the file
-\verb|SPECIES_nnn|, OH reaction is performed in the model simulation and tracer
-mass is lost by this reaction. A monthly averaged 3\degreee$\times$ 5\degreen resolution OH
-field averaged to 7 atmospheric levels is used. The fields have been obtained
-from the GEOS-CHEM model \citep{bey2001}. The reaction rate is temperature
-corrected and an activation rate of 1000 J\,mol$^{-1}$ is assumed.
-
-\subsection{\label{wetdepo}Wet deposition}
-
-Since version 8.0, in-cloud and below-cloud scavenging are treated differently.
-Based on the humidity and temperature from the meteorological input data, the
-occurence of clouds is calculated. If relative humidity exceeds 80\% the
-occurence of a cloud is assumed.
-
-{\bf In cloud scavenging} is treated differently for gases and particles.
-The implementation follows the scheme of \citet{hertel1995}.
-
-In general, the scavenging coefficient $\Lambda$ ((s$^{-1}$) depends on the precipitation
-rate $I$ (mm\,h$^{-1}$) and the height $H_i$ over which scavenging takes place:
-
-\begin{equation}
-\Lambda=\frac{S_i I}{H_i}
-\end{equation}
-
-$S_i$ is different for gases and particles. For particles,
-
-\begin{equation}
-S_i=0.9/cl
-\end{equation}
-
-where $cl$ is the cloud liquid water content
-
-\begin{equation}
-cl=2\times 10^{-7}\cdot I^{0.36} \;.
-\end{equation}
-
-For gases,
-
-\begin{equation}
-S_i=1/cl_\text{eff} \;,
-\end{equation}
-
-where $cl_\text{eff}$ is an effective cloud liquid water content:
-
-\begin{equation}
-cl_\text{eff}=\frac{(1-cl)}{H_\text{eff}RT}+cl \; .
-\end{equation}
-
-{\bf Below cloud scavenging} takes the form of an exponential decay process
-\citep{mcmahon1979}. With the scavenging coefficient $\Lambda$, wet
-deposition is described as
-
-\begin{equation}
-m(t+\Delta t)=m(t) \exp (- \Lambda \Delta t) \;,
-\end{equation}
-
-where $m$ is the particle mass. $\Lambda$ increases with the precipitation
-rate $I$ according to
-
-\begin{equation}
-\Lambda=AI^{B} \;,
-\label{wetscav}
-\end{equation}
-
-where $A$ [s$^{-1}$] is the scavenging coefficient at $I=$1~mm/hour and $B$
-gives the dependency on precipitation rate. Both $A$ and $B$ must be specified
-in file \verb|SPECIES_nnn|. FLEXPART uses the same scavenging coefficients for
-snow and rain.
-
-As wet deposition depends nonlinearly on precipitation rate, subgrid
-variability of precipitation must be accounted for \citep{hertel1995}. The
-area fraction which experiences precipitation given a certain grid-scale
-precipitation rate is calculated by
-
-\begin{equation}
-F=\max\left[0.05,CC\frac{I_l fr_l(I_l) + I_c fr_c(I_c)}{I_l+I_c}\right] \;,
-\end{equation}
-
-where $CC$ is the total cloud cover, $I_l$ and $I_c$ are the large scale and
-convective precipitation rates, respectively, and $fr_l$ and $fr_c$ are
-correction factors that depend on $I_l$ and $I_c$ (see Table~\ref{corrfacts}).
-The subgrid scale precipitation rate is then $I_s=(I_l+I_c)/F \;$.
-
-\begin{table}
-\setlength{\tabcolsep}{1.1mm}
-\caption{\label{corrfacts}
-Correction factors used for the calculation of the area fraction that
-experiences precipitation. Precipitation rates are in mm/hour.} \vspace{3mm}
-{\centerline{
-\begin{tabular}{cccccc} \hline
-~&\multicolumn{5}{c|}{$I_l$ and $I_c$} \\ \hline
-Factor&$I \le 1$&$1 < I \le 3$&$3 < I\le8$&$8 < I \le 20$&$20 < I$ \\ \hline
-$fr_l$&0.50&0.65&0.80&0.90&0.95 \\
-$fr_c$&0.40&0.55&0.70&0.80&0.90 \\ \hline
-\end{tabular}}}
-\end{table}
-
-\subsection{Dry deposition}
-
-Dry deposition is described in FLEXPART by a deposition velocity
-
-\begin{equation}
-v_d(z)=-F_C/C(z) \;,
-\end{equation}
-
-where $F_C$ and $C$ are the flux and the concentration of a species at height
-$z$ within the constant flux layer. A constant deposition velocity $v_d$ can
-be set (file \verb|SPECIES_nnn|). Alternatively, if the physical and chemical
-properties of a substance are known (file \verb|SPECIES_nnn|), more complex
-parameterizations for gases and particles are also available.
-
-\subsubsection{Dry deposition of gases}
-
-The deposition velocity of a gas is calculated with the {\em resistance method}
-\citep{wesely1977} in subroutine \verb|getvdep.f| according to
-
-\begin{equation}
-|v_d(z)|=\left[r_a(z)+r_b+r_c\right]^{-1} \;,
-\end{equation}
-
-where $r_a$ is the aerodynamic resistance between $z$ and the surface, $r_b$ is
-the quasilaminar sublayer resistance, and $r_c$ is the bulk surface resistance.
-
-The aerodynamic resistance $r_a$ is calculated in function \verb|raerod.f|
-using the flux-profile relationship based on Monin-Obukhov similarity theory
-\citep{stull1988}
-
-\begin{equation}
-r_a(z)=\frac{1}{\kappa u_*}[\ln(z/z_0)- \Psi _h(z/L)+ \Psi _h(z_0/L)] \;.
-\label{ra}
-\end{equation}
-
-Following \citet{erisman1994}, the quasilaminar sublayer resistance is
-
-\begin{equation}
-r_b=\frac{2}{\kappa u_*} \left(\frac{Sc}{Pr}\right)^{2/3} \;,
-\end{equation}
-
-where $Sc$ and $Pr$ are the Schmidt and Prandtl numbers, respectively. $Pr$ is
-0.72 and $Sc=\upsilon/D_i$, with $\upsilon$ being the kinematic viscosity of
-air and $D_i$ being the molecular diffusivity of species $i$ in air. The
-slight dependency of $\upsilon$ on air temperature is formulated in accordance
-with \citet{pruppacher1978}. $r_b$ is calculated in function
-\verb|getrb.f|.\par
-
-The surface resistance is calculated in function \verb|getrc.f| following
-\citet{wesely1989} as
-
-\begin{equation}
-\frac{1}{r_c}=
-\frac{1}{r_s+r_m}+\frac{1}{r_{lu}}+\frac{1}{r_{dc}+r_{cl}}+\frac{1}{r_{ac}+r_{gs}} \;,
-\end{equation}
-
-where $r_s$, $r_m$ and $r_{lu}$ represent the bulk values for leaf stomatal,
-leaf mesophyll and leaf cuticle surface resistances (alltogether the upper
-canopy resistance) , $r_{dc}$ represents the gas-phase transfer affected by
-buoyant convection in canopies, $r_{cl}$ the resistance of leaves, twig, bark
-and other exposed surfaces in the lower canopy, $r_{ac}$ the resistance for
-transfer that depends only on canopy height and density, and $r_{gs}$ the
-resistance for the soil, leaf litter, etc., at the ground. Each of these
-resistances is parameterized according to the species' chemical reactivity and
-solubility, the landuse type, and the meteorological conditions. The IGBP
-landuse inventory \citep{belward1999} provides the area fractions of 13 landuse
-classes for which roughness lengths $z_0$ are estimated, on a grid with 0.3
-resolution (Table~\ref{landuses}). Charnock's relationship \citep{stull1988}
-$z_0=0.016u_*^2/g$ is used to calculate $z_0$ for the classes ``Ocean'' and
-``Inland water'', because of its dependence on wave height. Deposition
-velocities are calculated for all landuse classes and weighted with their
-respective areas. The original resolution of the IGBP land cover
-classification is 1 km x 1 km. To save storage space, this was regridded to a
-0.3 x 0.3 degree resolution. Table~\ref{conversion} shows how the initial 17
-classse were transfered in the 13 classes used in the deposition scheme of
-\cite{wesely1989}. According to \cite{helmig2007} a resistance of snow to
-ozone deposition of 10000 s m$^{-1}$ was used. For SO$_2$ a value of 100
-according to \citet{zhang2002} was used in the model. As the Wesely scheme was
-initially developed for North America, the rain forest was not represented
-well. Therefore a new category was introduced and resistance values according
-to \cite{jacob1990} were used. The resistance values are dependent on 5
-different seasons. As on the southern hemisphere they are asynchronous to the
-northern hemisphere half a year was added when choosing the appropriate
-seasonal category. The snow depth is included in the original
-\cite{wesely1989} parameterization to some extend, as at a certain time of the
-year snow cover is assumed. In order to have more accurate information we use
-the snow cover based on the snow depth in the ECMWF fields. If the snow cover
-gets over 1 mm of water equivalent, the grid cell is considered as snow covered
-and category 12 (snow and ice) is applied.
-
-\begin{table}
-\setlength{\tabcolsep}{1.1mm}
-\caption{\label{landuses}
-List of the landuse classes and roughness lengths used by FLEXPART.
-``Charnock'' indicates that Charnock's relationship is used to calculate the
-roughness length.} \vspace{3mm}
-{\centerline{
-\begin{tabular}{lc} \hline
-Urban land & 0.7 \\
-Agricultural land & 0.1 \\
-Range land & 0.1 \\
-Deciduous forest & 1.0 \\
-Coniferous forest & 1.0 \\
-Mixed forest including wetland & 0.7 \\
-Water, both salt and fresh & Charnock \\
-Barren land mostly desert & 0.01 \\
-Nonforested wetland & 0.1 \\
-Mixed agricultural and range land & 0.1 \\
-Rocky open areas with low growing shrubs & 0.05 \\
-Snow and ice & 0.001 \\
-Rainforest & 1.0 \\ \hline
-\end{tabular}}}
-\end{table}
-
-\begin{table*}
-\setlength{\tabcolsep}{1.1mm}
-\caption{\label{conversion}
-Conversion from the IGBP land cover legend to the landuse categories used by Wesely}
-\vspace{3mm}
-{\centerline{
-\begin{tabular}{clcl} \hline
-\multicolumn{2}{c}{IGBP Land Cover Legend} & \multicolumn{2}{c}{Wesely} \\
-Value & Description & Value & Description \\
-1& Evergreen Needleleaf Forest& 5& Coniferous forest\\
-2& Evergreen Broadleaf Forest & 13& Rainforest\\
-3& Deciduous Needleleaf Forest& 4& Deciduous forest\\
-4& Deciduous Broadleaf Forest & 4& Deciduous forest\\
-5& Mixed Forest&6& Mixed forest including wetland\\
-6& Closed Shrublands& 11& rocky open areas with low growing shrubs\\
-7& Open Shrublands& 11& rocky open areas with low growing shrubs\\
-8& Woody Savannas&11& rocky open areas with low growing shrubs\\
-9& Savannas&11&rocky open areas with low growing shrubs\\
-10& Grasslands & 3 & Range land\\
-11& Permanent Wetlands & 9 & nonforested wetland \\
-12& Croplands & 2 & Agricultural land\\
-13& Urban and Built-Up & 1 & Urban land\\
-14& Cropland/Natural Vegetation Mosaic& 10 & mixed agricultural and range land \\
-15& Snow and Ice & 12 & snow and ice\\
-16& Barren or Sparsely Vegetated & 8& barren land mostly desert\\
-17& Water Bodies & 7 & water, both salt and fresh\\
-\end{tabular}}}
-\end{table*}
-
-\subsubsection{Dry deposition of particulate matter}
-
-The deposition of particulates is calculated in subroutine \verb|partdep.f|
-according to
-
-\begin{equation}
-v_d(z)=\left[r_a(z)+r_b+r_a(z)r_bv_g\right]^{-1}+v_g \;,
-\end{equation}
-
-where $v_g$ is the gravitational settling velocity calculated from
-\citep{slinn1982}
-
-\begin{equation}
-v_g=\frac{g \rho_p d_p^2C_{cun}}{18 \mu} \;,
-\end{equation}
-
-where $\rho_p$ and $d_p$ are the particle density and diameter, $\mu$ the
-dynamic viscosity of air (0.000018 kg m$^{-1}$s$^{-1}$) and $C_{cun}$ the
-Cunningham slip-flow correction. The quasilaminar sublayer resistance is
-calculated from the same relationship as for gases, with an additional
-impaction term. For further details see \citet{slinn1982}.\par
-
-Settling and dry deposition velocities are strongly dependent on particulate
-size. FLEXPART assumes a logarithmic normal size distribution of the
-particulate mass. The user must specify the mean particulate diameter
-$\overline{d_p}$ and a measure of the variation around $\overline{d_p}$,
-$\sigma_p$. Then, the settling and deposition velocities are calculated for
-several particle diameters and are weighted with their respective particulate
-mass fractions.
-
-Gravitational settling is important not only for the computation of the dry
-deposition velocity, but also affects the particle's trajectory. As a FLEXPART
-particle can normally represent several species, gravitational settling can
-only be taken into account correctly (i.e., influence particle trajectories) in
-single-species simulations. Pay attention that gravitational settling is
-simply switched off in multi-species simulations, without warning.
-
-With FLEXPART version 8.2, the temperature dependence of the dynamic viscosity
-is taken into account. Furthermore, we have extended the calculation of
-settling velocities to higher Reynolds numbers. For this, an iterative
-procedure has been introduced in subroutine \verb|get_settling.f|, where the
-iteration is started with Stokes’ law settling \citep{naeslund1991}, and then
-Reynolds number and settling velocity are calculated until convergence is
-achieved.
-
-\subsubsection{Loss of particle mass due to dry deposition}
-
-The depositon velocity is calculated for a reference height (parameter
-\verb|href| in file \verb|includepar|) of 15~m. For all particles below
-$2h_{ref}$, the mass lost by deposition is calculated by
-
-\begin{equation}
-\Delta m(t)=m(t)\left[{1-\exp\left({\frac{-v_d(h_{ref})\Delta t}{2h_{ref}}}\right)}\right] \;.
-\end{equation}
-
-\section{\label{conccalc}Calculation of concentrations, uncertainties, age spectra, and mass fluxes}
-
-Output quantities $C_{T_c}$ at time $T_c$ (output interval \verb|loutstep| is
-set in file \verb|COMMAND|) are calculated as time-averages over period
-$[T_c-\Delta T_c/2,T_C+\Delta T_c/2]$. $\Delta T_c$ must be specified
-(\verb|loutaver|) in file \verb|COMMAND|. To calculate the time-averages,
-concentrations $C_{T_s}$ at times $T_s$ within $[T_c-\Delta T_c/2,T_C+\Delta
-T_c/2]$ are sampled at shorter intervals $\Delta T_s$ (\verb|loutsample| in
-file \verb|COMMAND|) and are then divided by the number $N=\frac{\Delta
-T_c}{\Delta T_s}$ of samples taken:
-
-\begin{equation}
-C_{T_c}= \frac{1}{N} \sum_{i=1}^N {C_{T_s}} \;.
-\end{equation}
-
-Both $\Delta T_c$ and $\Delta T_s$ must be multiples of the FLEXPART
-synchronisation interval (\verb|lsynctime| in file \verb|COMMAND|). The
-shorter the sampling interval $\Delta T_s$, the more samples are taken and the
-more accurate are thus the time-averaged concentrations.
-
-\subsection{Concentrations, mixing ratios, and emission response functions}
-
-The user can choose (\verb|iout| in file \verb|COMMAND|, which must be set to 1
-for backward runs) whether concentrations, volume mixing ratios or both shall
-be produced. We shall use the term "concentration" and particle mass here, but
-note that the actual units are determined by the settings of \verb|ind_source|
-and \verb|ind_receptor|, according to Table~\ref{units}. The concentration in
-a grid cell is calculated in subroutine \verb|conccalc.f| by sampling the
-tracer mass fractions of all particles within the grid cell and dividing by the
-grid cell volume
-
-\begin{equation}
-C_{T_s} =\frac{1}{V}\sum_{i=1}^N (m_i f_i) \;,
-\end{equation}
-
-with $V$ being the grid cell volume, $m_i$ particle mass, $N$ the total number
-of particles, and $f_i$ the fraction of the mass of particle $i$ attributed to
-the respective grid cell. This mass fraction is calculated by a uniform kernel
-with bandwidths $(\Delta x,\Delta y)$, where $\Delta x$ and $\Delta y$ are the
-grid distances on the longitude-latitude output grid. Figure~\ref{kernel}
-illustrates this: The particle is located at the center of the shaded rectangle
-with side lengths $(\Delta x, \Delta y)$. Generally, the shaded area stretches
-over four grid cells, each of which receives a fraction of the particle's mass
-equal to the fraction of the shaded area falling within this cell. The uniform
-kernel is not used during the first 3 hours after a particle's release (when
-the mass is attributed only to the grid cell it resides in), in order to avoid
-smoothing close to the source.
-
-\begin{figure}[htb]
-\begin{minipage}[t]{2.8cm}
-\end{minipage}\hfill
-{\begin{minipage}[t]{12.5cm}
-
-\setlength{\unitlength}{2.5cm}
-\begin{picture}(3.0,3.0)
-
-\thicklines
-\multiput(0.5,0)(1,0){3}{\line(0,1){3.0}}
-\multiput(0,0.5)(0,1){3}{\line(1,0){3.0}}
-
-\thinlines
-\put(0.5,0.35){\vector(1,0){1.0}}
-\put(1.5,0.35){\vector(-1,0){1.0}}
-\put(0.35,0.5){\vector(0,1){1.0}}
-\put(0.35,1.5){\vector(0,-1){1.0}}
-
-\put(0.9,0.15){$\Delta x$}
-\put(0.05,0.92){$\Delta y$}
-
-\multiput(1.2909,1.25)(0.0909,0){10}{\line(0,1){1.0}}
-\multiput(1.2,1.34909)(0,0.0909){10}{\line(1,0){1.0}}
-
-\thicklines
-\put(1.67,1.76){\line(1,0){0.06}}
-\put(1.70,1.73){\line(0,1){0.06}}
-
-\put(1.2,1.25){\line(1,0){1.0}}
-\put(2.2,1.25){\line(0,1){1.0}}
-\put(2.2,2.25){\line(-1,0){1.0}}
-\put(1.2,2.25){\line(0,-1){1.0}}
-
-
-\end{picture}
-\end{minipage}}
-\caption{\label{kernel} Illustration of the uniform kernel used to calculate
-gridded concentration and deposition fields. The particle position is marked
-by ``{\rm +}''}
-\end{figure}
-
-Wet and dry deposition fields are calculated on the same output grid
-(subroutines \verb|wetdepokernel.f| and \verb|drydepokernel.f|) and are written
-to all output grid files. The deposited matter is accumulated over the course
-of a model run, i.e. it generally increases with model time. However,
-radioactive decay is calculated also for the deposited matter.
-
-\subsection{Uncertainties}
-
-The uncertainty of the output is estimated by carrying \verb|nclassunc| classes
-of particles in the model simulation, and determining the concentration
-separately for each class (subroutine \verb|conccalc.f|). The standard
-deviation, calculated from \verb|nclassunc| concentration estimates and divided
-by $\sqrt{\tt{nclassunc}}$, is the standard deviation of the mean concentration
-(subroutine \verb|concoutput.f|), which is also written to the output files for
-every grid cell. Note that the memory needed for some auxiliary fields
-increases with \verb|nclassunc| {Ãt and} the number of age classes (see below).
-It may, thus, be necessary to reduce \verb|nclassunc| for runs with large
-output grids and age spectra calculations or in the backward mode.
-
-\subsection{Age spectra}
-
-The age spectra option is switched on using \verb|lagespectra| in file
-\verb|COMMAND|, with the age classes specified in seconds in file
-\verb|AGECLASSES|. Concentrations are split into contributions from particles
-of different age, defined as the time passed since their release. Particles
-are terminated once they are older than the oldest age class and their storage
-space is made available to new particles. Therefore, the age spectra option
-can be used also with a single age class for defining a maximum particle age.
-
-\subsection{Parabolic kernel}
-
-In addition to the simple uniform kernel method, a computationally demanding
-parabolic kernel as described in \citep{uliasz1994} can be used to calculate
-surface concentrations for a limited number of receptor points (age spectra are
-not available in this case):
-
-\begin{equation}
-C_{T_s}(x,y,z=0)=\sum_{i=1}^N \left[ \frac{2m_iK(r_x,r_y,r_z)}{h_{x_i}h_{y_i}h_{z_i}} \right]\;,
-\end{equation}
-
-where $h_{x_i}$, $h_{y_i}$ and $h_{z_i}$ are the kernel bandwidths which
-determine the degree of smoothing, $r_x=(X_i-x)/h_{x_i}$,
-$r_y=(Y_i-y)/h_{y_i}$, $r_z=Z_i/h_{z_i}$ with $X_i$, $Y_i$ and $Z_i$ being the
-position of particle $i$. The kernel bandwidths are a function of the
-particles' age.
-
-\subsection{Mass fluxes}
-
-Mass flux calculations can be switched on using \verb|iflux| in file
-\verb|COMMAND|. Mass fluxes are calculated separately for eastward, westward,
-northward, southward, upward and downward directions and contain both
-grid-scale and subgrid-scale motions. Mass fluxes are determined for the
-centerlines of the output grid cells, e.g. vertical fluxes are calculated for
-motions across the half level of each output cell.
-
-\section{Domain-filling option}
-
-\subsection{General}
-
-If \verb|mdomainfill=1| in file \verb|COMMAND| particles are not released at
-specific locations. Instead, the longitudes and latitudes specified for the
-first release in the \verb|RELEASES| file are used to set up a global or
-limited model domain. The particles (number is also taken from
-\verb|RELEASES|) are then distributed in the model domain proportionally to air
-density (subroutine \verb|init_domainfill.f|). Each particle receives the same
-mass, altogether accounting for the total atmospheric mass. Subsequently,
-particles move freely in the atmosphere.
-
-If a limited domain is chosen, mass fluxes are determined in small grid boxes
-at the boundary of this domain (boundaries must be at least one grid box away
-from the boundaries of the meteorological input data). In the grid cells with
-air flowing into the model domain, mass fluxes are accumulated over time and
-whenever the accumulated mass exceeds the mass of a particle, a new particle
-(or more, if required) is released at a randomly chosen position at the
-boundary of the box (subroutine \verb|boundcond_domainfill.f|). At the
-outflowing boundaries particles are terminated. Note that, due to the change
-of mass of the atmosphere in the model domain and due to numerical effects, the
-number of particles used is not exactly constant throughout the simulation.
-
-\subsection{Stratospheric ozone tracer}
-
-If \verb|mdomainfill=2|, the domain-filling option is used to simulate a
-stratospheric ozone tracer. Upon particle creation, the potential vorticity
-(PV) at its position is determined by interpolation from the ECMWF data.
-Particles initially located in the troposphere (PV$<$\verb|pvcrit| potential
-vorticity units (pvu), default 2 pvu) are not used. In contrast, stratospheric
-particles (PV$>$\verb|pvcrit|) are given a mass according to:
-
-\begin{equation}
-M_{O_3}=M_{air}\, P \, C \, 48/29
-\end{equation}
-
-where $M_{air}$ is the mass of air a particle represents, $P$ is PV in pvu,
-$C=60\times$10$^{-9}$ pvu$^{-1}$ is the ozone/PV relationship \citep{stohl2000}
-(parameter \verb|ozonescale|), and the factor 48/29 converts from volume to
-mass mixing ratio. Particles are then allowed to advect through the
-stratosphere and into the troposphere according to the winds.
-
-\section{Model output}
-
-Tracer concentrations and/or mixing ratios (for forward runs), or emission
-sensitivity response functions (for backward runs) are calculated on a
-three-dimensional longitude-latitude grid, defined in file \verb|OUTGRID|,
-whose domain and resolution can differ from the grid on which meteorological
-input data are given. Two-dimensional wet and dry deposition fields are
-calculated over the same spatial domain, and tracer mass fluxes can also be
-determined on the 3-d grid. Except for the mass fluxes, output can also be
-produced on one nested output grid with higher horizontal but the same vertical
-resolution, defined in file \verb|OUTGRID_NEST|. For certain locations,
-specified in file \verb|RECEPTORS|, concentrations can also be calculated
-independently from a grid (see below). The time interval (variable
-\verb|loutstep|) at which output is produced is read in from file
-\verb|COMMAND|. For every output time and for every species (\verb|nnn|),
-files are created, with file names ending with date, time and species number in
-the format \verb|yyyymmddhhmmss_nnn|. A list of all these output times is
-written to the formatted file \verb|dates|. The dates indicate the ending time
-of an output sampling interval (see section~\ref{conccalc}).
-
-\subsection{Gridded output}
-
-There are several output options in FLEXPART, which can all be selected in file
-\verb|COMMAND|. Gridded output fields can be concentrations (files
-\verb|grid_conc_date_nnn|), volume mixing ratios (files
-\verb|grid_pptv_date_nnn|), emission response sensitivity in backward
-simulations (files \verb|grid_time_date_nnn|), or fluxes (files
-\verb|grid_flux_date|, unit 10$^{-12}$ kg m$^{-2}$ s$^{-1}$ for forward runs),
-or, in backward mode, sensitivities to initial conditions taken from another
-model (\verb|grid\_initial\_nnn|).
-
-The species number identifier \verb|nnn| starts at one (with leading zeros) and
-increases to the maximum number of species used in the simulation. Files
-\verb|grid_conc_date_nnn| are created only in forward runs, whereas files
-\verb|grid_time_date_nnn| are only created in backward runs. Note that the
-units of the files \verb|grid_conc_date_nnn| and \verb|grid_time_date_nnn|
-depend on the settings of the switches \verb|ind_source| and
-\verb|ind_receptor|, following Table~\ref{units}. In particular, the units of
-\verb|grid_conc_date| can also be mass mixing ratios. For forward runs,
-additional files \verb|grid_pptv_date_nnn| can be created, which contain volume
-mixing ratios for gases. Output files \verb|grid_conc*|, \verb|grid_pptv*|,
-and \verb|grid_time*| also contain wet and dry deposition fields (unit
-10$^{-12}$ kg m$^{-2}$ in forward mode), and all files contain, for each grid
-cell, corresponding uncertainties. All these file types share a common header,
-file \verb|header| produced by subroutine \verb|writeheader.f|, where important
-information on the model run (start of simulation, grid domain, number and
-position of vertical levels, age classes, release points, etc.) is stored. In
-all postprocessing programs, the header must be read in before the actual data
-files. File names for the output nests follow the same nomenclature as
-described above, but with \verb|_nest| added (e.g., \verb|header_nest|, or
-\verb|grid_conc_nest_date_nnn|). The output files are written with subroutines
-\verb|concoutput.f| and \verb|fluxoutput.f|.
-
-FLEXPART output typically contains many grid cells with zero values. It would
-be inefficient to write out all these zeroes. Therefore, a special format has
-been designed that compresses the information to the relevant information. In
-previous versions (up to version 7), the output consisted of a mixture of a
-full grid dump (including zeroes) and a sparse matrix format - output was
-switched between these two formats based on which one was smaller.
-
-In version 8.0, the output has been redesigned completely for yet more efficiency
-such that output file sizes are only about 40\% of what they used to be. The
-output grid is searched for consecutive sequences of non-zero values. The
-variable \verb|sp_count_i| gives the number of such sequences (n), and the
-integer field \verb|sparse_dump_i(n)| contains the field positions of the first
-non-zero element for every sequence. The variable \verb|sp_count_r| gives the
-total number (k) of non-zero values written out. They are contained in the
-real field \verb|sparse_dump_r(n)|. Since all physical output quantities of
-FLEXPART are non-zero, sequences are written out alternatingly as positive or
-negative values. Every switch between positive and negative values indicates
-that a new sequence with non-zero values starts. The field position for that
-start is contained in \verb|sparse_dump_i(k)| for the k-th switch between
-positive and negative. Zero values in between sequences are ignored and not
-written out. Field positions within the 3-d output field are coded such that a
-single integer value is sufficient. It can later be converted back to give
-positions in all three coordinates.
-
-The possibility to output the sensitivities to initial conditions for backward
-runs has been introduced with FLEXPART version 8.2. This option can be used to
-calculate the exact sensitivities of the concentrations (or mixing ratios,
-depending on what is simulated) to initial conditions either in concentration
-or mixing ratio units taken from a gridded data set, which can be produced
-either by another model or by a FLEXPART forward simulation. This option has
-been introduced to allow interfacing FLEXPART with other models. Multiplying
-the sensitivities in files \verb|grid_initial_nnn| with the corresponding
-concentrations (or mixing ratios, depending on option chosen for switch
-\verb|LINIT_COND| in file \verb|COMMAND|) from the forward simulation at the
-interfacing time gives the concentration (or mixing ratio) response at the
-receptor (taking into account possible loss processes during the FLEXPART
-simulation time).
-
-\subsection{Receptor point output}
-
-For a list of points at the surface, concentrations or mixing ratios in forward
-simulations can be determined with a grid-independent method. This information
-is written to files \verb|receptor_conc| and \verb|receptor_pptv|,
-respectively, for all dates of a simulation.
-
-\subsection{Particle dump and warm start option}
-
-Particle information (3-d position, release time, release point, and release
-masses for all species) can be written out to files (subroutine
-\verb|partoutput.f|) either continuously (binary files \verb|partposit_date|),
-or `only at the end' of a simulation (file \verb|partposit_end|). In both
-cases output is written every output interval but file \verb|partposit_end| is
-overwritten upon each new output. If FLEXPART must be terminated, it can be
-continued later on by reading in files \verb|header| and \verb|partposit_end|
-produced by the previous run (subroutine \verb|readpartpositions.f|). Such a
-warm start is done if variable \verb|ipin| is set to 1 in file \verb|COMMAND|.
-
-If option \verb|mquasilag| is chosen in file \verb|COMMAND|, particle dumps
-every output interval are produced in a very compact format by converting the
-positions to an \verb|integer*2| format (subroutine \verb|partoutput_short.f|).
-As some accuracy is lost in the conversion, this output is not used for the
-warm start option. Another difference to the normal particle dump is that
-every particle gets a unique number, thus allowing postprocessing routines to
-identify continuous particle trajectories.
-
-\subsection{Clustered plume trajectories}
-
-Condensed particle output using the clustering algorithm described in
-section~\ref{plumetraj} is written to the formatted file
-\verb|trajectories.txt|. Information on the release points (coordinates,
-release start and end, number of particles) is written by subroutine
-\verb|openouttraj.f| to the beginning of file \verb|trajectories.txt|.
-Subsequently, \verb|plumetraj.f| writes out a time sequence of the clustering
-results for each release point: release point number, time in seconds elapsed
-since the middle of the release interval, plume centroid position coordinates,
-various overall statistics (e.g., fraction of particles residing in the ABL and
-troposphere), and then for each cluster the cluster centroid position, the
-fraction of particles belonging to the cluster, and the root-mean-square
-distance of cluster member particles from the cluster centroid.
-
-\section{pflexpart: a Python routine for the analysis of FLEXPART output}
-
-To assist in the usage and analysis of FLEXPART data we have created a Python
-module that is available with this new release. The Python module 'pflexpart'
-enables the user to easily read and access the header and grid output data of
-the FLEXPART model runs. Furthermore, we provide some basic classes that
-assist in conducted standard analysis of backward and forward model runs.
-
-The module is released under the same GPL license as FLEXPART. As open source
-code it is constantly undergoing revision and updates from the community.
-Thus, the core functionality of the module is described online. See:
-http://transport.nilu.no/pflexpart
-
-The module is largely based on the well known Numpy and matplotlib Python
-modules as well as the {``basemap``} tool box of matplotlib. Additionally, for
-efficiency in reading the data, there are several custom build modules that use
-the \verb|readgrid.f| FORTRAN routines described above. Note, that some of
-these modules will require the user to compile them for their system to achieve
-maximum benefit.
-
-The central framework to the module is the pflexpart \verb|Header| class. This
-class will read a FLEXPART header file and provide some functionality toward
-data analysis. For instance, the \verb|Header| class has a
-\verb|fill_backward| method for backward runs that will calculate the Total
-Column and Footprint sensitivities from the N ageclasses used in the run. From
-this method, plotting of residence times and emission sensitivities is
-relatively simple.
-
-Other features include wrapper functions around the matplotlib toolboxes that
-allow for plotting of the data easily. The functions \verb|plot_totalcolumn|
-and \verb|plot_footprint| for example are customized wrappers of the
-\verb|plot_sensitivity| function. These functions take data objects that are
-created by the \verb|fill_backward| method of the \verb|Header| class and allow
-the user to create plots quickly. For forward runs, the \verb|Header.readgrid|
-method can be used, again with the \verb|plot_sensitivity| function of the
-pflexpart module.
-
-For more details, the reader is referred again to the more frequently updated
-module home page.
-
-\section{Final remark}
-
-In this note, we have described the Lagrangian particle dispersion model FLEXPART in version
-8.2. As FLEXPART is developed further this text will be kept up to date and will be accessible
-from the FLEXPART home page at http://transport.nilu.no/flexpart.
-
-\begin{thebibliography}{}
-
-\bibitem[Asman(1995)]{asman1995}
-Asman, W. A. H.:
-Parameterization of below-cloud scavenging of highly soluble gases under convective conditions.
-Atmos. Environ., 29, 1359--1368, 1995.
-\bibitem[Baumann and Stohl(1997)]{baumann1997}
-Baumann, K. and Stohl, A.:
-Validation of a long-range trajectory model using gas balloon tracks from the Gordon Bennett Cup 95.
-J. Appl. Meteor., 36, 711--720, 1997.
-\bibitem[Beljaars and Holtslag(1991)]{beljaars1991}
-Beljaars, A. C. M. and Holtslag, A. A. M.:
-Flux parameterization over land surfaces for atmospheric models.
-J. Appl. Meteor., 30, 327--341, 1991.
-\bibitem[Belward et al.(1999)]{belward1999}
-Belward, A.S., Estes, J.E., and Kline, K.D.:
-The IGBP-DIS 1-Km Land-Cover Data Set DISCover: A Project Overview.
-Photogrammetric Engineering and Remote Sensing , v. 65, no. 9, p. 1013--1020, 1999.
-\bibitem[Berkowicz and Prahm(1982)]{berkowicz1982}
-Berkowicz, R. and Prahm, L. P.:
-Evaluation of the profile method for estimation of surface fluxes of momentum and heat.
-Atmos. Environ., 16, 2809--2819, 1982.
-\bibitem[Bey et al.(2001)]{bey2001}
-Bey I, Jacob DJ, Yantosca RM, et al.:
-Asian chemical outflow to the Pacific in spring: Origins, pathways, and budgets.
-J. Geophys. Res., 106, 19, 23073-23095, 2001.
-\bibitem[Businger et al.(1971)]{businger1971}
-Businger, J. A., Wyngaard, J. C., Izumi, Y. and Bradley, E. F.:
-Flux-profile relationships in the atmospheric surface layer.
-J. Atmos. Sci., 28, 181--189, 1971.
-\bibitem[Dorling et al.(1992)]{dorling1992}
- Dorling, S. R., Davies, T. D. and Pierce, C.E.:
-Cluster analysis: a technique for estimating the synoptic meteorological controls on air and precipitation chemistry - method and applications.
-Atmos. Environ., 26A, 2575--2581, 1992.
-\bibitem[ECMWF(1995)]{ecmwf1995}
-ECMWF,
-User Guide to ECMWF Products 2.1. Meteorological Bulletin M3.2. Reading, UK, 1995.
-\bibitem[Emanuel(1991)]{emanuel1991}
-Emanuel, K. A.:
-A scheme for representing cumulus convection in large-scale models,
-J. Atmos. Sci., 48, 2313--2335, 1991.
-\bibitem[Emanuel and \v{Z}ivkovi\'{c}-Rothman(1999)]{emanuel1999}
-Emanuel, K. A., and \v{Z}ivkovi\'{c}-Rothman, M.:
-Development and evaluation of a convection scheme for use in climate models.
-J. Atmos. Sci., 56, 1766--1782, 1999.
-\bibitem[Erisman et al.(1994)]{erisman1994}
-Erisman, J. W., Van Pul, A. and Wyers, P.:
-Parametrization of surface resistance for the quantification of atmospheric deposition of acidifying pollutants and ozone.
-Atmos. Environ., 28, 2595--2607, 1994.
-\bibitem[Flesch et al.(1995)]{flesch1995}
-Flesch, T. K., Wilson, J. D., and Lee, E.:
-Backward-time Lagrangian stochastic dispersion models and their application to estimate gaseous emissions,
-J. Appl. Meteorol., 34, 1320--1333, 1995.
-\bibitem[Forster et al.(2001)]{forster2001}
-Forster, C., Wandinger, U., Wotawa, G., James, P., Mattis, I., Althausen, D., Simmonds, P., O'Doherty, S., Kleefeld, C., Jennings, S. G., Schneider, J., Trickl, T., Kreipl, S., J\"ager, H., Stohl, A.:
-Transport of boreal forest fire emissions from Canada to Europe.
-J. Geophys. Res., 106, 22,887--22,906, 2001.
-\bibitem[Gupta et al.(1997)]{gupta1997}
-Gupta, S., McNider, R. T., Trainer, M., Zamora, R. J., Knupp, K. and Singh, M.P.:
-Nocturnal wind structure and plume growth rates due to inertial oscillations.
-J. Appl. Meteor., 36, 1050--1063, 1997.
-\bibitem[Hanna(1982)]{hanna1982}
-Hanna, S.R.:
-Applications in air pollution modeling. In: Nieuwstadt F.T.M. and H. van Dop (ed.): {\em Atmospheric Turbulence and Air Pollution Modelling}.
-D. Reidel Publishing Company, Dordrecht, Holland, 1982.
-\bibitem[Helmig et al.(2007)]{helmig2007}
-Helmig D., Ganzeveld, L., Butler, T. and Oltmans S.J.:
-The role of ozone atmosphere-snow gas exchange on polar, boundary-layer tropospheric ozone - a review and sensitivity analysis
-Atmos. Chem. and Physics, 7, 15--30, 2007.
-\bibitem[Hertel et al.(1995)]{hertel1995}
-Hertel, O., Christensen, J. Runge, E. H., Asman, W. A. H., Berkowicz, R., Hovmand, M. F. and Hov, O.:
-Development and testing of a new variable scale air pollution model - ACDEP.
-Atmos. Environ., 29, 1267--1290, 1995.
-\bibitem[Hubbe et al.(1997)]{hubbe1997}
-Hubbe, J. M., Doran, J. C., Liljegren, J.C. and Shaw, W. J.:
-Observations of spatial variations of boundary layer structure over the southern Great Plains cloud and radiation testbed.
-J. Appl. Meteor., 36, 1221--1231, 1997.
-\bibitem[Jacob and Wofsy(1990)]{jacob1990}
-Jacob D. J., Wofsy W. C.:
-Budgets of reactive nitrogen, hydrocarbons, and ozone over the amazon-forest during the wet season.
-J. Geophys. Res., 95, 16737--16754, 1990.
-\bibitem[Kahl (1996)]{kahl1996}
-Kahl, J. D. W.:
-On the prediction of trajectory model error.
-Atmos. Environ., 30, 2945--2957, 1996.
-\bibitem[Legg and Raupach(1982)]{legg1982}
-Legg, B. J., and Raupach, M. R.:
-Markov-chain simulation of particle dispersion in inhomogeneous flows: the mean drift velocity induced by a gradient in Eulerian velocity variance.
-Bound.-Layer Met., 24, 3--13, 1982.
-\bibitem[Legras et al.(2003)]{legras2003}
-Legras, B., Joseph, B. and Lefevre, F.:
-Vertical diffusivity in the lower stratosphere from Lagrangian back-trajectory reconstructions of ozone profiles.
-J. Geophys. Res., 108, 4562, doi:10.1029/2002JD003045, 2003.
-\bibitem[Maryon(1998)]{maryon1998}
-Maryon, R. H.:
-Determining cross-wind variance for low frequency wind meander.
-Atmos. Environ., 32, 115--121, 1998.
-\bibitem[McMahon(1979)]{mcmahon1979}
-McMahon, T. A., and Denison, P. J.:
-Empirical atmospheric deposition parameters - a survey.
-Atmos. Environ., 13, 571--585, 1979.
-\bibitem[McNider et al.(1988)]{mcnider1988}
-McNider, R. T., Moran, M. D. and Pielke, R. A.:
-Influence of diurnal and inertial boundary layer oscillations on long-range dispersion.
-Atmos. Environ., 22, 2445--2462, 1988.
-\bibitem[Naeslund and Thaning(1991)]{naeslund1991}
-Naeslund, E., and Thaning, L.:
-On the settling velocity in a nonstationary atmosphere.
-Aerosol Sci. Technol., 14, 247-256, 1991.
-\bibitem[Petterssen(1940)]{petterssen1940}
-Petterssen, S.:
-Weather Analysis and Forecasting.
-McGraw-Hill Book Company, New York. pp. 221--223, 1940.
-\bibitem[Pruppacher and Klett(1978)]{pruppacher1978}
-Pruppacher, H. R. and Klett, J. D.:
-Microphysics of clouds and precipitation.
-D. Reidel Publishing Company, Dordrecht, 714p., 1978.
-\bibitem[Rodean(1996)]{rodean1996}
-Rodean, H.:
-Stochastic Lagrangian models of turbulent diffusion.
-Meteorological Monographs, 26 (48). American Meteorological Society, Boston, USA, 1996.
-\bibitem[Ryall et al.(1997)]{ryall1997}
-Ryall, D. B. and Maryon, R. H.:
-Validation of the UK Met Office's NAME model against the ETEX dataset. In: Nodop, K. (editor): ETEX Symposium on Long-Range Atmospheric Transport, Model Verification and Emergency Response, European Commission EUR 17346, 151--154, 1997.
-\bibitem[Seibert(2001)]{seibert2001}
-Seibert, P.:
-Inverse modelling with a Lagrangian particle dispersion model: application to point releases over limited time intervals. In: Gryning, S. E., Schiermeier, F.A. (eds.): Air Pollution Modeling and its Application XIV. Proc. of ITM Boulder. New York: Plenum Press, 381--389, 2001.
-\bibitem[Seibert and Frank(2004)]{seibert2004}
-Seibert, P. and Frank, A.:
-Source-receptor matrix calculation with a Lagrangian particle dispersion model in backward mode.
-Atmos. Chem. Phys., 4, 51--63, 2004.
-\bibitem[Seibert et al.(2001)]{seibertetal2001}
-Seibert, P., Kr\"uger, B. and Frank, A.:
-Parametrisation of convective mixing in a Lagrangian particle dispersion model, Proceedings of the 5th GLOREAM Workshop, Wengen, Switzerland, September 24--26, 2001.
-\bibitem[Slinn(1982)]{slinn1982}
-Slinn, W. G. N.:
-Predictions for particle deposition to vegetative canopies.
-Atmos. Environ., 16, 1785--1794, 1982.
-\bibitem[Spichtinger et al.(2001)]{spichtinger2001}
-Spichtinger, N., Wenig, M., James, P., Wagner, T., Platt, U. and Stohl, A.:
-Satellite detection of a continental-scale plume of nitrogen oxides from boreal forest fires,
-Geophys. Res. Lett., 28, 4579--4582, 2001.
-\bibitem[Stohl(1998)]{stohl1998}
-Stohl, A.:
-Computation, accuracy and applications of trajectories -- a review and bibliography.
-Atmos. Environ., 32, 947--966, 1998.
-\bibitem[Stohl et al.(2005)]{stohl2005}
-Stohl, A., Forster, C., Frank, A., Seibert, P., Wotawa, G.:
-Technical note: The Lagrangian particle dispersion model FLEXPART version 6.2.,
-Atmos. Chem. Phys., 5, 2461-2474, 2005
-\bibitem[Stohl et al.(2004)]{stohl2004}
-Stohl, A., Cooper, O. R., Damoah, R., Fehsenfeld, F. C., Forster, C., Hsie, E.-Y., Hübler, G., Parrish,
-D. D. and Trainer, M.:
-Forecasting for a Lagrangian aircraft campaign.
-Atmos. Chem. Phys., 4, 1113--1124, 2004.
-\bibitem[Stohl et al.(2002)]{stohl2002}
-Stohl, A., Eckhardt, S., Forster, C., James, P., Spichtinger, N. and Seibert, P.:
-A replacement for simple back trajectory calculations in the interpretation of atmospheric trace substance measurements.
-Atmos. Environ., 36, 4635--4648, 2002.
-\bibitem[Stohl et al.(2003)]{stohl2003}
-Stohl, A., Forster, C., Eckhardt, S., Spichtinger, N., Huntrieser, H., Heland, J., Schlager, H., Wilhelm, S., Arnold, F. and Cooper, O.:
-A backward modeling study of intercontinental pollution transport using aircraft measurements.
-J. Geophys. Res., 108, 4370, doi:10.1029/2002JD002862, 2003.
-\bibitem[Stohl et al.(1998)]{stohletal1998}
-Stohl, A., Hittenberger, M. and Wotawa, G.:
-Validation of the Lagrangian particle dispersion model FLEXPART against large scale tracer experiment data.
-Atmos. Environ., 32, 4245--4264, 1998.
-\bibitem[Stohl et al.(2000)]{stohl2000}
-Stohl, A., Spichtinger-Rakowsky, N., Bonasoni, P., Feldmann, H., Memmesheimer, M., Scheel, H. E., Trickl, T., H\"ubener, S. H., Ringer, W. and Mandl, M.:
-The influence of stratospheric intrusions on alpine ozone concentrations.
-Atmos. Environ., 34, 1323--1354, 2000.
-\bibitem[Stohl and Thomson(1999)]{stohlthomson1999}
-Stohl, A. and Thomson, D. J.:
-A density correction for Lagrangian particle dispersion models.
-Bound.-Layer Met., 90, 155--167, 1999.
-\bibitem[Stohl and Trickl(1999)]{stohl1999}
-Stohl, A. and Trickl, T.:
-A textbook example of long-range transport: Simultaneous observation of ozone maxima of stratospheric and North American origin in the free troposphere over Europe,
-J. Geophys. Res., 104, 30,445--30,462, 1999.
-\bibitem[Walmsley and Wesely(1996]{walmsley1996}
-Walmsley J.L., Wesely M.L.:
-Modification of coded parametrizations of surface resistances to gaseous dry deposition.
-Atmos. Environ., 30, 1181--1188, 1996.
-\bibitem[Stohl et al.(1995)]{stohl1995}
-Stohl, A., Wotawa, G., Seibert, P. and Kromp-Kolb, H.:
-Interpolation errors in wind fields as a function of spatial and temporal resolution and their impact on different types of kinematic trajectories.
-J. Appl. Meteor., 34, 2149--2165, 1995.
-\bibitem[Stull(1988)]{stull1988}
-Stull, R. B.:
-An Introduction to Boundary Layer Meteorology. Kluwer Academic Publishers, Dordrecht, 1988.
-\bibitem[Telford(1975)]{telford1975}
-Telford, J. W.:
-Turbulence, entrainment and mixing in cloud dynamics,
-Pure Appl. Geophys., 113, 1067--1084, 1975.
-\bibitem[Thomson(1987)]{thomson1987}
-Thomson D. J.:
-Criteria for the selection of stochastic models of particle trajectories in turbulent flows.
-J. Fluid Mech., 180, 529--556, 1987.
-\bibitem[Uliasz(1994)]{uliasz1994}
-Uliasz, M.:
-Lagrangian particle dispersion modeling in mesoscale applications. In: Zannetti, P. (ed.): {\it Environmental Modeling, Vol. II}. Computational Mechanics Publications, Southampton, UK, 1994.
-\bibitem[Velde et al.(1994)]{velde1994}
-Velde van de, R. J., Faber, W. S., Katwijk van, V. F., Kuylenstierna, J. C. I., Scholten., H. J., Thewessen, T. J. M., Verspuij, M. and Zevenbergen, M.:
-The Preparation of a European Land Use Database. National Institute of Public Health and Environmental Protection, Report nr 712401001, Bilthoven, The Netherlands, 1994.
-\bibitem[Vogelezang and Holtslag(1996)]{vogelezang1996}
-Vogelezang, D. H. P. and Holtslag, A. A. M.:
-Evaluation and model impacts of alternative boundary-layer height formulations.
-Bound.-Layer Met., 81, 245--269, 1996.
-\bibitem[Wesely and Hicks(1977)]{wesely1977}
-Wesely, M. L. and Hicks, B. B.:
-Some factors that affect the deposition rates of sulfur dioxide and similar gases on vegetation.
-J. Air Poll. Contr. Assoc., 27, 1110--1116, 1977.
-\bibitem[Wesely(1989)]{wesely1989}
-Wesely, M. L.:
-Parameterization of surface resistances to gaseous dry deposition in regional-scale numerical models.
-Atmos. Environ., 23, 1293--1304, 1989.
-\bibitem[Wilson and Flesch(1993)]{wilson1993}
-Wilson, D. J. and Flesch, T. K.:
-Flow boundaries in random-flight dispersion models: enforcing the well-mixed condition.
-J. Appl. Meteor., 32, 1695--1707, 1993.
-\bibitem[Wilson et al.(1983)]{wilson1983}
-Wilson, J. D., Legg, B. J. and Thomson, D. J.:
-Calculation of particle trajectories in the presence of a gradient in turbulent-velocity scale.
-Bound.-Layer Met., 27, 163--169, 1983.
-\bibitem[Wilson and Sawford(1996)]{wilson1996}
-Wilson, J. D. and Sawford, B. L.:
-Review of Lagrangian stochastic models for trajectories in the turbulent atmosphere.
-Bound.-Layer Met., 78, 191--210, 1996.
-\bibitem[Wotawa et al.(1996)]{wotawa1996}
-Wotawa, G., Stohl, A. and Kromp-Kolb, H.:
-Parameterization of the planetary boundary layer over Europe - a data comparison between the observation based OML preprocessor and ECMWF model data.
-Contr. Atmos. Phys., 69, 273--284, 1996.
-\bibitem[Wotawa and Stohl(1997)]{wotawa1997}
-Wotawa, G. and Stohl, A.:
-Boundary layer heights and surface fluxes of momentum and heat derived from ECMWF data for use in pollutant dispersion models -- problems with data accuracy.
-In: Gryning, S.-E., Beyrich, F. and E. Batchvarova (editors): The Determination of the Mixing Height -- Current Progress and Problems. EURASAP Workshop Proceedings, 1-3 October 1997, Ris{\o} National Laboratory, Denmark, 1997.
-\bibitem[Zannetti(1992)]{zannetti1992}
-Zannetti, P.:
-Particle Modeling and Its Application for Simulating Air Pollution Phenomena. In: Melli P. and P. Zannetti (ed.): Environmental Modelling. Computational Mechanics Publications, Southampton, UK, 1992.
-\bibitem[Zhang et al.(2002)]{zhang2002}
-Zhang L.M., Moran M.D., Makar P.A., Brook J.R. and S. Gong
-Modelling gaseous dry deposition in AURAMS: a unified regional air-quality modelling system
-Atmos. Environ., 36, 537-560, 2002.
-
-\end{thebibliography}
-
-\newpage
-
-\appendix
-
-\onecolumn
-
-\section{FLEXPART sample input files}
-\subsection{The pathnames file}
-A file \verb|pathnames| must exist in the directory where FLEXPART is started.
-It states the pathnames (absolute or relative) of input and output files:
-\begin{footnotesize}\begin{verbatim}
-/home/as/FLEXPART50/options/
-/volc/as/contrace/modelresults/forward/
-/volc/windcontrace/
-/volc/windcontrace/AVAILABLE
-/volc/nested/
-/volc/nested/AVAILABLE
-============================================
-
-Line 1: path where control files "COMMAND" and "RELEASES" are available
-Line 2: name of directory where output files are generated
-Line 3: path where meteorological fields are available (mother grid)
-Line 4: full filename of "AVAILABLE"-file (mother grid)
-
-Subsequent lines:
-Line 2n+3: path where meteorological fields are available (nested grid n)
-Line 2n+4: full filename of "AVAILABLE"-file (nested grid n)
-
-Line below last pathname must be:
-============================================
-
-The grids must be arranged such as that the coarse-scale nests
-come before the fine-scale nests. Multiple nests of the same
-nesting level are allowed. In that case, the order is arbitrary.
-\end{verbatim}\end{footnotesize}
-
-\newpage
-
-\subsection{Files in directory windfields}
-
-The directory where the meteorological input data are stored, here called
-\verb|windfields| (\verb|/volc/windcontrace/| in the above example
-\verb|pathnames| file), contains grib-code files containing the ECMWF data.
-All meteorological fields must have the same structure, i.e. the same
-computational domain and the same resolution. An example listing of this
-directory is given below.
-\begin{footnotesize}\begin{verbatim}
-AVAILABLE EN01102806 EN01102815
-EN01102800 EN01102809 EN01102818
-EN01102803 EN01102812 EN01102821
-\end{verbatim}\end{footnotesize}
-
-The file names of the grib-code files and their validation dates and times (in UTC) must be listed in the file \verb|AVAILABLE|. While it is practical to have this file reside in the same directory as the wind fields, this is no necessity and it can also be located elsewhere, as its file name is also given in the \verb|pathnames| file.
-\begin{footnotesize}\begin{verbatim}
-DATE TIME FILENAME SPECIFICATIONS
-YYYYMMDD HHMISS
-________ ______ __________ __________
-20011028 000000 EN01102800 ON DISC
-20011028 030000 EN01102803 ON DISC
-20011028 060000 EN01102806 ON DISC
-20011028 090000 EN01102809 ON DISC
-20011028 120000 EN01102812 ON DISC
-20011028 150000 EN01102815 ON DISC
-20011028 180000 EN01102818 ON DISC
-20011028 210000 EN01102821 ON DISC
-\end{verbatim}\end{footnotesize}
-
-Since version 7.0, FILENAME can be up to 256 characters long. Thus, the path
-to a file can be directly placed in the AVAILABLE file. If this feature is
-used, line 3 in the \verb|pathnames| file should be left empty.
-\begin{footnotesize}\begin{verbatim}
-DATE TIME FILENAME SPECIFICATIONS
-YYYYMMDD HHMISS
-________ ______ __________ __________
-20011028 000000 /work_disk/data/EN01102800 ON DISC
-20011028 030000 /work_disk/data/EN01102803 ON DISC
-20011028 060000 /work_disk/data/EN01102806 ON DISC
-20011028 090000 /work_disk/data/EN01102809 ON DISC
-20011028 120000 /work_disk/data/EN01102812 ON DISC
-20011028 150000 /work_disk/data/EN01102815 ON DISC
-20011028 180000 /work_disk/data/EN01102818 ON DISC
-20011028 210000 /work_disk/data/EN01102821 ON DISC
-\end{verbatim}\end{footnotesize}
-
-Nested wind fields must be stored in one or more different directory/ies, as specified in the \verb|pathnames| file.
-
-\newpage
-
-\subsection{Files in directory options}
-
-The files in directory \begin{footnotesize}\verb|options|\end{footnotesize} are used to specify the model run.
-An example listing of \begin{footnotesize}\verb|options|\end{footnotesize} is given below.
-\begin{footnotesize}\begin{verbatim}
-AGECLASSES IGBP_int1.dat RECEPTORS SPECIES
-COMMAND OH_7lev_agl.dat RELEASES surfdata.t
-COMMAND.alternative OUTGRID RELEASES.alternative surfdepo.t
-COMMAND.reference OUTGRID_NEST RELEASES.reference
-\end{verbatim}\end{footnotesize}
-
-Here, SPECIES is a subdirectory containing a number of files (this feature was introduced in version 8.0):
-\begin{footnotesize}\begin{verbatim}
-SPECIES:
-SPECIES_001 SPECIES_004 SPECIES_007
-SPECIES_002 SPECIES_005 SPECIES_008
-SPECIES_003 SPECIES_006 SPECIES_009
-\end{verbatim}\end{footnotesize}
-
-\subsubsection{File COMMAND}
-
-The most important configuration file for setting up a FLEXPART simulation is
-the \verb|COMMAND| file which specifies (1) the simulation direction (either
-forward or backward), (2) the start and (3) the end time of the simulation, (4)
-the frequency $T_c$ of the model output, (5) the averaging time $\Delta T_c$ of
-model output, and (6) the intervals $\Delta T_s$ at which concentrations are
-sampled, (7) the time constant for particle splitting $\Delta t_s$, (8) the
-synchronisation interval of FLEXPART, (9) the factor $c_{tl}$ by which the time
-steps must be smaller than the Lagrangian time scale, and (10) the refinement
-factor for the time step used for solving the Langevin equation of the vertical
-component of the turbulent wind. If (9) ($c_{tl}$) is negative, the Langevin
-equations are solved with constant time steps according to the synchronisation
-interval. In that case, the value of (10) is arbitrary. The synchronisation
-interval is the minimum time interval used by the model for all activities
-(such as concentration calculations, wet deposition calculations, interpolation
-of data, mesoscale wind fluctuations or output of data) other than the
-simulation of turbulent transport and dry deposition (if ($c_{tl}>0$). Further
-switches determine (11) whether concentrations, mixing ratios, residence times
-or plume trajectories (or combinations thereof) are to be calculated, (12) the
-option of particle position dump either at the end of or continuously during
-the simulation, (13) on/off of subgrid terrain effect parameterization, (14)
-on/off of deep convection parameterization, (15) on/off calculation of age
-spectra, (16) continuation of simulation from previous particle dump, (17)
-write output for each RELEASE location on/off, (18) on/off for mass flux
-calculations and output, (19) on/off for the domain-filling option of FLEXPART,
-(20) an indicator that determines whether mass or mass mixing ratio units are
-to be used at the source, (21) an indicator that determines whether mass or
-mass mixing ratio units are to be used at the receptor, (22) on/off of
-additional compact dump of the positions of numbered particles, (23) on/off for
-the use of nested output fields, (24) write sensitivity to initial conditions
-in backward mode off/mass units/mass mixing ratio units.
-
-Two versions of \verb|COMMAND| may be used, which both can be read in by
-FLEXPART: the first contains formatted input (i.e., a mask to be filled for the
-various input options that must be filled in), the second contains largely
-unformatted input and is recommended for the more experienced FLEXPART user.
-The following example is for formatted input.
-
-\begin{scriptsize}\begin{verbatim}
-********************************************************************************
-* *
-* Input file for the Lagrangian particle dispersion model FLEXPART *
-* Please select your options *
-* *
-********************************************************************************
-
-1. __ 3X, I2
- 1
- LDIRECT 1 FOR FORWARD SIMULATION, -1 FOR BACKWARD SIMULATION
-
-2. ________ ______ 3X, I8, 1X, I6
- 20040626 000000
- YYYYMMDD HHMISS BEGINNING DATE OF SIMULATION
-
-3. ________ ______ 3X, I8, 1X, I6
- 20040816 120000
- YYYYMMDD HHMISS ENDING DATE OF SIMULATION
-
-4. _____ 3X, I5
- 7200
- SSSSS OUTPUT EVERY SSSSS SECONDS
-
-5. _____ 3X, I5
- 7200
- SSSSS TIME AVERAGE OF OUTPUT (IN SSSSS SECONDS)
-
-6. _____ 3X, I5
- 900
- SSSSS SAMPLING RATE OF OUTPUT (IN SSSSS SECONDS)
-
-7. _________ 3X, I9
- 999999999
- SSSSSSSSS TIME CONSTANT FOR PARTICLE SPLITTING (IN SECONDS)
-
-8. _____ 3X, I5
- 900
- SSSSS SYNCHRONISATION INTERVAL OF FLEXPART (IN SECONDS)
-
-9. ---.-- 4X, F6.4
- -5.0
- CTL FACTOR, BY WHICH TIME STEP MUST BE SMALLER THAN TL
-
-10. --- 4X, I3
- 4
- IFINE DECREASE OF TIME STEP FOR VERTICAL MOTION BY FACTOR IFINE
-
-11. - 4X, I1
- 3
- IOUT 1 CONCENTRATION (RESIDENCE TIME FOR BACKWARD RUNS) OUTPUT, 2 MIXING RATIO OUTPUT, 3 BOTH,4 PLUME TRAJECT., 5=1+4
-
-12. - 4X, I1
- 2
- IPOUT PARTICLE DUMP: 0 NO, 1 EVERY OUTPUT INTERVAL, 2 ONLY AT END
-
-13. _ 4X, I1
- 1
- LSUBGRID SUBGRID TERRAIN EFFECT PARAMETERIZATION: 1 YES, 0 NO
-
-14. _ 4X, I1
- 1
- LCONVECTION CONVECTION: 1 YES, 0 NO
-
-15. _ 4X, I1
- 0
- LAGESPECTRA AGE SPECTRA: 1 YES, 0 NO
-
-16. _ 4X, I1
- 0
- IPIN CONTINUE SIMULATION WITH DUMPED PARTICLE DATA: 1 YES, 0 NO
-
-17. _
- 0 4X,I1
- IOFR IOUTPUTFOREACHREL CREATE AN OUTPUT FILE FOR EACH RELEASE LOCATION: 1 YES, 0 NO
-
-18. _ 4X, I1
- 0
- IFLUX CALCULATE FLUXES: 1 YES, 0 NO
-
-19. _ 4X, I1
- 0
- MDOMAINFILL DOMAIN-FILLING TRAJECTORY OPTION: 1 YES, 0 NO, 2 STRAT. O3 TRACER
-
-20. _ 4X, I1
- 1
- IND_SOURCE 1=MASS UNIT , 2=MASS MIXING RATIO UNIT
-
-21. _ 4X, I1
- 1
- IND_RECEPTOR 1=MASS UNIT , 2=MASS MIXING RATIO UNIT
-
-22. _ 4X, I1
- 0
- MQUASILAG QUASILAGRANGIAN MODE TO TRACK INDIVIDUAL PARTICLES: 1 YES, 0 NO
-
-23. _ 4X, I1
- 0
- NESTED_OUTPUT SHALL NESTED OUTPUT BE USED? 1 YES, 0 NO
-24. _ 4X, I1
- 2
- LINIT_COND INITIAL COND. FOR BW RUNS: 0=NO,1=MASS UNIT,2=MASS MIXING RATIO UNIT
-
-
-1. Simulation direction, 1 for forward, -1 for backward in time
- (consult Seibert and Frank, 2004 for backward runs)
-
-2. Beginning date and time of simulation. Must be given in format
- YYYYMMDD HHMISS, where YYYY is YEAR, MM is MONTH, DD is DAY, HH is HOUR,
- MI is MINUTE and SS is SECOND. Current version utilizes UTC.
-
-3. Ending date and time of simulation. Same format as 3.
-
-4. Average concentrations are calculated every SSSSS seconds.
-
-5. The average concentrations are time averages of SSSSS seconds
- duration. If SSSSS is 0, instantaneous concentrations are outputted.
-
-6. The concentrations are sampled every SSSSS seconds to calculate the time
- average concentration. This period must be shorter than the averaging time.
-
-7. Time constant for particle splitting. Particles are split into two
- after SSSSS seconds, 2xSSSSS seconds, 4xSSSSS seconds, and so on.
-
-8. All processes are synchronized with this time interval (lsynctime).
- Therefore, all other time constants must be multiples of this value.
- Output interval and time average of output must be at least twice lsynctime.
-
-9. CTL must be >1 for time steps shorter than the Lagrangian time scale
- If CTL<0, a purely random walk simulation is done
-
-10.IFINE=Reduction factor for time step used for vertical wind
-
-11.IOUT determines how the output shall be made: concentration
- (ng/m3, Bq/m3), mixing ratio (pptv), or both, or plume trajectory mode,
- or concentration + plume trajectory mode.
- In plume trajectory mode, output is in the form of average trajectories.
-
-12.IPOUT determines whether particle positions are outputted (in addition
- to the gridded concentrations or mixing ratios) or not.
- 0=no output, 1 output every output interval, 2 only at end of the
- simulation
-
-13.Switch on/off subgridscale terrain parameterization (increase of
- mixing heights due to subgridscale orographic variations)
-
-14.Switch on/off the convection parameterization
-
-15.Switch on/off the calculation of age spectra: if yes, the file AGECLASSES
- must be available
-
-16. If IPIN=1, a file "partposit_end" from a previous run must be available in
- the output directory. Particle positions are read in and previous simulation
- is continued. If IPIN=0, no particles from a previous run are used
-
-17. IF IOUTPUTFOREACHRELEASE is set to 1, one output field for each location
- in the RELEASES file is created. For backward calculation this should be
- set to 1. For forward calculation both possibilities are applicable.
-
-18. If IFLUX is set to 1, fluxes of each species through each of the output
- boxes are calculated. Six fluxes, corresponding to northward, southward,
- eastward, westward, upward and downward are calculated for each grid cell of
- the output grid. The control surfaces are placed in the middle of each
- output grid cell. If IFLUX is set to 0, no fluxes are determined.
-
-19. If MDOMAINFILL is set to 1, the first box specified in file RELEASES is used
- as the domain where domain-filling trajectory calculations are to be done.
- Particles are initialized uniformly distributed (according to the air mass
- distribution) in that domain at the beginning of the simulation, and are
- created at the boundaries throughout the simulation period.
-
-20. IND_SOURCE switches between different units for concentrations at the source
- NOTE that in backward simulations the release of computational particles
- takes place at the "receptor" and the sampling of particles at the "source".
- 1=mass units (for bwd-runs = concentration)
- 2=mass mixing ratio units
-21. IND_RECEPTOR switches between different units for concentrations at the receptor
- 1=mass units (concentrations)
- 2=mass mixing ratio units
-
-22. MQUASILAG indicates whether particles shall be numbered consecutively (1) or
- with their release location number (0). The first option allows tracking of
- individual particles using the partposit output files
-
-23. NESTED_OUTPUT decides whether model output shall be made also for a nested
- output field (normally with higher resolution)
-
-24. LINIT_COND determines whether, for backward runs only, the sensitivity to initial
- conditions shall be calculated and written to output files
- 0=no output, 1 or 2 determines in which units the initial conditions are provided.
-
-\end{verbatim}\end{scriptsize}
-
-\newpage
-
-\subsubsection{File OUTGRID}
-The file \verb|OUTGRID| specifies the output grid.
-\begin{scriptsize}\begin{verbatim}
-********************************************************************************
-* *
-* Input file for the Lagrangian particle dispersion model FLEXPART *
-* Please specify your output grid *
-* *
-********************************************************************************
-
-1. ------.---- 4X,F11.4
- -10.0000 GEOGRAFICAL LONGITUDE OF LOWER LEFT CORNER OF OUTPUT GRID
- OUTLONLEFT (left boundary of the first grid cell - not its centre)
-
-
-2. ------.---- 4X,F11.4
- 40.0000 GEOGRAFICAL LATITUDE OF LOWER LEFT CORNER OF OUTPUT GRID
- OUTLATLOWER (lower boundary of the first grid cell - not its centre)
-
-3. ----- 4X,I5
- 101 NUMBER OF GRID POINTS IN X DIRECTION (= No. of cells + 1)
- NUMXGRID
-
-4. ----- 4X,I5
- 47 NUMBER OF GRID POINTS IN Y DIRECTION (= No. of cells + 1)
- NUMYGRID
-
-5. ------.--- 4X,F10.3
- 0.500 GRID DISTANCE IN X DIRECTION
- DXOUTLON
-
-6. ------.--- 4X,F10.3
- 0.500 GRID DISTANCE IN Y DIRECTION
- DYOUTLAT
-
-7. -----.- 4X, F7.1
- 100.0
- LEVEL 1 HEIGHT OF LEVEL (UPPER BOUNDARY)
-
-8. -----.- 4X, F7.1
- 300.0
- LEVEL 2 HEIGHT OF LEVEL (UPPER BOUNDARY)
-
-9. -----.- 4X, F7.1
- 600.0
- LEVEL 3 HEIGHT OF LEVEL (UPPER BOUNDARY)
-
-10. -----.- 4X, F7.1
- 1000.0
- LEVEL 4 HEIGHT OF LEVEL (UPPER BOUNDARY)
-
-11. -----.- 4X, F7.1
- 2000.0
- LEVEL 5 HEIGHT OF LEVEL (UPPER BOUNDARY)
-
-12. -----.- 4X, F7.1
- 3000.0
- LEVEL 6 HEIGHT OF LEVEL (UPPER BOUNDARY)
-\end{verbatim}\end{scriptsize}
-In order to define the grid for a nested output field, the file
-\verb|OUTGRID_NEST| must exist. It has the same format as file \verb|OUTGRID|,
-but does not contain the vertical level information:
-
-\begin{scriptsize}\begin{verbatim}
-********************************************************************************
-* *
-* Input file for the Lagrangian particle dispersion model FLEXPART *
-* Please specify your output grid *
-* *
-********************************************************************************
-
-1. ------.---- 4X,F11.4
- -125.0000 GEOGRAFICAL LONGITUDE OF LOWER LEFT CORNER OF OUTPUT GRID
- OUTLONLEFT (left boundary of the first grid cell - not its centre)
-
-2. ------.---- 4X,F11.4
- 25.0000 GEOGRAFICAL LATITUDE OF LOWER LEFT CORNER OF OUTPUT GRID
- OUTLATLOWER (lower boundary of the first grid cell - not its centre)
-
-3. ----- 4X,I5
- 1 NUMBER OF GRID POINTS IN X DIRECTION (= No. of cells + 1)
- NUMXGRID
-
-4. ----- 4X,I5
- 1 NUMBER OF GRID POINTS IN Y DIRECTION (= No. of cells + 1)
- NUMYGRID
-
-5. ------.----- 4X,F12.5
- 0.33333 GRID DISTANCE IN X DIRECTION
- DXOUTLON
-
-6. ------.----- 4X,F12.5
- 0.25000 GRID DISTANCE IN Y DIRECTION
- DYOUTLAT
-\end{verbatim}\end{scriptsize}
-
-\newpage
-
-\subsubsection{File RECEPTORS}
-
-\verb|RECEPTORS| specifies the receptor locations for which the parabolic
-kernel method shall be applied to calculate air concentrations. The maximum
-number of receptor sites is set by parameter \verb|maxreceptor| in file
-\verb|includepar|.
-\begin{scriptsize}\begin{verbatim}
-********************************************************************************
-* *
-* Input file for the Lagrangian particle dispersion model FLEXPART *
-* Please specify your receptor points *
-* For the receptor points, ground level concentrations are calculated *
-* *
-********************************************************************************
-1. ---------------- 4X,A16
- F15 NAME OF RECEPTOR POINT
- RECEPTORNAME
-
-2. ------.---- 4X,F11.4
- 6.1333 GEOGRAFICAL LONGITUDE
- XRECEPTOR
-
-3. ------.---- 4X,F11.4
- 49.0833 GEOGRAFICAL LATITUDE
- YRECEPTOR
-================================================================================
-1. ---------------- 4X,A16
- NL01 NAME OF RECEPTOR POINT
- RECEPTORNAME
-
-2. ------.---- 4X,F11.4
- 5.7833 GEOGRAFICAL LONGITUDE
- XRECEPTOR
-
-3. ------.---- 4X,F11.4
- 50.9167 GEOGRAFICAL LATITUDE
- YRECEPTOR
-================================================================================
-\end{verbatim}\end{scriptsize}
-
-\newpage
-
-\subsubsection{File RELEASES}
-
-\begin{footnotesize}\verb|RELEASES|\end{footnotesize} defines the release
-specifications. In the first input line, the number $N$ of emitted species is
-defined (1 in the example below). At all locations, the same species must be
-released. The next $N$ input lines give a cross-reference to the respective file
-\begin{footnotesize}\verb|SPECIES_nnn|\end{footnotesize}, where the physical and
-chemical properties of the released species are given (also the temporal
-variations of emissions is defined for each species). Then follows a list of
-release sites, for each of which the release characteristics must be entered:
-the beginning and the ending time of the release, geographical coordinates of
-the lower left and upper right corners of the release location, type of
-vertical coordinate (above ground level, or above sea level), lower level and
-upper level of source box, the number of particles to be used, and the total
-mass emitted. Note that the mass entry must be repeated $N$ times, one mass
-per species released. Finally, a name is assigned to each release point.\par
-
-The particles are released from random locations within a four-dimensional box
-extending from the lower to the upper level above a rectangle (on a lat/lon
-grid) defined by the geographical coordinates, and between the release's start
-and end. With some of the coordinates set identically, line or point sources
-can be specified.
-
-As for \verb|COMMAND|, the \verb|RELEASES| file can be provided formatted or
-unformatted. The example below shows the formatted version.
-
-\begin{scriptsize}\begin{verbatim}
-*************************************************************************
-* *
-* *
-* *
-* Input file for the Lagrangian particle dispersion model FLEXPART *
-* Please select your options *
-* *
-* *
-* *
-*************************************************************************
-+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
- 1
-___ i3 Total number of species emitted
-
- 24
-___ i3 Index of species in file SPECIES
-
-=========================================================================
-20011028 150007
-________ ______ i8,1x,i6 Beginning date and time of release
-
-20011028 150046
-________ ______ i8,1x,i6 Ending date and time of release
-
- 9.4048
-____.____ f9.4 Longitude [DEG] of lower left corner
-
- 48.5060
-____.____ f9.4 Latitude [DEG] of lower left corner
-
- 9.5067
-____.____ f9.4 Longitude [DEG] of upper right corner
-
- 48.5158
-____.____ f9.4 Latitude [DEG] of upper right corner
-
- 2
-_________ i9 1 for m above ground, 2 for m above sea level, 3 for pressure in hPa
-
- 6933.60
-_____.___ f10.3 Lower z-level (in m agl or m asl)
-
- 6950.40
-_____.___ f10.3 Upper z-level (in m agl or m asl)
-
- 20000
-_________ i9 Total number of particles to be released
-
-1.0000E00
-_.____E__ e9.4 Total mass emitted
-
-FLIGHT_11242
-________________________________________ character*40 comment
-+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
-20011028 150047
-________ ______ i8,1x,i6 Beginning date and time of release
-
-20011028 150107
-________ ______ i8,1x,i6 Ending date and time of release
-
- 9.3038
-____.____ f9.4 Longitude [DEG] of lower left corner
-
- 48.5158
-____.____ f9.4 Latitude [DEG] of lower left corner
-
- 9.4048
-____.____ f9.4 Longitude [DEG] of upper right corner
-
- 48.5906
-____.____ f9.4 Latitude [DEG] of upper right corner
-
- 2
-_________ i9 1 for m above ground, 2 for m above sea level, 3 for pressure in hPa
-
- 6833.50
-_____.___ f10.3 Lower z-level (in m agl or m asl)
-
- 6950.40
-_____.___ f10.3 Upper z-level (in m agl or m asl)
-
- 20000
-_________ i9 Total number of particles to be released
-
-1.0000E00
-_.____E__ e9.4 Total mass emitted
-
-FLIGHT_11185
-________________________________________ character*40 comment
-+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
-
-\end{verbatim}\end{scriptsize}
-
-\newpage
-
-\subsubsection{File AGECLASSES}
-
-\verb|AGECLASSES| provides the times for the age class calculation. In the
-first data line, the number $n$ of age classes is set, and ages are listed in
-the following $n$ lines. The entries specify the end times (in seconds) of the
-respective intervals to be used, the first one starting at zero seconds.
-Particles are dropped from the simulation once they exceed the maximum age.
-Even if no age classes are needed, this option (with the number of age classes
-set to 1) can be useful to determine the age at which particles are removed
-from the simulation.
-
-\begin{footnotesize}\begin{verbatim}
-************************************************
-* *
-*Lagrangian particle dispersion model FLEXPART *
-* Please select your options *
-* *
-*This file determines the ageclasses to be used*
-* *
-*Ages are given in seconds. The first class *
-*starts at age zero and goes up to the first *
-*age specified. The last age gives the maximum *
-*time a particle is carried in the simulation. *
-* *
-************************************************
- 6 Integer Number of age classes
-43200 Integer Age class 1
-86400 Integer Age class 2
-129600
-172800
-259200
-345600
-\end{verbatim}\end{footnotesize}
-
-\newpage
-
-\subsubsection{Files SPECIES\_nnn and surfdata.t}
-
-\begin{footnotesize}\verb|SPECIES_nnn|\end{footnotesize} (where \verb|nnn| is
-a zero-padded identifier of the species number) specifies all physico-chemical
-properties for the given species. Entries are the half life (due to
-radioactive or chemical decay), wet deposition information (\verb|A| and \verb|B| are the
-factors defined by Eq.~\ref{wetscav}), dry deposition information for
-gases ($D=D_{H_2O}/D_i$, $D_{H_2O}$ is the diffusivity of water vapor and \verb|D_i|
-is the diffusivity of the species, \verb|H| is the effective Henry's constant, and
-\verb|f0| varies between 0 and 1 and gives the reactivity of a species relative to
-that of ozone. For nonreactive species \verb|f0| is 0, for slightly reactive it is
-0.1 and for highly reactive it is 1.), dry deposition information for
-particulates (\verb|rho| specifies the density of the substance, \verb|dquer| its mean
-diameter $\overline{d_p}$, and \verb|dsig| the measure of variation $\sigma_p$).
-Radioactive decay is switched off by specifying a negative half life, wet
-deposition is switched off by specifying negative \verb|A|, dry deposition of gases
-is switched off by negative \verb|D|, dry deposition of particles is switched off by
-negative \verb|rho|. If no detailed information for deposition velocity calculation
-is available, a constant deposition velocity \verb|vd| (cm s$^{-1}$) can be used.
-\verb|molweight| gives the molecular weight of the species, which is needed for
-mixing ratio output. For degradation in an monthly averaged OH field
-\citep{bey2001} the OH Reaction ratio at 25\degreee C for the species can be given,
-units are (cm$^3$/s).
-
-Optionally an emission variation information can be added at the end of the
-file, defined as following: Since FLEXPART version 6.0, emission factors can be
-defined that change the temporal variation of particle releases. This is
-useful, for instance, to simulate the typical daily and weekly cycle of
-anthropogenic emissions. The emission factors are given in the file of the
-corresponding species \verb|SPECIES_nnn|, where \verb|nnn| is the species
-number defined in file \verb|RELEASES|. If no emission variation information
-is given, emission rates for species \verb|nnn| are taken as constant. Release
-rates can vary with the hour of the day and with the day of the week, according
-to the local time at the release location. Emission factors must be 1 on
-average. 24 hourly as well as 7 daily values must be specified. Furthermore,
-different disaggregation factors must be given for area sources and for point
-sources. FLEXPART distinguishes between the two using the lower altitude of
-the release box: area sources are assumed to start below 0.5 m above the
-ground, whereas point sources are assumed to be higher. Please note that when
-this option is used, it is not so easy to determine the maximum number of
-particles present at a particular time of the model run. It might then be
-necessary to increase the parameter \verb|maxpart| to a higher value than what
-would otherwise be needed. The following is an example for an
-\verb|SPECIES_nnn| file including emission variation.
-
-\begin{scriptsize}\begin{verbatim}
-****************************************************************************
-* *
-* Input file for the Lagrangian particle dispersion model FLEXPART *
-* Definition file of chemical species/radionuclides *
-* *
-****************************************************************************
-EU-CO Tracer name
--999.9 Species half life
--9.9E-09 Wet deposition - A
- Wet deposition - B
--9.9 Dry deposition (gases) - D
- Dry deposition (gases) - Henrys const.
- Dry deposition (gases) - f0 (reactivity)
--9.9E09 Dry deposition (particles) - rho
- Dry deposition (particles) - dquer
- Dry deposition (particles) - dsig
--9.99 Alternative: dry deposition velocity
- 28.00 molweight
--9.9E-09 OH Reaction rate at 25 deg, [cm^3/s]
--9 number of associated specias (neg. none) - not implemented yet
--99.99 KOA - organic matter air partitioning
-hr_start co_area co_point
- 0 0.535 0.932 0-1 local time
- 1 0.405 0.931 1-2 local time
- 2 0.317 0.927
- 3 0.265 0.926
- 4 0.259 0.928
- 5 0.367 0.936
- 6 0.668 0.952
- 7 1.039 0.975
- 8 1.015 1.046
- 9 0.965 1.055
-10 1.016 1.061
-11 1.133 1.064
-12 1.269 1.067
-13 1.368 1.068
-14 1.516 1.069
-15 1.681 1.068
-16 1.777 1.024
-17 1.827 1.017
-18 1.538 1.008
-19 1.282 1.007
-20 1.136 1.004
-21 1.020 0.996
-22 0.879 0.981
-23 0.723 0.958 23-24 local time
-week_day co_area co_point
-1 1.060 1.000 Monday
-2 1.060 1.000 Tuesday
-3 1.060 1.000 Wednesday
-4 1.060 1.000 Thursday
-5 1.060 1.000 Friday
-6 0.900 1.000 Saturday
-7 0.800 1.000 Sunday
-\end{verbatim}\end{scriptsize}
-
-\begin{footnotesize}\verb|IGBP_int1.dat|\end{footnotesize} contains the landuse inventory in binary format, and
-\begin{footnotesize}\verb|surfdata.t|\end{footnotesize}, shown below, gives the roughness lengths for each landuse class:
-
-\begin{footnotesize}
-\begin{verbatim}
-13 landuse categories are related roughness length
---------------------------------------------------------
-landuse comment z0
---------------------------------------------------------
- 1 Urban land 0.7
- 2 Agricultural land 0.1
- 3 Range land 0.1
- 4 Deciduous forest 1.
- 5 Coniferous forest 1.
- 6 Mixed forest including wetland 0.7
- 7 Water, both salt and fresh 0.001
- 8 Barren land mostly desert 0.01
- 9 Nonforested wetland 0.1
-10 Mixed agricultural and range land 0.1
-11 Rocky open areas with low growing shrubs 0.05
-12 Snow and ice 0.001
-13 Rainforest 1.
-\end{verbatim}
-\end{footnotesize}
-
-\newpage
-
-\subsubsection{File surfdepo.t}
-\verb|surfdepo.t| gives the resistances needed for the parameterization of dry deposition of gases for the 13 landuse classes and five seasonal categories.
-This file must not be changed by the user.\par
-
-\begin{scriptsize}\begin{verbatim}
-DRY DEPOSITION
-==============================================================================
-AFTER WESELY, 1989
-==============================================================================
-1 to 11: Landuse types after Wesely; 12 .. snow, 13 .. rainforest
-==============================================================================
-Values are tabulated for 5 seasonal categories:
-1 Midsummer with lush vegetation
-2 Autumn with unharvested cropland
-3 Late autumn after frost, no snow
-4 Winter, snow on ground and subfreezing
-5 Transitional spring with partially green short annuals
-==============================================================================
- 1 2 3 4 5 6 7 8 9 10 11 12 13
-________________________________________________________________________________________________________________
-ri 9999. 60. 120. 70. 130. 100. 9999. 9999. 80. 100. 150. 9999. 200. 1
-rlu 9999. 2000. 2000. 2000. 2000. 2000. 9999. 9999. 2500. 2000. 4000. 9999. 1000.
-rac 100. 200. 100. 2000. 2000. 2000. 0. 0. 300. 150. 200. 0. 2000.
-rgss 400. 150. 350. 500. 500. 100. 0. 1000. 0. 220. 400. 100. 200.
-rgso 300. 150. 200. 200. 200. 300. 2000. 400. 1000. 180. 200. 10000. 200.
-rcls 9999. 2000. 2000. 2000. 2000. 2000. 9999. 9999. 2500. 2000. 4000. 9999. 9999.
-rclo 9999. 1000. 1000. 1000. 1000. 1000. 9999. 9999. 1000. 1000. 1000. 9999. 9999.
-_________________________________________________________________________________________________________________
-ri 9999. 9999. 9999. 9999. 250. 500. 9999. 9999. 9999. 9999. 9999. 9999. 200. 2
-rlu 9999. 9000. 9000. 9000. 4000. 8000. 9999. 9999. 9000. 9000. 9000. 9999. 1000.
-rac 100. 150. 100. 1500. 2000. 1700. 0. 0. 200. 120. 140. 0. 2000.
-rgss 400. 200. 350. 500. 500. 100. 0. 1000. 0. 300. 400. 100. 200.
-rgso 300. 150. 200. 200. 200. 300. 2000. 400. 800. 180. 200. 10000. 200.
-rcls 9999. 9000. 9000. 9000. 2000. 4000. 9999. 9999. 9000. 9000. 9000. 9999. 9999.
-rclo 9999. 400. 400. 400. 1000. 600. 9999. 9999. 400. 400. 400. 9999. 9999.
-_________________________________________________________________________________________________________________
-ri 9999. 9999. 9999. 9999. 250. 500. 9999. 9999. 9999. 9999. 9999. 9999. 200. 3
-rlu 9999. 9999. 9000. 9000. 4000. 8000. 9999. 9999. 9000. 9000. 9000. 9999. 1000.
-rac 100. 10. 100. 1000. 2000. 1500. 0. 0. 100. 50. 120. 0. 2000.
-rgss 400. 150. 350. 500. 500. 200. 0. 1000. 0. 200. 400. 100. 200.
-rgso 300. 150. 200. 200. 200. 300. 2000. 400. 1000. 180. 200. 10000. 200.
-rcls 9999. 9999. 9000. 9000. 3000. 6000. 9999. 9999. 9000. 9000. 9000. 9999. 9999.
-rclo 9999. 1000. 400. 400. 1000. 600. 9999. 9999. 800. 600. 600. 9999. 9999.
-_________________________________________________________________________________________________________________
-ri 9999. 9999. 9999. 9999. 400. 800. 9999. 9999. 9999. 9999. 9999. 9999. 200. 4
-rlu 9999. 9999. 9999. 9999. 6000. 9000. 9999. 9999. 9000. 9000. 9000. 9999. 1000.
-rac 100. 10. 10. 1000. 2000. 1500. 0. 0. 50. 10. 50. 0. 2000.
-rgss 100. 100. 100. 100. 100. 100. 0. 1000. 100. 100. 50. 100. 200.
-rgso 600. 3500. 3500. 3500. 3500. 3500. 2000. 400. 3500. 3500. 3500. 10000. 200.
-rcls 9999. 9999. 9999. 9000. 200. 400. 9999. 9999. 9000. 9999. 9000. 9999. 9999.
-rclo 9999. 1000. 1000. 400. 1500. 600. 9999. 9999. 800. 1000. 800. 9999. 9999.
-_________________________________________________________________________________________________________________
-ri 9999. 120. 240. 140. 250. 190. 9999. 9999. 160. 200. 300. 9999. 200. 5
-rlu 9999. 4000. 4000. 4000. 2000. 3000. 9999. 9999. 4000. 4000. 8000. 9999. 1000.
-rac 100. 50. 80. 1200. 2000. 1500. 0. 0. 200. 60. 120. 0. 2000.
-rgss 500. 150. 350. 500 500. 200. 0. 1000. 0. 250. 400. 100. 200.
-rgso 300. 150. 200. 200. 200. 300. 2000. 400. 1000. 180. 200. 10000. 200.
-rcls 9999. 4000. 4000. 4000. 2000. 3000. 9999. 9999. 4000. 4000. 8000. 9999. 9999.
-rclo 9999. 1000. 500. 500. 1500. 700. 9999. 9999. 600. 800. 800. 9999. 9999.
-_________________________________________________________________________________________________________________
-\end{verbatim}\end{scriptsize}
-
-\end{document}
diff --git a/documentation/fluxdiagram.txt b/documentation/fluxdiagram.txt
deleted file mode 100755
index 613d2b48..00000000
--- a/documentation/fluxdiagram.txt
+++ /dev/null
@@ -1,120 +0,0 @@
-******************************************************************************
-* FLEXPART model basic calling structure *
-******************************************************************************
-
-FLEXPART --> gasdev1 --> ran3
- --> readpaths
- --> readcommand --> juldate
- --> skplin
- --> readageclasses
- --> readavailable --> juldate
- --> gridcheck
- --> gridcheck_nests
- --> readoutgrid --> skplin
- --> readoutgrid_nest --> skplin
- --> readreceptors
- --> readspecies
- --> readlanduse
- --> assignland
- --> readreleases --> skplin
- --> part0 --> erf
- --> readdepo
- --> coordtrafo
- --> readpartpositions
- --> writeheader
- --> writeheader_nest
- --> openreceptors
- --> openouttraj
- --> outgrid_ini
- --> outgrid_ini_nest
- --> timemanager --> wetdepo --> interpol_rain
- --> interpol_rain_nests
- --> wetdepokernel
- --> wetdepokernel_nest
- --> convmix --> sort2
- --> calcmatrix --> convect --> tlift
- --> redist
- --> calcfluxes
- --> getfields --> see %1
- --> init_domainfill
- --> boundcond_domainfill
- --> releaseparticles --> caldate
- --> ran1 (random.f)
- --> convmix --> sort2
- --> calcmatrix --> convect --> tlift
- --> redist
- --> calcfluxes
- --> conccalc
- --> partoutput_short
- --> concoutput --> caldate
- --> mean
- --> concoutput_nest --> caldate
- --> mean
- --> plumetraj --> clustering --> distance2
- --> centerofmass
- --> mean
- --> distance
- --> fluxoutput --> caldate
- --> partoutput --> caldate
- --> conccalc
- --> initialize --> same calls as advance
- --> advance --> ran3
- --> interpol_all
- --> interpol_all_nests
- --> interpol_misslev
- --> interpol_misslev_nests
- --> hanna or hanna1
- --> hanna_short
- --> interpol_vdep
- --> interpol_vdep_nests
- --> interpol_wind
- --> interpol_wind_nests
- --> windalign
- --> cll2xy (various projection routines in cmapf1.0.f)
- --> cxy2ll
- --> interpol_wind_short
- --> interpol_wind_short_nests
- --> calcfluxes
- --> drydepokernel
- --> drydepokernel_nest
- --> partoutput --> caldate
-
-______________________________________________________________________________
-%1
- --> readwind --> pbopen
- --> pbgrib
- (--> swap32)
- --> gribex
- --> pbclose
- --> shift_field_0
- --> shift_field
- --> pbl_profile --> psim
- --> psih
- --> readwind_nests --> pbopen
- --> pbgrib
- --> swap32
- --> gribex
- --> pbclose
- --> pbl_profile --> psim
- --> psih
- --> calcpar --> scalev --> ew
- --> obukhov
- --> richardson --> qvsat
- --> getvdep --> caldate
- --> getrb
- --> raerod --> psih
- --> getrc
- --> partdep
- --> calcpv
- --> calcpar_nests --> scalev --> ew
- --> obukhov
- --> richardson --> qvsat
- --> getvdep --> caldate
- --> getrb
- --> raerod --> psih
- --> getrc
- --> partdep
- --> calcpv_nests
- --> verttransform --> cc2gll (cmapf1.0.f)
- --> verttransform_nests --> cc2gll (cmapf1.0.f)
-______________________________________________________________________________
diff --git a/documentation/memo_verttr.ps.gz b/documentation/memo_verttr.ps.gz
deleted file mode 100755
index 0cd96f81c2c5cc35c9fe16deba9ecdd65abef6b3..0000000000000000000000000000000000000000
GIT binary patch
literal 0
HcmV?d00001
literal 18850
zcmb2|=HQt7Ptu8jIX5*oKfWxrsHCJwub`M=Yi)M^6SrwkzyA=m+@0ZYt8l6W&m_mH
z-L20yUq4XNdp&gr?+)o^9Zl7xx|*h%D^Fc@I-7sL_#AKAvL{97C7MekXV$PZ3!1<C
zE%<YH{jXndSAVPdocC3$e(uiuf7jh#H;sSx+v(k(zrWu7d-41}@u#nMMSYpQyZ`pr
zr&kXjGWXs5Bdv0uU38rOvHsOZZ=XGSxczBaYy19K`<V6nV(zTTGyDIoZfkADjeTzB
zJ3fB>R8;!^>7nI^>+jB6|Do&Kzns$QzU;ftK7OmIt-hIC_pfN;!}yya-MdZ{X5W}&
zdv8si{Jyw*Yq#ZJuTM8W&18P;_UF3d!_nX0l^-sTul@T?e|7nrKc|mgZ0DDc%g^mt
z-M{*J`s~?{ue9~+<e&eaTD#jT*hVHd>&w@o-FqT!*KDh}{`2lH{?KW)8y(ckZ(sfU
z_m$1os@;`$<}I9lbo=V};<Jyp?>^q{Ixm$$`CothuS3`8+<H}1`}=EI@wc+CAD%u+
z{QCLk>)mgU{e3t84(B}SYw7&m6H>d2<>su{6Z?F$yyo4Lv%>3Y58e0t{w1%r`kdPQ
zdvo^GI@yO?{P_2BZT07s)|vCq$-n>b_pP}<|Lv!5|9<_H*n0c*@7KSN9{u#IZfiyH
zr+;!6qAT`y{CxE6qg431lBIRAk0x#QzRqy&?$^h)lWkvG?)}{#@$>6j;p*yNiqSG#
zK6Z!yyL?%D|A+b4#I^US7f0;hKQ}k;{51X@$EMeA-gQ65-foTg_8HHr<9@z7y7czd
zr;p}!Z@plB=b$v->_?v4wsjWlx#?6;VU_V&%k<J6la)Dgx3=FeaA42n|Gmxc`SQO>
zm38aFYkr^Qf0y=iL+t-O7S(t18uQA&UD3OBbXvvk9rZQaBlhi%Pg!sL=ehWGe*ayK
z+iQ2-$eDiq`n3y%8(vDv{d-$C)#`B2--*R+JnzE%x8?BPc3&fP?MuJIjpI+h9?dHK
z_vD@YH2(hYN2X2wo0`r2C;9c}vv;dX|CfBSf1B{pR?n|K&hF0x*U0r>zM6l3mhx(s
zyix4wf8U-x`6kAm@3&9t?e8~<tKWa_4(C7p^{epv>upQ(#Vo|Cc1_MK{{7+Y@!eOI
z7U=r_%UQ5%N9~P&bM#6Vykd=OV}D=x`P-)_cZF7e{F}7%uAcp_$$7oY9op~DFX?~%
z`t!f6owbkJ&xJ)FNZVt3dxEWw#V&L14?V8GONut$)L}Ttz2{NzyDO3%U-;zTe|&ZH
zYg%QWX2KeVGdA<(8G3$qn`~B>tCG2u!MWt9^z^izw&&vC{T<l0{knJS&w}*Ltou4P
zHQh=2f8a;S_MMNVquDnxc0asPmi)%=7r(!4+rAxfcjN40biESKJ@wkYZr)w3XVHD%
z>*_vL?zPw>|Lpglw8{PF<<6IHua&!cWZ~JL=g&+1JbZoq+iT3%J{<|`Y@hK|Sh3x$
zN#Wm|iN~as%F8#|iR)~afAiWWetLPE)3>kcwQ@QyF8}>xE5Ih3Yp&3{z5AL#)8Vt?
z2}P^tm;Nbhm$bU9U~uBSIK!ts^B7K@Pq6rVzWd+fMf)%HRD5!5K4Qx7Kc}*6t5y8o
z`1xxqnAdvfRTou!z4cgfxx2ky9JfyW<1@du`ttI-eht^Zmcqw2KYr%>$(KVJ`0l^z
zKD#eI$G)cOSMVd3`Pa-R1e>4!Jzs2s#)NI!4WIn|{VUXeJ+je%FViQqVx!)^xH~!L
z7+K~YD=5zuU{sErTf6IC&WXR%pTD1Pz-4pfV8e&ICvRSTD!i;A`1PI}%oVlVoZsb~
zWWH>)&b!$m`+!@d>Yv=*drj|`+)R|Jcsxs^xVC<3)w$j`7PF@5{JihVHi7%ClK$zR
zHu~NE{(Ui%CqLpfusP>(fA(8Gvtw&CeQTu-d^@`O>-{U%RI>zAZi4@O7GQ+@52#
z&ur7L-@aST<CD3PUopkEG5p$<*fs0dzi;jRFPZc9<WAc#qp$N48SHi~XL0vyUVO+#
z!>%E+{JOo(!$gzAMRm92^%Rol@pzUvx99CUm=>|*?!kAD%J%K>6<^EE_x|LBsp7&5
zlNaqSkI8?#v&O!!#++~CzR&*k*}j1fU&KzT%lB(rKH0eJPbA-G^RB12Z`+DH1Ya_5
zEU11Rw}J6q<!*uJ$2Pz9uDkZ`+PN3ZysrBF2}>)^>Tv%sFW&U-$?D~sH<wsF_;UBz
zyO$s9woaXK^yKQ*XP+%U>c4$9|91a8JNJC`{QXfKGxtW$=u(+hw7GJB)r~nd+kect
z<q&1&H8D@ASHXM9VQ!g2*%~)4DEj?-Umnq)zi+mt6H~92lA`a2eU_1l3;3EnVp29r
ze|hzDLHKV&{deol<lh~rTT$#V`-Yv(&b!H0_B93djt7_@+g_Qu&)(9e&~CEQ?|&?>
z3?*dpg5#d2rcROzIK>|*SMl!%n*c+1K<ccj6=JQMpITS%-+R3M$o3Zvm)D(&_<eoj
zrEH(n-~WEPUe4VA|I4wtcWevS&3JCUKcN2JoRY(AkJ#4VE&QBcCno*>+2Vcss+p8(
zKHoiA{lPBg*Szif<7>XJjD8ckVaXEb`S$fkZnm$!TBd3>;nknR7dPzNzdNqZ#;$7f
zuYb3b%fIM5e0UqbE&D@r>w3S0Fq!{vGu!tUo4@>0_4Rago8B^axuTgzzAj<wvURrj
zeCo`b9zJ{3srU4(Rs{O{Pd{`&fB!_0BmXTvEm6^YJi};N-Z$pNA1({twoczYXX*9j
z=gU(1qr=~PNp;WDXZvoen)1Hk@5=MHML&FP43ci+O)Dy1;3Thg?R71)^1;@yl4@R8
z9(74}=e4=}8g?%`vXuMLliw2^=GaBrhp>iU=l6cty5*r+?2mc=@1_3!eEIg#xtp>|
z#h1A5fBaNa^zF;4h(9xJ?e=n6McD2=Ra)R^-NioLUvl5Vjj^^jTfa`;`s3qCxt}jj
z{`&Eu<j1eq%XhO{{ckudEypI?l>E@*`p35Ed-)m-xUFy51>X7iLeBl$g~P(8ta5*Q
z!uOQ^o?dfApeXpx0`-pYL)R*Pn|*XV$1Yy5k6HO@Y5KP+qvpHD(&d6u@z*MO7w_jO
zy>{S}xbn(N_b+niAKGZVZR(l=j`rD4W#9Jbi(f7(EGzzR=oI^TgYUFMyFPc{FTeQw
z@{Kl|G{tRSMY=BM80xqkcij8pY4P2C&f8bdx1Axz*4cO8v6P>++HHTN_y_&-T>(cI
zecNaM^=HzLz3Vrf4411<{1W=6*7WM*2|qOtr%QZ%x#>pwzB9`TKLpQx$T(+Vq2%!*
zja!>^+2d0Z%S}G6INQCgKlnZO7M%;5@{7Ywb`^ej>1_7#T8-GUW8c5FXs14RmZ@d1
zshE>)SKDr8A$!E^MfD?dxpRN7i0u(twk>PZzL`}ew}h6&W>l|;3ch_zaK7m6N4pEE
z=9n{C``lNot*%*oTj%n2H{qWW1qayo=&WzExFwljGGDH)=owq1LFnRj{d*=k3M^5c
z-{<wO^<rY`s#zQ6vwX2w?-VsLXI1Xh9Z@k`b56b9x9XS`|KXME?=INtmR|YB@aD!>
z-|Gt>si(Kh{4z&y9nT!`U1u)^Zct7yKEP9TZqd1%H|OmQBi8)cyxHgetX_wwvd@_V
zrpV;ZXWXP}n73syN6lvC66ZVF+%n8;2O7ED9n2FPx-I?vR?qNjjLc|Lt8n2Lf2EN=
z{RQ9M&!#p?5_|iy9_b!?(sAhNfnzeyOkPQNAIx`-)4TZZjlja^uBs7tuDqYPlf_}P
zh5XNz8677$bE}*mE;@F%Z~ixT8P<J$>r_5&i8+~}{qyR3cb`O+t*kPQOdmC0F-s^P
z6gnpKpQE)%XV<2uXJq*+1lPZJsk3(48d<Q@WywX4sq^FJFW57OS#Rr|bK(r#=`Ncd
zmv8vFbhGBfoDKd$Y#iGS53!nd)%<wtvT>*2iivCbdNL0CY}wPcw39{n!ZP-s+f?E|
z>0D6%aAjf>^GW?zie}nt7SF6HZ;>gP(w+H0PjKJeiR+Z7XEt+~s2CkR(z5taouAd*
zREy15*<N(sOK5N@s<jF-WL)K+Z(?xS&~WXnik@SYR$PD96+6Ga;XLDsU6IRzM|YLj
zb$6ZLy>i`!B`5rwe|%vK<rdJ_m_51lWq^hFkMB);dY3)d{P&Ax?%4^#BDza7mu>dB
zuafV(f_LkR-Dgd=o;<hnTIoBNiH+M`p4633`Do^$kk87zCQG#8W`e-phd*ZAeDrzN
zdYNl$(w&Q#O!`txo^srg3_iY4=JM%hi&uy}GXKWwBX7EB0k@md9z{jxrVlTz1wE~P
z>&&!ZzT=~2JkchdBZ*n1NSFP^2IEialg{-V=oIF-dy-p7`@kpR@C|?B|6UhmxUtyW
z{B`*<#(=F0w!Wx!7G*eXJ2BTZGDD3+oMVdMFYg1DwhyakC8RR!-tftFF0W|-gY%J7
z{thLZH2wEHj<>%OAv{4?B{|lla7j$p<$%W*Gv6F``Tl9jL%s*6=6UOBK6}52uk)es
zF`*MVDrb}!82>qbT|Tc;YWgLM=&QxNs{{iMIatJ%TxkwiwUFt;s)gF8%sx+0eIa>&
zM&{h7zH*JTQ|;zf#s3%6eHG)dq$rG`>3M)bZJ2OVGP}{z7jsUiT6p{De~Enbl-)sz
ztHsJsc*QF1<@W;fxNk0~IwEz3Bjoi*4XYWO8s1$9yIc9FD}SSpsp%G>Pcqsrd)&h<
z4lyu<%KWTqsyJ|%cZGGq)-4kjUt98w;Z)v=Y98U&altP<TOSn(drX+hYRxA1Am(@l
z<N3-pCw-HeD$R->C|4h{{m^FcNjqTc>c11h3o~Zf*ngcE!&T82S@5uUUG0)RJZfS>
z&hz@2Qhn^plnwfw<<<R)SG4A^_`0uoGHI3eDreT|H{4uZCfl&^Gkc1Ey^+~q`MkMp
z>J>c?zMg&OSNw4lYkHnqllsDQgW=}o9;}9sA6Ye7<{P}2aXfgw=>9@C387^dQusDM
z^kOPmxXy#O@Qs$&=SBR<*Q+O#wHvwwMaCCyYjL<A{3m6fam=AJv4OMsdJK~{$tYj+
zjgr~Xdv>dkgGI29$zz{Fmv8f=H#+n-)OkI5@TF5>*}u}vWsJtX`&%8t6ej4tRA#ST
zlaMxb=0x`68kZQ19$N<_E9O1kpr3V)b+hzIbBlMk!o0Iul@l0c6C|de5Rdp;Sgspl
zyF6~WvYyGw<INo>7@mcP)`nZmO_SkN%aA!RUu^5zl-|zki#E;DaJhWod4yOG^P**s
zId)I->G%@FwAI@7pR~n?Rvqi)1B?%LHZ0{Tjo^{+xbkps0%z~}YOO1iG8oMwTP!0h
zqN)YH#BDouV^X!l?Cgbq81i=T=wx2l^il9vqWkG%Rx6KxIqTOxYsPi+IclAqQ+RH1
z)$CQ)aw-ekCFAw6U_w)E`X9Euv?r_gwFou!9ZhDpd0g&(Vb+372R<h6)1JMa1q&9I
z^kn|L*SFBv<w8TBV~OD0?yn1r6P!&KDZi+(kd6vk)OVPnXud%t=dFz&AN5~I$jB%-
zSpSn(duooLxLT~={AClJCWR<e8Z@ob^Xh1Rv_0YX(j$&SE2nTw{}I)2n)|upTeVB7
z1#*+pl`c+t#>A?lvOv(N!q0n($=CT_tC!f_ycQSavuWd{C7A_NRI*;}NL>Cw^2w^k
z^`3KVcFb#k@_C8&rw^I0Ca-w)*@!P!p<J&qs+q%;X^p6hVOGhNH06qvmY19+nYIxk
z5mT>(`L(zlzR9BFcX3kjgyt!-83xLan{PY{3M~5`l&kQ}J?`9z4YoVOFE(7gzHIJE
zo=25N*G`yM+TF7JdgDa#qD_-8dK8!*(_67~VnOA+&h<hE_Ac-^JA3}J(=#2-<t=Y2
zSg^FSNhT&e;c>mEvhu6sB<m$Rq&#Y(X661}lj?WPcXIPD^Y<Pu&*qd0&1+=x`W5FI
zm~~1v#c+w!>*wqC|FTW<`>Ar-@$!+GD!j4BmLAMImE(1x*T{G`qx|HqJs!UE$|Or)
z2c@l={=U&&<l04_>$j#o+L`-2jsHx}oj^%usi1YN`pHiBBxh}&RKL+|?W5LowfVNj
zm7mVM`4DLoy=$V6EoVyS+FLht9a;1YrYe@*ov{7gmQN9qYs4q?%N+2Yd8%kuVQ=D|
z9kctIuiT6}{$Rxs?qK!AlTA8~k*>}sxpJ81w6$@Z?VOc+@FUaa)}{>OS<^JlLp*hv
zS?>8y_P#Xb)!U4GCDkiIaTXFEHn{ByebKofqWqLiL-d|9nH8IZo|ikddzyPM>MUdw
z(vubbmiFR^a;@wq5uWN^i@B~@$MkH?E^RVTKBl7mRA+0R5l@-l)4t@nCa*kKakiwM
z6c7Ac5S-r?aIe*nFLwI(<x{7~mrPZ&y~>uwvzEWir_K1(B!lY_7f)<6E4@*oouw#|
z<F4rP_@u(5rJmC_NxxA&xt;0L(Yg0j)qC{Woityc<&kCQnRkrEy7Lmh*Ty{;XXFbk
z$t+_GeBp3L=CA!?@xwVQ`x0zt&pV!SC#lK#5|`!NJ&WwP&s~^rcF{APVXg4@TMqYm
zaxHdQZ!lo@<J<h~3@2l&S@p7OZUtc*Gd@NM^H09X?`ip5dFC1ppZ)XaDq2qv;98r)
z$gxj>UA0HZeW@4ExqxjhA&(b^ShN0AI^kp-micd=P&T_jg?p~&3P#>39X@wGtM<)Q
zNPeN9JA02pep8~~b^XMIX>t>T?^#7&4xO~o&ho>jxyJe5jz5j)EfniLv~-2?qaY=D
z_YfteUfGK?zHC0OqN`ylKH;>Y9;41wMn0E`?u}<8mpr+q{PxRc6$Yno4PJ*-9t7y;
z{0j9c(hq!To)p9@z{imId_jEh#%7;mO&kYWQcg=wEwP`$Z}TDc+uqMj%&U3SVw9G<
zo;cu<rFnC4fUi&g8=mZYlVh(LIa{cADVpRjcoW3A@}wJQJ^Q*&=PJR@iYfb}e&u~K
z+MUwkGg0|Qq@C<Was8f4FAC3GXI}p}r7p)g{ZrVXh7ZbY1p+gSf99<yTW0ybNAl&a
z>6t7)V}9#APcFH5tx;;VfJ)JXCn_&mZF=38&5)=nGl_Lrc5LR7@9O7VSlxJbGnQne
z2%Nvw;TAYe_q;);qgz{K{LINMoH9=`UU@5PcW)EP^ofdjd-k@o>+H?md5h*PVwTVn
zeDm#6%ZgX3=^uV*Y*s0Fxgx=1w$OBSX@=c$tslNryy$34VXj=x=-j(FY^IDtMb4$7
z(@UCk@6_B=@@=xPnq?Xi`pJ&rKth4;mj`z?T$+3@CD1KHfBx}f8B8vJ3s|iK{wh>?
z+HI*nAawaV%WU(-Li`H7TQWA>liaXQ?cJpS4JY6C##a~^{PlS6tLq5lJ{0YA{TL>^
z;6v%bpMu6K4TK|06RfUHlF++xr9?Aja^#`O*QUD!X1{&1>0!Jsx1@)}&OJG%Lgp7D
zpE$f+y6BwPkt%~?o(YP^UoLU4e|f{W!oumCaHnl;^MVHo$7dUyI?lDhtb$3PbkY84
zzw|cpu5S4LQ_8v3SLVeAhG&UZ5>s__$_~|s{7HH2mn!ZdB4T)@qvhtrd5XW}OP+OT
zKM8UvIVN`0r`5ah6W^=?2GyT!YEFw+Fs~?GaAcJymuvDlt@LTU7pJy}PM&!`CDzk!
zqUuFAPr)m_*BqC$23|J4HI;d4sd}qxy_oVDjurFV7_SCQvNkpAp8p^&z2!u{R)7dc
z<k9@&w@da;)s5BU+WtkQzHiQ)F1<~eQcqeREZ$<4x+8<rlHYM**&~-)xk*3zm)o7M
z@19!0s{QeyVq~YupY<PDwGB7FSe+g*U2e{_7MItFK4om@-}I%#OfNNT=6UPi-L-H3
z6W@tng!#WbyQF{8;q{RnHp`<Yh-vPbY<BAZD!DSh_}M-@SCZ5_x46Z5&Q!nT;@MJo
z<<YfBsU?kVr`SpiS58r=|F!$(3_EW=_QfxEcP*2*WfS)Oy=byOqY$%=)`|bxA8$N2
zTrS8YR`P0=1^1DQPxe<Xk=)I|cSY7?_T|aDyn>{c+6Qj&`H~+XBA9XRLZi@je>aUC
z;o1v>v{*RKEO0vbL1DVYFFlK;k2H*2Bm|dUIPxo;`RE&u8NE(wksKilf9gp}$jnu9
z|1puj=#mZp<eZd(>f@Xf9G*7w?UsDpHPd)T>m0U(fEeb@Ij7GZk<FYGqHu10<}(rJ
z8PR$7l7CL{YTa_Qtns|<Pod7ay1OoTajoh#II`63!Q%k;BA%zK?-w^#hVRPB+qih!
z(rXr{Zf6^%WvN~KbtQ0f(UTu3t0vFME-?!-eYC*cF|5$OV|Jg(5_QY{>y}t4ytegd
zJhkF*T4nP?AE~~bkq0+Bte-4mU^IQ+5uOOv38xy)o!HCv({l$~%UtF|Ue=1`!5)oL
zJiionPg)=NYHLj2%$qN#l*CNebEtn1e8na4#>q7)`<>4=Uf%Dt@u1ohn?2`6`-1Hp
zdcR~kO8<Pu>8aoUXUV-fPV1nKJC669boaB&|E>GM_yglcwcf|tlLAfFUM|#`<Ebw-
zE6^dtC3LO0sHefioQ{`b>^xiyfqTuAisG~#OH}WyuqsZxm9bD_@p?ONw`@nf1MQqU
zCU~@Q`I$C2@b_FW;hHtC=hckHSE+k`r@X(B!pHG^^?m-R#TQp>&@R^r+$6POiL&{I
zaF0W6pB4NjTxWc6<odi<O(nV+F@FCfUU}JWoxLR8-#C`>#neZK7HRV&Z8_T3rKLNW
zJH~qod$EZ0;f1oQyqR1@MVI}i&$^*@zcfv0dbT>BVwkq}oS3=3YL9O=?(&a+S(RJk
z;xKX9)H~lz4{v?pann?|Hl^#$D<AI!37cgn=7qR@{5@%>&|)X+BN__&j-FqdTf>f+
zG1}~`QPWt!!aZSnr)OK^lk(;W9>(jH%a(uf@j19f_O9xai!pwWPbQzQ2sM@1y<}^f
zrQ-zY&d!&fTaPyx*Vw)I+jqtx#dIQrMzO)21q#;c7cW1X^h`xw=J%vGU%0d%$CxFh
zE!4WJHt+b8Jx2MhG7eWFiXTm7u=UJ5)_vmm+a3KOuTJ-+<vIQ~+5D$9>Cl`sX4&`I
zFXJZH%>KA^+V0R2pD<=^&q9YY%ck5|aQBwi1%p@jH5I};Lv$7%y0lC!Qqpdvt8Jlw
zet+L*hIo#>6E@29yzE&xzl5FbHOD^#lZ~$@Pnx{s^%BcdW{qbrS_<zEs^gn+sy_B(
zq_M=5pmS0$Y_n@t&T_t2C|q7R>)77&dX|$?c78b-qx|mtyy8c@9&26HFbr<{(`;9}
z%<<|>*9W)Tc9^HCaRfh4nU;ENPvf*dYcmv7zr8V;>7cvQKK!210~4=Kvu)is^OmIf
zT$9Qyu{OW2(sS|&*P=>RRppmU7Rtu;s6|9{D$itpWM?h3!IIV1!^|MjgF$&_(-F_*
z_k8U9K9x<n#b9gshvmH8*|?H~s=A=hQ~xDC(8*%f+|X%R-s2wd{bUlWtp4Ja+`R#6
zX_*3Mm3Owz3bsG*`F@5(%&o&e#W%DiKAF5xA|WJeo@-}iQH?^x%*kA?CMmU-`=(T{
z()oP0_OZ{xxHk5u*FLE2&}q}quQvGJ^v7{Y{V!8vqd6CQSe8bYlx?2W`uJtz^6q7}
zywBd6T)ym+wAo3c|H$T>z4Gabxq8vRO@ya6B|PIOxn5aZ(k#EgmsNMlt+e;IPEFC<
zojWI*E8>cJ@yn{m&x*{ht(Cb~V;fc^H*vY~3gx32Cl;PbzRO!#78Sv;al6mLo}cxn
zzR!MUqxkwp-<s<5l?{qZS7gLE-kf+$y~%R^t*-pzhn}%N?>aHdT6|7QT|}pQ?J0vb
z-&yvw-<+dkc-;Ai|K=B#+{-IEl)jh>teN$AS@78%D=qT)<HCZk9EnQOFbEgW2w-i?
zS$=4~*u($HTih1y&-X6)D735ap{nWs%L<cz=eJbxDcio=FZ{}~=gW@&ek-0ETzdS^
zdZAo!;#2nJ%ae@$hnaody!uYl+)tr?V!@nZPagVA4L?wFWY#vl{hEort!KD$T$lMq
zlqD|TC3ZgadgOM`Q-@O?tf@M>d}`W;;FRa@|5~tD%1rvz)%k=`ipS-kjrk?*M1TI-
zdz=Lhhp_it(fQplO?v0&bBC0d9h%mEcAtDfxq4}miSSLQ1CH0)O?*C!^n4L$(0y;W
zk?U09#>ZYW71wEN%*brml6rOdo27An_Z$Ci`Q7ubV8V0Tv-_ltJr|}Ny|?Ke-+!O=
zX$HNQ*FTjrRzD}hILnghxc7hF898dPlU3Xg9!c)-=z40`*zoy4yziY!Q=<cux2wb-
zWAZtiqSv{TNvp7`YC4<uKSfj4&b>t%>{~zn-Z|xyi)KBeN^Dc)bGO)K^^tWMixy|>
zeEpjxV#R4y)v((k&6ex_%(#5+&8}OCUs8YaGoLlO_qqOv^MX014%x1YUcUWfx{hP%
z0@?bvc`IxzQj9G(c(6uDeobIYne$nJ`D#$ztO+MnW;(cw8ZR$2d$s1f)o0twdNXpC
z1ZM>#`%49%aNnjocbU!Nr|FJLyCkMwIJm&)vis4=YMEOiLoe@^-1=?D%FX-yCHG%2
za_fEjv)oVF-s_3sVJVU5>d$PmI!}n~S!F(*S6xD>WDaB5w~DC3z>GTv&!;(Fzqwa<
zR#b(GaBos=NL80h*01d1-)kISt153_IEO3Y{lohfMY6JYML*ekS}PoWddO)?|EC=n
zTyB-dvcJAobKuPJmosIu<r1^ryXq@0HNR#3LS1oTw`odD*@Esxl|9E>Z30fObY|yb
z;@sBrPc!Chfz{T?OF^F+E~o@Ictz#s=<HGb?`L*WS!eHxnJavn;?wJ9Ncc^UYT8|L
zOQ`W>(uNdXJ<iHa{*3uc`)&uC<TgmU_6hnI#T`Acmnr_mx`}4Dw05-r^!&Y?f!`}4
z=x1}ylOtDyy!w*MCg0&oO?#QxTynhYm6G9wNfS@i1x#2GGD~Q=i{8AMYuA35aC-5<
zMDdb|rZ$pMzRyIBt}<S+Z#Z+?!PFt-dhnka`;VVoGoPoMqpxrZPglU?May^3|E0jT
z_Iw1p_M{D8XBRKaylipk+?=+Or{|WPTgPZRW0z7zRzy&v{^A+QHjHndu1q&7b-OJX
zFYIO@c(B9r<nIp6(%zE46AG4Du9Xlq2-`G2M3?)3?R=37x=zoTOAY^e>%aW^FYxl|
z%b%W}x~ms7VTPoG>XCmBkIYzl@bt>Y{M9KR4aFI_UAO6f&h%QmCd2Mv#G)jZ{7D<4
z@^0L*+3fK9*tMXWO2&T2t=<*x^0zqau;sDh+x*{roa_JEDaD@SlxaKKD!TB@k2mQh
zWz#NS6w5lacpc}lyB%wNH?-&)G<G^~I<f!C<(C(P8fNV~|4ltF`flIStG=47`6f)E
zTekEcN^|YYo?VpYsGz<+LYQYVt9J2}R}pHWJs%j2#Is#$)=knboHN~i{f<B9rldMI
zdM%Zj@aNu=ZL0TE=5<+q?Cv_7=$>$JThZf{kF|4be|rf!y-EoCF>&7J-3OB9U9Gd(
z>aOuqSB9-J#JY-M?W=BoCf00@ClWL2Pb^Qqvb;!0OH9I$y&*7X6JuYXm*fT>BQyC+
zAG$7|IFS@?rs-b2O8e?1j{j3boNp&ASf2escI)khFJJ!9buRd_|I3rsRM8Td7xk~3
zr6RZ7yI$7L{Bm=`qM$mb56q{hoUu@{J~E}q`q7kUE~kFZy3scM^+I#EmBy`tCuFB6
zpR7C1$o#VMpuh9lC4HHbW{aON6*w5o!jk^XXo98xACEYH^Wfq@sU=(+?KaAUri7ka
z<=1rO#|s_z&gW}V7d=Q$ZOn@Mz;RS`ujtetk_l(E_@Byss9XPjMcMA-H$x|1R`fYv
zeyzgzj0DTJER_T&&(8-o7^PUR3%eW;_8@D?Htmo4%bp2UcYir0m36r1!t6TNAK^<|
zHs#!&dxQUptE9)}FPT3R_FB#ec3M59v~ok%)UUmz``*tHHFz;=;;*iUokz?$Z}jwu
z>s_7jiT42CT0W)VZK+|B!GRjfRd*ORbQY8?_~rLm-tTpcR?37)9!^SpX<NR|WR!mz
z`?W~+;!pdit<ECs%E705<}8VuyoYP$wTY{?a_}GO_LZFJcXRjTrT5R4NVk~tCBO84
z?WAIMA)(_}8eh%KmW(CZr=Rd1{_k}x=v~nIH$OcWa;E>3I`BDzFY|nZnzG>JnWal6
z1|1Z<$aPYCz32{Yk&X?<9VT-QF&*iNOq(LS;f%b`^<NuyAN!LQ_j#-T^;MnE&%{35
z`IyzKxp0k<Hs8?&OBsu5f1N3qRkXcD%jti_+idMqD=YRcH?Nk7YA<X2%(m-A<HS~<
zy_c41M-}u|@@W0!ulDxHdwDXrPeC{4<=cZdS7yEnGs)m%-BkO6o1va@#l>nbv*>Bd
zOXs}pF>?K<uGjTi`?RgW)2f7-{z3E3oIhj3o7AHjHBB+EYuX1-Gqv+`CP`^|OQ-ud
z>{KwltaV1(yDvlXo{z*P<%gF|BK`c>I|IM)R_wpIa`&x}tM?ietfPJ(UeaD;9QjCi
zFV`xmt*@sBs>f#gtrRn0IQu8@C)?4a69-;KX}8N>7Bp?%nKbRuxu(nuwl530`@T&0
zYNNRB!ffZOE#G)F=S~fC6AIhn@^96dizk^JzbMS!Qr!4R??lR__@c5)je4`~tiKd&
z>YVO&W=$?@xY6mZ60Kh+(ylLGnybB&xqo6^b;+gv>hv``lfKW3n8v61L~e~h=9!!m
zU%Ev<Ei?;Trg8mz3LBqyn%Yu}GwBE4M1EkHZo0AcM8|U9l_?C|uZ54VS)lBbIcepm
zlbb%PEUEHV-}1C<>Zv)RfjLXn#X|0icurX#cegKWt?9-;&2zR-opMIE_kzs!HHY8$
zIvReTt+?h*b4F|N7Sjbgu1|aTUb1mn<O!CxDV!eSdxN_c1TnqTKD*lH*g{=S<)^k=
zyt+=SuMV4ffBR{^L+`^*9gV0AxO3#yS)Dv1*Y0o8ObZk)MWij<cabNjgK6n@9^a)8
z59%n{XFp$)bo$nkyxvqjmBywN7Lm%=B3_}XPu;qXxu2dJlqozpD=5lfa&}hoslBN-
zeGaXK-(Gwz&TCg)b)>NDsqfY~CeKdKeq|}OWNNri^NOUKhYuQUpK>zwm8Iw^ovSuK
z@2r%IX@7Jh>D@^y9V1sKW8-OD^B<jExGjHKNm%Wwr3|fKinSITo!;tTdUT;!|3+@@
z)8RqCQnqnDUVrmS>Sp#}#~&s)r%0d6>^bsOWWvVC<uMs=l_wl>zijt*`mL7Dk+$>a
zN3sO5E&qAK>77at_ul@to+kO=x;Z}A>*lXM_vP%ui*KCvpAV6Jp2Boi*>~~wD@M_q
zL&}m?o^GyTiL#I0dei*&Z1b>Yy-1$Sc?~9#d(QY?bCLY^J7mt5s>JP87oRQF@S78U
z`Ma3VQ>$H-ir-&+m3eyR!eYO*UIyzP>KENIthoL=aG|-k&oP#%|B}zC@|E>*e2YAF
zS2~DCA;X~b)ZUjN8>YXi%(5&H{qd<+(cjB|>ilab=Cnnef24BJ%#DwA1AnjZPT$>H
z^H;b$4q5y1X`n>)qREQ=IY+9>d`{bRPK$l`WTV_O|I=lslMM8t&&nk~?T@nDyGX_7
z;sm4kpqoi7_Y4EO1UB!9UFr~BW2k+EX;aAa1$!N`rv3}LJm+0}m>RPo>+uh5sj-^D
zPTXsY9-pbvZwnVonY&hU>AD%eU7dnw-U~j@rK-C|=E?p;VQU+ls|wD)k#@ZG-Ma79
zln*wVUoB?|=t-@fmi|o3xaf@8tw^Wc2h#2tTsNB77hJW$tIFMbotEarH>(Qv)*8Bq
z+DGzS<>J@1d1|5Qc`SbB6!Y3+R}43+Evd*%7fai8yhpD3yUocU!$np{TW7={lCk~C
zp?0iG(O<))vzh1lv5RF43ks&TY`tsyY_9FIT(24}kEcbxV&BgCluu8dvf*X$q;KiV
zlhXceetA22R;^c<Z(-pg?j5fcW=-5Yxhlze<!zP8yS8jv^xom{H8Jz3Dl3uo3Egjg
z1&a9@CdBqi&f4Ssu+Zw;@4u(QS30G|{nuf>e#Its;!_=4ZIQcvZwfbM^ep%!xkdTw
znTX{Rqk4XBSD3fASU<aWxo=TZXS=M}Yy(EEk7?c0-`e*+JM(he>4i_&9G6P#9`v5q
zc~Yy`-Bm-ndy(&M7K5U!W7mC@BxTMzdb$QlUMyBhoz{{k^IT{7%yNJ0dvj|xp89s~
z^pV}sySjMxv~g)}O<S&WG=0~kBIe2KQY0T%=boIo%jK-QqvrfAinnvr&g>HE-}<p{
zQjO1{%i9&^Dt+oY9ptsH$Ykl<$i^F+4X;lAqM}tXNj`=3uHw1p0iVC0Ub*vnao~>m
zpV#^>-XP;Nt-2+0v4nG1Ytq#@A>A2Ijn!PwW@hr8eiA&dw98XkkVmZL%QS1V$XyM$
zwMBeXy*}~3YWeZuN6d7CrHZNcB`I9VMPf6p*Yc%mt@`!q`!s*$mua4BW<BKyy|p3q
zQt*nLeFAx(8w7ib&dj*rp|BwET0~HXhwA;Q`PwD3IF58XsEImUE-6Y5$!z4fP;{kN
zWXoLEjgg^Ow^~*v#4X!%#4Kv&u@tGrYr;>ttzMEArhGNsxbt`(pWb9yDa#pabH!K>
z&iiyA;&)!*E1lO|Y`li%YCpcPbfw<-9(L}Yn(LM5F1fq29S>TkMHZx;a{HpWI-18{
za>*w%`4yU{R5NBDsk32kYF)5)?HP*#B`ZeJJh`)rJ|sAwx^{L--%2C3%|cr`!Y-)H
zb@{hgXX?>{!^@O%52v*5xfgIIq>p3H#tVlf(nEXre%ZY%*&)(UG+A_)!TYVZE^-Dt
zE<Jj2;hm@|3rYQ{3o0vaO>X>k=0J*A`2>|2Cf=tlCw=cK-d<vtmhyGm)JFfUKF^YZ
zr4;tIXl0$8ETtK*y?9oz`Sdpz)$`AaMzr3^{cOXfs(W0hIX_jqCzGu*)!5^jUs2K0
zSNdADs}?0J&|5NNm+zrDY<_z86x2@dnQ?0R)s&rmOa>=eW!Ck7v7Owkl{s-~Sf#Hi
zL#~9t>YbYG#`zLf55q)#%9b9Ve>)`QWU)h{W!M`9<{3Ws=O?F|RL;zj4zjr(ow7G$
zvD@J#KK7d!70$V^IM}FcXsO%2EO2Yvrsa_uDW2a2KK_llk+ApHtc$|#MH@tul1u~V
zOV0T$syD&#Z(sG%8NW5x_8rSU<vTyC<(GxH*0tR{4#w}M_+GFm{#wClDEjuoMi045
zOQv-1^OLf2&$E15e6+!(+-q~me^!-u<sLEGr(RCwOMSVvNQ8;)+@x{|;YSyHR#gWq
z(KyK0s&1dY$?ka6cgroRPA|ODqI)kya^-pK&p0+~{S$`GQFF6$R(d##_I*+C_#1k0
zky*jX<Qu^ZmO_?UiPihAoaCFn<F&E&qrx?RntHFyPIfiz)?r(5bo)UiZr5eC(+&NX
zB?U&u?Ytkb?epSI;h$OmKkw_bf0TXjlKkphl4lED=Z4-hSSl64Ci%=XEb^2hcX4ZD
z>SW8Qw)JK+eRihIl~3ZmyVY7(=Y7GfH2;KCMq880s{W_^&J15*@OJeo)gNhpb-zVg
zaV^^v_;J>nUh}i(3{6t+aoyzE<i6rbqTJGb>PFexj~ee9Ez#O><(}2WZ5o~j7duH@
zDtxp>M7zr1WmTNx{K(gfH&5J?G;e|T%llt0u53E@BqvV%fbA~xoXgYVR||S^ac;g|
z{`LRwMQoko(Yu|VnsuG`4J*<5Ic2F8TjY*uYELryH}cIY4!gGWo2ZJa*ZtSI>p4%a
z@|YbO5}YP2oi%;Y!MG<$x6~$ky8R9^R}0vyQ<MDe%IP<nnGa6M7wP<8dh*%p%Et!Y
z^OF{|GQLc>cR%RpKCX2E<%;tngSd}+O+0>%bHUR+d(XUyWe(n?!zlIUs?2Qt(9F~C
zjB|e<ENI^LM`DFkir3jS1y<7*-~72IV(VM>F9O?heI&zuwm%S@zvywzJ)gh>^UQ;S
z-L5*aEq=RB!)_^$<uiSa)2jmRg)ZH*+U%vqy~ec;j6JdQi@UsDWcsk*VQpV5TGhE+
zOLeZMI@jgN_D#nxEIhrX<JRQ2S5HMZoH-!>Sa{WyCBn_Fk4xsV<wmD1J7`zf$X8Vr
zH+S3fH_wk%*hEz<U3_d+?u0EtrjH*SD*JHY@(fFF*Cq*Bb?@uzpG&NY3=Y0^;h@Pn
z%W{Utb2@IFdFjz;$3MGYQa&u%YUQ#J_nwv4iv9~R+)5AaXJ8P1{eEi4f?d6uT7{Ys
zODmU6Sgocl^LU%9PMnwFHM1paQ=UcCuDHDC)8$#8wWMBc^SZdLX7P-yXKSizr>xF4
zlAU_(#2Y52Nj}f+$*D=2Pr08Gb8KJMCXG|?Vs2|an=&mpez`AOW$t?e)BUn1t5SS=
z-!D}7=oN0SbNFK9!lq+Rx9nD5*;+m?#$Rmf$DZnoY4cP5&2m=Dt#Lhe{;Y`hNgk=m
zw{98aW_ffc+?zF}S|w`h#LIR|12)f)Oet+W<&(;m9M2aLFFCn=McB(%S0cQWl9vX)
zIULhjtJWQ|b?szL8JRU#ze`I6s-DcOEvuDWb=gW{vTy0r#OIc!!M4BUpFUeQef_MN
z+Fxbf#;U1n&Rn-rJ~Q}iNPo&c{poY!TRr$sdsca#<5G)XvBq0$7Hh_@zu#7TbAQx2
zOYmTInOII{bVXDr!}NqXXQn)0$eooU;}}`((|B;@&d=_%guk%37BA3DTUX$Fi*w!i
z-8C%#Umo;(R?r)+_@?plxk=G?>Z)g*VR*iEFPrFzEeD+r6<nS4coWw@ohiC(XKW<H
zY#2^%t#3Co>zcMKsZy}(_jk?A))TiigBJxAg*>S}EkC7u(e+Qo+Z(;C!-6yd{s=~^
zOD>DqzfiI^-*h=I_tEEp-&SsN@eBN{pY(PSj~(a!8m(0pUs{FM9ceul*>?V1*Uetx
zsRGMn6CYVr&*uByYN)%^e^$@au)sMHSM!Q=rUsi`4=He$P*@zfdD`>EQC(XuuU_?W
za+^%>^IMv$CC)w!nW5%;@^QLs+BN^2%{<!mGfvk`suGG@p>ANC*uw1Y7pwI$cjd9H
z`8~H{1VSX2)W7aiUH8|DuXNkV_*-RsGh$g9ES^8>mu#K6$L3kcq>Z`1?HrV!ooh?u
zx-rjq^5p{Gu!>htW2!%2Sy`4o$?leFzNb#src0K}-IBXzL`)B#F=Kl#e`5TUEmxv`
zs!n-g^R7uL`ID)NeY2Uw^;=&;CmvGtyH<aH+vbI7r)F=O@q&FtdPMt~oT)o+Y2A#k
zbJI>Y<F9qOV<DKlMOI$LplWs7oHKWf++DULG|#-$(`meWUiE&qx9roF+x$<FH9ov^
zTH47N{#JXo&F|CJYbB=}TdlCNUhnfoXvxnh{48@<Fnx<LPTib;?^C#ssO;HgvvVWX
zhm@w-->6F6>v7F)>hq-x`&iDOW4w6t>qVYBcBxYf+*xN;H!ay-!m?P1abx%=)y<cV
zg($ghJnvPUxpA(@lRh5y<i(fGLl(bXyZqDDi{FyBPcgZCZOyvo6|5mzX|jCF<j*R!
z@h~r~Tbo-d_3PXM-rmJemuqlL=)ZHGZ!fz<&cE$%Hh&Q2*;a0UIi`F4=c<Xt&im$n
zFqO^~Gu56V5fCx$$HR{cf+jld&g0ecy)C=@XNtq(b6g8fT<|J#TyG(MSM3_3>`BS*
zmeV>N(>IhJetpNra{7w&(vvmJOjD*RZaKXrosT<>YuXwS+jT~+{9Mge@275K6g~B_
zXw4L>iF*E}2UowS*!ODZ{*KtChpn9qLxl40J&9etayy^Ir0!1hMG?znLj#`AynX&r
z&%$*x*rUQ-!;M$hKZ@0fmwPj7)8W^vPR8DM+~4KeeL8pTl4(}cxcZOmvHNhpJn-wB
zokH!$x2;;Xs^hLiQgu|J|LwehFCtnox7^$REt}$PQ@Js}$Y(Os1%ZTzpY`2xKe6}9
z3N30o#W&j`LNsc<?LBE#39+unBE7l$Z=6^jKbvb!&Bqh1OReS<6>6JnExe`oxolf~
zLzv*_nh?vE>}L6^?!~NaX03dA@u>I8s@GFiG=HqPFjfA=xdSRyFD5PIn&WYeWo4W1
z+EqCneQu)scQx+1RlGd4^3%ptqX@5qaw!)YoqcZVCy1#VUyDAdTajfv*YTXM<L%}W
zsnF$zruv<7c9&ajURIQJBW~v2Z*$)0&YiPNyzydIv&^AZ>)RL3e5iiFSys12m*vVK
zg^CM~*RC~0dYvfQbpF*gt>jrs%;}$xHqR{0>94Qjx>dX2$o5k^YmOf+bLxpp%T_OX
z8zCR~^v~)~L1%VeDpd5h@L9>>TdU>fDD54YXpveF+L!3y=znvck5u;Zx>HN#jFfKq
zDjVj@NpDr^R=+f1VWI%DGNWEHLw(oLKkmzo?O$3w+HRI1y`y1cNNB8LOIC}A>*Q}a
z39pVHShn=rKLw`@E7l|C+ADXkNBPd(;ZZG?5H*2qNws3la{H$aNiLH^Ch*8^G&%7t
z<bB7PP|IbV{hIRAtWRB=>^kSbnR12$^JmXH8&}xxVX1xHK}{lnZ$E>>+RnpLSqU#!
z%(?PV;0@~{m!;hnrz)>(`L(ytWbgA}o#<*&37@M|w}n>;&k<FvnB{V4s@CxZjZ>%1
z_X}Nre#?IGZr4St-o5gW+xh$Oj#s-%eyljrVew>|`!D9ArhcD`-TMnZ9B?i;xMIm|
zjyCD;E~X7D-Rh1Xy16ZOW5_PaE0VV}*bl2ey14dIf%D<GDU-fk$x4kjirw}g=*X`v
z=VUkQt=u_z*Nld{?gH+q)^Y+ok?U%$MZCXE{P=6vCJWy0Ma=of<PYCC_o6BD=fO8i
z92M`mMXqiwaW2wc-7oV*u6fnvq{La5N-Q3F7l?3aF|R*x#AS=2cjs;~x1^dAMb*7c
zi$5$`y=A}n)wNx}GY!+5|AzTQ%4r*1$eGnY<@}M50GZF%gWh;>?q-(Mo2Rwb)zIUi
z;0?(@{@sgrSkL<QT~mAEyH45j?p|hx3NKpUw(>Q1`{W{Xv07E`Wb)^zx9j{q3kH{d
zIOA}`NcPT6&nr*W)F*{G`kr_sx%V`WeTB<EHc{CQ*{!pz(soEaId2;h{r6Do_7b}f
z7d(&O(UP3Cq;F^HvI+Cvp2?Qqsyo+?+5YakNm(1dN-FiLZ>pWQy?y?JL<8G~=C_%#
zJ1uQvPM!<?B;54I&}oI>wzczjI`34ORvnifwPupS(U^tyZv3ik+>VR$_N7?gVeERz
z7ykPJpYBhE555Zwuciw<`}I|UQQrKC*2(AE-(nwi-4S@nl^B18O|43Q>XoCqjtehd
z5}gvbS#|&8FvFg_g3s+m58|g@w{&G?WG(sLVmX6#%d*4y>Q6HlUE2|?Z2O;0;lqh3
zCwKABoRr#@7*w}i^!-NPw3nxXFK$jL+|YdDT+z$kJDabqyKu2}ooo0PkB@%SZGOnU
zYhASbnMdfwg%95e%@*DIN@|7Tt+|KZY5e4!r8txE*clcTD|PFgay#M`q=KxqOS_rp
zZ*_RvacSxvwo`nHxtV-*FSYY*^}jp}J2@>=_j}a3BTC+Pxxz{vncM1=J}k@fxg8pz
z=Q>Ac@tpUK9<p233z_<AhbpgFwEa}tq4j!;>y~@YcU)<;c&U&PgNOXax4da3a^35K
z*R}g@HdeQp8#L7<`R(-^=V#ssc{sb$-AIVx!bxjZldV%(RJrP(H>dw;OVE9}Jk8Z(
z<qLPqPr`QsdwldJx4D{q3AI#BSSk5(=F#ZI=JS;w8s1Fvydw}SrX+jzi^vJ~JDN<E
z6D2~At-sZ7^VTLTrN}SKdugBF3?+jlK|RmT2OaG(df7E?x9rL}69XsSiQL1U-{qCY
zzq$O{>B8xo{<*$r6@8+eb@la`rl7@dGScq}y|uU`)Uc}Ob(+P*E6?u~%L#4>T$(PC
z^=l%Nu*11am!BqWzdz&DnWftDnYpDUQ@^>l{mZ%_`Ni9M@v1zd+p_b2>g>@GU;6an
zg(KTbvX^OmTy^!I5ND9=e~sx$n{V4pj8k~;<Gwgoh1<*0PiKWd@{tMcVM$g7p{xz>
z8GiiQ@-QvY_(3&O+{?wQLf+&iXCInZ=X{ib<GF#rw_D+nhfnA*Udnv9H+R-juA^>m
z7JFXxS`{ghzH;Zwtr`1#@3)vANVj<H;dW;p%Y<{e+&tW=2|UyIPR&$tz4J|X=0f?C
z+h=Zg&?$6Abk)q3o`;ohe_z$UV`R|URr>tfZN{W`4O=93Ey#Co*_)etLWj+N%R~NM
z0zU+HpZaG~lBDjr@RY9HN~ZTgC*3l`7x+Z$SUlL~A94R&_4`bI%X|KPg}J9!Ze5Y%
zx^-$%>=xf!%X(j2&&qZY>)Il=QpI`m-)*k{CmV9yzMBy8X@P53vX@HgkEY+#zpnX^
z65;l+;O)*F(|xh4ZkQcCIqjO6>BVF7W@?7TFiO4U)7i%1!#K-!{nnp%Bl4GgV2h2d
zI(<ciGyG+cUPsv(_QMkvn(lJDeWv$P-|RWFi{ISPkFYf^E^)a!^M1vyXLS*i%cPg(
zXj?0!U*Ek&a>lmn{`IbwAC|N2UJ<o!Mj8KVuYA9TN#2Keuf7TAnxeAO=<uR#v4%S`
zV}JF8%{4uq|09|68#jA#-=!0|o=0ylw{=;Q@zOGcVR~U$a?uT0iO$p|XZv@aci0qY
z8<P51o-H>_t+gz`rpI}b?wr8-nITEh1($ax88EJW5#`?+dV2mxkNTA%S68wAytA(?
z;CH-nA7iwphIrp?hACSe&VTmvKKAqKnFfU~#-1z+O8rMzzIfhqnLeR==Fhf{>3c%b
zt5;h7e|tWSRlUgn?Ii2o0!{bOZ5tLaY-o^5%#OUZ{`eo}5+AoC6PzxE%B?!|@g~dP
zof4<Y0uw(JuiCBkcBaB6pWTlO7v~xJ3a#6DJz++MxyR99?x}YQ(;rA~UCA(MvYmUO
z*LB0EFS^!lF`fKe=&)hG=2O!pCLia^ba%}-H`903{AWtM4_XBn1Ls)=v3{*ykr1&^
z@Ule4^U{!(T>o?PZb^r1_G4ZAa<it6Mce0(mS=Z3b~+k=Y__s#;au}5-C?sAFZ1>1
znRjKGo~W+9{iOHS^Plh1f6aMx*XPsz)<?M)R6l=K{kO=>A$v>xmwDCa@5Cs|-(KN!
z@mNTR_|%XYb#bk`+P=j+JKt$Lxvq3lZSbmdvqdViwBBm-<=vfdv-r95{ebTqtc$jP
z5Q?qb-Mu$R>4l{Vf9iudSG%p2Cumz`FV5cjQen@tOZ=ZqxU61I`g^Wl_WJJCn>xM=
zZ4BHrYhUiJJp1@AFV?SWcSA0<#jx+p%-*lYZ0dSoMY_(-OI=%~6=(8(NR@xX`^+WD
z@<q!0(#f~;=H5Ct<#>#V9dAw;L$k!9-n%meR_m$<CpzrEf9RBo!o--$Tb>M7-o_JH
zo!jELij6K;X*}jh?z&UA+}(QG4TrC%<&5l(iT$m(owh0cCey;n-!8AUUdpC%`oQTw
zm){v?R%c9|H6cE_sn1FMr8uv~$*-Rmoch-FO?dJj_3V3f$K7kxm$I(N(R=&Q^Lf(K
zlAV`W(>j}-`2LHWTA39c{xmn}@MeSMOTC3NzAUxMZBYF8Y-*9+e}~4PcM5xU=Ca2x
zx_E5M-{%STI|R0FWIun*$1DGer<R1wnk~lOH#4ui)44dk=jyc1=v^gK>jL<t-W`}f
zh5OgSnK5n34^zZ0^ekBDlcl%0`Lf%_Pjj~}UDZF+-6C?+(#>}wZabg<_p;qt<@-uA
zbu+UvE#BFpiwregzIdKuzGLmTTS{l`bcYR^&1-bt2Upj9x_zqaWV!Zj|B2ETH~93n
zd@eeEKPM+A|GUZsXTH`7iH6c!mlfWAkPA8(p1OPftZCDP9()W-f7Yf{RH9;<mi^(x
z`#uYg&DjP%d_rkqrZ@e?F3wtd{g6y_iPY7ioSTB>88VCCdd%%htDl+ct9rb9lYzEn
z;ume7GhZie?wb1h&XPOn^gzwpGHj7#@cIK+0VFFXGwd0pd!l3hORL22h!-%U4g
zp5DP>c`SZ|%yX{b(+?8YbuHp|v^I`h)xj%qY|Y=GX9xAKZE6Yscg}D2)uMwQ>b+WD
zryN{l75(l;&5rgBKQn(gn|*$N!$DeF>50kK$@K#9PxR}~+yAKDyYool@%UeLyQ?bp
z96q@v%FZS)JYMhLb@SD~&whP;xT^T{{9ktaqwW7^e)xHC{q*wHZ*PCS|MA48f*<#-
z=C5BCFFt?w|EkK)wz`LN<5RlJXYW3`dRbh{ng|{7%l_{7*W^vRJ^x+*=?xX-TXx#+
zv#Qz=CA+?FpKaaK%FKU)KULdHW5oE@>h<YgdG+bV?kibaYa{0CuJ1oBq`tfR`s~N;
zi#LBg{PF9><H`I?X?%wsJ-#?gcHzM<`j5ZIFF*Fy{KdQ5$?-`AhU>-U#V_}}$IIWB
zSu3~g^kab!_qMP8y8ChUKJK#&`5inZX0rQN{oGW3`}osu%2AJ0>KX-|0-nCGdA{$9
zVsiWI#q0C>uXn$Eb)wGR*7xn#qlI$f?<?kS4&r~`pI<(C*MpgtOSa8Ar@O4UbjzOO
zbKhoF_9dTr@##g<?wtq4fA6r8`fdL|)v4LO_H$@^cRg!b-1>L@`gbq>n%Dbm`ucO6
zXU=Zi`}@(0oX=j(aT^pEF5k{Me|`Ju_N#^Sm|4Edzn2d)fAQ~Q9RIqV37kEJ>_@L3
zw|xHL?bToRs_v8)J^U8?KuxWY?fdK5yR-XdK0au9?RuWgnr*kA{`z+H=rgI}{kFe0
z?AvP-w=>=LRz&xngAr?AUq9aH{F5u->7g10m5VojzAF2CVEY<*j)w2Y^Y|ZL-K?kI
ze~<Hs;_=7-3;(RT@F+&^@82KuvcDYNxPI2LpI-0(^gs6AJw1F|OTC5Nc5d<RmrMoc
zH$C2bg-MEAPTQt1v2@DPjmIOTi)wa6<%X}6-}Zl^IOEdITbA6u`t<SFqV9`!(toZN
zbIAYw`hv}3w@}G_#$*o5g~DoO`=cIxu3Gx}^?o_|-KQ5n)iu!Q72r~3yOQ#m<MXC9
zd~O*lluzxBTC2bQ!fEEdjS26Rct5pyRPEdK?CINQMZ5Rx7BXm+TYq^<b{WT?13B5>
zB~$7fUmr47T5)f_z>B8E2bEZk|JWDyDD<Yp8#|dbY)hQ>p4dFe_g`;%;z9O1$Dey!
z2S1Q+cv1HD&yFqL=Wp4{{C)W6q4(m~GHlxzk1cDGl)4!!*TlHQ$w=XWu+!u)-lcON
zemQzkR_u*jjKubNix-{!#_c12VW(M^>Vms2i_YzR_+<6Yo34kHmbL1BI&`eOvZTD`
zcv`)!)xO)d9Fk#+JTKguC;yk_#*eJ;JW}$^pZ_Ji*lUy4w66Nvu9csful=uilihsL
zTA}Lg{I5Kz#^vpcPdc*g7PAgI;oWn>Bk^y+Qqz(wzw2RflggvBZTDv9^l)F;9WhTZ
z#X4eL%WeBj{qs+huYLKG@BhWJ+UkA3X8!ruA#lj$|M!i{GY+VDEx#I{_uTIMw(Luj
zuQ7CQVe(&l?%L|;po4$o`wx~IJXri++3)B--nIKJ${w}VeC<Ehr(gEw$Ez1Llb@Zt
z`lEtH?cD}on!Id1!%e|)`D)4FMT6^G9}oo6X?>B1{xlP_9}=IggSbAK-<|KUh{
z|GzI%#=pBKK6{op^VnXWweKvhzy13xETnSV&Yg<;?C#B5tJ>Wt7s0l`fj3g?(y9aH
zpRL5)x{p3=_?&Uz&nN!lb2`+n?3r=lqP%B;dwKnj#~*ucxp!WO;4>4JS`jzp+xvcR
z#?14|?~Zb%pGce;W_&+F@^Jmpf75S&{Um#&SMbl(i|zd3ZZesF_Z{=PJuB}0!my>R
zG4ENIYpQ7LJb0U>e%9lKb!O>*)q<1L^_~QY)b-j=RhY(bGr>XU;OQR?zf}bk`|qC(
zIn&Lyet&bGW2Ykj0eSW!<45Z@*Cgtv1s^O)V>+%B8ldCxo2TI9UiOZ!HYY_}+LxE}
zd$(2E>|;&uIh%C<LYP=t%k10x9!zz5BarmZXW!M&xf+3emS5WU{(SbJ@qE|pCGsym
z^-b^Gk-ll4f0CNWn-|6`o|o*R=FROq>$G^mKjzf@+P2@}*R{QF?3e5PKTkkuUz-~H
zf~Qw(>sdJsme|hwtA6N=WSE{N+qB!|*(Gdy1sQ&<?mSg(_sjm0$SIE8hci8X6pA(I
zZ9IAU{GK1JPRSZil#jL@c=eergH71q<9nCZ^L4&*Wh){@t|}d2I<e!p`PQAyr&w*<
zcBkn}?bi@{f4NnvsI1Z@=kc#;Q@KNRuRLh3<Wqb2TwL8rK-;@ZXtQnI$3y!+=aw<&
z|L!|}^<lT1#_SKTw9NGOo)CW-HKnhtLUG@Yfaeui`x>q--1c$aZI_+0zw-9%4lFv+
zS+t|K_5AlK%-_DR`Po-=DCxezLCLVAav}kaPDhULJrr#yS!&;K{S5!?W%ndS9<_NF
zygZv4v{~q|(b?~>GCuoFa`|O?@_C`R%AVVK2iWo(xGEASPOo%oP0y)5zmzNEFl)-c
z;t&VvMNID#t-94zLJkxPZgSIpV%+sne9ghbdT#Z0n|JDI*nTqUIpTim*xuhVeJ*F_
zDo5@)B6#<J!JVForafow8nkGX9^THj-@-v;ci3-PsTWS?+|KJ=`OVGS!v5?>&qK4)
zN`rs(b$zNe`?UCeuAY5cO=qXjw1)TZq}BdKwLLG;Tr|7%8iQ{w|B-s8ZAWshR~(z>
z8hC}*eV5&&#{ctd{DtDUzFxh^wJ4<Kjgv%>NZPl62+M=@Vm4Qng<VMZO*P&7curP8
z;qEZ@>1necGjo-{Jzyu5D0<FG>X`nLs7)*9-OS=lo~--&!=&F|#hCtnQhjcFpZDMC
z$6CklBx|GvzOGZuN{(IFYF?^(?Wg1Cbmvvh54nt1+1}4OP~3Iu%>v1n8ve7_q)cBL
zaDT7=a|Z`!OXpsm9SQvJ^_k*JXZ~iYKmPdH2TK7CTdVVIf(5<F>zY0!XFg%5tt)-v
zdDM57pVR&ePtLo&+02}sc1)qi>8(k#i)mwu34iNnmb)Tz;+}Rpvt?gjwP7(=Y{$Q+
zty*t1y5of3&8=*>-*eYi{zqS)jq@E>omDgQ5<0|oZ(}ccoE<w~TCM7gWAg60`M0aA
zdm2<D-Ul{WA6oJMyhgl1;;N(EOB%Kb%};JMUb8`(<yHCTj|VS3vsC<3lj-=Zw|eIm
zZrxly1^ecJxTZDp^w<7gy09y7MXVI-+NI*Fxh5+s&l6|AGvWHYwX0$+B0{UR<hDI1
znYTVm?(~oD(9&bP*+y%dL(fWg>^Q$B>qN=k2`4P)hdy|=;r{b;GiCQ@A2@X6{iNK@
zR(cJ83>K_hb$5MOko@#dF?ZITIX^`v$l%WP@16StQ+6$h&fWI<^j1ly^Ogd<pKm`s
z%eC#0mS+1UrRm$JZ!uXZzUzFoPew@gj?`lh<reN2^_l!Sc_sVP$Fu78?p77u^*Z#D
zl;OLtyuYpLpQvBC)_s0Pz4#Y9mHFp;XBr)w@_gZ&2~l#(QY`8lIZx~{o%$n3Q~drL
z?!&Xg%{Oq!-cu?sl(KfQJ;ryifa#>-+UDSzJ(2U@|CwT4ac8#Ux5eIKzl-)xO|1M|
zad_p+r)id%Q4xJ#`50tm?-f+un7!M_K(Hcz+V}6(j};`F-&n2un7gTV`kRO9#YMY}
zuKzF>Uw`4G_Cc-8H=F7<iZQ&n`FN}6?A41;Z_S%+|NNB)!%c?7jDRAJ=>jeN&x3a9
zJ@br_tc$&|s9L~GtRr}G?b)L-mp1(SaVLhA<^0u`hr^O@-noCV=9khzTZub6mu#PX
zJAC`<)7c3c?Hj8yCDqSMm!FNF;_GZLail*w_r=`*WxHbzKML$&;O6Uo_$INiX>)k^
k?6dye^YhH*^X5Oh?Ejkk*SG(rMgRE?wdOoqv4nvE0M<wL-2eap
diff --git a/documentation/mkdocs.yml b/documentation/mkdocs.yml
new file mode 100644
index 00000000..f0df483b
--- /dev/null
+++ b/documentation/mkdocs.yml
@@ -0,0 +1,30 @@
+site_name: Flexpart
+# default is ./site/
+# could change this to /var/www/html/docs
+site_dir: "/tmp/cr-site/"
+# site_dir: "/var/www/html/documentation/general/"
+#docs_dir: "docs/"
+repo_url: https://gitlab.phaidra.org/flexpart/flexpart
+repo_name: IMGW/Flexpart
+# this makes relative links valid
+use_directory_urls: false
+theme:
+ name: readthedocs
+plugins:
+# - tags
+ - search
+extra_javascript:
+ - https://cdnjs.cloudflare.com/ajax/libs/mathjax/2.7.0/MathJax.js?config=TeX-AMS-MML_HTMLorMML
+markdown_extensions:
+ - smarty
+ - toc:
+ permalink: True
+ - codehilite:
+nav:
+ - 'index.md'
+ - 'installation.md'
+ - 'running.md'
+ - 'output.md'
+ - 'transport.md'
+ - 'evolution.md'
+ - 'examples.md'
diff --git a/documentation/program_list.txt b/documentation/program_list.txt
deleted file mode 100755
index 42dbb9c2..00000000
--- a/documentation/program_list.txt
+++ /dev/null
@@ -1,160 +0,0 @@
-SHORT DESCRIPTION OF THE SOURCE CODE FILES USED BY THE FLEXPART MODEL
-_____________________________________________________________________
-FLEXPART.f main program, manages reading of run specifications, etc.;
- last call is to timemanager.f, which manages the actual model
- integration
-advance.f advection of the particles by grid-scale and turbulent winds;
- solves the Langevin equations
-assignland.f assigns the fractions of 8 landuse classes to each ECMWF grid
- point
-boundcond_domainfill.f creates particles at the inflowing/destroys particles
- at the outflowing boundary, if domain-filling option is used
-calcfluxes.f calculates the gross N-S, E-W and up-down mass fluxes
- resulting from the motion of a single particle
-calcmatrix.f interface to the convection scheme (convect.f) by K. Emanuel
-calcpar.f calculates boundary layer parameters: friction velocity,
- convective velocity scale, Obukhov length, PBL height, partly
- by calling other routines
-calcpar_nests.f same as calcpar.f, but for the nested grids
-calcpv.f calculates potential vorticity for mother domain grid points
-calcpv_nests.f same as calcpv.f, but for the nested grids
-caldate.f computes calendar date from Julian date
-centerofmass.f calculates the center of mass of n points on the Earth
-clustering.f cluster analysis of particle position
-cmapf1.0.f Program package for coordinate transformations between
- latitude/longitude grid and polar stereographic projection
-conccalc.f calculates concentrations or residence times and/or
- mixing ratios on the output grid and at receptor locations
-concoutput.f writes out concentrationsor residence times and/or
- mixing ratios on the output grid and at receptor locations
- (files grid_conc_date, grid_pptv_date, grid_time_date)
-concoutput_nest.f same as concoutput.f, but for the nested output grid
-convect.f convection scheme written by Kerry Emanuel (slightly modified)
-convmix.f handles all the calculations related to convective mixing
-coordtrafo.f transformation of release point coordinates from geografical
- to grid coordinates
-distance.f calculates distance (km) between 2 points on Earth's surface
- given their positions in degrees
-distance2.f calculates distance (km) between 2 points on Earth's surface
- given their positions in radians
-drydepokernel.f calculates gridded dry deposition field using a uniform kernel
-drydepokernel_nest.f same as drydepokernel.f, but for the nested output grid
-erf.f error function
-ew.f calculation of saturation water vapor pressure for given
- air temperature
-fluxoutput.f writes out mass fluxes on the output grid (grid_flux_date)
-getfields.f manages reading of new wind fields if required, and calls all
- routines that do calculations on the input grids
-getrb.f computes quasilaminar sublayer resistance to dry deposition
- of gases
-getrc.f calculates surface resistance to dry deposition of gases
-getvdep.f calculates dry deposition velocities
-gridcheck.f determines grid domain, resolution, etc., from GRIB file and
- checks whether dimensions comply with settings in includepar
-gridcheck_nests.f same as gridcheck.f, but for the nested grids
-hanna.f parameterization of the turbulent velocity variance and
- the respective timescales; Langevin equation for w'/sigw
-hanna1.f alternative model to hanna.f: Langevin equation for w'
- drift correction velocity after Wilson
-hanna_short.f same as hanna.f, but only for the vertical wind
-includecom include file containing important global variables
-includeconv include file containing variables used in the convection scheme
-includeinterpol include file containing variables used for interpolation in
- routines called from advance.f
-includehanna include file used for turbulence parameterization
-includepar include file containing all globally used parameters
-init_domainfill.f distributes particles homogeneously in the computation domain
-initialize.f initializes the turbulence statistics for a particle
-interpol_all.f interpolates all data needed in advance.f for two levels
- within the PBL and for all surface data
-interpol_all_nests.f same as interpol_all.f, but for the nested grids
-interpol_misslev.f interpolates for a level in the PBL that was not provided
- by interpol_all.f, because particle has moved out of the
- two sandwiched layers
-interpol_misslev_nests.f same as interpol_misslev.f, but for the nested grids
-interpol_rain.f interpolates large-scale and convective precipitation,
- and of total cloud cover
-interpol_rain_nests.f same as interpol_rain.f, but for the nested grids
-interpol_vdep.f interpolates the deposition velocity
-interpol_vdep_nests.f same as interpol_vdep.f, but for the nested grids
-interpol_wind.f interpolates winds above the PBL and calculates the wind's
- standard deviation for grid points around particle location
-interpol_wind_nests.f same as interpol_wind.f, but for the nested grids
-interpol_wind_short.f interpolates winds above the PBL
-interpol_wind_short_nests.f same as interpol_wind_short.f, but for nested grids
-juldate.f compute julian date from calendar date
-mean.f calculates the mean and standard deviation of a field
-obukhov.f calculates Obukhov length from surface heat flux
-openouttraj.f opens the output files for the plume trajectory output
-openreceptors.f opens output files for receptor location output, and writes
- out some basic information (location and names of receptors)
- (files receptor_conc and receptor_pptv)
-outgrid_init.f initializes the output grid and calculates volume and area
- of output grid cells
-outgrid_init_nest.f same as outgrid_init.f, but for the nested output grid
-part0.f calculates time-independent factors for the dry deposition
- of particles
-partdep.f calculates dry deposition velocities for particles
-partoutput.f writes out the particle positions to files partposit_date, or
- partposit_end
-partoutput_short.f dumps particle output in a compact format; particles are
- uniquely numbered
-pbl_profile.f calculates surface stress and sensible heat flux using
- the profile method
-plumetraj.f calculates a plume centroid trajectory and manages particle
- clustering; writes output to file trajectories.txt
-psih.f stability correction term for heat
-psim.f stability correction term for momentum
-qvsat.f saturation specif. humidity at given pressure and temperature
-raerod.f calculation of the aerodynamic resistance ra to dry deposition
-random.f subroutines needed for generation of normally distriubted
- random numbers
-readageclasses.f reads number and time intervals of age classes to be used
-readavailable.f reads, which wind fields are available during the modelling
- period
-readcommand.f reads basic user commands, e.g. start and end of simulation,
- frequency of output, etc.
-readdepo.f reads parameters needed for dry deposition of gases
-readlanduse.f reads landuse inventory and the respective roughness lengths
-readoutgrid.f reads the definition of the output domain
-readoutgrid_nest.f same as readoutgrid.f, but for the nested output grid
-readpartpositions.f reads particle positions from a previous run's
- partposit_end file, in order to initialize particle positions
- for the new run
-readpaths.f reads the path names of input/output files and wind fields
-readreceptors.f reads names and coordinates of receptor points for which the
- parabolic kernel shall be applied
-readreleases.f reads release specifications (start and end of release,
- coordinates, number of particles, masses released, etc.)
-readspecies.f reads physical and chemical properties of gases and aerosols
-readwind.f reads the ECMWF meteorological data fields; contains the
- calls to GRIB decoding routines
-readwind_nests.f same as readwind.f, but for the nested grids
-redist.f redistributes particles according to convective fluxes
-releaseparticles.f releases the particles during the simulation; called every
- lsynctime seconds
-richardson.f calculates convective velocity scale and PBL height using
- critical Richardson number concept
-scalev.f computes friction velocity from surface stress
-shift_field.f shifts global fields by nxshift grid cells, and repeats
- westernmost grid points at easternmost domain boundary
-shift_field_0.f same as shift_field.f, but for some fields with 2 dimensions
- only (e.g. topography)
-skplin.f skips n lines of a given input file
-sort2.f sorts particles according to their coordinates
-timemanager.f time management of FLEXPART model simulation: determines when
- particles are released and advected, when concentrations
- calculations are done and concentrations written out, and
- calls all the respective subroutines
-verttransform.f transforms 3-d fields from eta coordinates to Cartesian
- terrain-following coordinates
-verttransform_nests.f same as verttransform.f, but for the nested grids
-wetdepo.f calculates the wet deposition
-wetdepokernel.f assigns the deposition from an individual particle to the
- deposition fields using a uniform kernel of bandwidths dx, dy
-wetdepokernel_nest.f same as wetdepokernel.f, but for the nested output grid
-windalign.f transforms turbulent velocities from along- and cross-wind
- components to Cartesian u and v components
-writeheader.f creates the file header and writes important information about
- the model run in it
-writeheader_nest.f same as writeheader.f, but for the nested output grid
diff --git a/documentation/release_notes_9.2.rtf b/documentation/release_notes_9.2.rtf
deleted file mode 100644
index 7de925ca..00000000
--- a/documentation/release_notes_9.2.rtf
+++ /dev/null
@@ -1,133 +0,0 @@
-{\rtf1\ansi\ansicpg1252\cocoartf1138\cocoasubrtf510
-{\fonttbl\f0\fswiss\fcharset0 Helvetica;\f1\fnil\fcharset0 Cambria;}
-{\colortbl;\red255\green255\blue255;}
-\paperw11900\paperh16840\margl1440\margr1440\vieww16320\viewh13780\viewkind0
-\deftab720
-\pard\tx566\tx1133\tx1700\tx2267\tx2834\tx3401\tx3968\tx4535\tx5102\tx5669\tx6236\tx6803\pardeftab720\ri0
-
-\f0\fs28 \cf0 Release notes for FLEXPART 9.2 \
-\
-VERSION 9.0.2\
-\
-Starting point from ZAMG svn trunk early 2013\
-\
-VERSION 9.0.2.1 (from SEC)\
-\
-Version previously on the svn trunk plus minor changes (bugfixes)\
-\
-VERSION 9.1.0 \
-\
-HSO Changes\
-Called flexpart91_hasod on svn branches \
-(not the parallel version from Stephan Henne)\
-Main addition: namelists for COMMAND input and output \
-\
-VERSION 9.1.1\
-\
-Merge HSO, SEC and svn trunk\
- - add minor bug fixes to HSO 's version\
- - changes to releases\
-> ! num_min_discrete if less, release cannot be randomized and happens at *\
-> ! time mid-point of release interval *\
-\
-> !!!! Modification to decrease scavenging and make it more realistic \
-\
-\
-VERSION 9.1.2 (NIK\'92s changes) \
-\
-Main changes: \
- - deposition scheme: variation of scavenging parameters\
- - options: changes in SPECIES for parameter input \
-\
-VERSION 9.1.3 (PS's changes ) \
-\
-update to wetdepo.f90 and other routines \
-Prepared by PS for version 8 (F77).\
-Distributed in the tarball newcloudscheme.tgz\
-\
-VERSION 9.1.4 (minor changes - bug fixes - compatibility issues between NIK and PS schemes)\
-\pard\pardeftab720\ri0
-\cf0 \
- readpartpositions.f90, line 79 (from version 9.0.2)\
- issues: just a warning on numpointin not being equal to numpoint\
- test backward compatibility with namelist COMMAND\
-\
-\pard\tx566\tx1133\tx1700\tx2267\tx2834\tx3401\tx3968\tx4535\tx5102\tx5669\tx6236\tx6803\pardeftab720\ri0
-\cf0 VERSION 9.1.5 (XF)\
-\
-Modification to gfs routines to read fnl winds \
-\pard\pardeftab720\ri0
-\cf0 Modifications to the parameters module \
-\
-\pard\tx566\tx1133\tx1700\tx2267\tx2834\tx3401\tx3968\tx4535\tx5102\tx5669\tx6236\tx6803\pardeftab720\ri0
-\cf0 VERSION 9.1.6 (RT)\
-\
-changes in input and output\
-\pard\tx566\tx1133\tx1700\tx2267\tx2834\tx3401\tx3968\tx4535\tx5102\tx5669\tx6236\tx6803\pardeftab720\ri0
-
-\fs24 \cf0 writeheader_surf
-\fs28 \
-\pard\pardeftab720\ri0
-\cf0 \
-\
-VERSION 9.1.6.2\
-Add header in text format\
-\
-\pard\tx566\tx1133\tx1700\tx2267\tx2834\tx3401\tx3968\tx4535\tx5102\tx5669\tx6236\tx6803\pardeftab720\ri0
-\cf0 VERSION 9.1.7 \
-\
-\pard\tx566\tx1133\tx1700\tx2267\tx2834\tx3401\tx3968\tx4535\tx5102\tx5669\tx6236\tx6803\pardeftab720\ri0
-
-\f1\fs24 \cf0 - makefile changes,\
-\pard\pardeftab720\ri0
-\cf0 \
-\pard\pardeftab720\ri380\sa180
-
-\b \cf0 - Ticket #11
-\b0 - suppress check in read positions \
-
-\b - Ticket #22
-\b0 - dates on the fly\
-
-\b - Ticket #13
-\b0 - check path\
-\pard\pardeftab720\ri0
-\cf0 /home/vsinclai/FLEXPART/EXERCISES/HelloWorld/optionsCOMMAND\
-\
-- SYSTEM_CLOCK calls, verbosity\
-print*, 'WARNING: path not ending in /' \
-\pard\pardeftab720\ri0
-
-\f0\fs28 \cf0 \
-FLEXPART 9.1.8 \
-\
-(minor fixes - inclusion of additional tickets from the trac system) \
-\
-revise version numbers:\
-correct for trim(flexversion) instead of V8.2 V9.0, FLEXPART V9.0\
-on leader, etc.\
-\
-minor modifications to \
- openouttraj.f90 \
- writeheader_nest_surf.f90s\
-\
-messages depending on verbosity level\
-\
-Not included in 9.1.8:\
-\
-- Massimo's new PBL scheme\
-\
-- Paralelization (ES working on this)\
-\
-- NetCDF handling \
-\
-Submitted to developers for testing.\
-\
-\pard\tx566\tx1133\tx1700\tx2267\tx2834\tx3401\tx3968\tx4535\tx5102\tx5669\tx6236\tx6803\pardeftab720\ri0
-\cf0 VERSION 9.1.9\
-\
-Retraction to Nina's scheme due to changes in naming variables incompatible between NIK and PS.\
-\
-VERSION 9.2 based on AST's FLEXPART_CLEAN\
-\
-}
\ No newline at end of file
diff --git a/options.reference/COMMAND.reference b/options.reference/COMMAND.reference
index 811fc41a..8e1e0fa3 100644
--- a/options.reference/COMMAND.reference
+++ b/options.reference/COMMAND.reference
@@ -107,7 +107,7 @@
1. Simulation direction, 1 for forward, -1 for backward in time
- (consult Seibert and Frank, 2004 for backward runs)
+ (consult Seibert and Frank, 2004 for backward runs)
2. Beginning date and time of simulation. Must be given in format
YYYYMMDD HHMISS, where YYYY is YEAR, MM is MONTH, DD is DAY, HH is HOUR,
diff --git a/options.reference/OUTGRID b/options.reference/OUTGRID
index 903925d7..3f1222e0 100644
--- a/options.reference/OUTGRID
+++ b/options.reference/OUTGRID
@@ -1,50 +1,50 @@
-********************************************************************************
-* *
-* Input file for the Lagrangian particle dispersion model FLEXPART *
-* Please specify your output grid *
-* *
-********************************************************************************
-
-1. ------.---- 4X,F11.4
- -179.0000 GEOGRAFICAL LONGITUDE OF LOWER LEFT CORNER OF OUTPUT GRID
- OUTLONLEFT (left boundary of the first grid cell - not its centre)
-
-2. ------.---- 4X,F11.4
- -90.0000 GEOGRAFICAL LATITUDE OF LOWER LEFT CORNER OF OUTPUT GRID
- OUTLATLOWER (lower boundary of the first grid cell - not its centre)
-
-3. ----- 4X,I5
- 720 NUMBER OF GRID POINTS IN X DIRECTION (= No. of cells + 1)
- NUMXGRID
-
-4. ----- 4X,I5
- 360 NUMBER OF GRID POINTS IN Y DIRECTION (= No. of cells + 1)
- NUMYGRID
-
-5. ------.--- 4X,F10.3
- 0.50 GRID DISTANCE IN X DIRECTION
- DXOUTLON
-
-6. ------.--- 4X,F10.3
- 0.50 GRID DISTANCE IN Y DIRECTION
- DYOUTLAT
-
-10. -----.- 4X, F7.1
- 100.0
- LEVEL 1 HEIGHT OF LEVEL (UPPER BOUNDARY)
-
-10. -----.- 4X, F7.1
- 500.0
- LEVEL 2 HEIGHT OF LEVEL (UPPER BOUNDARY)
-
-10. -----.- 4X, F7.1
- 1000.0
- LEVEL 3 HEIGHT OF LEVEL (UPPER BOUNDARY)
-
-10. -----.- 4X, F7.1
- 10000.0
- LEVEL 4 HEIGHT OF LEVEL (UPPER BOUNDARY)
-
-10. -----.- 4X, F7.1
- 40000.0
- LEVEL 5 HEIGHT OF LEVEL (UPPER BOUNDARY)
+********************************************************************************
+* *
+* Input file for the Lagrangian particle dispersion model FLEXPART *
+* Please specify your output grid *
+* *
+********************************************************************************
+
+1. ------.---- 4X,F11.4
+ -179.0000 GEOGRAFICAL LONGITUDE OF LOWER LEFT CORNER OF OUTPUT GRID
+ OUTLONLEFT (left boundary of the first grid cell - not its centre)
+
+2. ------.---- 4X,F11.4
+ -90.0000 GEOGRAFICAL LATITUDE OF LOWER LEFT CORNER OF OUTPUT GRID
+ OUTLATLOWER (lower boundary of the first grid cell - not its centre)
+
+3. ----- 4X,I5
+ 720 NUMBER OF GRID POINTS IN X DIRECTION (= No. of cells + 1)
+ NUMXGRID
+
+4. ----- 4X,I5
+ 360 NUMBER OF GRID POINTS IN Y DIRECTION (= No. of cells + 1)
+ NUMYGRID
+
+5. ------.--- 4X,F10.3
+ 0.50 GRID DISTANCE IN X DIRECTION
+ DXOUTLON
+
+6. ------.--- 4X,F10.3
+ 0.50 GRID DISTANCE IN Y DIRECTION
+ DYOUTLAT
+
+10. -----.- 4X, F7.1
+ 100.0
+ LEVEL 1 HEIGHT OF LEVEL (UPPER BOUNDARY)
+
+10. -----.- 4X, F7.1
+ 500.0
+ LEVEL 2 HEIGHT OF LEVEL (UPPER BOUNDARY)
+
+10. -----.- 4X, F7.1
+ 1000.0
+ LEVEL 3 HEIGHT OF LEVEL (UPPER BOUNDARY)
+
+10. -----.- 4X, F7.1
+ 10000.0
+ LEVEL 4 HEIGHT OF LEVEL (UPPER BOUNDARY)
+
+10. -----.- 4X, F7.1
+ 40000.0
+ LEVEL 5 HEIGHT OF LEVEL (UPPER BOUNDARY)
diff --git a/options.reference/SPECIES/SPECIES.README b/options.reference/SPECIES/SPECIES.README
index 433b4c95..f5dc0249 100644
--- a/options.reference/SPECIES/SPECIES.README
+++ b/options.reference/SPECIES/SPECIES.README
@@ -6,62 +6,74 @@ gfortran specoverview.f90 -o specoverview
./specoverview
UPDATE FOR FLEXPART VERSION 10.3:
----------------------------------------------------------------------------------------------------------------------------
-Please note that the format of the SPECIES files has changed from the previous version (9.2) of FLEXPART and it is important
-to update all SPECIES files accordingly. The use of SPECIES files from older FLEXPART versions may lead to run-time
-errors or erroneous results.
----------------------------------------------------------------------------------------------------------------------------
-Half life due to radioactive or chemical decay and can be switched off by specifying a negative value.
+--------------------------------------------------------------------------------Please note that the format of the SPECIES files has changed from the previous
+version (9.2) of FLEXPART and it is important to update all SPECIES files
+accordingly. The use of SPECIES files from older FLEXPART versions may lead to
+run-time errors or erroneous results.
+--------------------------------------------------------------------------------Half life due to radioactive or chemical decay and can be switched off by
+specifying a negative value.
Molecular weight (molweight of the species, needed for mixing ratio output)
----------------------------------------------------------------------------------------------------------------------------
-WET DEPOSITION
+--------------------------------------------------------------------------------WET DEPOSITION
Below-cloud scavenging
- Gases:
- A and B are the parameters for below-cloud scavenging defined by Eq. scavenging coefficient = A x precipitation-rate^B
- If you migrate from FLEXPART version 9.2 and below this is equal to A and B as it was.
+A and B are the parameters for below-cloud scavenging defined by
+ Eq. scavenging coefficient = A x precipitation-rate^B
+ If you migrate from FLEXPART version 9.2 and below this is equal to A and
+ B as it was.
- Particles:
- A "rain collection efficiency"
- B "snow collection efficiency" are both defined by Equations 46-47.
- Suggested values for particle scavenging are A=1.0,B=1.0.
- Using values A=0.2 and B=0.2 will give results close to the old scavenging scheme of FLEXPART version 9.2 and below.
+ A "rain collection efficiency"
+ B "snow collection efficiency" are both defined by Equations 46-47.
+ Suggested values for particle scavenging are A=1.0,B=1.0.
+ Using values A=0.2 and B=0.2 will give results close to the old scavenging
+ scheme of FLEXPART version 9.2 and below.
In-cloud scavenging
- Gases:
Is switched on if Ai or Bi are given greater than 0
- If you migrate from FLEXPART version 9.2 and below this is equal to Ai and Bi should be set to 1
+ If you migrate from FLEXPART version 9.2 and below this is equal to Ai and
+ Bi should be set to 1
- Particles:
- Ai ("Cloud Condensation Nuclei (CCN) efficiency")
- Bi ("Ice Nuclei (IN) efficiency") are both from Eq. 51.
- Suggested values for particle scavenging are Ai=0.9 and Bi=0.1.
- Using values Ai=0.9 and Bi=0.9 should give results cto the old scavenging scheme of FLEXPART version 9.2 and below.
----------------------------------------------------------------------------------------------------------------------------
-DRY DEPOSITION
+ Ai ("Cloud Condensation Nuclei (CCN) efficiency")
+ Bi ("Ice Nuclei (IN) efficiency") are both from Eq. 51.
+ Suggested values for particle scavenging are Ai=0.9 and Bi=0.1.
+ Using values Ai=0.9 and Bi=0.9 should give results cto the old scavenging
+ scheme of FLEXPART version 9.2 and below.
+--------------------------------------------------------------------------------DRY DEPOSITION
- Gases:
- D is the diffusivity of water vapor and
- D_i is the diffusivity of the species,
- H is the effective Henry's constant,
- f0 varies between 0 and 1 and gives the reactivity of a species relative to that of ozone. For non-reactive species f0 is 0, for slightly reactive it is 0.1 and for highly reactive it is 1.
- Dry deposition of gases is switched off by negative D.
+ D is the diffusivity of water vapor and
+ D_i is the diffusivity of the species,
+ H is the effective Henry's constant,
+ f0 varies between 0 and 1 and gives the reactivity of a species relative to
+ that of ozone. For non-reactive species f0 is 0, for slightly reactive it
+ is 0.1 and for highly reactive it is 1.
+ Dry deposition of gases is switched off by negative D.
- Particles:
- rho specifies the density of the substance,
- dquer its mean diameter
- dsig the measure of variation.
- If no detailed information for deposition velocity calculation is available, a constant deposition velocity vd [cm s-1] can be used.
- Dry deposition of particles is switched off by negative rho.
----------------------------------------------------------------------------------------------------------------------------
-OH REACTION:
- can be turned on by giving parameter C [cm^3/molecule/sec]], D [K] and N [no unit] positive values, defined by Eq. 39.
- OH reaction is switched off by negative C.
----------------------------------------------------------------------------------------------------------------------------
-Optionally emission variation information
- can be added at the end of the file, defined as following: Since FLEXPART version 6.0, emission factors can be defined that change the temporal variation of particle releases. This is useful, for instance,
-to simulate the typical daily and weekly cycle of anthropogenic emissions. The emission factors are given in the file of the
-corresponding species SPECIES_nnn, where nnn is the species number defined in file RELEASES. If no emission variation
-information is given, emission rates for species nnn are taken as constant. Release rates can vary with the hour of the day
-and with the day of the week, according to the local time at the release location. Emission factors must be 1 on average. 24
-hourly as well as 7 daily values must be specified. Furthermore, different disaggregation factors must be given for area sources
-and for point sources. FLEXPART distinguishes between the two using the lower altitude of the release box: area sources are
-assumed to start below 0.5 m above the ground, whereas point sources are assumed to be higher. Please note that when this
-option is used, it is not so easy to determine the maximum number of particles present at a particular time of the model run. It
-might then be necessary to increase the parameter maxpart to a higher value than what would otherwise be needed.
+ rho specifies the density of the substance,
+ dquer its mean diameter
+ dsig the measure of variation.
+ If no detailed information for deposition velocity calculation is available,
+ a constant deposition velocity vd [cm s-1] can be used.
+ Dry deposition of particles is switched off by negative rho.
+--------------------------------------------------------------------------------OH REACTION:
+ can be turned on by giving parameter C [cm^3/molecule/sec]], D [K] and
+ N [no unit] positive values, defined by Eq. 39.
+ OH reaction is switched off by negative C.
+--------------------------------------------------------------------------------Optionally emission variation information can be added at the end of the file,
+defined as following: Since FLEXPART version 6.0, emission factors can be
+defined that change the temporal variation of particle releases. This is
+useful, for instance, to simulate the typical daily and weekly cycle of
+anthropogenic emissions. The emission factors are given in the file of the
+corresponding species SPECIES_nnn, where nnn is the species number defined in
+file RELEASES. If no emission variation information is given, emission rates
+for species nnn are taken as constant. Release rates can vary with the hour of
+the day and with the day of the week, according to the local time at the
+release location. Emission factors must be 1 on average. 24 hourly as well as
+7 daily values must be specified. Furthermore, different disaggregation factors
+must be given for area sources and for point sources. FLEXPART distinguishes
+between the two using the lower altitude of the release box: area sources are
+assumed to start below 0.5 m above the ground, whereas point sources are
+assumed to be higher. Please note that when this option is used, it is not so
+easy to determine the maximum number of particles present at a particular time
+of the model run. It might then be necessary to increase the parameter maxpart
+to a higher value than what would otherwise be needed.
diff --git a/options.reference/surfdata.t b/options.reference/surfdata.t
index 95a38fb7..d19e8410 100644
--- a/options.reference/surfdata.t
+++ b/options.reference/surfdata.t
@@ -1,17 +1,17 @@
-13 landuse categories are related roughness length
---------------------------------------------------------
-landuse comment z0
---------------------------------------------------------
- 1 Urban land 0.7
- 2 Agricultural land 0.1
- 3 Range land 0.1
- 4 Deciduous forest 1.
- 5 Coniferous forest 1.
- 6 Mixed forest including wetland 0.7
- 7 water, both salt and fresh 0.001
- 8 barren land mostly desert 0.01
- 9 nonforested wetland 0.1
-10 mixed agricultural and range land 0.1
-11 rocky open areas with low grow shrubs 0.05
-12 snow and ice 0.001
-13 rainforest 1.
+13 landuse categories are related roughness length
+--------------------------------------------------------
+landuse comment z0
+--------------------------------------------------------
+ 1 Urban land 0.7
+ 2 Agricultural land 0.1
+ 3 Range land 0.1
+ 4 Deciduous forest 1.
+ 5 Coniferous forest 1.
+ 6 Mixed forest including wetland 0.7
+ 7 water, both salt and fresh 0.001
+ 8 barren land mostly desert 0.01
+ 9 nonforested wetland 0.1
+10 mixed agricultural and range land 0.1
+11 rocky open areas with low grow shrubs 0.05
+12 snow and ice 0.001
+13 rainforest 1.
diff --git a/options/COMMAND b/options/COMMAND
index 00b360c9..a3d03fc1 100644
--- a/options/COMMAND
+++ b/options/COMMAND
@@ -13,25 +13,26 @@
LOUTSTEP= 3600, ! Interval of model output; average concentrations calculated every LOUTSTEP (s)
LOUTAVER= 3600, ! Interval of output averaging (s)
LOUTSAMPLE= 900, ! Interval of output sampling (s), higher stat. accuracy with shorter intervals
- ITSPLIT= 99999999, ! Interval of particle splitting (s)
+ LOUTRESTART= 86400, ! Interval of writing restart files (s), switched off when set to -1
LSYNCTIME= 900, ! All processes are synchronized to this time interval (s)
CTL= -5.0000000, ! CTL>1, ABL time step = (Lagrangian timescale (TL))/CTL, uses LSYNCTIME if CTL<0
IFINE= 4, ! Reduction for time step in vertical transport, used only if CTL>1
- IOUT= 1, ! Output type: [1]mass 2]pptv 3]1&2 4]plume 5]1&4, +8 for NetCDF output
- IPOUT= 0, ! Particle position output: 0]no 1]every output 2]only at end 3]time averaged
+ IOUT= 1, ! Gridded output type: [0]off [1]mass 2]pptv 3]1&2 4]plume 5]1&4, +8 for NetCDF output
+ IPOUT= 0, ! Particle position output: 0]off 1]every output 2]only at end
LSUBGRID= 0, ! Increase of ABL heights due to sub-grid scale orographic variations;[0]off 1]on
LCONVECTION= 1, ! Switch for convection parameterization;0]off [1]on
LAGESPECTRA= 0, ! Switch for calculation of age spectra (needs AGECLASSES);[0]off 1]on
- IPIN= 0, ! Warm start from particle dump (needs previous partposit_end file); [0]no 1]yes
+ IPIN= 0, ! Warm start from particle dump; [0]no 1]from restart.bin file 2]from previous partoutput file 3]self made initial conditions 4]restart.bin and self made initial conditions
IOUTPUTFOREACHRELEASE= 1, ! Separate output fields for each location in the RELEASE file; [0]no 1]yes
IFLUX= 0, ! Output of mass fluxes through output grid box boundaries
MDOMAINFILL= 0, ! Switch for domain-filling, if limited-area particles generated at boundary
- IND_SOURCE= 1, ! Unit to be used at the source ; [1]mass 2]mass mixing ratio
- IND_RECEPTOR= 1, ! Unit to be used at the receptor; [1]mass 2]mass mixing ratio 3]wet depo. 4]dry depo.
+ IND_SOURCE= 1, ! Unit to be used at the source; [1]mass 2]mass mixing ratio
+ IND_RECEPTOR= 1, ! Unit to be used at the receptor; [0]no receptor [1]mass 2]mass mixing ratio 3]wet depo. 4]dry depo.
MQUASILAG= 0, ! Quasi-Lagrangian mode to track individual numbered particles
NESTED_OUTPUT= 0, ! Output also for a nested domain
LINIT_COND= 0, ! Output sensitivity to initial conditions (bkw mode only) [0]off 1]conc 2]mmr
SURF_ONLY= 0, ! Output only for the lowest model layer, used w/ LINIT_COND=1 or 2
CBLFLAG= 0, ! Skewed, not Gaussian turbulence in the convective ABL, need large CTL and IFINE
OHFIELDS_PATH= "../../flexin/", ! Default path for OH file
+ NXSHIFT= 359, ! Shift of the global meteorological data. Default 359 for ECMWF and 0 for GFS if not given
/
diff --git a/options/PARTOPTIONS b/options/PARTOPTIONS
new file mode 100644
index 00000000..0f05584d
--- /dev/null
+++ b/options/PARTOPTIONS
@@ -0,0 +1,42 @@
+***************************************************************************************************************
+* *
+* Input file for the Lagrangian particle dispersion model FLEXPART *
+* Please select which fields you would like to print in the partoutput files *
+* *
+***************************************************************************************************************
+&PARTOPTIONS
+ LONGITUDE= .true., !
+ LONGITUDE_AVERAGE= .true., !
+ LATITUDE= .true., !
+ LATITUDE_AVERAGE= .true., !
+ HEIGHT= .true., !
+ HEIGHT_AVERAGE= .true., !
+ PV= .true., !
+ PV_AVERAGE= .true., !
+ QV= .true., !
+ QV_AVERAGE= .false., !
+ DENSITY= .false., !
+ DENSITY_AVERAGE= .false., !
+ TEMPERATURE= .false., !
+ TEMPERATURE_AVERAGE= .false., !
+ PRESSURE= .false., !
+ PRESSURE_AVERAGE= .false., !
+ MIXINGHEIGHT= .false., !
+ MIXINGHEIGHT_AVERAGE= .false., !
+ TROPOPAUSE= .false., !
+ TROPOPAUSE_AVERAGE= .false., !
+ TOPOGRAPHY= .false., !
+ TOPOGRAPHY_AVERAGE= .false., !
+ MASS= .false., !
+ MASS_AVERAGE= .false., !
+ U= .false., !
+ U_AVERAGE= .false., !
+ V= .false., !
+ V_AVERAGE= .false., !
+ W= .false., !
+ W_AVERAGE= .false., !
+ VSETTLING= .false., !
+ VSETTLING_AVERAGE= .false., !
+ WETDEPOSITION= .false., !
+ DRYDEPOSITION= .false.,
+ /
diff --git a/options/SPECIES/SPECIES.README b/options/SPECIES/SPECIES.README
index 31df8c40..4a1e8579 100644
--- a/options/SPECIES/SPECIES.README
+++ b/options/SPECIES/SPECIES.README
@@ -6,62 +6,13 @@ gfortran specoverview.f90 -o specoverview
./specoverview
UPDATE FOR FLEXPART VERSION 10.0 DEV:
----------------------------------------------------------------------------------------------------------------------------
-Please note that the format of the SPECIES files has changed from the previous version (9.2) of FLEXPART and it is important
-to update all SPECIES files accordingly. The use of SPECIES files from older FLEXPART versions may lead to run-time
-errors or erroneous results.
----------------------------------------------------------------------------------------------------------------------------
-Half life due to radioactive or chemical decay and can be switched off by specifying a negative value.
-Molecular weight (molweight of the species, needed for mixing ratio output)
----------------------------------------------------------------------------------------------------------------------------
-WET DEPOSITION
-
-Below-cloud scavenging
-- Gases:
- A and B are the parameters for below-cloud scavenging defined by Eq. scavenging coefficient = A x precipitation-rate^B
- If you migrate from FLEXPART version 9.2 and below this is equal to A and B as it was.
-- Particles:
- A "rain collection efficiency"
- B "snow collection efficiency" are both defined by Equations 46-47.
- Suggested values for particle scavenging are A=1.0,B=1.0.
- Using values A=0.2 and B=0.2 will give results close to the old scavenging scheme of FLEXPART version 9.2 and below.
-
-In-cloud scavenging
-- Gases:
- Is switched on if Ai or Bi are given greater than 0
- If you migrate from FLEXPART version 9.2 and below this is equal to Ai and Bi should be set to 1
-- Particles:
- Ai ("Cloud Condensation Nuclei (CCN) efficiency")
- Bi ("Ice Nuclei (IN) efficiency") are both from Eq. 51.
- Suggested values for particle scavenging are Ai=0.9 and Bi=0.1.
- Using values Ai=0.9 and Bi=0.9 should give results cto the old scavenging scheme of FLEXPART version 9.2 and below.
----------------------------------------------------------------------------------------------------------------------------
-DRY DEPOSITION
-- Gases:
- D is the diffusivity of water vapor and
- D_i is the diffusivity of the species,
- H is the effective Henry’s constant,
- f0 varies between 0 and 1 and gives the reactivity of a species relative to that of ozone. For non-reactive species f0 is 0, for slightly reactive it is 0.1 and for highly reactive it is 1.
- Dry deposition of gases is switched off by negative D.
-- Particles:
- rho specifies the density of the substance,
- dquer its mean diameter
- dsig the measure of variation.
- If no detailed information for deposition velocity calculation is available, a constant deposition velocity vd [cm s-1] can be used.
- Dry deposition of particles is switched off by negative rho.
----------------------------------------------------------------------------------------------------------------------------
-OH REACTION:
- can be turned on by giving parameter C [cm^3/molecule/sec]], D [K] and N [no unit] positive values, defined by Eq. 39.
- OH reaction is switched off by negative C.
----------------------------------------------------------------------------------------------------------------------------
-Optionally emission variation information
- can be added at the end of the file, defined as following: Since FLEXPART version 6.0, emission factors can be defined that change the temporal variation of particle releases. This is useful, for instance,
-to simulate the typical daily and weekly cycle of anthropogenic emissions. The emission factors are given in the file of the
-corresponding species SPECIES_nnn, where nnn is the species number defined in file RELEASES. If no emission variation
-information is given, emission rates for species nnn are taken as constant. Release rates can vary with the hour of the day
-and with the day of the week, according to the local time at the release location. Emission factors must be 1 on average. 24
-hourly as well as 7 daily values must be specified. Furthermore, different disaggregation factors must be given for area sources
-and for point sources. FLEXPART distinguishes between the two using the lower altitude of the release box: area sources are
-assumed to start below 0.5 m above the ground, whereas point sources are assumed to be higher. Please note that when this
-option is used, it is not so easy to determine the maximum number of particles present at a particular time of the model run. It
-might then be necessary to increase the parameter maxpart to a higher value than what would otherwise be needed.
+--------------------------------------------------------------------------------
+Please note that the format of the SPECIES files has changed from the previous
+version (9.2) of FLEXPART and it is important to update all SPECIES files
+accordingly. The use of SPECIES files from older FLEXPART versions may lead to
+run-time errors or erroneous results.
+--------------------------------------------------------------------------------
+Half life due to radioactive or chemical decay and can be switched off by
+specifying a negative value. Molecular weight (molweight of the species, needed
+for mixing ratio output)
+--------------------------------------------------------------------------------
diff --git a/options/SPECIES/SPECIES_002 b/options/SPECIES/SPECIES_002
index d957d10e..371e65b0 100644
--- a/options/SPECIES/SPECIES_002
+++ b/options/SPECIES/SPECIES_002
@@ -10,6 +10,7 @@
PDENSITY=-0.9E+9, ! Dry deposition (particles) - rho
PDQUER=0., ! Dry deposition (particles) - dquer
PDSIGMA=0., ! Dry deposition (particles) - dsig
+ PNDIA=1, ! Dry deposition (particles) - ndia
PDRYVEL=-9.9, ! Alternative: dry deposition velocity
PRELDIFF=1.6, ! Dry deposition (gases) - D
PHENRY=1.0E-2, ! Dry deposition (gases) - Henrys const.
diff --git a/options/SPECIES/SPECIES_003 b/options/SPECIES/SPECIES_003
index c561d5ce..3df5f23c 100644
--- a/options/SPECIES/SPECIES_003
+++ b/options/SPECIES/SPECIES_003
@@ -10,6 +10,7 @@
PDENSITY=-0.9E+9, ! Dry deposition (particles) - rho
PDQUER=0.0, ! Dry deposition (particles) - dquer
PDSIGMA=0.0, ! Dry deposition (particles) - dsig
+ PNDIA=1, ! Dry deposition (particles) - ndia
PDRYVEL=-9.99, ! Alternative: dry deposition velocity
PRELDIFF=1.2, ! Dry deposition (gases) - D
PHENRY=2.0E-03, ! Dry deposition (gases) - Henrys const.
diff --git a/options/SPECIES/SPECIES_004 b/options/SPECIES/SPECIES_004
index 26b6e263..2fea08e6 100644
--- a/options/SPECIES/SPECIES_004
+++ b/options/SPECIES/SPECIES_004
@@ -10,6 +10,7 @@
PDENSITY=-0.9E9, ! Dry deposition (particles) - rho
PDQUER=0.0, ! Dry deposition (particles) - dquer
PDSIGMA=0.0, ! Dry deposition (particles) - dsig
+ PNDIA=1, ! Dry deposition (particles) - ndia
PDRYVEL=-9.99, ! Alternative: dry deposition velocity
PRELDIFF=1.6, ! Dry deposition (gases) - D
PHENRY=1.0E-02, ! Dry deposition (gases) - Henrys const.
diff --git a/options/SPECIES/SPECIES_005 b/options/SPECIES/SPECIES_005
index 3d32f6fb..900a461c 100644
--- a/options/SPECIES/SPECIES_005
+++ b/options/SPECIES/SPECIES_005
@@ -10,6 +10,7 @@
PDENSITY=-0.9E+9, ! Dry deposition (particles) - rho
PDQUER=0.0, ! Dry deposition (particles) - dquer
PDSIGMA=0.0, ! Dry deposition (particles) - dsig
+ PNDIA=1, ! Dry deposition (particles) - ndia
PDRYVEL=-9.99, ! Alternative: dry deposition velocity
PRELDIFF=1.9, ! Dry deposition (gases) - D
PHENRY=1E14, ! Dry deposition (gases) - Henrys const.
diff --git a/options/SPECIES/SPECIES_006 b/options/SPECIES/SPECIES_006
index 263a5d6c..446441a6 100644
--- a/options/SPECIES/SPECIES_006
+++ b/options/SPECIES/SPECIES_006
@@ -10,6 +10,7 @@
PDENSITY=-0.9E+9, ! Dry deposition (particles) - rho
PDQUER=0.0, ! Dry deposition (particles) - dquer
PDSIGMA=0.0, ! Dry deposition (particles) - dsig
+ PNDIA=1, ! Dry deposition (particles) - ndia
PDRYVEL=-9.99, ! Alternative: dry deposition velocity
PRELDIFF=1.6, ! Dry deposition (gases) - D
PHENRY=100000.0, ! Dry deposition (gases) - Henrys const.
diff --git a/options/SPECIES/SPECIES_007 b/options/SPECIES/SPECIES_007
index c29c4589..362ff3ae 100644
--- a/options/SPECIES/SPECIES_007
+++ b/options/SPECIES/SPECIES_007
@@ -10,6 +10,7 @@
PDENSITY=-0.9E+9, ! Dry deposition (particles) - rho
PDQUER=0.0, ! Dry deposition (particles) - dquer
PDSIGMA=0.0, ! Dry deposition (particles) - dsig
+ PNDIA=1, ! Dry deposition (particles) - ndia
PDRYVEL=-9.99, ! Alternative: dry deposition velocity
PRELDIFF=1.4, ! Dry deposition (gases) - D
PHENRY=100000.0, ! Dry deposition (gases) - Henrys const.
diff --git a/options/SPECIES/SPECIES_008 b/options/SPECIES/SPECIES_008
index 5878deac..5c49b9b0 100644
--- a/options/SPECIES/SPECIES_008
+++ b/options/SPECIES/SPECIES_008
@@ -10,6 +10,7 @@
PDENSITY=-0.9E9, ! Dry deposition (particles) - rho
PDQUER=0.0, ! Dry deposition (particles) - dquer
PDSIGMA=0.0, ! Dry deposition (particles) - dsig
+ PNDIA=1, ! Dry deposition (particles) - ndia
PDRYVEL=-9.99, ! Alternative: dry deposition velocity
PRELDIFF=1.6, ! Dry deposition (gases) - D
PHENRY=1.0E-02, ! Dry deposition (gases) - Henrys const.
diff --git a/options/SPECIES/SPECIES_009 b/options/SPECIES/SPECIES_009
index 5069aa50..b15e0955 100644
--- a/options/SPECIES/SPECIES_009
+++ b/options/SPECIES/SPECIES_009
@@ -10,6 +10,7 @@
PDENSITY=-0.9E+9, ! Dry deposition (particles) - rho
PDQUER=0.0, ! Dry deposition (particles) - dquer
PDSIGMA=0.0, ! Dry deposition (particles) - dsig
+ PNDIA=1, ! Dry deposition (particles) - ndia
PDRYVEL=-9.99, ! Alternative: dry deposition velocity
PRELDIFF=1,3, ! Dry deposition (gases) - D
PHENRY=6000.0, ! Dry deposition (gases) - Henrys const.
diff --git a/options/SPECIES/SPECIES_010 b/options/SPECIES/SPECIES_010
index b1760674..2fb4e88d 100644
--- a/options/SPECIES/SPECIES_010
+++ b/options/SPECIES/SPECIES_010
@@ -10,6 +10,7 @@
PDENSITY=-0.9E+9, ! Dry deposition (particles) - rho
PDQUER=0.0, ! Dry deposition (particles) - dquer
PDSIGMA=0.0, ! Dry deposition (particles) - dsig
+ PNDIA=1, ! Dry deposition (particles) - ndia
PDRYVEL=-9.99, ! Alternative: dry deposition velocity
PRELDIFF=2.6, ! Dry deposition (gases) - D
PHENRY=3.6, ! Dry deposition (gases) - Henrys const.
diff --git a/options/SPECIES/SPECIES_011 b/options/SPECIES/SPECIES_011
index 5f59ea57..371c515e 100644
--- a/options/SPECIES/SPECIES_011
+++ b/options/SPECIES/SPECIES_011
@@ -10,6 +10,7 @@
PDENSITY=-0.9E+9, ! Dry deposition (particles) - rho
PDQUER=0.0, ! Dry deposition (particles) - dquer
PDSIGMA=0.0, ! Dry deposition (particles) - dsig
+ PNDIA=1, ! Dry deposition (particles) - ndia
PDRYVEL=-9.99, ! Alternative: dry deposition velocity
PRELDIFF=1.1, ! Dry deposition (gases) - D
PHENRY=2.0E14, ! Dry deposition (gases) - Henrys const.
diff --git a/options/SPECIES/SPECIES_012 b/options/SPECIES/SPECIES_012
index 9c64b66e..d4bd4ac2 100644
--- a/options/SPECIES/SPECIES_012
+++ b/options/SPECIES/SPECIES_012
@@ -10,6 +10,7 @@
PDENSITY=2000.0, ! Dry deposition (particles) - rho
PDQUER=4.0E-07, ! Dry deposition (particles) - dquer
PDSIGMA=3.3, ! Dry deposition (particles) - dsig
+ PNDIA=1, ! Dry deposition (particles) - ndia
PDRYVEL=-9.99, ! Alternative: dry deposition velocity
PRELDIFF=-9.9, ! Dry deposition (gases) - D
PHENRY=-0.9E+9, ! Dry deposition (gases) - Henrys const.
diff --git a/options/SPECIES/SPECIES_013 b/options/SPECIES/SPECIES_013
index 2a384dae..21da254f 100644
--- a/options/SPECIES/SPECIES_013
+++ b/options/SPECIES/SPECIES_013
@@ -10,6 +10,7 @@
PDENSITY=2.0E+3, ! Dry deposition (particles) - rho
PDQUER=4.0E-07, ! Dry deposition (particles) - dquer
PDSIGMA=3.3, ! Dry deposition (particles) - dsig
+ PNDIA=1, ! Dry deposition (particles) - ndia
PDRYVEL=-9.99, ! Alternative: dry deposition velocity
PRELDIFF=-9.9, ! Dry deposition (gases) - D
PHENRY=-0.9E+9, ! Dry deposition (gases) - Henrys const.
diff --git a/options/SPECIES/SPECIES_014 b/options/SPECIES/SPECIES_014
index 5f4114e2..5ad90790 100644
--- a/options/SPECIES/SPECIES_014
+++ b/options/SPECIES/SPECIES_014
@@ -10,6 +10,7 @@
PDENSITY=-0.9E+9, ! Dry deposition (particles) - rho
PDQUER=0.0, ! Dry deposition (particles) - dquer
PDSIGMA=0.0, ! Dry deposition (particles) - dsig
+ PNDIA=1, ! Dry deposition (particles) - ndia
PDRYVEL=-9.99, ! Alternative: dry deposition velocity
PRELDIFF=2.7, ! Dry deposition (gases) - D
PHENRY=100000.0, ! Dry deposition (gases) - Henrys const.
diff --git a/options/SPECIES/SPECIES_015 b/options/SPECIES/SPECIES_015
index c3e12111..d8fad0fa 100644
--- a/options/SPECIES/SPECIES_015
+++ b/options/SPECIES/SPECIES_015
@@ -10,6 +10,7 @@
PDENSITY=2500.0, ! Dry deposition (particles) - rho
PDQUER=6.0E-07, ! Dry deposition (particles) - dquer
PDSIGMA=3.3, ! Dry deposition (particles) - dsig
+ PNDIA=1, ! Dry deposition (particles) - ndia
PDRYVEL=-9.99, ! Alternative: dry deposition velocity
PRELDIFF=-9.9, ! Dry deposition (gases) - D
PHENRY=-9.9, ! Dry deposition (gases) - Henrys const.
diff --git a/options/SPECIES/SPECIES_016 b/options/SPECIES/SPECIES_016
index b3bd842a..fad26c57 100644
--- a/options/SPECIES/SPECIES_016
+++ b/options/SPECIES/SPECIES_016
@@ -10,6 +10,7 @@
PDENSITY=1900.0, ! Dry deposition (particles) - rho
PDQUER=0.4E-06, ! Dry deposition (particles) - dquer
PDSIGMA=3.3, ! Dry deposition (particles) - dsig
+ PNDIA=1, ! Dry deposition (particles) - ndia
PDRYVEL=-9.99, ! Alternative: dry deposition velocity
PRELDIFF=-9.9, ! Dry deposition (gases) - D
PHENRY=-0.9E-9, ! Dry deposition (gases) - Henrys const.
diff --git a/options/SPECIES/SPECIES_017 b/options/SPECIES/SPECIES_017
index cc2cb2bf..54d9aec2 100644
--- a/options/SPECIES/SPECIES_017
+++ b/options/SPECIES/SPECIES_017
@@ -10,6 +10,8 @@
PDENSITY=2500.0, ! Dry deposition (particles) - rho
PDQUER=6.0E-07, ! Dry deposition (particles) - dquer
PDSIGMA=3.3, ! Dry deposition (particles) - dsig
+ PNDIA=1, ! Dry deposition (particles) - ndia
+ PNDIA=1, ! Dry deposition (particles) - ndia
PDRYVEL=-9.99, ! Alternative: dry deposition velocity
PRELDIFF=-9.9, ! Dry deposition (gases) - D
PHENRY=-0.9E-9, ! Dry deposition (gases) - Henrys const.
diff --git a/options/SPECIES/SPECIES_018 b/options/SPECIES/SPECIES_018
index 80e7e41f..e10df574 100644
--- a/options/SPECIES/SPECIES_018
+++ b/options/SPECIES/SPECIES_018
@@ -10,6 +10,7 @@
PDENSITY=2500.0, ! Dry deposition (particles) - rho
PDQUER=6.0E-07, ! Dry deposition (particles) - dquer
PDSIGMA=3.3, ! Dry deposition (particles) - dsig
+ PNDIA=1, ! Dry deposition (particles) - ndia
PDRYVEL=-9.99, ! Alternative: dry deposition velocity
PRELDIFF=-9.9, ! Dry deposition (gases) - D
PHENRY=-0.9E-9, ! Dry deposition (gases) - Henrys const.
diff --git a/options/SPECIES/SPECIES_019 b/options/SPECIES/SPECIES_019
index 61f688f5..76cc9868 100644
--- a/options/SPECIES/SPECIES_019
+++ b/options/SPECIES/SPECIES_019
@@ -10,6 +10,7 @@
PDENSITY=-0.9E+9, ! Dry deposition (particles) - rho
PDQUER=0.0, ! Dry deposition (particles) - dquer
PDSIGMA=0.0, ! Dry deposition (particles) - dsig
+ PNDIA=1, ! Dry deposition (particles) - ndia
PDRYVEL=-9.99, ! Alternative: dry deposition velocity
PRELDIFF=-9.9, ! Dry deposition (gases) - D
PHENRY=-0.9E-9, ! Dry deposition (gases) - Henrys const.
diff --git a/options/SPECIES/SPECIES_020 b/options/SPECIES/SPECIES_020
index c656ee7e..17dafa57 100644
--- a/options/SPECIES/SPECIES_020
+++ b/options/SPECIES/SPECIES_020
@@ -10,6 +10,7 @@
PDENSITY=2500.0, ! Dry deposition (particles) - rho
PDQUER=6.0E-07, ! Dry deposition (particles) - dquer
PDSIGMA=3.3, ! Dry deposition (particles) - dsig
+ PNDIA=1, ! Dry deposition (particles) - ndia
PDRYVEL=-9.99, ! Alternative: dry deposition velocity
PRELDIFF=-9.9, ! Dry deposition (gases) - D
PHENRY=-0.9E-9, ! Dry deposition (gases) - Henrys const.
diff --git a/options/SPECIES/SPECIES_021 b/options/SPECIES/SPECIES_021
index 3fd7630c..4d89b6c7 100644
--- a/options/SPECIES/SPECIES_021
+++ b/options/SPECIES/SPECIES_021
@@ -10,6 +10,7 @@
PDENSITY=-0.9E+9, ! Dry deposition (particles) - rho
PDQUER=0.0, ! Dry deposition (particles) - dquer
PDSIGMA=0.0, ! Dry deposition (particles) - dsig
+ PNDIA=1, ! Dry deposition (particles) - ndia
PDRYVEL=-9.99, ! Alternative: dry deposition velocity
PRELDIFF=-9.9, ! Dry deposition (gases) - D
PHENRY=-0.9E-9, ! Dry deposition (gases) - Henrys const.
diff --git a/options/SPECIES/SPECIES_022 b/options/SPECIES/SPECIES_022
index d3379763..50accc07 100644
--- a/options/SPECIES/SPECIES_022
+++ b/options/SPECIES/SPECIES_022
@@ -10,6 +10,7 @@
PDENSITY=-0.9E+9, ! Dry deposition (particles) - rho
PDQUER=0.0, ! Dry deposition (particles) - dquer
PDSIGMA=0.0, ! Dry deposition (particles) - dsig
+ PNDIA=1, ! Dry deposition (particles) - ndia
PDRYVEL=-9.99, ! Alternative: dry deposition velocity
PRELDIFF=-9.9, ! Dry deposition (gases) - D
PHENRY=-0.9E-9, ! Dry deposition (gases) - Henrys const.
diff --git a/options/SPECIES/SPECIES_023 b/options/SPECIES/SPECIES_023
index 29495352..12461e76 100644
--- a/options/SPECIES/SPECIES_023
+++ b/options/SPECIES/SPECIES_023
@@ -10,6 +10,7 @@
PDENSITY=-0.9E-9, ! Dry deposition (particles) - rho
PDQUER=0.0, ! Dry deposition (particles) - dquer
PDSIGMA=0.0, ! Dry deposition (particles) - dsig
+ PNDIA=1, ! Dry deposition (particles) - ndia
PDRYVEL=-9.99, ! Alternative: dry deposition velocity
PRELDIFF=2.0, ! Dry deposition (gases) - D
PHENRY=100000.0, ! Dry deposition (gases) - Henrys const.
diff --git a/options/SPECIES/SPECIES_024 b/options/SPECIES/SPECIES_024
index 703e7455..92284f31 100644
--- a/options/SPECIES/SPECIES_024
+++ b/options/SPECIES/SPECIES_024
@@ -10,6 +10,7 @@
PDENSITY=-0.9E+9, ! Dry deposition (particles) - rho
PDQUER=0.0, ! Dry deposition (particles) - dquer
PDSIGMA=0.0, ! Dry deposition (particles) - dsig
+ PNDIA=1, ! Dry deposition (particles) - ndia
PDRYVEL=-9.99, ! Alternative: dry deposition velocity
PRELDIFF=-9.9, ! Dry deposition (gases) - D
PHENRY=-0.9E-9, ! Dry deposition (gases) - Henrys const.
diff --git a/options/SPECIES/SPECIES_025 b/options/SPECIES/SPECIES_025
index 7567baed..f41666a2 100644
--- a/options/SPECIES/SPECIES_025
+++ b/options/SPECIES/SPECIES_025
@@ -10,6 +10,7 @@
PDENSITY=1400.0, ! Dry deposition (particles) - rho
PDQUER=2.5E-07, ! Dry deposition (particles) - dquer
PDSIGMA=1.25, ! Dry deposition (particles) - dsig
+ PNDIA=1, ! Dry deposition (particles) - ndia
PDRYVEL=-9.99, ! Alternative: dry deposition velocity
PRELDIFF=-9.9, ! Dry deposition (gases) - D
PHENRY=-0.9E-9, ! Dry deposition (gases) - Henrys const.
diff --git a/options/SPECIES/SPECIES_026 b/options/SPECIES/SPECIES_026
index 9312b5e5..da37f55e 100644
--- a/options/SPECIES/SPECIES_026
+++ b/options/SPECIES/SPECIES_026
@@ -10,6 +10,7 @@
PDENSITY=-0.9E+9, ! Dry deposition (particles) - rho
PDQUER=0.0, ! Dry deposition (particles) - dquer
PDSIGMA=0.0, ! Dry deposition (particles) - dsig
+ PNDIA=1, ! Dry deposition (particles) - ndia
PDRYVEL=-9.99, ! Alternative: dry deposition velocity
PRELDIFF=-9.9, ! Dry deposition (gases) - D
PHENRY=-0.9E-9, ! Dry deposition (gases) - Henrys const.
diff --git a/options/SPECIES/SPECIES_027 b/options/SPECIES/SPECIES_027
index 50574872..6265f9ba 100644
--- a/options/SPECIES/SPECIES_027
+++ b/options/SPECIES/SPECIES_027
@@ -10,6 +10,7 @@
PDENSITY=-0.9E+9, ! Dry deposition (particles) - rho
PDQUER=0.0, ! Dry deposition (particles) - dquer
PDSIGMA=0.0, ! Dry deposition (particles) - dsig
+ PNDIA=1, ! Dry deposition (particles) - ndia
PDRYVEL=-9.99, ! Alternative: dry deposition velocity
PRELDIFF=-9.9, ! Dry deposition (gases) - D
PHENRY=-0.9E-9, ! Dry deposition (gases) - Henrys const.
diff --git a/options/SPECIES/SPECIES_031 b/options/SPECIES/SPECIES_031
index 57638cf8..701f2866 100644
--- a/options/SPECIES/SPECIES_031
+++ b/options/SPECIES/SPECIES_031
@@ -10,6 +10,7 @@
PDENSITY=-0.9E+9, ! Dry deposition (particles) - rho
PDQUER=0.0, ! Dry deposition (particles) - dquer
PDSIGMA=0.0, ! Dry deposition (particles) - dsig
+ PNDIA=1, ! Dry deposition (particles) - ndia
PDRYVEL=-9.99, ! Alternative: dry deposition velocity
PRELDIFF=4.3, ! Dry deposition (gases) - D
PHENRY=3.1, ! Dry deposition (gases) - Henrys const.
diff --git a/options/SPECIES/SPECIES_034 b/options/SPECIES/SPECIES_034
index 5fac2029..5e7ebe27 100644
--- a/options/SPECIES/SPECIES_034
+++ b/options/SPECIES/SPECIES_034
@@ -10,6 +10,7 @@
PDENSITY=-0.9E+9, ! Dry deposition (particles) - rho
PDQUER=0.0, ! Dry deposition (particles) - dquer
PDSIGMA=0.0, ! Dry deposition (particles) - dsig
+ PNDIA=1, ! Dry deposition (particles) - ndia
PDRYVEL=-9.99, ! Alternative: dry deposition velocity
PRELDIFF=4.3, ! Dry deposition (gases) - D
PHENRY=422.0, ! Dry deposition (gases) - Henrys const.
diff --git a/options/SPECIES/SPECIES_040 b/options/SPECIES/SPECIES_040
index db992872..c84cd113 100644
--- a/options/SPECIES/SPECIES_040
+++ b/options/SPECIES/SPECIES_040
@@ -7,9 +7,10 @@
PCSNOW_AERO=1.0, ! Below-cloud scavenging (particles) - Csnow (csnow_aero)
PCCN_AERO=0.9, ! In-cloud scavenging (particles) - CCNeff (ccn_aero)
PIN_AERO=0.1, ! In-cloud scavenging (particles) - INeff (in_aero)
- PDENSITY=2000.0, ! Dry deposition (particles) - rho
- PDQUER=4.0E-07, ! Dry deposition (particles) - dquer
+ PDENSITY=1000.0, ! Dry deposition (particles) - rho
+ PDQUER=50.0E-06, ! Dry deposition (particles) - dquer (equivalent diameter for shape)
PDSIGMA=3.3, ! Dry deposition (particles) - dsig
+ PNDIA=1, ! Dry deposition (particles) - ndia
PDRYVEL=-9.9, ! Alternative: dry deposition velocity
PRELDIFF=-9.9, ! Dry deposition (gases) - D
PHENRY=-0.9E-9, ! Dry deposition (gases) - Henrys const.
@@ -18,4 +19,10 @@
POHCCONST=-0.9E-9, ! OH Reaction rate - C [cm^3/molecule/sec]
POHDCONST=-9.9, ! OH Reaction rate - D [K]
POHNCONST=2.0, ! OH Reaction rate - C [cm^3/molecule/sec]
+ PSHAPE=1, ! 0 for sphere, 1 any shape (defined by axes PLA,PIA,PSA), 2-cylinder, 3-cube, 4-tetrahedron, 5-octahedron, 6-ellipsoid
+ PASPECTRATIO=20.0 ! Aspect ratio of cylinders: works for PSHAPE=2 only
+ PLA=940, ! Longest axis in micrometer (Bagheri & Bonadonna 2016): only for PSHAPE=1
+ PIA=9.4, ! Intermediate axis in micrometer: only for PSHAPE=1
+ PSA=9.4, ! Smallest axis in micrometer: only for PSHAPE=1
+ PORIENT=0, ! 0 for horizontal, 1 for random orientation of particles, 2 for an average between random and horizontal
/
diff --git a/options/surfdata.t b/options/surfdata.t
index 95a38fb7..d19e8410 100644
--- a/options/surfdata.t
+++ b/options/surfdata.t
@@ -1,17 +1,17 @@
-13 landuse categories are related roughness length
---------------------------------------------------------
-landuse comment z0
---------------------------------------------------------
- 1 Urban land 0.7
- 2 Agricultural land 0.1
- 3 Range land 0.1
- 4 Deciduous forest 1.
- 5 Coniferous forest 1.
- 6 Mixed forest including wetland 0.7
- 7 water, both salt and fresh 0.001
- 8 barren land mostly desert 0.01
- 9 nonforested wetland 0.1
-10 mixed agricultural and range land 0.1
-11 rocky open areas with low grow shrubs 0.05
-12 snow and ice 0.001
-13 rainforest 1.
+13 landuse categories are related roughness length
+--------------------------------------------------------
+landuse comment z0
+--------------------------------------------------------
+ 1 Urban land 0.7
+ 2 Agricultural land 0.1
+ 3 Range land 0.1
+ 4 Deciduous forest 1.
+ 5 Coniferous forest 1.
+ 6 Mixed forest including wetland 0.7
+ 7 water, both salt and fresh 0.001
+ 8 barren land mostly desert 0.01
+ 9 nonforested wetland 0.1
+10 mixed agricultural and range land 0.1
+11 rocky open areas with low grow shrubs 0.05
+12 snow and ice 0.001
+13 rainforest 1.
diff --git a/src/FLEXPART.f90 b/src/FLEXPART.f90
index 94dd7d30..307680d6 100644
--- a/src/FLEXPART.f90
+++ b/src/FLEXPART.f90
@@ -17,10 +17,15 @@ program flexpart
! Changes: *
! Unified ECMWF and GFS builds *
! Marian Harustak, 12.5.2017 *
+ ! (moved to read_options_and_initialise_flexpart by LB) *
! - Added detection of metdata format using gributils routines *
! - Distinguished calls to ecmwf/gfs gridcheck versions based on *
! detected metdata format *
! - Passed metdata format down to timemanager *
+ ! L. Bakels 2022 *
+ ! - OpenMP parallelisation *
+ ! - Added input options *
+ ! - Restructuring into subroutines (below) *
!*****************************************************************************
! *
! Variables: *
@@ -28,35 +33,22 @@ program flexpart
! Constants: *
! *
!*****************************************************************************
-
- use point_mod
+ use omp_lib, only: OMP_GET_MAX_THREADS
use par_mod
use com_mod
- use conv_mod
-
- use random_mod, only: gasdev1
- use class_gribfile
-
-#ifdef USE_NCF
- use netcdf_output_mod, only: writeheader_netcdf
-#endif
+ use timemanager_mod
+ use output_mod
implicit none
- integer :: i,j,ix,jy,inest, iopt
- integer :: idummy = -320
- character(len=256) :: inline_options !pathfile, flexversion, arg2
- integer :: metdata_format = GRIBFILE_CENTRE_UNKNOWN
- integer :: detectformat
-
-
- ! Generate a large number of random numbers
- !******************************************
+ real :: s_timemanager
+ character(len=256) :: &
+ inline_options ! pathfile, flexversion, arg2
- do i=1,maxrand-1,2
- call gasdev1(idummy,rannumb(i),rannumb(i+1))
- end do
- call gasdev1(idummy,rannumb(maxrand),rannumb(maxrand-1))
+ ! Keeping track of the total running time of FLEXPART, printed out at the end.
+ !*****************************************************************************
+ CALL SYSTEM_CLOCK(count_clock, count_rate, count_max)
+ s_total = (count_clock - count_clock0)/real(count_rate)
! FLEXPART version string
@@ -89,176 +81,191 @@ program flexpart
!*******************************************************
print*,'Welcome to FLEXPART ', trim(flexversion)
print*,'FLEXPART is free software released under the GNU General Public License.'
-
+ write(*,*) 'FLEXPART is running with ', trim(wind_coord_type), 'coordinates.'
+ ! Reading the number of threads available and print them for user
+ !****************************************************************
+#ifdef _OPENMP
+ numthreads = OMP_GET_MAX_THREADS()
+ numthreads_grid = min(numthreads,max_numthreads_grid)
+ !numthreads = min(40,numthreads)
+#else
+ numthreads = 1
+ numthreads_grid = 1
+#endif
- ! Ingest inline options
- !*******************************************************
- if (inline_options(1:1).eq.'-') then
- print*,'inline_options:',inline_options
- !verbose mode
- iopt=index(inline_options,'v')
- if (iopt.gt.0) then
- verbosity=1
- !print*, iopt, inline_options(iopt+1:iopt+1)
- if (trim(inline_options(iopt+1:iopt+1)).eq.'2') then
- print*, 'Verbose mode 2: display more detailed information during run'
- verbosity=2
- endif
- endif
- !debug mode
- iopt=index(inline_options,'d')
- if (iopt.gt.0) then
- debug_mode=.true.
- endif
- if (trim(inline_options).eq.'-i') then
- print*, 'Info mode: provide detailed run specific information and stop'
- verbosity=1
- info_flag=1
- endif
- if (trim(inline_options).eq.'-i2') then
- print*, 'Info mode: provide more detailed run specific information and stop'
- verbosity=2
- info_flag=1
- endif
- endif
-
- if (verbosity.gt.0) then
- print*, 'nxmax=',nxmax
- print*, 'nymax=',nymax
- print*, 'nzmax=',nzmax
- print*,'nxshift=',nxshift
+ if (numthreads.gt.1) then
+ write(*,*)
+ write(*,*) "*********** WARNING *********************************"
+ write(*,*) "* FLEXPART running in parallel mode *"
+ write(*,*) "* Number of uncertainty classes in *"
+ write(*,*) "* set to number of threads:", numthreads_grid, ". *"
+ write(*,*) "* All other computations are done with *"
+ write(*,*) "* ", numthreads, " threads. *"
+ write(*,*) "******************************************************"
+ write(*,*)
endif
+
+ ! Reading user specified options, allocating fields and checking bounds
+ !**********************************************************************
+ call read_options_and_initialise_flexpart
+
+ ! Inform whether output kernel is used or not
+ !*********************************************
+ if (lroot) then
+ if (.not.lusekerneloutput) then
+ write(*,*) "Concentrations are calculated without using kernel"
+ else
+ write(*,*) "Concentrations are calculated using kernel"
+ end if
+ end if
+
+ if (turboff) write(*,*) 'Turbulence switched off'
+
+ ! Calculate particle trajectories
+ !********************************
+ CALL SYSTEM_CLOCK(count_clock, count_rate, count_max)
+ s_timemanager = (count_clock - count_clock0)/real(count_rate)
+
+ call timemanager
+
+ CALL SYSTEM_CLOCK(count_clock, count_rate, count_max)
+ s_timemanager = (count_clock - count_clock0)/real(count_rate) - s_timemanager
+
+ CALL SYSTEM_CLOCK(count_clock, count_rate, count_max)
+ s_total = (count_clock - count_clock0)/real(count_rate) - s_total
- if (verbosity.gt.0) then
- write(*,*) 'call readpaths'
- endif
+ write(*,*) 'Read wind fields: ', s_readwind, ' seconds'
+ write(*,*) 'Timemanager: ', s_timemanager, ' seconds,', 'first timestep: ',s_firstt, 'seconds'
+ write(*,*) 'Write particle files: ', s_writepart, ' seconds'
+ write(*,*) 'Total running time: ', s_total, ' seconds'
+ write(*,*) 'tps,io,tot: ', (s_timemanager-s_firstt)/4.,(s_readwind+s_writepart)/5.,s_total
+ write(*,*) 'CONGRATULATIONS: YOU HAVE SUCCESSFULLY COMPLETED A FLE&
+ &XPART MODEL RUN!'
+
+end program flexpart
+
+
+subroutine read_options_and_initialise_flexpart
+
+ !*****************************************************************************
+ ! *
+ ! Moved from main flexpart program: *
+ ! Reading all option files, initialisation of random numbers, and *
+ ! allocating memory for windfields, grids, etc. *
+ ! *
+ ! L. Bakels 2022 *
+ ! *
+ !*****************************************************************************
+
+ use point_mod
+ use random_mod
+ use par_mod
+ use com_mod
+ use conv_mod
+ use class_gribfile
+ use readoptions_mod
+ use windfields_mod
+ use plume_mod
+ use initialise_mod
+ use drydepo_mod
+ use getfields_mod
+ use interpol_mod, only: interpol_allocate
+ use outg_mod
+ use binary_output_mod
+
+ implicit none
+
+ integer :: &
+ i, & ! loop variable for number of points
+ inest ! loop variable for nested gridcells
+ integer :: &
+ j, & ! loop variable for random numbers
+ idummy=-320 ! dummy value used by the random routine
+
+ call allocate_random(numthreads)
+
+ ! Generate a large number of random numbers
+ !******************************************
+ do j=1,maxrand-1,2
+ call gasdev1(idummy,rannumb(j),rannumb(j+1))
+ end do
+ call gasdev1(idummy,rannumb(maxrand),rannumb(maxrand-1))
+
+ ! Read pathnames from file in working director that specify I/O directories
+ !**************************************************************************
call readpaths
-
- if (verbosity.gt.1) then !show clock info
- !print*,'length(4)',length(4)
- !count=0,count_rate=1000
- CALL SYSTEM_CLOCK(count_clock0, count_rate, count_max)
- !WRITE(*,*) 'SYSTEM_CLOCK',count, count_rate, count_max
- !WRITE(*,*) 'SYSTEM_CLOCK, count_clock0', count_clock0
- !WRITE(*,*) 'SYSTEM_CLOCK, count_rate', count_rate
- !WRITE(*,*) 'SYSTEM_CLOCK, count_max', count_max
- endif
! Read the user specifications for the current model run
!*******************************************************
-
- if (verbosity.gt.0) then
- write(*,*) 'call readcommand'
- endif
call readcommand
- if (verbosity.gt.0) then
- write(*,*) ' ldirect=', ldirect
- write(*,*) ' ibdate,ibtime=',ibdate,ibtime
- write(*,*) ' iedate,ietime=', iedate,ietime
- if (verbosity.gt.1) then
- CALL SYSTEM_CLOCK(count_clock, count_rate, count_max)
- write(*,*) 'SYSTEM_CLOCK',(count_clock - count_clock0)/real(count_rate) !, count_rate, count_max
- endif
- endif
-
- ! Initialize arrays in com_mod
- !*****************************
- call com_mod_allocate_part(maxpart)
-
! Read the age classes to be used
!********************************
- if (verbosity.gt.0) then
- write(*,*) 'call readageclasses'
- endif
call readageclasses
- if (verbosity.gt.1) then
- CALL SYSTEM_CLOCK(count_clock, count_rate, count_max)
- write(*,*) 'SYSTEM_CLOCK',(count_clock - count_clock0)/real(count_rate) !, count_rate, count_max
- endif
+
+ ! Allocate memory for windfields
+ !*******************************
+ call windfields_allocate
+ if (numbnests.ge.1) then
+ ! If nested wind fields are used, allocate arrays
+ !************************************************
+ call windfields_nest_allocate
+ endif
! Read, which wind fields are available within the modelling period
!******************************************************************
-
- if (verbosity.gt.0) then
- write(*,*) 'call readavailable'
- endif
call readavailable
+ if (ipout.ne.0) call readpartoptions
+
! Detect metdata format
!**********************
- if (verbosity.gt.0) then
- write(*,*) 'call detectformat'
- endif
-
- metdata_format = detectformat()
+ call detectformat
if (metdata_format.eq.GRIBFILE_CENTRE_ECMWF) then
print *,'ECMWF metdata detected'
+ if (nxshift.eq.-9999) nxshift=359
elseif (metdata_format.eq.GRIBFILE_CENTRE_NCEP) then
print *,'NCEP metdata detected'
+ if (nxshift.eq.-9999) nxshift=0
else
print *,'Unknown metdata format'
stop
endif
-
-
-
- ! If nested wind fields are used, allocate arrays
- !************************************************
-
- if (verbosity.gt.0) then
- write(*,*) 'call com_mod_allocate_nests'
- endif
- call com_mod_allocate_nests
+ write(*,*) 'NXSHIFT is set to', nxshift
! Read the model grid specifications,
! both for the mother domain and eventual nests
!**********************************************
-
- if (verbosity.gt.0) then
- write(*,*) 'call gridcheck'
- endif
-
if (metdata_format.eq.GRIBFILE_CENTRE_ECMWF) then
call gridcheck_ecmwf
- else
+ else
call gridcheck_gfs
- end if
-
- if (verbosity.gt.1) then
- CALL SYSTEM_CLOCK(count_clock, count_rate, count_max)
- write(*,*) 'SYSTEM_CLOCK',(count_clock - count_clock0)/real(count_rate) !, count_rate, count_max
- endif
-
- if (verbosity.gt.0) then
- write(*,*) 'call gridcheck_nests'
- endif
- call gridcheck_nests
+ endif
- ! Read the output grid specifications
- !************************************
+ ! Set the upper level for where the convection will be working
+ !*************************************************************
+ call set_upperlevel_convect
- if (verbosity.gt.0) then
- write(*,*) 'call readoutgrid'
+ if (numbnests.ge.1) then
+ ! If nested wind fields are used, allocate arrays
+ !************************************************
+ call gridcheck_nests
endif
- call readoutgrid
+ ! Read the output grid specifications if requested by user
+ !*********************************************************
+ if (iout.ne.0) then
+ call readoutgrid
- if (nested_output.eq.1) then
- call readoutgrid_nest
- if (verbosity.gt.0) then
- write(*,*) '# readoutgrid_nest'
+ if (nested_output.eq.1) then
+ call readoutgrid_nest
endif
endif
! Read the receptor points for which extra concentrations are to be calculated
!*****************************************************************************
-
- if (verbosity.eq.1) then
- print*,'call readreceptors'
- endif
call readreceptors
! Read the physico-chemical species property table
@@ -266,210 +273,132 @@ program flexpart
!SEC: now only needed SPECIES are read in readreleases.f
!call readspecies
-
! Read the landuse inventory
!***************************
+ call readlanduse ! CHECK ETA
- if (verbosity.gt.0) then
- print*,'call readlanduse'
- endif
- call readlanduse
-
- ! Assign fractional cover of landuse classes to each ECMWF grid point
- !********************************************************************
-
- if (verbosity.gt.0) then
- print*,'call assignland'
- endif
- call assignland
-
- ! Read the coordinates of the release locations
- !**********************************************
-
- if (verbosity.gt.0) then
- print*,'call readreleases'
- endif
- call readreleases
-
- ! Read and compute surface resistances to dry deposition of gases
- !****************************************************************
-
- if (verbosity.gt.0) then
- print*,'call readdepo'
- endif
- call readdepo
+ ! For continuation of previous run or from user defined initial
+ ! conditions, read in particle positions
+ !*************************************************************************
+ call flexpart_initialise_particles
! Convert the release point coordinates from geografical to grid coordinates
!***************************************************************************
+ call coordtrafo(nxmin1,nymin1) ! CHECK ETA
- call coordtrafo
- if (verbosity.gt.0) then
- print*,'call coordtrafo'
- endif
-
- ! Initialize all particles to non-existent
- !*****************************************
-
- if (verbosity.gt.0) then
- print*,'Initialize all particles to non-existent'
- endif
- do j=1,maxpart
- itra1(j)=-999999999
- end do
+ ! Read and compute surface resistances to dry deposition of gases
+ !****************************************************************
+ call readdepo ! CHECK ETA
- ! For continuation of previous run, read in particle positions
- !*************************************************************
+ ! Allocate dry deposition fields if necessary
+ !*********************************************
+ call drydepo_allocate
+ call convection_allocate
+ call getfields_allocate
+ call interpol_allocate
- if (ipin.eq.1) then
- if (verbosity.gt.0) then
- print*,'call readpartpositions'
- endif
- call readpartpositions
- else
- if (verbosity.gt.0) then
- print*,'numpart=0, numparticlecount=0'
- endif
- numpart=0
- numparticlecount=0
- endif
+ ! Assign fractional cover of landuse classes to each ECMWF grid point
+ !********************************************************************
+ call assignland ! CHECK ETA
! Calculate volume, surface area, etc., of all output grid cells
! Allocate fluxes and OHfield if necessary
!***************************************************************
-
- if (verbosity.gt.0) then
- print*,'call outgrid_init'
+ if (iout.ne.0) then
+ call outgrid_init ! CHECK ETA
+ if (nested_output.eq.1) call outgrid_init_nest ! CHECK ETA
endif
- call outgrid_init
- if (nested_output.eq.1) call outgrid_init_nest
! Read the OH field
!******************
-
- if (OHREA.eqv..TRUE.) then
- if (verbosity.gt.0) then
- print*,'call readOHfield'
- endif
- call readOHfield
- endif
-
- ! Write basic information on the simulation to a file "header"
- ! and open files that are to be kept open throughout the simulation
- !******************************************************************
-
-#ifdef USE_NCF
- if (lnetcdfout.eq.1) then
- call writeheader_netcdf(lnest=.false.)
- else
- call writeheader
- end if
-
- if (nested_output.eq.1) then
- if (lnetcdfout.eq.1) then
- call writeheader_netcdf(lnest=.true.)
- else
- call writeheader_nest
- endif
- endif
-#endif
-
- if (verbosity.gt.0) then
- print*,'call writeheader'
+ if (OHREA) then
+ call readOHfield ! CHECK ETA
endif
- call writeheader
- ! FLEXPART 9.2 ticket ?? write header in ASCII format
- call writeheader_txt
- !if (nested_output.eq.1) call writeheader_nest
- if (nested_output.eq.1.and.surf_only.ne.1) call writeheader_nest
- if (nested_output.eq.1.and.surf_only.eq.1) call writeheader_nest_surf
- if (nested_output.ne.1.and.surf_only.eq.1) call writeheader_surf
-
- !open(unitdates,file=path(2)(1:length(2))//'dates')
-
- if (verbosity.gt.0) then
- print*,'call openreceptors'
- endif
+#ifndef USE_NCF
call openreceptors
- if ((iout.eq.4).or.(iout.eq.5)) call openouttraj
+#endif
+ if ((iout.eq.4).or.(iout.eq.5)) call openouttraj ! CHECK ETA
- ! Releases can only start and end at discrete times (multiples of lsynctime)
- !***************************************************************************
-
- if (verbosity.gt.0) then
- print*,'discretize release times'
- endif
- do i=1,numpoint
- ireleasestart(i)=nint(real(ireleasestart(i))/real(lsynctime))*lsynctime
- ireleaseend(i)=nint(real(ireleaseend(i))/real(lsynctime))*lsynctime
- end do
! Initialize cloud-base mass fluxes for the convection scheme
!************************************************************
- if (verbosity.gt.0) then
- print*,'Initialize cloud-base mass fluxes for the convection scheme'
- endif
-
- do jy=0,nymin1
- do ix=0,nxmin1
- cbaseflux(ix,jy)=0.
- end do
- end do
+ cbaseflux(0:nxmin1,0:nymin1)=0.
do inest=1,numbnests
- do jy=0,nyn(inest)-1
- do ix=0,nxn(inest)-1
- cbasefluxn(ix,jy,inest)=0.
- end do
- end do
+ cbasefluxn(0:nxn(inest)-1,0:nyn(inest)-1,inest)=0.
end do
- ! Inform whether output kernel is used or not
- !*********************************************
- if (lroot) then
- if (.not.lusekerneloutput) then
- write(*,*) "Concentrations are calculated without using kernel"
- else
- write(*,*) "Concentrations are calculated using kernel"
- end if
- end if
+ ! Allocating nan_count for CBL option
+ !************************************
+ allocate(nan_count(numthreads))
+end subroutine read_options_and_initialise_flexpart
- ! Calculate particle trajectories
- !********************************
+subroutine flexpart_initialise_particles
- if (verbosity.gt.0) then
- if (verbosity.gt.1) then
- CALL SYSTEM_CLOCK(count_clock, count_rate, count_max)
- write(*,*) 'SYSTEM_CLOCK',(count_clock - count_clock0)/real(count_rate) !, count_rate, count_max
- endif
- if (info_flag.eq.1) then
- print*, 'info only mode (stop)'
- stop
- endif
- print*,'call timemanager'
- endif
+ !*****************************************************************************
+ ! *
+ ! This subroutine handles the different forms of starting FLEXPART *
+ ! depending on IPIN (set in COMMAND) *
+ ! *
+ ! IPIN=0: this routine is not called and particles are read from the *
+ ! RELEASE option file *
+ ! IPIN=1: restarting from a restart.bin file, written by a previous run *
+ ! IPIN=2: restarting from a partoutput_xxx.nc file written by a previous *
+ ! run, depending on what PARTOPTIONS the user has chosen, this *
+ ! option might not be possible to use *
+ ! IPIN=3: starting a run from a user defined initial particle conditions, *
+ ! more on how to create such a file can be found in the manual *
+ ! IPIN=4: restarting a run, while also reading in the initial particle *
+ ! conditions *
+ ! *
+ ! Author: L. Bakels 2022 *
+ ! *
+ !*****************************************************************************
+
+ use point_mod
+ use com_mod
+ use initialise_mod
+#ifdef USE_NCF
+ use netcdf_output_mod
+#endif
+ use readoptions_mod
+ use restart_mod
+
+ implicit none
+
+ integer :: i
+
+ ! Read the coordinates of the release locations
+ !**********************************************
+ if (ipin.le.2) call readreleases ! CHECK ETA
- if (verbosity.gt.0) write (*,*) 'timemanager> call wetdepo'
- call timemanager(metdata_format)
-
-
- if (verbosity.gt.0) then
-! NIK 16.02.2005
- do i=1,nspec
- if (tot_inc_count(i).gt.0) then
- write(*,*) '**********************************************'
- write(*,*) 'Scavenging statistics for species ', species(i), ':'
- write(*,*) 'Total number of occurences of below-cloud scavenging', &
- & tot_blc_count(i)
- write(*,*) 'Total number of occurences of in-cloud scavenging', &
- & tot_inc_count(i)
- write(*,*) '**********************************************'
- endif
+ itime_init=0
+ if ((ipin.eq.1).or.(ipin.eq.4)) then ! Restarting from restart.bin file
+ call readrestart
+ else if (ipin.eq.2) then ! Restarting from netcdf partoutput file
+#ifdef USE_NCF
+ call readpartpositions
+#else
+ stop 'Compile with netCDF if you want to use the ipin=2 option.'
+#endif
+ else if (ipin.eq.3) then ! User defined particle properties
+ ! Reading initial conditions from netcdf file
+#ifdef USE_NCF
+ call readinitconditions_netcdf
+#else
+ stop 'Compile with netCDF if you want to use the ipin=3 option.'
+#endif
+ else
+ ! Releases can only start and end at discrete times (multiples of lsynctime)
+ !***************************************************************************
+ do i=1,numpoint
+ ireleasestart(i)=nint(real(ireleasestart(i))/real(lsynctime))*lsynctime
+ ireleaseend(i)=nint(real(ireleaseend(i))/real(lsynctime))*lsynctime
end do
+ numpart=0
+ numparticlecount=0
endif
-
- write(*,*) 'CONGRATULATIONS: YOU HAVE SUCCESSFULLY COMPLETED A FLE&
- &XPART MODEL RUN!'
-end program flexpart
+end subroutine flexpart_initialise_particles
\ No newline at end of file
diff --git a/src/advance_mod.f90 b/src/advance_mod.f90
new file mode 100644
index 00000000..37265ec3
--- /dev/null
+++ b/src/advance_mod.f90
@@ -0,0 +1,802 @@
+! SPDX-FileCopyrightText: FLEXPART 1998-2019, see flexpart_license.txt
+! SPDX-License-Identifier: GPL-3.0-or-later
+
+!*****************************************************************************
+! *
+! L. Bakels 2022: This module contains the computation of particle *
+! trajectories *
+! *
+!*****************************************************************************
+
+module advance_mod
+ use point_mod
+ use par_mod
+ use com_mod
+ use interpol_mod
+ use cmapf_mod
+ use random_mod, only: ran3,iseed1
+ use coordinates_ecmwf_mod
+ use particle_mod
+ use turbulence_mod
+ use settling_mod
+
+ implicit none
+ real, parameter :: &
+ eps2=1.e-9, &
+ eps3=tiny(1.0), &
+ eps_eta=1.e-4
+ real :: &
+ eps
+ private :: advance_abovePBL,advance_PBL,advance_PettersonCorrection,&
+ advance_updateXY,advance_adjusttopheight
+contains
+
+subroutine advance(itime,ipart,thread)
+ !*****************************************************************************
+ ! *
+ ! Calculation of turbulent particle trajectories utilizing a *
+ ! zero-acceleration scheme, which is corrected by a numerically more *
+ ! accurate Petterssen scheme whenever possible. *
+ ! *
+ ! Particle positions are read in, incremented, and returned to the calling *
+ ! program. *
+ ! *
+ ! In different regions of the atmosphere (PBL vs. free troposphere), *
+ ! different parameters are needed for advection, parameterizing turbulent *
+ ! velocities, etc. For efficiency, different interpolation routines have *
+ ! been written for these different cases, with the disadvantage that there *
+ ! exist several routines doing almost the same. They all share the *
+ ! included file 'interpol_mod'. The following *
+ ! interpolation routines are used: *
+ ! *
+ ! interpol_all(_nests) interpolates everything (called inside the PBL) *
+ ! interpol_misslev(_nests) if a particle moves vertically in the PBL, *
+ ! additional parameters are interpolated if it *
+ ! crosses a model level *
+ ! interpol_wind(_nests) interpolates the wind and determines the *
+ ! standard deviation of the wind (called outside *
+ ! PBL) also interpolates potential vorticity *
+ ! interpol_wind_short(_nests) only interpolates the wind (needed for the *
+ ! Petterssen scheme) *
+ ! interpol_vdep(_nests) interpolates deposition velocities *
+ ! *
+ ! *
+ ! Author: A. Stohl *
+ ! *
+ ! 16 December 1997 *
+ ! *
+ ! Changes: *
+ ! *
+ ! 8 April 2000: Deep convection parameterization *
+ ! *
+ ! May 2002: Petterssen scheme introduced *
+ ! *
+ ! 2021, L. Bakels: *
+ ! - Separated PBL and above PBL computations in different *
+ ! subroutines *
+ ! - Moved all turbulence computations to turbulence_mod.f90 *
+ !*****************************************************************************
+ ! *
+ ! Variables: *
+ ! icbt 1 if particle not transferred to forbidden state, *
+ ! else -1 *
+ ! dawsave accumulated displacement in along-wind direction *
+ ! dcwsave accumulated displacement in cross-wind direction *
+ ! dxsave accumulated displacement in longitude *
+ ! dysave accumulated displacement in latitude *
+ ! h [m] Mixing height *
+ ! lwindinterv [s] time interval between two wind fields *
+ ! itime [s] time at which this subroutine is entered *
+ ! itimec [s] actual time, which is incremented in this subroutine *
+ ! href [m] height for which dry deposition velocity is calculated *
+ ! ladvance [s] Total integration time period *
+ ! ldirect 1 forward, -1 backward *
+ ! ldt [s] Time step for the next integration *
+ ! lsynctime [s] Synchronisation interval of FLEXPART *
+ ! ngrid index which grid is to be used *
+ ! nrand index for a variable to be picked from rannumb *
+ ! nstop if > 1 particle has left domain and must be stopped *
+ ! prob probability of absorption due to dry deposition *
+ ! rannumb(maxrand) normally distributed random variables *
+ ! rhoa air density *
+ ! rhograd vertical gradient of the air density *
+ ! up,vp,wp random velocities due to turbulence (along wind, cross *
+ ! wind, vertical wind *
+ ! usig,vsig,wsig mesoscale wind fluctuations *
+ ! xt,yt,zt Particle position *
+ ! *
+ !*****************************************************************************
+
+ ! openmp change
+ use omp_lib, only: OMP_GET_THREAD_NUM
+ ! openmp change end
+
+ implicit none
+ integer, intent(in) :: &
+ itime, & ! time index
+ ipart, & ! particle index
+ thread ! OMP thread
+ integer :: &
+ itimec, &
+ i,j,k, & ! loop variables
+ nrand, & ! random number used for turbulence
+ memindnext, & ! seems useless
+ ngr, & ! temporary new grid index of moved particle
+ nsp ! loop variables for number of species
+ real :: &
+ ux,vy, & ! random turbulent velocities above PBL
+ weta_settling, & ! Settling velocity in eta coordinates
+ tropop, & ! height of troposphere
+ dxsave,dysave, & ! accumulated displacement in long and lat
+ dawsave,dcwsave ! accumulated displacement in wind directions
+ logical :: &
+ abovePBL ! flag that will be set to 'true' if computation needs to be completed above PBL
+
+ eps=nxmax/3.e5
+
+ part(ipart)%nstop=.false.
+ do i=1,nmixz
+ indzindicator(i)=.true.
+ end do
+
+ if (DRYDEP) then ! reset probability for deposition
+ depoindicator=.true.
+ part(ipart)%prob=0.
+ endif
+
+ if (lsettling) part(ipart)%settling=0.
+
+ !if (ipart.eq.1) write(*,*) 'Mass: ', part(ipart)%mass(:), itime
+ dxsave=0. ! reset position displacements
+ dysave=0. ! due to mean wind
+ dawsave=0. ! and turbulent wind
+ dcwsave=0.
+
+ itimec=itime
+
+ nrand=int(ran3(iseed1(thread),thread)*real(maxrand-1))+1
+
+ ! Determine whether lat/long grid or polarstereographic projection
+ ! is to be used
+ ! Furthermore, determine which nesting level to be used
+ !*****************************************************************
+ call find_ngrid(part(ipart)%xlon,part(ipart)%ylat)
+
+ !***************************
+ ! Interpolate necessary data
+ !***************************
+
+ if (abs(itime-memtime(1)).lt.abs(itime-memtime(2))) then
+ memindnext=1
+ else
+ memindnext=2
+ endif
+
+ ! Convert z(eta) to z(m) for the turbulence scheme, w(m/s)
+ ! is computed in verttransform_ecmwf.f90
+
+ call update_zeta_to_z(itime,ipart)
+
+ ! Determine nested grid coordinates
+ ! Determine the lower left corner and its distance to the current position
+ ! Calculate variables for time interpolation
+ !*******************************************
+ call initialise_interpol_mod(itime,real(part(ipart)%xlon),real(part(ipart)%ylat),&
+ real(part(ipart)%z),real(part(ipart)%zeta))
+
+ ! Compute maximum mixing height around particle position
+ !*******************************************************
+
+ ! Compute the height of the troposphere and the PBL at the x-y location of the particle
+ call interpol_htropo_hmix(tropop,h)
+ zeta=real(part(ipart)%z)/h
+
+ !*************************************************************
+ ! If particle is in the PBL, interpolate once and then make a
+ ! time loop until end of interval is reached
+ !*************************************************************
+ ! In the PBL we use meters instead of eta coordinates for the vertical transport
+ abovePBL=.true.
+ if (zeta.le.1.) then
+ abovePBL=.false.
+ call advance_PBL(itime,itimec,&
+ dxsave,dysave,dawsave,dcwsave,abovePBL,nrand,ipart,thread)
+ if ((wind_coord_type.eq.'ETA').and.(lsettling)) then
+ call w_to_weta(itime,real(part(ipart)%idt),part(ipart)%xlon, &
+ part(ipart)%ylat,part(ipart)%z,part(ipart)%zeta, &
+ part(ipart)%settling,weta_settling)
+ weta=weta+weta_settling
+ endif
+
+ endif
+
+ !**********************************************************
+ ! For all particles that are outside the PBL, make a single
+ ! time step. Only horizontal turbulent disturbances are
+ ! calculated. Vertical disturbances are reset.
+ !**********************************************************
+
+ ! Interpolate the wind
+ !*********************
+ if (abovePBL) then
+ call advance_abovePBL(itime,itimec,&
+ dxsave,dysave,ux,vy,tropop,nrand,ipart)
+ endif ! Above PBL computation
+
+ !****************************************************************
+ ! Add mesoscale random disturbances
+ ! This is done only once for the whole lsynctime interval to save
+ ! computation time
+ !****************************************************************
+
+
+ ! Mesoscale wind velocity fluctuations are obtained by scaling
+ ! with the standard deviation of the grid-scale winds surrounding
+ ! the particle location, multiplied by a factor turbmesoscale.
+ ! The autocorrelation time constant is taken as half the
+ ! time interval between wind fields
+ !****************************************************************
+ if (.not. turboff) then ! mesoscale turbulence is found to give issues, so turned off
+ if (mesoscale_turbulence) then
+ call interpol_mesoscale(itime,real(part(ipart)%xlon),real(part(ipart)%ylat), &
+ real(part(ipart)%z),real(part(ipart)%zeta))
+ call turbulence_mesoscale(nrand,dxsave,dysave,ipart,usig,vsig,wsig,wsigeta,eps_eta)
+ endif
+
+ !*************************************************************
+ ! Transform along and cross wind components to xy coordinates,
+ ! add them to u and v, transform u,v to grid units/second
+ ! and calculate new position
+ !*************************************************************
+
+ call windalign(dxsave,dysave,dawsave,dcwsave,ux,vy)
+ dxsave=dxsave+ux ! comment by mc: comment this line to stop the particles horizontally for test reasons
+ dysave=dysave+vy
+ endif
+
+ call advance_updateXY(dxsave,dysave,ipart)
+ if (part(ipart)%nstop.eqv..true.) return
+
+ ! If particle above highest model level, set it back into the domain
+ !*******************************************************************
+ call advance_adjusttopheight(ipart)
+
+ !************************************************************************
+ ! Now we could finish, as this was done in FLEXPART versions up to 4.0.
+ ! However, truncation errors of the advection can be significantly
+ ! reduced by doing one iteration of the Petterssen scheme, if this is
+ ! possible.
+ ! Note that this is applied only to the grid-scale winds, not to
+ ! the turbulent winds.
+ !************************************************************************
+
+ ! The Petterssen scheme can only applied with long time steps (only then u
+ ! is the "old" wind as required by the scheme); otherwise do nothing
+ !*************************************************************************
+
+ if (part(ipart)%idt.ne.abs(lsynctime)) return
+
+ ! The Petterssen scheme can only be applied if the ending time of the time step
+ ! (itime+ldt*ldirect) is still between the two wind fields held in memory;
+ ! otherwise do nothing
+ !******************************************************************************
+
+ if (abs(itime+part(ipart)%idt*ldirect).gt.abs(memtime(2))) return
+
+ ! Apply it also only if starting and ending point of current time step are on
+ ! the same grid; otherwise do nothing
+ !*****************************************************************************
+ ! ngr = ngrid
+ ! call find_ngrid(part(ipart)%xlon,part(ipart)%ylat)
+
+ if (nglobal.and.(real(part(ipart)%ylat).gt.switchnorthg)) then
+ ngr=-1
+ else if (sglobal.and.(real(part(ipart)%ylat).lt.switchsouthg)) then
+ ngr=-2
+ else
+ ngr=0
+ ! Temporary fix for nested layer edges: replaced eps with dxn and dyn (LB)
+ do j=numbnests,1,-1
+ if ((real(part(ipart)%xlon).gt.xln(j)+dxn(j)).and.(real(part(ipart)%xlon).lt.xrn(j)-dxn(j)).and. &
+ (real(part(ipart)%ylat).gt.yln(j)+dyn(j)).and.(real(part(ipart)%ylat).lt.yrn(j)-dyn(j))) then
+ ngr=j
+ exit
+ endif
+ end do
+ endif
+
+ if (ngr.ne.ngrid) return
+
+ call advance_PettersonCorrection(itime,ipart)
+end subroutine advance
+
+subroutine advance_abovePBL(itime,itimec,dxsave,dysave,&
+ ux,vy,tropop,nrand,ipart)
+
+ implicit none
+ integer, intent(in) :: &
+ itime, & ! time index
+ ipart ! particle index
+ integer, intent(inout) :: &
+ itimec, & ! next timestep
+ nrand ! random number used for turbulence
+ real, intent(in) :: &
+ tropop ! height of troposphere
+ real, intent(inout) :: &
+ ux,vy, & ! random turbulent velocities above PBL
+ dxsave,dysave ! accumulated displacement in long and lat
+ real :: &
+ dt, & ! real(ldt)
+ xts,yts,zts,ztseta, & ! local 'real' copy of the particle position
+ weta_settling, & ! settling velocity in eta coordinates
+ wp ! random turbulence velocities
+ integer :: &
+ insp,nsp ! loop variables for number of species
+
+ zts=real(part(ipart)%z)
+ ztseta=real(part(ipart)%zeta)
+ xts=real(part(ipart)%xlon)
+ yts=real(part(ipart)%ylat)
+ if (lsettling) part(ipart)%settling=0.
+
+ call interpol_wind(itime,xts,yts,zts,ztseta,ipart)
+
+ ! Compute everything for above the PBL
+
+ ! Assume constant, uncorrelated, turbulent perturbations
+ ! In the stratosphere, use a small vertical diffusivity d_strat,
+ ! in the troposphere, use a larger horizontal diffusivity d_trop.
+ ! Turbulent velocity scales are determined based on sqrt(d_trop/dt)
+ !******************************************************************
+
+ part(ipart)%idt=abs(lsynctime-itimec+itime)
+ dt=real(part(ipart)%idt)
+
+ if (.not.turboff) then
+ call turbulence_stratosphere(dt,nrand,ux,vy,wp,tropop,zts)
+ else
+ !sec switch off turbulence
+ ux=0.0
+ vy=0.0
+ wp=0.0
+ endif
+
+ ! If particle represents only a single species, add gravitational settling
+ ! velocity. The settling velocity is zero for gases
+ !*************************************************************************
+ ! Does not work in eta coordinates yet
+ if (mdomainfill.eq.0) then
+ if (lsettling) then
+ if ((ipin.ne.3).and.(ipin.ne.4)) then
+ do insp=1,nspec
+ nsp=insp
+ if (xmass(part(ipart)%npoint,nsp).gt.eps3) exit
+ end do
+ else
+ nsp=1
+ endif
+ ! LB change to eta coords?
+ if (density(nsp).gt.0.) then
+ call get_settling(itime,xts,yts,zts,nsp,part(ipart)%settling)
+ select case (wind_coord_type)
+ case ('ETA')
+ call update_zeta_to_z(itime,ipart)
+ call w_to_weta(itime,dt,part(ipart)%xlon,part(ipart)%ylat, &
+ part(ipart)%z,part(ipart)%zeta,part(ipart)%settling,weta_settling)
+ weta=weta+weta_settling
+ case ('METER')
+ w=w+part(ipart)%settling
+ case default
+ w=w+part(ipart)%settling
+ end select
+ end if
+ endif
+ end if
+
+ ! Calculate position at time step itime+lsynctime
+ !************************************************
+ dxsave=dxsave+(u+ux)*dt
+ dysave=dysave+(v+vy)*dt
+
+ select case (wind_coord_type)
+ case ('ETA')
+ if (wp.ne.0.) then
+ call update_zeta_to_z(itime,ipart)
+ call update_z(ipart,wp*dt*real(ldirect))
+ if (part(ipart)%z.lt.0.) call set_z(ipart,min(h-eps2,-1.*part(ipart)%z)) ! if particle below ground -> reflection
+ call update_z_to_zeta(itime,ipart)
+ endif
+ call update_zeta(ipart,weta*dt*real(ldirect))
+ if (part(ipart)%zeta.ge.1.) call set_zeta(ipart,1.-(part(ipart)%zeta-1.))
+ if (part(ipart)%zeta.eq.1.) call update_zeta(ipart,-eps_eta)
+ case ('METER')
+ call update_z(ipart,(w+wp)*dt*real(ldirect))
+ if (part(ipart)%z.lt.0.) call set_z(ipart,min(h-eps2,-1.*part(ipart)%z))
+ case default
+ call update_z(ipart,(w+wp)*dt*real(ldirect))
+ if (part(ipart)%z.lt.0.) call set_z(ipart,min(h-eps2,-1.*part(ipart)%z))
+ end select
+end subroutine advance_abovePBL
+
+subroutine advance_PBL(itime,itimec,&
+ dxsave,dysave,dawsave,dcwsave,abovePBL,nrand,ipart,thread)
+ use drydepo_mod, only: drydepo_probability
+
+ implicit none
+
+ logical, intent(inout) :: &
+ abovePBL ! flag that will be set to 'true' if computation needs to be completed above PBL
+ integer, intent(in) :: &
+ itime, & ! time index
+ ipart, & ! particle index
+ thread ! number of the omp thread
+ real, intent(inout) :: &
+ dxsave,dysave, & ! accumulated displacement in long and lat
+ dawsave,dcwsave ! accumulated displacement in wind directions
+ integer, intent(inout) :: &
+ itimec, & ! next timestep
+ nrand ! random number used for turbulence
+ real :: &
+ dt, & ! real(ldt)
+ xts,yts,zts,ztseta, & ! local 'real' copy of the particle position
+ rhoa, & ! air density, used in CBL
+ rhograd ! vertical gradient of the air density, used in CBL
+ integer :: &
+ loop, & ! loop variable for time in the PBL
+ nsp,insp ! loop variable for species
+ real :: vdepo(maxspec) ! deposition velocities for all species
+
+ eps=nxmax/3.e5
+ if (lsettling) part(ipart)%settling=0.
+
+ ! BEGIN TIME LOOP
+ !================
+ ! For wind_coord_type=ETA:
+ ! Within this loop, only METER coordinates are used, and the new z value will be updated
+ ! to ETA coordinates at the end
+ !***************************************************************************************
+ call update_zeta_to_z(itime,ipart)
+
+ loop=0
+ pbl_loop : do
+ loop=loop+1
+ if (method.eq.1) then
+ part(ipart)%idt=min(part(ipart)%idt,abs(lsynctime-itimec+itime))
+ itimec=itimec+part(ipart)%idt*ldirect
+ else
+ part(ipart)%idt=abs(lsynctime)
+ itimec=itime+lsynctime
+ endif
+ dt=real(part(ipart)%idt)
+ xts=real(part(ipart)%xlon)
+ yts=real(part(ipart)%ylat)
+ zts=real(part(ipart)%z)
+
+ zeta=zts/h
+ if (loop.eq.1) then ! Temporal interpolation only done for the first iteration
+ if (ngrid.le.0) then
+ xts=real(part(ipart)%xlon)
+ yts=real(part(ipart)%ylat)
+ call interpol_PBL(itime,xts,yts,zts,real(part(ipart)%zeta))
+ else
+ call interpol_PBL(itime,xtn,ytn,zts,real(part(ipart)%zeta))
+ endif
+
+ else
+ ! Determine the level below the current position for u,v,rho
+ !***********************************************************
+ call find_z_level_meters(zts)
+
+ ! If one of the levels necessary is not yet available,
+ ! calculate it
+ !*****************************************************
+ call interpol_PBL_misslev()
+ endif
+
+
+ ! Vertical interpolation of u,v,w,rho and drhodz
+ !***********************************************
+
+ ! Vertical distance to the level below and above current position
+ ! both in terms of (u,v) and (w) fields
+ !****************************************************************
+ call interpol_PBL_short(zts,rhoa,rhograd) ! Vertical interpolation
+
+ ! Compute the turbulent disturbances
+ ! Determine the sigmas and the timescales
+ !****************************************
+ if (.not.turboff) then
+ call turbulence_boundarylayer(ipart,nrand,dt,zts,rhoa,rhograd,thread) ! Note: zts and nrand get updated
+ ! Determine time step for next integration
+ !*****************************************
+ if (turbswitch) then
+ part(ipart)%idt=int(min(tlw,h/max(2.*abs(part(ipart)%turbvel%w*sigw),1.e-5), &
+ 0.5/abs(dsigwdz))*ctl)
+ else
+ part(ipart)%idt=int(min(tlw,h/max(2.*abs(part(ipart)%turbvel%w),1.e-5))*ctl)
+ endif
+ else
+ part(ipart)%turbvel%u=0.0
+ part(ipart)%turbvel%v=0.0
+ part(ipart)%turbvel%w=0.0
+ endif
+
+ part(ipart)%idt=max(part(ipart)%idt,mintime)
+
+
+ ! If particle represents only a single species, add gravitational settling
+ ! velocity. The settling velocity is zero for gases, or if particle
+ ! represents more than one species
+ !*************************************************************************
+
+ if (mdomainfill.eq.0) then
+ if (lsettling) then
+ if ((ipin.ne.3).and.(ipin.ne.4)) then
+ do insp=1,nspec
+ nsp=insp
+ if (xmass(part(ipart)%npoint,nsp).gt.eps3) exit
+ end do
+ else
+ nsp=1
+ endif
+ if (density(nsp).gt.0.) then
+ call get_settling(itime,xts,yts,zts,nsp,part(ipart)%settling) !bugfix
+ w=w+part(ipart)%settling
+ end if
+ end if
+ endif
+
+ ! Horizontal displacements during time step dt are small real values compared
+ ! to the position; adding the two, would result in large numerical errors.
+ ! Thus, displacements are accumulated during lsynctime and are added to the
+ ! position at the end
+ !****************************************************************************
+
+ dxsave=dxsave+u*dt
+ dysave=dysave+v*dt
+ dawsave=dawsave+part(ipart)%turbvel%u*dt
+ dcwsave=dcwsave+part(ipart)%turbvel%v*dt
+ ! How can I change the w to w(eta) efficiently?
+ select case (wind_coord_type)
+ case ('ETA')
+ call update_z(ipart,w*dt*real(ldirect))
+ zts=real(part(ipart)%z)
+ ! HSO/AL: Particle managed to go over highest level -> interpolation error in goto 700
+ ! alias interpol_wind (division by zero)
+ if (zts.ge.height(nz)) call set_z(ipart,height(nz)-100.*eps) ! Manually for z instead
+ case ('METER')
+ call update_z(ipart,w*dt*real(ldirect))
+ call advance_adjusttopheight(ipart)
+ end select
+ zts=real(part(ipart)%z)
+
+ if (zts.gt.h) then
+ call update_z_to_zeta(itime,ipart)
+ if (itimec.ne.itime+lsynctime) abovePBL=.true. ! complete the current interval above PBL
+ return
+ endif
+
+ ! Determine probability of deposition
+ !************************************
+ call drydepo_probability(part(ipart)%prob,dt,zts,vdepo)
+
+ if (zts.lt.0.) call set_z(ipart,min(h-eps2,-1.*part(ipart)%z)) ! if particle below ground -> reflection
+
+
+ if (itimec.eq.(itime+lsynctime)) then
+ ! Converting the z position that changed through turbulence motions to eta coords
+ call update_z_to_zeta(itime,ipart)
+ return ! finished
+ endif
+ end do pbl_loop
+ call update_z_to_zeta(itime,ipart)
+end subroutine advance_PBL
+
+subroutine advance_PettersonCorrection(itime,ipart)
+
+ implicit none
+
+ integer, intent(in) :: &
+ itime, & ! time index
+ ipart ! particle index
+ integer :: &
+ nsp,insp ! loop variables for number of species
+ real :: &
+ xts,yts,zts,ztseta, & ! local 'real' copy of the particle position
+ uold,vold,wold,woldeta, &
+ weta_settling
+ real(kind=dp) :: &
+ ztemp ! temporarily storing z position
+
+
+ xts=real(part(ipart)%xlon)
+ yts=real(part(ipart)%ylat)
+ zts=real(part(ipart)%z)
+ ztseta=real(part(ipart)%zeta)
+ if (lsettling) part(ipart)%settling=0.
+
+ ! Memorize the old wind
+ !**********************
+
+ uold=u
+ vold=v
+
+ select case (wind_coord_type)
+ case ('ETA')
+ woldeta=weta
+ case ('METER')
+ wold=w
+ case default
+ wold=w
+ end select
+
+ ! Interpolate wind at new position and time
+ !******************************************
+ call interpol_wind_short(itime+part(ipart)%idt*ldirect,xts,yts,zts,ztseta)
+
+ if (mdomainfill.eq.0) then
+ if (lsettling) then
+ if ((ipin.ne.3).and.(ipin.ne.4)) then
+ do insp=1,nspec
+ nsp=insp
+ if (xmass(part(ipart)%npoint,nsp).gt.eps3) exit
+ end do
+ else
+ nsp=1
+ endif
+ if (density(nsp).gt.0.) then
+ select case (wind_coord_type)
+
+ case ('ETA')
+ call update_zeta_to_z(itime+part(ipart)%idt,ipart)
+ call update_z_to_zeta(itime+part(ipart)%idt,ipart)
+ zts=real(part(ipart)%z)
+ call get_settling(itime+part(ipart)%idt,xts,yts,zts,nsp,part(ipart)%settling) !bugfix
+ call w_to_weta(itime+part(ipart)%idt,real(part(ipart)%idt),part(ipart)%xlon, &
+ part(ipart)%ylat,part(ipart)%z,part(ipart)%zeta, &
+ part(ipart)%settling,weta_settling)
+ weta=weta+weta_settling
+ !woldeta=real(part(ipart)%zeta-part(ipart)%zeta_prev)/real(part(ipart)%idt*ldirect)
+ case ('METER')
+ call get_settling(itime+part(ipart)%idt,xts,yts,zts,nsp,part(ipart)%settling)
+ w=w+part(ipart)%settling
+
+ case default
+ call get_settling(itime+part(ipart)%idt,xts,yts,zts,nsp,part(ipart)%settling)
+ w=w+part(ipart)%settling
+ end select
+ end if
+ endif
+ end if
+
+ ! Determine the difference vector between new and old wind
+ ! (use half of it to correct position according to Petterssen)
+ !*************************************************************
+
+ u=(u-uold)/2.
+ v=(v-vold)/2.
+
+ select case (wind_coord_type)
+ case ('ETA')
+ weta=(weta-woldeta)/2.
+ call update_zeta(ipart,weta*real(part(ipart)%idt*ldirect))
+ if (part(ipart)%zeta.ge.1.) call set_zeta(ipart,1.-(part(ipart)%zeta-1.))
+ if (part(ipart)%zeta.eq.1.) call update_zeta(ipart,-eps_eta)
+
+ case ('METER')
+ w=(w-wold)/2.
+ call update_z(ipart,w*real(part(ipart)%idt*ldirect))
+ if (part(ipart)%z.lt.0.) call set_z(ipart,min(h-eps2,-1.*part(ipart)%z)) ! if particle below ground -> reflection
+
+ case default
+ w=(w-wold)/2.
+ call update_z(ipart,w*real(part(ipart)%idt*ldirect))
+ if (part(ipart)%z.lt.0.) call set_z(ipart,min(h-eps2,-1.*part(ipart)%z))
+ end select
+
+ ! Finally, correct the old position
+ !**********************************
+ call advance_updateXY(u*part(ipart)%idt,v*part(ipart)%idt,ipart)
+
+ ! If particle above highest model level, set it back into the domain
+ !*******************************************************************
+ call advance_adjusttopheight(ipart)
+end subroutine advance_PettersonCorrection
+
+subroutine advance_updateXY(xchange,ychange,ipart)
+
+ implicit none
+
+ integer, intent(in) :: &
+ ipart ! particle number
+ real, intent(in) :: &
+ xchange,ychange ! change in position
+ real :: &
+ xlon,ylat,xpol,ypol, & ! temporarily storing new particle positions
+ gridsize,cosfact ! used to compute new positions of particles
+
+ eps=nxmax/3.e5
+
+ if (ngrid.ge.0) then
+ cosfact=dxconst/cos((real(part(ipart)%ylat)*dy+ylat0)*pi180)
+ call update_xlon(ipart,real(xchange*cosfact*real(ldirect),kind=dp))
+ call update_ylat(ipart,real(ychange*dyconst*real(ldirect),kind=dp))
+ else if (ngrid.eq.-1) then ! around north pole
+ xlon=xlon0+real(part(ipart)%xlon)*dx !comment by mc: compute old particle position
+ ylat=ylat0+real(part(ipart)%ylat)*dy
+ call cll2xy(northpolemap,ylat,xlon,xpol,ypol) !convert old particle position in polar stereographic
+ gridsize=1000.*cgszll(northpolemap,ylat,xlon) !calculate size in m of grid element in polar stereographic coordinate
+ xpol=xpol+xchange/gridsize*real(ldirect) !position in grid unit polar stereographic
+ ypol=ypol+ychange/gridsize*real(ldirect)
+ call cxy2ll(northpolemap,xpol,ypol,ylat,xlon) !convert to lat long coordinate
+ call set_xlon(ipart,real((xlon-xlon0)/dx,kind=dp))!convert to grid units in lat long coordinate, comment by mc
+ call set_ylat(ipart,real((ylat-ylat0)/dy,kind=dp))
+ else if (ngrid.eq.-2) then ! around south pole
+ xlon=xlon0+real(part(ipart)%xlon)*dx
+ ylat=ylat0+real(part(ipart)%ylat)*dy
+ call cll2xy(southpolemap,ylat,xlon,xpol,ypol)
+ gridsize=1000.*cgszll(southpolemap,ylat,xlon)
+ xpol=xpol+xchange/gridsize*real(ldirect)
+ ypol=ypol+ychange/gridsize*real(ldirect)
+ call cxy2ll(southpolemap,xpol,ypol,ylat,xlon)
+ call set_xlon(ipart,real((xlon-xlon0)/dx,kind=dp))
+ call set_ylat(ipart,real((ylat-ylat0)/dy,kind=dp))
+ endif
+
+ ! If global data are available, use cyclic boundary condition
+ !************************************************************
+ if (xglobal) then
+ if (part(ipart)%xlon.ge.real(nxmin1,kind=dp)) call update_xlon(ipart,-real(nxmin1,kind=dp))
+ if (part(ipart)%xlon.lt.0.) call update_xlon(ipart,real(nxmin1,kind=dp))
+ if (part(ipart)%xlon.le.real(eps,kind=dp)) call set_xlon(ipart,real(eps,kind=dp))
+ if (abs(part(ipart)%xlon-real(nxmin1,kind=dp)).le.eps) call set_xlon(ipart,real(nxmin1-eps,kind=dp))
+ endif
+
+ ! HSO/AL: Prevent particles from disappearing at the pole
+ !******************************************************************
+ if (sglobal .and. part(ipart)%ylat.lt.0. ) then
+ call set_xlon(ipart,mod(part(ipart)%xlon+real(nxmin1/2.,kind=dp),real(nxmin1,kind=dp)))
+ call set_ylat(ipart,-part(ipart)%ylat)
+ ! In extremely rare cases, the ylat exceeds the bounds, so we set it back into the domain here
+ if ( part(ipart)%ylat.gt.real(nymin1,kind=dp) ) then
+ call set_ylat(ipart,real(nymin1,kind=dp)-mod(part(ipart)%ylat,real(nymin1,kind=dp)))
+ endif
+ else if (nglobal .and. part(ipart)%ylat.gt.real(nymin1,kind=dp) ) then
+ call set_xlon(ipart,mod(part(ipart)%xlon+real(nxmin1/2.,kind=dp),real(nxmin1,kind=dp)))
+ call set_ylat(ipart,2.*real(nymin1,kind=dp)-part(ipart)%ylat)
+ endif
+
+ ! Check position: If trajectory outside model domain, terminate it
+ !*****************************************************************
+ ! Not necessary to check when using global domain, but some problems in the meteo data could cause particles
+ ! to go crazy.
+ ! if (gdomainfill) return
+ if ((part(ipart)%xlon.lt.0.).or.(part(ipart)%xlon.ge.real(nxmin1,kind=dp)).or.(part(ipart)%ylat.lt.0.).or. &
+ (part(ipart)%ylat.gt.real(nymin1,kind=dp))) then
+ part(ipart)%nstop=.true.
+ return
+ endif
+end subroutine advance_updateXY
+
+subroutine advance_adjusttopheight(ipart)
+
+ implicit none
+
+ integer, intent(in) :: &
+ ipart ! particle index
+
+ eps=nxmax/3.e5
+
+ select case (wind_coord_type)
+ case ('ETA')
+ if (part(ipart)%zeta.le.real(uvheight(nz),kind=dp)) then
+ call set_zeta(ipart,uvheight(nz)+eps_eta)
+ endif
+ case ('METER')
+ if (part(ipart)%z.ge.real(height(nz),kind=dp)) call set_z(ipart,height(nz)-100.*eps)
+ case default
+ if (part(ipart)%z.ge.real(height(nz),kind=dp)) call set_z(ipart,height(nz)-100.*eps)
+ end select
+end subroutine advance_adjusttopheight
+
+end module advance_mod
diff --git a/src/binary_output_mod.f90 b/src/binary_output_mod.f90
new file mode 100644
index 00000000..b88e25a3
--- /dev/null
+++ b/src/binary_output_mod.f90
@@ -0,0 +1,4538 @@
+! SPDX-FileCopyrightText: FLEXPART 1998-2019, see flexpart_license.txt
+! SPDX-License-Identifier: GPL-3.0-or-later
+
+ !*****************************************************************************
+ ! *
+ ! This module contains routines that output gridded data to binary files. *
+ ! *
+ ! Not all routines that should have a netcdf equivalent, have one yet: *
+ ! writeheader_binary_nest_surf,writeheader_binary_surf,concoutput_surf, *
+ ! concoutput_surf_nest,initial_cond_output,initial_cond_output_inversion, *
+ ! concoutput_inversion_nest *
+ ! *
+ ! L. Bakels 2022 *
+ ! *
+ !*****************************************************************************
+
+module binary_output_mod
+
+ use point_mod
+ use outg_mod
+ use par_mod
+ use com_mod
+ use date_mod
+ use windfields_mod
+
+ implicit none
+
+contains
+
+subroutine writeheader_binary
+
+ !*****************************************************************************
+ ! *
+ ! This routine produces a file header containing basic information on the *
+ ! settings of the FLEXPART run. *
+ ! The header file is essential and must be read in by any postprocessing *
+ ! program before reading in the output data. *
+ ! *
+ ! Author: A. Stohl *
+ ! *
+ ! 7 August 2002 *
+ ! *
+ !*****************************************************************************
+ ! *
+ ! Modified to remove TRIM around the output of flexversion so that *
+ ! it will be a constant length (defined in com_mod.f90) in output header *
+ ! *
+ ! Don Morton, Boreal Scientific Computing *
+ ! 07 May 2017 *
+ ! *
+ !*****************************************************************************
+ ! *
+ ! Variables: *
+ ! *
+ ! xlon longitude *
+ ! xl model x coordinate *
+ ! ylat latitude *
+ ! yl model y coordinate *
+ ! *
+ !*****************************************************************************
+
+ implicit none
+
+ integer :: jjjjmmdd,ihmmss,i,ix,jy,j
+ real :: xp1,yp1,xp2,yp2
+
+
+ !************************
+ ! Open header output file
+ !************************
+
+ open(unitheader,file=path(2)(1:length(2))//'header', &
+ form='unformatted',err=998)
+
+
+ ! Write the header information
+ !*****************************
+
+ if (ldirect.eq.1) then
+ write(unitheader) ibdate,ibtime, flexversion
+ else
+ write(unitheader) iedate,ietime, flexversion
+ endif
+
+ ! Write info on output interval, averaging time, sampling time
+ !*************************************************************
+
+ write(unitheader) loutstep,loutaver,loutsample
+
+ ! Write information on output grid setup
+ !***************************************
+
+ write(unitheader) outlon0,outlat0,numxgrid,numygrid, &
+ dxout,dyout
+ write(unitheader) numzgrid,(outheight(i),i=1,numzgrid)
+
+ call caldate(bdate,jjjjmmdd,ihmmss)
+ write(unitheader) jjjjmmdd,ihmmss
+
+ ! Write number of species, and name for each species (+extra name for depositions)
+ ! Indicate the dimension of the fields (i.e., 1 for deposition fields, numzgrid for
+ ! concentration fields
+ !*****************************************************************************
+
+ write(unitheader) 3*nspec,maxpointspec_act
+ do i=1,nspec
+ write(unitheader) 1,'WD_'//species(i)(1:7)
+ write(unitheader) 1,'DD_'//species(i)(1:7)
+ write(unitheader) numzgrid,species(i)
+ end do
+
+ ! Write information on release points: total number, then for each point:
+ ! start, end, coordinates, # of particles, name, mass
+ !************************************************************************
+
+ write(unitheader) numpoint
+ do i=1,numpoint
+ write(unitheader) ireleasestart(i),ireleaseend(i),kindz(i)
+ xp1=xpoint1(i)*dx+xlon0
+ yp1=ypoint1(i)*dy+ylat0
+ xp2=xpoint2(i)*dx+xlon0
+ yp2=ypoint2(i)*dy+ylat0
+ write(unitheader) xp1,yp1,xp2,yp2,zpoint1(i),zpoint2(i)
+ write(unitheader) npart(i),1
+ if (numpoint.le.1000) then
+ write(unitheader) compoint(i)
+ else
+ write(unitheader) compoint(1001)
+ endif
+ do j=1,nspec
+ write(unitheader) xmass(i,j)
+ write(unitheader) xmass(i,j)
+ write(unitheader) xmass(i,j)
+ end do
+ end do
+
+ ! Write information on some model switches
+ !*****************************************
+
+ write(unitheader) method,lsubgrid,lconvection, &
+ ind_source,ind_receptor
+
+ ! Write age class information
+ !****************************
+
+ write(unitheader) nageclass,(lage(i),i=1,nageclass)
+
+
+ ! Write topography to output file
+ !********************************
+
+ do ix=0,numxgrid-1
+ write(unitheader) (oroout(ix,jy),jy=0,numygrid-1)
+ end do
+ close(unitheader)
+
+ return
+
+
+998 write(*,*) ' #### FLEXPART MODEL ERROR! THE FILE #### '
+ write(*,*) ' #### '//path(2)(1:length(2))//'header'//' #### '
+ write(*,*) ' #### CANNOT BE OPENED. IF A FILE WITH THIS #### '
+ write(*,*) ' #### NAME ALREADY EXISTS, DELETE IT AND START #### '
+ write(*,*) ' #### THE PROGRAM AGAIN. #### '
+ stop
+
+end subroutine writeheader_binary
+
+subroutine writeheader_binary_nest
+
+ !*****************************************************************************
+ ! *
+ ! This routine produces a file header containing basic information on the *
+ ! settings of the FLEXPART run. *
+ ! The header file is essential and must be read in by any postprocessing *
+ ! program before reading in the output data. *
+ ! *
+ ! Author: A. Stohl *
+ ! *
+ ! 7 August 2002 *
+ ! *
+ !*****************************************************************************
+ ! *
+ ! Modified to remove TRIM around the output of flexversion so that *
+ ! it will be a constant length (defined in com_mod.f90) in output header *
+ ! *
+ ! Don Morton, Boreal Scientific Computing *
+ ! 07 May 2017 *
+ ! *
+ !*****************************************************************************
+ ! *
+ ! Variables: *
+ ! *
+ ! xlon longitude *
+ ! xl model x coordinate *
+ ! ylat latitude *
+ ! yl model y coordinate *
+ ! *
+ !*****************************************************************************
+
+ implicit none
+
+ integer :: jjjjmmdd,ihmmss,i,ix,jy,j
+ real :: xp1,yp1,xp2,yp2
+
+
+ !************************
+ ! Open header output file
+ !************************
+
+ open(unitheader,file=path(2)(1:length(2))//'header_nest', &
+ form='unformatted',err=998)
+
+
+ ! Write the header information
+ !*****************************
+
+ if (ldirect.eq.1) then
+ write(unitheader) ibdate,ibtime, flexversion
+ else
+ write(unitheader) iedate,ietime, flexversion
+ endif
+
+ ! Write info on output interval, averaging time, sampling time
+ !*************************************************************
+
+ write(unitheader) loutstep,loutaver,loutsample
+
+ ! Write information on output grid setup
+ !***************************************
+
+ write(unitheader) outlon0n,outlat0n,numxgridn,numygridn, &
+ dxoutn,dyoutn
+ write(unitheader) numzgrid,(outheight(i),i=1,numzgrid)
+
+ call caldate(bdate,jjjjmmdd,ihmmss)
+ write(unitheader) jjjjmmdd,ihmmss
+
+ ! Write number of species, and name for each species (+extra name for depositions)
+ ! Indicate the dimension of the fields (i.e., 1 for deposition fields, numzgrid for
+ ! concentration fields
+ !*****************************************************************************
+
+ write(unitheader) 3*nspec,maxpointspec_act
+ do i=1,nspec
+ write(unitheader) 1,'WD_'//species(i)(1:7)
+ write(unitheader) 1,'DD_'//species(i)(1:7)
+ write(unitheader) numzgrid,species(i)
+ end do
+
+ ! Write information on release points: total number, then for each point:
+ ! start, end, coordinates, # of particles, name, mass
+ !************************************************************************
+
+ write(unitheader) numpoint
+ do i=1,numpoint
+ write(unitheader) ireleasestart(i),ireleaseend(i),kindz(i)
+ xp1=xpoint1(i)*dx+xlon0
+ yp1=ypoint1(i)*dy+ylat0
+ xp2=xpoint2(i)*dx+xlon0
+ yp2=ypoint2(i)*dy+ylat0
+ write(unitheader) xp1,yp1,xp2,yp2,zpoint1(i),zpoint2(i)
+ write(unitheader) npart(i),1
+ if (numpoint.le.1000) then
+ write(unitheader) compoint(i)
+ else
+ write(unitheader) compoint(1001)
+ endif
+ do j=1,nspec
+ write(unitheader) xmass(i,j)
+ write(unitheader) xmass(i,j)
+ write(unitheader) xmass(i,j)
+ end do
+ end do
+
+ ! Write information on some model switches
+ !*****************************************
+
+ write(unitheader) method,lsubgrid,lconvection, &
+ ind_source,ind_receptor
+
+ ! Write age class information
+ !****************************
+
+ write(unitheader) nageclass,(lage(i),i=1,nageclass)
+
+
+ ! Write topography to output file
+ !********************************
+
+ do ix=0,numxgridn-1
+ write(unitheader) (orooutn(ix,jy),jy=0,numygridn-1)
+ end do
+ close(unitheader)
+
+ return
+
+
+998 write(*,*) ' #### FLEXPART MODEL ERROR! THE FILE #### '
+ write(*,*) ' #### '//path(2)(1:length(2))//'header'//' #### '
+ write(*,*) ' #### CANNOT BE OPENED. IF A FILE WITH THIS #### '
+ write(*,*) ' #### NAME ALREADY EXISTS, DELETE IT AND START #### '
+ write(*,*) ' #### THE PROGRAM AGAIN. #### '
+ stop
+
+end subroutine writeheader_binary_nest
+
+subroutine writeheader_binary_nest_surf
+
+ !*****************************************************************************
+ ! *
+ ! This routine produces a file header containing basic information on the *
+ ! settings of the FLEXPART run. *
+ ! The header file is essential and must be read in by any postprocessing *
+ ! program before reading in the output data. *
+ ! *
+ ! Author: A. Stohl *
+ ! *
+ ! 7 August 2002 *
+ ! *
+ !*****************************************************************************
+ ! *
+ ! Modified to remove TRIM around the output of flexversion so that *
+ ! it will be a constant length (defined in com_mod.f90) in output header *
+ ! *
+ ! Don Morton, Boreal Scientific Computing *
+ ! 07 May 2017 *
+ ! *
+ !*****************************************************************************
+ ! *
+ ! Variables: *
+ ! *
+ ! xlon longitude *
+ ! xl model x coordinate *
+ ! ylat latitude *
+ ! yl model y coordinate *
+ ! *
+ !*****************************************************************************
+
+ implicit none
+
+ integer :: jjjjmmdd,ihmmss,i,ix,jy,j
+ real :: xp1,yp1,xp2,yp2
+
+
+ !************************
+ ! Open header output file
+ !************************
+
+ open(unitheader,file=path(2)(1:length(2))//'header_nest_grid_time', &
+ form='unformatted',err=998)
+
+
+ ! Write the header information
+ !*****************************
+
+ if (ldirect.eq.1) then
+ write(unitheader) ibdate,ibtime,flexversion
+ else
+ write(unitheader) iedate,ietime,flexversion
+ endif
+
+ ! Write info on output interval, averaging time, sampling time
+ !*************************************************************
+
+ write(unitheader) loutstep,loutaver,loutsample
+
+ ! Write information on output grid setup
+ !***************************************
+
+ write(unitheader) outlon0n,outlat0n,numxgridn,numygridn, &
+ dxoutn,dyoutn
+ write(unitheader) 1,(outheight(1),i=1,1)
+
+ call caldate(bdate,jjjjmmdd,ihmmss)
+ write(unitheader) jjjjmmdd,ihmmss
+
+ ! Write number of species, and name for each species (+extra name for depositions)
+ ! Indicate the dimension of the fields (i.e., 1 for deposition fields, numzgrid for
+ ! concentration fields
+ !*****************************************************************************
+
+ write(unitheader) 3*nspec,maxpointspec_act
+ do i=1,nspec
+ write(unitheader) 1,'WD_'//species(i)(1:7)
+ write(unitheader) 1,'DD_'//species(i)(1:7)
+ write(unitheader) 1,species(i)
+ end do
+
+ ! Write information on release points: total number, then for each point:
+ ! start, end, coordinates, # of particles, name, mass
+ !************************************************************************
+
+ write(unitheader) numpoint
+ do i=1,numpoint
+ write(unitheader) ireleasestart(i),ireleaseend(i),kindz(i)
+ xp1=xpoint1(i)*dx+xlon0
+ yp1=ypoint1(i)*dy+ylat0
+ xp2=xpoint2(i)*dx+xlon0
+ yp2=ypoint2(i)*dy+ylat0
+ write(unitheader) xp1,yp1,xp2,yp2,zpoint1(i),zpoint2(i)
+ write(unitheader) npart(i),1
+ if (numpoint.le.1000) then
+ write(unitheader) compoint(i)
+ else
+ write(unitheader) compoint(1001)
+ endif
+ do j=1,nspec
+ write(unitheader) xmass(i,j)
+ write(unitheader) xmass(i,j)
+ write(unitheader) xmass(i,j)
+ end do
+ end do
+
+ ! Write information on some model switches
+ !*****************************************
+
+ write(unitheader) method,lsubgrid,lconvection, &
+ ind_source,ind_receptor
+
+ ! Write age class information
+ !****************************
+
+ write(unitheader) nageclass,(lage(i),i=1,nageclass)
+
+
+ ! Write topography to output file
+ !********************************
+
+ do ix=0,numxgridn-1
+ write(unitheader) (orooutn(ix,jy),jy=0,numygridn-1)
+ end do
+ close(unitheader)
+
+ return
+
+
+998 write(*,*) ' #### FLEXPART MODEL ERROR! THE FILE #### '
+ write(*,*) ' #### '//path(2)(1:length(2))//'header'//' #### '
+ write(*,*) ' #### CANNOT BE OPENED. IF A FILE WITH THIS #### '
+ write(*,*) ' #### NAME ALREADY EXISTS, DELETE IT AND START #### '
+ write(*,*) ' #### THE PROGRAM AGAIN. #### '
+ stop
+
+end subroutine writeheader_binary_nest_surf
+
+subroutine writeheader_binary_surf
+
+ !*****************************************************************************
+ ! *
+ ! This routine produces a file header containing basic information on the *
+ ! settings of the FLEXPART run. *
+ ! The header file is essential and must be read in by any postprocessing *
+ ! program before reading in the output data. *
+ ! *
+ ! Author: A. Stohl *
+ ! *
+ ! 7 August 2002 *
+ ! *
+ !*****************************************************************************
+ ! *
+ ! Modified to remove TRIM around the output of flexversion so that *
+ ! it will be a constant length (defined in com_mod.f90) in output header *
+ ! *
+ ! Don Morton, Boreal Scientific Computing *
+ ! 07 May 2017 *
+ ! *
+ !*****************************************************************************
+ ! *
+ ! Variables: *
+ ! *
+ ! xlon longitude *
+ ! xl model x coordinate *
+ ! ylat latitude *
+ ! yl model y coordinate *
+ ! *
+ !*****************************************************************************
+
+ implicit none
+
+ integer :: jjjjmmdd,ihmmss,i,ix,jy,j
+ real :: xp1,yp1,xp2,yp2
+
+
+ !************************
+ ! Open header output file
+ !************************
+
+ open(unitheader,file=path(2)(1:length(2))//'header_grid_time', &
+ form='unformatted',err=998)
+
+
+ ! Write the header information
+ !*****************************
+
+ if (ldirect.eq.1) then
+ write(unitheader) ibdate,ibtime, flexversion
+ else
+ write(unitheader) iedate,ietime, flexversion
+ endif
+
+ ! Write info on output interval, averaging time, sampling time
+ !*************************************************************
+
+ write(unitheader) loutstep,loutaver,loutsample
+
+ ! Write information on output grid setup
+ !***************************************
+
+ write(unitheader) outlon0,outlat0,numxgrid,numygrid, &
+ dxout,dyout
+ write(unitheader) 1,(outheight(1),i=1,1)
+
+ call caldate(bdate,jjjjmmdd,ihmmss)
+ write(unitheader) jjjjmmdd,ihmmss
+
+ ! Write number of species, and name for each species (+extra name for depositions)
+ ! Indicate the dimension of the fields (i.e., 1 for deposition fields, numzgrid for
+ ! concentration fields
+ !*****************************************************************************
+
+ write(unitheader) 3*nspec,maxpointspec_act
+ do i=1,nspec
+ write(unitheader) 1,'WD_'//species(i)(1:7)
+ write(unitheader) 1,'DD_'//species(i)(1:7)
+ write(unitheader) 1,species(i)
+ end do
+
+ ! Write information on release points: total number, then for each point:
+ ! start, end, coordinates, # of particles, name, mass
+ !************************************************************************
+
+ write(unitheader) numpoint
+ do i=1,numpoint
+ write(unitheader) ireleasestart(i),ireleaseend(i),kindz(i)
+ xp1=xpoint1(i)*dx+xlon0
+ yp1=ypoint1(i)*dy+ylat0
+ xp2=xpoint2(i)*dx+xlon0
+ yp2=ypoint2(i)*dy+ylat0
+ write(unitheader) xp1,yp1,xp2,yp2,zpoint1(i),zpoint2(i)
+ write(unitheader) npart(i),1
+ if (numpoint.le.1000) then
+ write(unitheader) compoint(i)
+ else
+ write(unitheader) compoint(1001)
+ endif
+ do j=1,nspec
+ write(unitheader) xmass(i,j)
+ write(unitheader) xmass(i,j)
+ write(unitheader) xmass(i,j)
+ end do
+ end do
+
+ ! Write information on some model switches
+ !*****************************************
+
+ write(unitheader) method,lsubgrid,lconvection, &
+ ind_source,ind_receptor
+
+ ! Write age class information
+ !****************************
+
+ write(unitheader) nageclass,(lage(i),i=1,nageclass)
+
+
+ ! Write topography to output file
+ !********************************
+
+ do ix=0,numxgrid-1
+ write(unitheader) (oroout(ix,jy),jy=0,numygrid-1)
+ end do
+ close(unitheader)
+
+ return
+
+
+998 write(*,*) ' #### FLEXPART MODEL ERROR! THE FILE #### '
+ write(*,*) ' #### '//path(2)(1:length(2))//'header'//' #### '
+ write(*,*) ' #### CANNOT BE OPENED. IF A FILE WITH THIS #### '
+ write(*,*) ' #### NAME ALREADY EXISTS, DELETE IT AND START #### '
+ write(*,*) ' #### THE PROGRAM AGAIN. #### '
+ stop
+
+end subroutine writeheader_binary_surf
+
+subroutine openreceptors
+
+ !*****************************************************************************
+ ! *
+ ! This routine opens the receptor output files and writes out the receptor *
+ ! names and the receptor locations. The receptor output files are not *
+ ! closed, but kept open throughout the simulation. Concentrations are *
+ ! continuously dumped to these files. *
+ ! *
+ ! Author: A. Stohl *
+ ! *
+ ! 7 August 2002 *
+ ! *
+ !*****************************************************************************
+ ! *
+ ! Variables: *
+ ! numreceptor actual number of receptor points specified *
+ ! receptornames names of the receptor points *
+ ! xreceptor,yreceptor coordinates of the receptor points *
+ ! *
+ !*****************************************************************************
+
+ implicit none
+
+ integer :: j
+
+ ! Open output file for receptor points and write out a short header
+ ! containing receptor names and locations
+ !******************************************************************
+
+ if (numreceptor.ge.1) then ! do it only if receptors are specified
+
+ ! Concentration output
+ !*********************
+
+ if ((iout.eq.1).or.(iout.eq.3).or.(iout.eq.5)) then
+ open(unitoutrecept,file=path(2)(1:length(2))//'receptor_conc', &
+ form='unformatted',err=997)
+ write(unitoutrecept) (receptorname(j),j=1,numreceptor)
+ write(unitoutrecept) (xreceptor(j)*dx+xlon0, &
+ yreceptor(j)*dy+ylat0,j=1,numreceptor)
+ endif
+
+ ! Mixing ratio output
+ !********************
+
+ if ((iout.eq.2).or.(iout.eq.3)) then
+ open(unitoutreceptppt,file=path(2)(1:length(2))//'receptor_pptv', &
+ form='unformatted',err=998)
+ write(unitoutreceptppt) (receptorname(j),j=1,numreceptor)
+ write(unitoutreceptppt) (xreceptor(j)*dx+xlon0, &
+ yreceptor(j)*dy+ylat0,j=1,numreceptor)
+ endif
+ endif
+
+ return
+997 write(*,*) ' #### FLEXPART MODEL ERROR! THE FILE #### '
+ write(*,*) ' #### receptor_conc #### '
+ write(*,*) ' #### CANNOT BE OPENED. #### '
+ stop
+
+998 write(*,*) ' #### FLEXPART MODEL ERROR! THE FILE #### '
+ write(*,*) ' #### receptor_pptv #### '
+ write(*,*) ' #### CANNOT BE OPENED. #### '
+ stop
+end subroutine openreceptors
+
+subroutine concoutput(itime,outnum,gridtotalunc,wetgridtotalunc, &
+ drygridtotalunc)
+ ! i i o o
+ ! o
+ !*****************************************************************************
+ ! *
+ ! Output of the concentration grid and the receptor concentrations. *
+ ! *
+ ! Author: A. Stohl *
+ ! *
+ ! 24 May 1995 *
+ ! *
+ ! 13 April 1999, Major update: if output size is smaller, dump output *
+ ! in sparse matrix format; additional output of *
+ ! uncertainty *
+ ! *
+ ! 05 April 2000, Major update: output of age classes; output for backward*
+ ! runs is time spent in grid cell times total mass of *
+ ! species. *
+ ! *
+ ! 17 February 2002, Appropriate dimensions for backward and forward runs *
+ ! are now specified in file par_mod *
+ ! *
+ ! June 2006, write grid in sparse matrix with a single write command *
+ ! in order to save disk space *
+ ! *
+ ! 2008 new sparse matrix format *
+ ! *
+ !*****************************************************************************
+ ! *
+ ! Variables: *
+ ! outnum number of samples *
+ ! ncells number of cells with non-zero concentrations *
+ ! sparse .true. if in sparse matrix format, else .false. *
+ ! tot_mu 1 for forward, initial mass mixing ration for backw. runs *
+ ! *
+ !*****************************************************************************
+
+ use unc_mod
+ use mean_mod
+
+ implicit none
+
+ real(kind=dp) :: jul
+ integer :: itime,i,ix,jy,kz,ks,kp,l,iix,jjy,kzz,nage,jjjjmmdd,ihmmss
+ integer :: sp_count_i,sp_count_r
+ real :: sp_fact
+ real :: outnum,densityoutrecept(maxreceptor),xl,yl
+ ! RLT
+ real :: densitydryrecept(maxreceptor)
+ real :: factor_dryrecept(maxreceptor)
+
+ real(dep_prec) :: auxgrid(nclassunc)
+ real(sp) :: gridtotal,gridsigmatotal,gridtotalunc
+ real(dep_prec) :: wetgridtotal,wetgridsigmatotal,wetgridtotalunc
+ real(dep_prec) :: drygridtotal,drygridsigmatotal,drygridtotalunc
+ real :: halfheight,dz,dz1,dz2,tot_mu(maxspec,maxpointspec_act)
+ real,parameter :: smallnum = tiny(0.0) ! smallest number that can be handled
+ real,parameter :: weightair=28.97
+ logical :: sp_zer
+ logical,save :: init=.true.
+ character :: adate*8,atime*6
+ character(len=3) :: anspec
+ integer :: mind
+ character(LEN=8),save :: file_stat='REPLACE'
+ logical :: ldates_file
+ logical :: lexist
+ integer :: ierr
+ character(LEN=100) :: dates_char
+
+ ! Determine current calendar date, needed for the file name
+ !**********************************************************
+
+ jul=bdate+real(itime,kind=dp)/86400._dp
+ call caldate(jul,jjjjmmdd,ihmmss)
+ write(adate,'(i8.8)') jjjjmmdd
+ write(atime,'(i6.6)') ihmmss
+
+ ! Overwrite existing dates file on first call, later append to it
+ ! This fixes a bug where the dates file kept growing across multiple runs
+
+ ! If 'dates' file exists in output directory, make a backup
+ inquire(file=path(2)(1:length(2))//'dates', exist=ldates_file)
+ if (ldates_file.and.init) then
+ open(unit=unitdates, file=path(2)(1:length(2))//'dates',form='formatted', &
+ &access='sequential', status='old', action='read', iostat=ierr)
+ open(unit=unittmp, file=path(2)(1:length(2))//'dates.bak', access='sequential', &
+ &status='replace', action='write', form='formatted', iostat=ierr)
+ do while (.true.)
+ read(unitdates, '(a)', iostat=ierr) dates_char
+ if (ierr.ne.0) exit
+ write(unit=unittmp, fmt='(a)', iostat=ierr, advance='yes') trim(dates_char)
+ end do
+ close(unit=unitdates)
+ close(unit=unittmp)
+ end if
+
+ open(unitdates,file=path(2)(1:length(2))//'dates', ACCESS='APPEND', STATUS=file_stat)
+ write(unitdates,'(a)') adate//atime
+ close(unitdates)
+
+ ! Overwrite existing dates file on first call, later append to it
+ ! This fixes a bug where the dates file kept growing across multiple runs
+ IF (init) THEN
+ file_stat='OLD'
+ init=.false.
+ END IF
+
+
+ ! For forward simulations, output fields have dimension MAXSPEC,
+ ! for backward simulations, output fields have dimension MAXPOINT.
+ ! Thus, make loops either about nspec, or about numpoint
+ !*****************************************************************
+
+
+ if (ldirect.eq.1) then
+ do ks=1,nspec
+ do kp=1,maxpointspec_act
+ tot_mu(ks,kp)=1
+ end do
+ end do
+ else
+ do ks=1,nspec
+ do kp=1,maxpointspec_act
+ tot_mu(ks,kp)=xmass(kp,ks)
+ end do
+ end do
+ endif
+
+
+ !*******************************************************************
+ ! Compute air density: sufficiently accurate to take it
+ ! from coarse grid at some time
+ ! Determine center altitude of output layer, and interpolate density
+ ! data to that altitude
+ !*******************************************************************
+
+ mind=memind(2)
+ do kz=1,numzgrid
+ if (kz.eq.1) then
+ halfheight=outheight(1)/2.
+ else
+ halfheight=(outheight(kz)+outheight(kz-1))/2.
+ endif
+ do kzz=2,nz
+ if ((height(kzz-1).lt.halfheight).and. &
+ (height(kzz).gt.halfheight)) goto 46
+ end do
+46 kzz=max(min(kzz,nz),2)
+ dz1=halfheight-height(kzz-1)
+ dz2=height(kzz)-halfheight
+ dz=dz1+dz2
+ do jy=0,numygrid-1
+ do ix=0,numxgrid-1
+ xl=outlon0+real(ix)*dxout
+ yl=outlat0+real(jy)*dyout
+ xl=(xl-xlon0)/dx
+ yl=(yl-ylat0)/dy !v9.1.1
+ iix=max(min(nint(xl),nxmin1),0)
+ jjy=max(min(nint(yl),nymin1),0)
+ ! densityoutgrid(ix,jy,kz)=(rho(iix,jjy,kzz,2)*dz1+ &
+ ! rho(iix,jjy,kzz-1,2)*dz2)/dz
+ densityoutgrid(ix,jy,kz)=(rho(iix,jjy,kzz,mind)*dz1+ &
+ rho(iix,jjy,kzz-1,mind)*dz2)/dz
+ ! RLT
+ densitydrygrid(ix,jy,kz)=(rho_dry(iix,jjy,kzz,mind)*dz1+ &
+ rho_dry(iix,jjy,kzz-1,mind)*dz2)/dz
+ end do
+ end do
+ end do
+
+ do i=1,numreceptor
+ xl=xreceptor(i)
+ yl=yreceptor(i)
+ iix=max(min(nint(xl),nxmin1),0)
+ jjy=max(min(nint(yl),nymin1),0)
+ !densityoutrecept(i)=rho(iix,jjy,1,2)
+ densityoutrecept(i)=rho(iix,jjy,1,mind)
+ ! RLT
+ densitydryrecept(i)=rho_dry(iix,jjy,1,mind)
+ end do
+
+ ! RLT
+ ! conversion factor for output relative to dry air
+ factor_drygrid=densityoutgrid/densitydrygrid
+ factor_dryrecept=densityoutrecept/densitydryrecept
+
+ ! Output is different for forward and backward simulations
+ do kz=1,numzgrid
+ do jy=0,numygrid-1
+ do ix=0,numxgrid-1
+ if (ldirect.eq.1) then
+ factor3d(ix,jy,kz)=1.e12/volume(ix,jy,kz)/outnum
+ else
+ factor3d(ix,jy,kz)=real(abs(loutaver))/outnum
+ endif
+ end do
+ end do
+ end do
+
+ !*********************************************************************
+ ! Determine the standard deviation of the mean concentration or mixing
+ ! ratio (uncertainty of the output) and the dry and wet deposition
+ !*********************************************************************
+
+ gridtotal=0.
+ gridsigmatotal=0.
+ gridtotalunc=0.
+ wetgridtotal=0.
+ wetgridsigmatotal=0.
+ wetgridtotalunc=0.
+ drygridtotal=0.
+ drygridsigmatotal=0.
+ drygridtotalunc=0.
+
+ do ks=1,nspec
+
+ write(anspec,'(i3.3)') ks
+
+ if (DRYBKDEP.or.WETBKDEP) then !scavdep output
+ if (DRYBKDEP) &
+ open(unitoutgrid,file=path(2)(1:length(2))//'grid_drydep_'//adate// &
+ atime//'_'//anspec,form='unformatted')
+ if (WETBKDEP) &
+ open(unitoutgrid,file=path(2)(1:length(2))//'grid_wetdep_'//adate// &
+ atime//'_'//anspec,form='unformatted')
+ write(unitoutgrid) itime
+ else
+ if ((iout.eq.1).or.(iout.eq.3).or.(iout.eq.5)) then
+ if (ldirect.eq.1) then
+ open(unitoutgrid,file=path(2)(1:length(2))//'grid_conc_'//adate// &
+ atime//'_'//anspec,form='unformatted')
+ else
+ open(unitoutgrid,file=path(2)(1:length(2))//'grid_time_'//adate// &
+ atime//'_'//anspec,form='unformatted')
+ endif
+ write(unitoutgrid) itime
+ endif
+ if ((iout.eq.2).or.(iout.eq.3)) then ! mixing ratio
+ open(unitoutgridppt,file=path(2)(1:length(2))//'grid_pptv_'//adate// &
+ atime//'_'//anspec,form='unformatted')
+ write(unitoutgridppt) itime
+ endif
+ endif ! if deposition output
+
+ do kp=1,maxpointspec_act
+ do nage=1,nageclass
+
+ do jy=0,numygrid-1
+ do ix=0,numxgrid-1
+
+ ! WET DEPOSITION
+ if ((WETDEP).and.(ldirect.gt.0)) then
+ do l=1,nclassunc
+ auxgrid(l)=wetgridunc(ix,jy,ks,kp,l,nage)
+ end do
+ call mean(auxgrid,wetgrid(ix,jy), &
+ wetgridsigma(ix,jy),nclassunc)
+ ! Multiply by number of classes to get total concentration
+ wetgrid(ix,jy)=wetgrid(ix,jy) &
+ *nclassunc
+ wetgridtotal=wetgridtotal+wetgrid(ix,jy)
+ ! Calculate standard deviation of the mean
+ wetgridsigma(ix,jy)= &
+ wetgridsigma(ix,jy)* &
+ sqrt(real(nclassunc))
+ wetgridsigmatotal=wetgridsigmatotal+ &
+ wetgridsigma(ix,jy)
+ endif
+
+ ! DRY DEPOSITION
+ if ((DRYDEP).and.(ldirect.gt.0)) then
+ do l=1,nclassunc
+ auxgrid(l)=drygridunc(ix,jy,ks,kp,l,nage)
+ end do
+ call mean(auxgrid,drygrid(ix,jy), &
+ drygridsigma(ix,jy),nclassunc)
+ ! Multiply by number of classes to get total concentration
+ drygrid(ix,jy)=drygrid(ix,jy)* &
+ nclassunc
+ drygridtotal=drygridtotal+drygrid(ix,jy)
+ ! Calculate standard deviation of the mean
+ drygridsigma(ix,jy)= &
+ drygridsigma(ix,jy)* &
+ sqrt(real(nclassunc))
+ drygridsigmatotal=drygridsigmatotal+ &
+ drygridsigma(ix,jy)
+ endif
+
+ ! CONCENTRATION OR MIXING RATIO
+ do kz=1,numzgrid
+ do l=1,nclassunc
+ auxgrid(l)=gridunc(ix,jy,kz,ks,kp,l,nage)
+ end do
+ call mean(auxgrid,grid(ix,jy,kz), &
+ gridsigma(ix,jy,kz),nclassunc)
+ ! Multiply by number of classes to get total concentration
+ grid(ix,jy,kz)= &
+ grid(ix,jy,kz)*nclassunc
+ gridtotal=gridtotal+grid(ix,jy,kz)
+ ! Calculate standard deviation of the mean
+ gridsigma(ix,jy,kz)= &
+ gridsigma(ix,jy,kz)* &
+ sqrt(real(nclassunc))
+ gridsigmatotal=gridsigmatotal+ &
+ gridsigma(ix,jy,kz)
+ end do
+ end do
+ end do
+
+ !*******************************************************************
+ ! Generate output: may be in concentration (ng/m3) or in mixing
+ ! ratio (ppt) or both
+ ! Output the position and the values alternated multiplied by
+ ! 1 or -1, first line is number of values, number of positions
+ ! For backward simulations, the unit is seconds, stored in grid_time
+ !*******************************************************************
+
+ ! Concentration output
+ !*********************
+ if ((iout.eq.1).or.(iout.eq.3).or.(iout.eq.5)) then
+
+ ! Wet deposition
+ sp_count_i=0
+ sp_count_r=0
+ sp_fact=-1.
+ sp_zer=.true.
+ if ((ldirect.eq.1).and.(WETDEP)) then
+ do jy=0,numygrid-1
+ do ix=0,numxgrid-1
+ !oncentraion greater zero
+ if (wetgrid(ix,jy).gt.smallnum) then
+ if (sp_zer.eqv..true.) then ! first non zero value
+ sp_count_i=sp_count_i+1
+ sparse_dump_i(sp_count_i)=ix+jy*numxgrid
+ sp_zer=.false.
+ sp_fact=sp_fact*(-1.)
+ endif
+ sp_count_r=sp_count_r+1
+ sparse_dump_r(sp_count_r)= &
+ sp_fact*1.e12*wetgrid(ix,jy)/area(ix,jy)
+ else ! concentration is zero
+ sp_zer=.true.
+ endif
+ end do
+ end do
+ else
+ sp_count_i=0
+ sp_count_r=0
+ endif
+ write(unitoutgrid) sp_count_i
+ write(unitoutgrid) (sparse_dump_i(i),i=1,sp_count_i)
+ write(unitoutgrid) sp_count_r
+ write(unitoutgrid) (sparse_dump_r(i),i=1,sp_count_r)
+
+ ! Dry deposition
+ sp_count_i=0
+ sp_count_r=0
+ sp_fact=-1.
+ sp_zer=.true.
+ if ((ldirect.eq.1).and.(DRYDEP)) then
+ do jy=0,numygrid-1
+ do ix=0,numxgrid-1
+ if (drygrid(ix,jy).gt.smallnum) then
+ if (sp_zer.eqv..true.) then ! first non zero value
+ sp_count_i=sp_count_i+1
+ sparse_dump_i(sp_count_i)=ix+jy*numxgrid
+ sp_zer=.false.
+ sp_fact=sp_fact*(-1.)
+ endif
+ sp_count_r=sp_count_r+1
+ sparse_dump_r(sp_count_r)= &
+ sp_fact* &
+ 1.e12*drygrid(ix,jy)/area(ix,jy)
+ else ! concentration is zero
+ sp_zer=.true.
+ endif
+ end do
+ end do
+ else
+ sp_count_i=0
+ sp_count_r=0
+ endif
+ write(unitoutgrid) sp_count_i
+ write(unitoutgrid) (sparse_dump_i(i),i=1,sp_count_i)
+ write(unitoutgrid) sp_count_r
+ write(unitoutgrid) (sparse_dump_r(i),i=1,sp_count_r)
+
+
+
+ ! Concentrations
+ sp_count_i=0
+ sp_count_r=0
+ sp_fact=-1.
+ sp_zer=.true.
+ do kz=1,numzgrid
+ do jy=0,numygrid-1
+ do ix=0,numxgrid-1
+ if (grid(ix,jy,kz).gt.smallnum) then
+ if (sp_zer.eqv..true.) then ! first non zero value
+ sp_count_i=sp_count_i+1
+ sparse_dump_i(sp_count_i)= &
+ ix+jy*numxgrid+kz*numxgrid*numygrid
+ sp_zer=.false.
+ sp_fact=sp_fact*(-1.)
+ endif
+ sp_count_r=sp_count_r+1
+ if (lparticlecountoutput) then
+ sparse_dump_r(sp_count_r)= &
+ sp_fact* &
+ grid(ix,jy,kz)
+ else
+ sparse_dump_r(sp_count_r)= &
+ sp_fact* &
+ grid(ix,jy,kz)* &
+ factor3d(ix,jy,kz)/tot_mu(ks,kp)
+ end if
+
+ else ! concentration is zero
+ sp_zer=.true.
+ endif
+ end do
+ end do
+ end do
+ write(unitoutgrid) sp_count_i
+ write(unitoutgrid) (sparse_dump_i(i),i=1,sp_count_i)
+ write(unitoutgrid) sp_count_r
+ write(unitoutgrid) (sparse_dump_r(i),i=1,sp_count_r)
+
+
+
+ endif ! concentration output
+
+ ! Mixing ratio output
+ !********************
+
+ if ((iout.eq.2).or.(iout.eq.3)) then ! mixing ratio
+
+ ! Wet deposition
+ sp_count_i=0
+ sp_count_r=0
+ sp_fact=-1.
+ sp_zer=.true.
+ if ((ldirect.eq.1).and.(WETDEP)) then
+ do jy=0,numygrid-1
+ do ix=0,numxgrid-1
+ if (wetgrid(ix,jy).gt.smallnum) then
+ if (sp_zer.eqv..true.) then ! first non zero value
+ sp_count_i=sp_count_i+1
+ sparse_dump_i(sp_count_i)= &
+ ix+jy*numxgrid
+ sp_zer=.false.
+ sp_fact=sp_fact*(-1.)
+ endif
+ sp_count_r=sp_count_r+1
+ sparse_dump_r(sp_count_r)= &
+ sp_fact* &
+ 1.e12*wetgrid(ix,jy)/area(ix,jy)
+ else ! concentration is zero
+ sp_zer=.true.
+ endif
+ end do
+ end do
+ else
+ sp_count_i=0
+ sp_count_r=0
+ endif
+ write(unitoutgridppt) sp_count_i
+ write(unitoutgridppt) (sparse_dump_i(i),i=1,sp_count_i)
+ write(unitoutgridppt) sp_count_r
+ write(unitoutgridppt) (sparse_dump_r(i),i=1,sp_count_r)
+
+
+ ! Dry deposition
+ sp_count_i=0
+ sp_count_r=0
+ sp_fact=-1.
+ sp_zer=.true.
+ if ((ldirect.eq.1).and.(DRYDEP)) then
+ do jy=0,numygrid-1
+ do ix=0,numxgrid-1
+ if (drygrid(ix,jy).gt.smallnum) then
+ if (sp_zer.eqv..true.) then ! first non zero value
+ sp_count_i=sp_count_i+1
+ sparse_dump_i(sp_count_i)= &
+ ix+jy*numxgrid
+ sp_zer=.false.
+ sp_fact=sp_fact*(-1)
+ endif
+ sp_count_r=sp_count_r+1
+ sparse_dump_r(sp_count_r)= &
+ sp_fact* &
+ 1.e12*drygrid(ix,jy)/area(ix,jy)
+ else ! concentration is zero
+ sp_zer=.true.
+ endif
+ end do
+ end do
+ else
+ sp_count_i=0
+ sp_count_r=0
+ endif
+ write(unitoutgridppt) sp_count_i
+ write(unitoutgridppt) (sparse_dump_i(i),i=1,sp_count_i)
+ write(unitoutgridppt) sp_count_r
+ write(unitoutgridppt) (sparse_dump_r(i),i=1,sp_count_r)
+
+
+ ! Mixing ratios
+ sp_count_i=0
+ sp_count_r=0
+ sp_fact=-1.
+ sp_zer=.true.
+ do kz=1,numzgrid
+ do jy=0,numygrid-1
+ do ix=0,numxgrid-1
+ if (grid(ix,jy,kz).gt.smallnum) then
+ if (sp_zer.eqv..true.) then ! first non zero value
+ sp_count_i=sp_count_i+1
+ sparse_dump_i(sp_count_i)= &
+ ix+jy*numxgrid+kz*numxgrid*numygrid
+ sp_zer=.false.
+ sp_fact=sp_fact*(-1.)
+ endif
+ sp_count_r=sp_count_r+1
+ sparse_dump_r(sp_count_r)= &
+ sp_fact* &
+ 1.e12*grid(ix,jy,kz) &
+ /volume(ix,jy,kz)/outnum* &
+ weightair/weightmolar(ks)/densityoutgrid(ix,jy,kz)
+ else ! concentration is zero
+ sp_zer=.true.
+ endif
+ end do
+ end do
+ end do
+ write(unitoutgridppt) sp_count_i
+ write(unitoutgridppt) (sparse_dump_i(i),i=1,sp_count_i)
+ write(unitoutgridppt) sp_count_r
+ write(unitoutgridppt) (sparse_dump_r(i),i=1,sp_count_r)
+
+ endif ! output for ppt
+
+ end do
+ end do
+
+ close(unitoutgridppt)
+ close(unitoutgrid)
+
+ end do
+
+ ! RLT Aug 2017
+ ! Write out conversion factor for dry air
+ inquire(file=path(2)(1:length(2))//'factor_drygrid',exist=lexist)
+ if (lexist) then
+ ! open and append
+ open(unitoutfactor,file=path(2)(1:length(2))//'factor_drygrid',form='unformatted',&
+ status='old',action='write',access='append')
+ else
+ ! create new
+ open(unitoutfactor,file=path(2)(1:length(2))//'factor_drygrid',form='unformatted',&
+ status='new',action='write')
+ endif
+ sp_count_i=0
+ sp_count_r=0
+ sp_fact=-1.
+ sp_zer=.true.
+ do kz=1,numzgrid
+ do jy=0,numygrid-1
+ do ix=0,numxgrid-1
+ if (factor_drygrid(ix,jy,kz).gt.(1.+smallnum).or.factor_drygrid(ix,jy,kz).lt.(1.-smallnum)) then
+ if (sp_zer.eqv..true.) then ! first value not equal to one
+ sp_count_i=sp_count_i+1
+ sparse_dump_i(sp_count_i)= &
+ ix+jy*numxgrid+kz*numxgrid*numygrid
+ sp_zer=.false.
+ sp_fact=sp_fact*(-1.)
+ endif
+ sp_count_r=sp_count_r+1
+ sparse_dump_r(sp_count_r)= &
+ sp_fact*factor_drygrid(ix,jy,kz)
+ else ! factor is one
+ sp_zer=.true.
+ endif
+ end do
+ end do
+ end do
+ write(unitoutfactor) sp_count_i
+ write(unitoutfactor) (sparse_dump_i(i),i=1,sp_count_i)
+ write(unitoutfactor) sp_count_r
+ write(unitoutfactor) (sparse_dump_r(i),i=1,sp_count_r)
+ close(unitoutfactor)
+
+
+ if (gridtotal.gt.0.) gridtotalunc=gridsigmatotal/gridtotal
+ if (wetgridtotal.gt.0.) wetgridtotalunc=wetgridsigmatotal/ &
+ wetgridtotal
+ if (drygridtotal.gt.0.) drygridtotalunc=drygridsigmatotal/ &
+ drygridtotal
+
+ ! Dump of receptor concentrations
+
+ if (numreceptor.gt.0 .and. (iout.eq.2 .or. iout.eq.3) ) then
+ write(unitoutreceptppt) itime
+ do ks=1,nspec
+ write(unitoutreceptppt) (1.e12*creceptor(i,ks)/outnum* &
+ weightair/weightmolar(ks)/densityoutrecept(i),i=1,numreceptor)
+ end do
+ endif
+
+ ! Dump of receptor concentrations
+
+ if (numreceptor.gt.0) then
+ write(unitoutrecept) itime
+ do ks=1,nspec
+ write(unitoutrecept) (1.e12*creceptor(i,ks)/outnum, &
+ i=1,numreceptor)
+ end do
+ endif
+
+ ! RLT Aug 2017
+ ! Write out conversion factor for dry air
+ if (numreceptor.gt.0) then
+ inquire(file=path(2)(1:length(2))//'factor_dryreceptor',exist=lexist)
+ if (lexist) then
+ ! open and append
+ open(unitoutfactor,file=path(2)(1:length(2))//'factor_dryreceptor',form='unformatted',&
+ status='old',action='write',access='append')
+ else
+ ! create new
+ open(unitoutfactor,file=path(2)(1:length(2))//'factor_dryreceptor',form='unformatted',&
+ status='new',action='write')
+ endif
+ write(unitoutfactor) itime
+ write(unitoutfactor) (factor_dryrecept(i),i=1,numreceptor)
+ close(unitoutfactor)
+ endif
+
+ creceptor(:,:)=0.
+ gridunc(:,:,:,:,:,:,:)=0.
+end subroutine concoutput
+
+subroutine concoutput_nest(itime,outnum)
+ ! i i
+ !*****************************************************************************
+ ! *
+ ! Output of the concentration grid and the receptor concentrations. *
+ ! *
+ ! Author: A. Stohl *
+ ! *
+ ! 24 May 1995 *
+ ! *
+ ! 13 April 1999, Major update: if output size is smaller, dump output *
+ ! in sparse matrix format; additional output of *
+ ! uncertainty *
+ ! *
+ ! 05 April 2000, Major update: output of age classes; output for backward*
+ ! runs is time spent in grid cell times total mass of *
+ ! species. *
+ ! *
+ ! 17 February 2002, Appropriate dimensions for backward and forward runs *
+ ! are now specified in file par_mod *
+ ! *
+ ! June 2006, write grid in sparse matrix with a single write command *
+ ! in order to save disk space *
+ ! *
+ ! 2008 new sparse matrix format *
+ ! *
+ !*****************************************************************************
+ ! *
+ ! Variables: *
+ ! outnum number of samples *
+ ! ncells number of cells with non-zero concentrations *
+ ! sparse .true. if in sparse matrix format, else .false. *
+ ! tot_mu 1 for forward, initial mass mixing ration for backw. runs *
+ ! *
+ !*****************************************************************************
+ use unc_mod
+ use mean_mod
+
+ implicit none
+
+ real(kind=dp) :: jul
+ integer :: itime,i,ix,jy,kz,ks,kp,l,iix,jjy,kzz,nage,jjjjmmdd,ihmmss
+ integer :: sp_count_i,sp_count_r
+ real :: sp_fact
+ real :: outnum,densityoutrecept(maxreceptor),xl,yl
+ ! RLT
+ real :: densitydryrecept(maxreceptor)
+ real :: factor_dryrecept(maxreceptor)
+
+ !real densityoutgrid(0:numxgrid-1,0:numygrid-1,numzgrid),
+ ! +grid(0:numxgrid-1,0:numygrid-1,numzgrid,maxspec,maxpointspec_act,
+ ! + maxageclass)
+ !real wetgrid(0:numxgrid-1,0:numygrid-1,maxspec,maxpointspec_act,
+ ! + maxageclass)
+ !real drygrid(0:numxgrid-1,0:numygrid-1,maxspec,
+ ! + maxpointspec_act,maxageclass)
+ !real gridsigma(0:numxgrid-1,0:numygrid-1,numzgrid,maxspec,
+ ! + maxpointspec_act,maxageclass),
+ ! + drygridsigma(0:numxgrid-1,0:numygrid-1,maxspec,
+ ! + maxpointspec_act,maxageclass),
+ ! + wetgridsigma(0:numxgrid-1,0:numygrid-1,maxspec,
+ ! + maxpointspec_act,maxageclass)
+ !real factor(0:numxgrid-1,0:numygrid-1,numzgrid)
+ !real sparse_dump_r(numxgrid*numygrid*numzgrid)
+ !integer sparse_dump_i(numxgrid*numygrid*numzgrid)
+
+ !real sparse_dump_u(numxgrid*numygrid*numzgrid)
+ real(dep_prec) :: auxgrid(nclassunc)
+ real :: halfheight,dz,dz1,dz2,tot_mu(maxspec,maxpointspec_act)
+ real,parameter :: smallnum = tiny(0.0) ! smallest number that can be handled
+ real,parameter :: weightair=28.97
+ logical :: sp_zer
+ character :: adate*8,atime*6
+ character(len=3) :: anspec
+ logical :: lexist
+ integer :: mind
+
+
+ ! Determine current calendar date, needed for the file name
+ !**********************************************************
+
+ jul=bdate+real(itime,kind=dp)/86400._dp
+ call caldate(jul,jjjjmmdd,ihmmss)
+ write(adate,'(i8.8)') jjjjmmdd
+ write(atime,'(i6.6)') ihmmss
+
+
+ ! For forward simulations, output fields have dimension MAXSPEC,
+ ! for backward simulations, output fields have dimension MAXPOINT.
+ ! Thus, make loops either about nspec, or about numpoint
+ !*****************************************************************
+
+
+ if (ldirect.eq.1) then
+ do ks=1,nspec
+ do kp=1,maxpointspec_act
+ tot_mu(ks,kp)=1
+ end do
+ end do
+ else
+ do ks=1,nspec
+ do kp=1,maxpointspec_act
+ tot_mu(ks,kp)=xmass(kp,ks)
+ end do
+ end do
+ endif
+
+
+ !*******************************************************************
+ ! Compute air density: sufficiently accurate to take it
+ ! from coarse grid at some time
+ ! Determine center altitude of output layer, and interpolate density
+ ! data to that altitude
+ !*******************************************************************
+
+ mind=memind(2)
+ do kz=1,numzgrid
+ if (kz.eq.1) then
+ halfheight=outheight(1)/2.
+ else
+ halfheight=(outheight(kz)+outheight(kz-1))/2.
+ endif
+ do kzz=2,nz
+ if ((height(kzz-1).lt.halfheight).and. &
+ (height(kzz).gt.halfheight)) goto 46
+ end do
+46 kzz=max(min(kzz,nz),2)
+ dz1=halfheight-height(kzz-1)
+ dz2=height(kzz)-halfheight
+ dz=dz1+dz2
+ do jy=0,numygridn-1
+ do ix=0,numxgridn-1
+ xl=outlon0n+real(ix)*dxoutn
+ yl=outlat0n+real(jy)*dyoutn
+ xl=(xl-xlon0)/dx
+ yl=(yl-ylat0)/dy
+ iix=max(min(nint(xl),nxmin1),0)
+ jjy=max(min(nint(yl),nymin1),0)
+ ! densityoutgrid(ix,jy,kz)=(rho(iix,jjy,kzz,2)*dz1+ &
+ ! rho(iix,jjy,kzz-1,2)*dz2)/dz
+ densityoutgrid(ix,jy,kz)=(rho(iix,jjy,kzz,mind)*dz1+ &
+ rho(iix,jjy,kzz-1,mind)*dz2)/dz
+ ! RLT
+ densitydrygrid(ix,jy,kz)=(rho_dry(iix,jjy,kzz,mind)*dz1+ &
+ rho_dry(iix,jjy,kzz-1,mind)*dz2)/dz
+ end do
+ end do
+ end do
+
+ do i=1,numreceptor
+ xl=xreceptor(i)
+ yl=yreceptor(i)
+ iix=max(min(nint(xl),nxmin1),0)
+ jjy=max(min(nint(yl),nymin1),0)
+ !densityoutrecept(i)=rho(iix,jjy,1,2)
+ densityoutrecept(i)=rho(iix,jjy,1,mind)
+ ! RLT
+ densitydryrecept(i)=rho_dry(iix,jjy,1,mind)
+ end do
+
+ ! RLT
+ ! conversion factor for output relative to dry air
+ factor_drygrid=densityoutgrid/densitydrygrid
+ factor_dryrecept=densityoutrecept/densitydryrecept
+
+ ! Output is different for forward and backward simulations
+ do kz=1,numzgrid
+ do jy=0,numygridn-1
+ do ix=0,numxgridn-1
+ if (ldirect.eq.1) then
+ factor3d(ix,jy,kz)=1.e12/volumen(ix,jy,kz)/outnum
+ else
+ factor3d(ix,jy,kz)=real(abs(loutaver))/outnum
+ endif
+ end do
+ end do
+ end do
+
+ !*********************************************************************
+ ! Determine the standard deviation of the mean concentration or mixing
+ ! ratio (uncertainty of the output) and the dry and wet deposition
+ !*********************************************************************
+
+ do ks=1,nspec
+
+ write(anspec,'(i3.3)') ks
+
+ if (DRYBKDEP.or.WETBKDEP) then !scavdep output
+ if (DRYBKDEP) &
+ open(unitoutgrid,file=path(2)(1:length(2))//'grid_drydep_nest_'//adate// &
+ atime//'_'//anspec,form='unformatted')
+ if (WETBKDEP) &
+ open(unitoutgrid,file=path(2)(1:length(2))//'grid_wetdep_nest_'//adate// &
+ atime//'_'//anspec,form='unformatted')
+ write(unitoutgrid) itime
+ else
+ if ((iout.eq.1).or.(iout.eq.3).or.(iout.eq.5)) then
+ if (ldirect.eq.1) then
+ open(unitoutgrid,file=path(2)(1:length(2))//'grid_conc_nest_' &
+ //adate// &
+ atime//'_'//anspec,form='unformatted')
+ else
+ open(unitoutgrid,file=path(2)(1:length(2))//'grid_time_nest_' &
+ //adate// &
+ atime//'_'//anspec,form='unformatted')
+ endif
+ write(unitoutgrid) itime
+ endif
+ endif
+
+ if ((iout.eq.2).or.(iout.eq.3)) then ! mixing ratio
+ open(unitoutgridppt,file=path(2)(1:length(2))//'grid_pptv_nest_' &
+ //adate// &
+ atime//'_'//anspec,form='unformatted')
+
+ write(unitoutgridppt) itime
+ endif
+
+ do kp=1,maxpointspec_act
+ do nage=1,nageclass
+
+ do jy=0,numygridn-1
+ do ix=0,numxgridn-1
+
+ ! WET DEPOSITION
+ if ((WETDEP).and.(ldirect.gt.0)) then
+ do l=1,nclassunc
+ auxgrid(l)=wetgriduncn(ix,jy,ks,kp,l,nage)
+ end do
+ call mean(auxgrid,wetgrid(ix,jy), &
+ wetgridsigma(ix,jy),nclassunc)
+ ! Multiply by number of classes to get total concentration
+ wetgrid(ix,jy)=wetgrid(ix,jy) &
+ *nclassunc
+ ! Calculate standard deviation of the mean
+ wetgridsigma(ix,jy)= &
+ wetgridsigma(ix,jy)* &
+ sqrt(real(nclassunc))
+ endif
+
+ ! DRY DEPOSITION
+ if ((DRYDEP).and.(ldirect.gt.0)) then
+ do l=1,nclassunc
+ auxgrid(l)=drygriduncn(ix,jy,ks,kp,l,nage)
+ end do
+ call mean(auxgrid,drygrid(ix,jy), &
+ drygridsigma(ix,jy),nclassunc)
+ ! Multiply by number of classes to get total concentration
+ drygrid(ix,jy)=drygrid(ix,jy)* &
+ nclassunc
+ ! Calculate standard deviation of the mean
+ drygridsigma(ix,jy)= &
+ drygridsigma(ix,jy)* &
+ sqrt(real(nclassunc))
+ endif
+
+ ! CONCENTRATION OR MIXING RATIO
+ do kz=1,numzgrid
+ do l=1,nclassunc
+ auxgrid(l)=griduncn(ix,jy,kz,ks,kp,l,nage)
+ end do
+ call mean(auxgrid,grid(ix,jy,kz), &
+ gridsigma(ix,jy,kz),nclassunc)
+ ! Multiply by number of classes to get total concentration
+ grid(ix,jy,kz)= &
+ grid(ix,jy,kz)*nclassunc
+ ! Calculate standard deviation of the mean
+ gridsigma(ix,jy,kz)= &
+ gridsigma(ix,jy,kz)* &
+ sqrt(real(nclassunc))
+ end do
+ end do
+ end do
+
+
+ !*******************************************************************
+ ! Generate output: may be in concentration (ng/m3) or in mixing
+ ! ratio (ppt) or both
+ ! Output the position and the values alternated multiplied by
+ ! 1 or -1, first line is number of values, number of positions
+ ! For backward simulations, the unit is seconds, stored in grid_time
+ !*******************************************************************
+
+ ! Concentration output
+ !*********************
+ if ((iout.eq.1).or.(iout.eq.3).or.(iout.eq.5)) then
+
+ ! Wet deposition
+ sp_count_i=0
+ sp_count_r=0
+ sp_fact=-1.
+ sp_zer=.true.
+ if ((ldirect.eq.1).and.(WETDEP)) then
+ do jy=0,numygridn-1
+ do ix=0,numxgridn-1
+ !oncentraion greater zero
+ if (wetgrid(ix,jy).gt.smallnum) then
+ if (sp_zer.eqv..true.) then ! first non zero value
+ sp_count_i=sp_count_i+1
+ sparse_dump_i(sp_count_i)=ix+jy*numxgridn
+ sp_zer=.false.
+ sp_fact=sp_fact*(-1.)
+ endif
+ sp_count_r=sp_count_r+1
+ sparse_dump_r(sp_count_r)= &
+ sp_fact*1.e12*wetgrid(ix,jy)/arean(ix,jy)
+ ! sparse_dump_u(sp_count_r)=
+ !+ 1.e12*wetgridsigma(ix,jy,ks,kp,nage)/area(ix,jy)
+ else ! concentration is zero
+ sp_zer=.true.
+ endif
+ end do
+ end do
+ else
+ sp_count_i=0
+ sp_count_r=0
+ endif
+ write(unitoutgrid) sp_count_i
+ write(unitoutgrid) (sparse_dump_i(i),i=1,sp_count_i)
+ write(unitoutgrid) sp_count_r
+ write(unitoutgrid) (sparse_dump_r(i),i=1,sp_count_r)
+ ! write(unitoutgrid) sp_count_u
+ ! write(unitoutgrid) (sparse_dump_u(i),i=1,sp_count_r)
+
+ ! Dry deposition
+ sp_count_i=0
+ sp_count_r=0
+ sp_fact=-1.
+ sp_zer=.true.
+ if ((ldirect.eq.1).and.(DRYDEP)) then
+ do jy=0,numygridn-1
+ do ix=0,numxgridn-1
+ if (drygrid(ix,jy).gt.smallnum) then
+ if (sp_zer.eqv..true.) then ! first non zero value
+ sp_count_i=sp_count_i+1
+ sparse_dump_i(sp_count_i)=ix+jy*numxgridn
+ sp_zer=.false.
+ sp_fact=sp_fact*(-1.)
+ endif
+ sp_count_r=sp_count_r+1
+ sparse_dump_r(sp_count_r)= &
+ sp_fact* &
+ 1.e12*drygrid(ix,jy)/arean(ix,jy)
+ ! sparse_dump_u(sp_count_r)=
+ !+ 1.e12*drygridsigma(ix,jy,ks,kp,nage)/area(ix,jy)
+ else ! concentration is zero
+ sp_zer=.true.
+ endif
+ end do
+ end do
+ else
+ sp_count_i=0
+ sp_count_r=0
+ endif
+ write(unitoutgrid) sp_count_i
+ write(unitoutgrid) (sparse_dump_i(i),i=1,sp_count_i)
+ write(unitoutgrid) sp_count_r
+ write(unitoutgrid) (sparse_dump_r(i),i=1,sp_count_r)
+ ! write(*,*) sp_count_u
+ ! write(unitoutgrid) (sparse_dump_u(i),i=1,sp_count_r)
+
+
+
+ ! Concentrations
+ sp_count_i=0
+ sp_count_r=0
+ sp_fact=-1.
+ sp_zer=.true.
+ do kz=1,numzgrid
+ do jy=0,numygridn-1
+ do ix=0,numxgridn-1
+ if (grid(ix,jy,kz).gt.smallnum) then
+ if (sp_zer.eqv..true.) then ! first non zero value
+ sp_count_i=sp_count_i+1
+ sparse_dump_i(sp_count_i)= &
+ ix+jy*numxgridn+kz*numxgridn*numygridn
+ sp_zer=.false.
+ sp_fact=sp_fact*(-1.)
+ endif
+ sp_count_r=sp_count_r+1
+ sparse_dump_r(sp_count_r)= &
+ sp_fact* &
+ grid(ix,jy,kz)* &
+ factor3d(ix,jy,kz)/tot_mu(ks,kp)
+ ! if ((factor(ix,jy,kz)/tot_mu(ks,kp)).eq.0)
+ ! + write (*,*) factor(ix,jy,kz),tot_mu(ks,kp),ks,kp
+ ! sparse_dump_u(sp_count_r)=
+ !+ ,gridsigma(ix,jy,kz,ks,kp,nage)*
+ !+ factor(ix,jy,kz)/tot_mu(ks,kp)
+ else ! concentration is zero
+ sp_zer=.true.
+ endif
+ end do
+ end do
+ end do
+ write(unitoutgrid) sp_count_i
+ write(unitoutgrid) (sparse_dump_i(i),i=1,sp_count_i)
+ write(unitoutgrid) sp_count_r
+ write(unitoutgrid) (sparse_dump_r(i),i=1,sp_count_r)
+ ! write(unitoutgrid) sp_count_u
+ ! write(unitoutgrid) (sparse_dump_u(i),i=1,sp_count_r)
+
+
+
+ endif ! concentration output
+
+ ! Mixing ratio output
+ !********************
+
+ if ((iout.eq.2).or.(iout.eq.3)) then ! mixing ratio
+
+ ! Wet deposition
+ sp_count_i=0
+ sp_count_r=0
+ sp_fact=-1.
+ sp_zer=.true.
+ if ((ldirect.eq.1).and.(WETDEP)) then
+ do jy=0,numygridn-1
+ do ix=0,numxgridn-1
+ if (wetgrid(ix,jy).gt.smallnum) then
+ if (sp_zer.eqv..true.) then ! first non zero value
+ sp_count_i=sp_count_i+1
+ sparse_dump_i(sp_count_i)= &
+ ix+jy*numxgridn
+ sp_zer=.false.
+ sp_fact=sp_fact*(-1.)
+ endif
+ sp_count_r=sp_count_r+1
+ sparse_dump_r(sp_count_r)= &
+ sp_fact* &
+ 1.e12*wetgrid(ix,jy)/arean(ix,jy)
+ ! sparse_dump_u(sp_count_r)=
+ ! + ,1.e12*wetgridsigma(ix,jy,ks,kp,nage)/area(ix,jy)
+ else ! concentration is zero
+ sp_zer=.true.
+ endif
+ end do
+ end do
+ else
+ sp_count_i=0
+ sp_count_r=0
+ endif
+ write(unitoutgridppt) sp_count_i
+ write(unitoutgridppt) (sparse_dump_i(i),i=1,sp_count_i)
+ write(unitoutgridppt) sp_count_r
+ write(unitoutgridppt) (sparse_dump_r(i),i=1,sp_count_r)
+ ! write(unitoutgridppt) sp_count_u
+ ! write(unitoutgridppt) (sparse_dump_u(i),i=1,sp_count_r)
+
+
+ ! Dry deposition
+ sp_count_i=0
+ sp_count_r=0
+ sp_fact=-1.
+ sp_zer=.true.
+ if ((ldirect.eq.1).and.(DRYDEP)) then
+ do jy=0,numygridn-1
+ do ix=0,numxgridn-1
+ if (drygrid(ix,jy).gt.smallnum) then
+ if (sp_zer.eqv..true.) then ! first non zero value
+ sp_count_i=sp_count_i+1
+ sparse_dump_i(sp_count_i)= &
+ ix+jy*numxgridn
+ sp_zer=.false.
+ sp_fact=sp_fact*(-1)
+ endif
+ sp_count_r=sp_count_r+1
+ sparse_dump_r(sp_count_r)= &
+ sp_fact* &
+ 1.e12*drygrid(ix,jy)/arean(ix,jy)
+ ! sparse_dump_u(sp_count_r)=
+ ! + ,1.e12*drygridsigma(ix,jy,ks,kp,nage)/area(ix,jy)
+ else ! concentration is zero
+ sp_zer=.true.
+ endif
+ end do
+ end do
+ else
+ sp_count_i=0
+ sp_count_r=0
+ endif
+ write(unitoutgridppt) sp_count_i
+ write(unitoutgridppt) (sparse_dump_i(i),i=1,sp_count_i)
+ write(unitoutgridppt) sp_count_r
+ write(unitoutgridppt) (sparse_dump_r(i),i=1,sp_count_r)
+ ! write(unitoutgridppt) sp_count_u
+ ! write(unitoutgridppt) (sparse_dump_u(i),i=1,sp_count_r)
+
+
+ ! Mixing ratios
+ sp_count_i=0
+ sp_count_r=0
+ sp_fact=-1.
+ sp_zer=.true.
+ do kz=1,numzgrid
+ do jy=0,numygridn-1
+ do ix=0,numxgridn-1
+ if (grid(ix,jy,kz).gt.smallnum) then
+ if (sp_zer.eqv..true.) then ! first non zero value
+ sp_count_i=sp_count_i+1
+ sparse_dump_i(sp_count_i)= &
+ ix+jy*numxgridn+kz*numxgridn*numygridn
+ sp_zer=.false.
+ sp_fact=sp_fact*(-1.)
+ endif
+ sp_count_r=sp_count_r+1
+ sparse_dump_r(sp_count_r)= &
+ sp_fact* &
+ 1.e12*grid(ix,jy,kz) &
+ /volumen(ix,jy,kz)/outnum* &
+ weightair/weightmolar(ks)/densityoutgrid(ix,jy,kz)
+ ! sparse_dump_u(sp_count_r)=
+ !+ ,1.e12*gridsigma(ix,jy,kz,ks,kp,nage)/volume(ix,jy,kz)/
+ !+ outnum*weightair/weightmolar(ks)/
+ !+ densityoutgrid(ix,jy,kz)
+ else ! concentration is zero
+ sp_zer=.true.
+ endif
+ end do
+ end do
+ end do
+ write(unitoutgridppt) sp_count_i
+ write(unitoutgridppt) (sparse_dump_i(i),i=1,sp_count_i)
+ write(unitoutgridppt) sp_count_r
+ write(unitoutgridppt) (sparse_dump_r(i),i=1,sp_count_r)
+ ! write(unitoutgridppt) sp_count_u
+ ! write(unitoutgridppt) (sparse_dump_u(i),i=1,sp_count_r)
+
+ endif ! output for ppt
+
+ end do
+ end do
+
+ close(unitoutgridppt)
+ close(unitoutgrid)
+
+ end do
+
+ ! RLT Aug 2017
+ ! Write out conversion factor for dry air
+ inquire(file=path(2)(1:length(2))//'factor_drygrid_nest',exist=lexist)
+ if (lexist) then
+ ! open and append
+ open(unitoutfactor,file=path(2)(1:length(2))//'factor_drygrid_nest',form='unformatted',&
+ status='old',action='write',access='append')
+ else
+ ! create new
+ open(unitoutfactor,file=path(2)(1:length(2))//'factor_drygrid_nest',form='unformatted',&
+ status='new',action='write')
+ endif
+ sp_count_i=0
+ sp_count_r=0
+ sp_fact=-1.
+ sp_zer=.true.
+ do kz=1,numzgrid
+ do jy=0,numygridn-1
+ do ix=0,numxgridn-1
+ if (factor_drygrid(ix,jy,kz).gt.(1.+smallnum).or.factor_drygrid(ix,jy,kz).lt.(1.-smallnum)) then
+ if (sp_zer.eqv..true.) then ! first value not equal to one
+ sp_count_i=sp_count_i+1
+ sparse_dump_i(sp_count_i)= &
+ ix+jy*numxgridn+kz*numxgridn*numygridn
+ sp_zer=.false.
+ sp_fact=sp_fact*(-1.)
+ endif
+ sp_count_r=sp_count_r+1
+ sparse_dump_r(sp_count_r)= &
+ sp_fact*factor_drygrid(ix,jy,kz)
+ else ! factor is one
+ sp_zer=.true.
+ endif
+ end do
+ end do
+ end do
+ write(unitoutfactor) sp_count_i
+ write(unitoutfactor) (sparse_dump_i(i),i=1,sp_count_i)
+ write(unitoutfactor) sp_count_r
+ write(unitoutfactor) (sparse_dump_r(i),i=1,sp_count_r)
+ close(unitoutfactor)
+
+ creceptor(:,:)=0.
+ griduncn(:,:,:,:,:,:,:)=0.
+end subroutine concoutput_nest
+
+subroutine concoutput_inversion(itime,outnum,gridtotalunc,wetgridtotalunc, &
+ drygridtotalunc)
+ ! i i o o
+ ! o
+ !*****************************************************************************
+ ! *
+ ! Output of the concentration grid and the receptor concentrations. *
+ ! *
+ ! Author: A. Stohl *
+ ! *
+ ! 24 May 1995 *
+ ! *
+ ! 13 April 1999, Major update: if output size is smaller, dump output *
+ ! in sparse matrix format; additional output of *
+ ! uncertainty *
+ ! *
+ ! 05 April 2000, Major update: output of age classes; output for backward*
+ ! runs is time spent in grid cell times total mass of *
+ ! species. *
+ ! *
+ ! 17 February 2002, Appropriate dimensions for backward and forward runs *
+ ! are now specified in file par_mod *
+ ! *
+ ! June 2006, write grid in sparse matrix with a single write command *
+ ! in order to save disk space *
+ ! *
+ ! 2008 new sparse matrix format *
+ !
+ ! January 2017, Separate files by release but include all timesteps
+ ! *
+ !*****************************************************************************
+ ! *
+ ! Variables: *
+ ! outnum number of samples *
+ ! ncells number of cells with non-zero concentrations *
+ ! sparse .true. if in sparse matrix format, else .false. *
+ ! tot_mu 1 for forward, initial mass mixing ration for backw. runs *
+ ! *
+ !*****************************************************************************
+
+ use unc_mod
+ use mean_mod
+
+ implicit none
+
+ real(kind=dp) :: jul
+ integer :: itime,i,ix,jy,kz,ks,kp,l,iix,jjy,kzz,nage,jjjjmmdd,ihmmss
+ integer :: sp_count_i,sp_count_r
+ real :: sp_fact
+ real :: outnum,densityoutrecept(maxreceptor),xl,yl
+ ! RLT
+ real :: densitydryrecept(maxreceptor)
+ real :: factor_dryrecept(maxreceptor)
+
+
+ real(dep_prec) :: auxgrid(nclassunc)
+ real(sp) :: gridtotal,gridsigmatotal,gridtotalunc
+ real(dep_prec) :: wetgridtotal,wetgridsigmatotal,wetgridtotalunc
+ real(dep_prec) :: drygridtotal,drygridsigmatotal,drygridtotalunc
+ real :: halfheight,dz,dz1,dz2,tot_mu(maxspec,maxpointspec_act)
+ real,parameter :: smallnum = tiny(0.0) ! smallest number that can be handled
+ real,parameter :: weightair=28.97
+ logical :: sp_zer
+ character :: adate*8,atime*6
+ character(len=3) :: anspec
+ logical :: lexist
+ character :: areldate*8,areltime*6
+ logical,save :: lstart=.true.
+ logical,save,allocatable,dimension(:) :: lstartrel
+ integer :: ierr
+ character(LEN=100) :: dates_char
+ integer, parameter :: unitrelnames=654
+
+
+ if(lstart) then
+ allocate(lstartrel(maxpointspec_act))
+ lstartrel(:)=.true.
+ endif
+ print*, 'lstartrel = ',lstartrel
+
+ if (verbosity.eq.1) then
+ print*,'inside concoutput_inversion '
+ CALL SYSTEM_CLOCK(count_clock)
+ WRITE(*,*) 'SYSTEM_CLOCK',count_clock - count_clock0
+ endif
+
+ ! Determine current calendar date
+ !**********************************************************
+
+ jul=bdate+real(itime,kind=dp)/86400._dp
+ call caldate(jul,jjjjmmdd,ihmmss)
+ write(adate,'(i8.8)') jjjjmmdd
+ write(atime,'(i6.6)') ihmmss
+
+
+ ! Prepare output files for dates
+ !**********************************************************
+
+ ! Overwrite existing dates file on first call, later append to it
+ ! If 'dates' file exists in output directory, copy to new file dates.old
+ inquire(file=path(2)(1:length(2))//'dates', exist=lexist)
+ if (lexist.and.lstart) then
+ ! copy contents of existing dates file to dates.old
+ print*, 'warning: replacing old dates file'
+ open(unit=unitdates, file=path(2)(1:length(2))//'dates',form='formatted', &
+ &access='sequential', status='old', action='read', iostat=ierr)
+ open(unit=unittmp, file=path(2)(1:length(2))//'dates.old', access='sequential', &
+ &status='replace', action='write', form='formatted', iostat=ierr)
+ do while (.true.)
+ read(unitdates, '(a)', iostat=ierr) dates_char
+ if (ierr.ne.0) exit
+ write(unit=unittmp, fmt='(a)', iostat=ierr, advance='yes') trim(dates_char)
+ end do
+ close(unit=unitdates)
+ close(unit=unittmp)
+ ! create new dates file
+ open(unit=unitdates, file=path(2)(1:length(2))//'dates',form='formatted', &
+ &access='sequential', status='replace', iostat=ierr)
+ close(unit=unitdates)
+ endif
+
+ open(unitdates,file=path(2)(1:length(2))//'dates', ACCESS='APPEND')
+ write(unitdates,'(a)') adate//atime
+ close(unitdates)
+
+ !CGZ: Make a filename with names of releases
+ if (lstart) then
+ open(unit=unitrelnames, file=path(2)(1:length(2))//'releases_out',form='formatted', &
+ &access='sequential', status='replace', iostat=ierr)
+ close(unitrelnames)
+ endif
+
+ print*, 'after creating dates files: lstart = ',lstart
+ ! print*, 'outnum:',outnum
+ ! print*, 'datetime:',adate//atime
+
+
+ ! For forward simulations, output fields have dimension MAXSPEC,
+ ! for backward simulations, output fields have dimension MAXPOINT.
+ ! Thus, make loops either about nspec, or about numpoint
+ !*****************************************************************
+
+
+ if (ldirect.eq.1) then
+ do ks=1,nspec
+ do kp=1,maxpointspec_act
+ tot_mu(ks,kp)=1
+ end do
+ end do
+ else
+ do ks=1,nspec
+ do kp=1,maxpointspec_act
+ tot_mu(ks,kp)=xmass(kp,ks)
+ end do
+ end do
+ endif
+
+
+ if (verbosity.eq.1) then
+ print*,'concoutput_inversion 2'
+ CALL SYSTEM_CLOCK(count_clock)
+ WRITE(*,*) 'SYSTEM_CLOCK',count_clock - count_clock0
+ endif
+
+ !*******************************************************************
+ ! Compute air density: sufficiently accurate to take it
+ ! from coarse grid at some time
+ ! Determine center altitude of output layer, and interpolate density
+ ! data to that altitude
+ !*******************************************************************
+
+ do kz=1,numzgrid
+ if (kz.eq.1) then
+ halfheight=outheight(1)/2.
+ else
+ halfheight=(outheight(kz)+outheight(kz-1))/2.
+ endif
+ do kzz=2,nz
+ if ((height(kzz-1).lt.halfheight).and. &
+ (height(kzz).gt.halfheight)) goto 46
+ end do
+46 kzz=max(min(kzz,nz),2)
+ dz1=halfheight-height(kzz-1)
+ dz2=height(kzz)-halfheight
+ dz=dz1+dz2
+ do jy=0,numygrid-1
+ do ix=0,numxgrid-1
+ xl=outlon0+real(ix)*dxout
+ yl=outlat0+real(jy)*dyout
+ xl=(xl-xlon0)/dx
+ yl=(yl-ylat0)/dy
+ iix=max(min(nint(xl),nxmin1),0)
+ jjy=max(min(nint(yl),nymin1),0)
+ densityoutgrid(ix,jy,kz)=(rho(iix,jjy,kzz,2)*dz1+ &
+ rho(iix,jjy,kzz-1,2)*dz2)/dz
+ ! RLT
+ densitydrygrid(ix,jy,kz)=(rho_dry(iix,jjy,kzz,2)*dz1+ &
+ rho_dry(iix,jjy,kzz-1,2)*dz2)/dz
+ end do
+ end do
+ end do
+
+ do i=1,numreceptor
+ xl=xreceptor(i)
+ yl=yreceptor(i)
+ iix=max(min(nint(xl),nxmin1),0)
+ jjy=max(min(nint(yl),nymin1),0)
+ densityoutrecept(i)=rho(iix,jjy,1,2)
+ ! RLT
+ densitydryrecept(i)=rho_dry(iix,jjy,1,2)
+ end do
+
+ ! RLT
+ ! conversion factor for output relative to dry air
+ factor_drygrid=densityoutgrid/densitydrygrid
+ factor_dryrecept=densityoutrecept/densitydryrecept
+
+ ! Output is different for forward and backward simulations
+ do kz=1,numzgrid
+ do jy=0,numygrid-1
+ do ix=0,numxgrid-1
+ if (ldirect.eq.1) then
+ factor3d(ix,jy,kz)=1.e12/volume(ix,jy,kz)/outnum
+ else
+ factor3d(ix,jy,kz)=real(abs(loutaver))/outnum
+ endif
+ end do
+ end do
+ end do
+
+ !*********************************************************************
+ ! Determine the standard deviation of the mean concentration or mixing
+ ! ratio (uncertainty of the output) and the dry and wet deposition
+ !*********************************************************************
+
+ if (verbosity.eq.1) then
+ print*,'concoutput_inversion 3 (sd)'
+ CALL SYSTEM_CLOCK(count_clock)
+ WRITE(*,*) 'SYSTEM_CLOCK',count_clock - count_clock0
+ endif
+ gridtotal=0.
+ gridsigmatotal=0.
+ gridtotalunc=0.
+ wetgridtotal=0.
+ wetgridsigmatotal=0.
+ wetgridtotalunc=0.
+ drygridtotal=0.
+ drygridsigmatotal=0.
+ drygridtotalunc=0.
+
+ do ks=1,nspec
+
+ write(anspec,'(i3.3)') ks
+
+ ! loop over releases
+ do kp=1,maxpointspec_act
+
+ print*, 'itime = ',itime
+ !print*, 'lage(1) = ',lage(1)
+ print*, 'ireleasestart(kp) = ',ireleasestart(kp)
+ print*, 'ireleaseend(kp) = ',ireleaseend(kp)
+
+ ! check itime is within release and backward trajectory length
+ if (nageclass.eq.1) then
+ if ((itime.gt.ireleaseend(kp)).or.(itime.lt.(ireleasestart(kp)-lage(1)))) then
+ go to 10
+ endif
+ endif
+
+ ! calculate date of release for filename
+ jul=bdate+real(ireleasestart(kp),kind=dp)/86400._dp ! this is the current day
+ call caldate(jul,jjjjmmdd,ihmmss)
+ write(areldate,'(i8.8)') jjjjmmdd
+ write(areltime,'(i6.6)') ihmmss
+ print*, 'areldate/areltime = ',areldate//areltime
+
+ ! calculate date of field
+ jul=bdate+real(itime,kind=dp)/86400._dp
+ call caldate(jul,jjjjmmdd,ihmmss)
+ write(adate,'(i8.8)') jjjjmmdd
+ write(atime,'(i6.6)') ihmmss
+
+ if ((iout.eq.1).or.(iout.eq.3).or.(iout.eq.5)) then
+ if (ldirect.eq.1) then
+ ! concentrations
+ inquire(file=path(2)(1:length(2))//'grid_conc_'//areldate// &
+ areltime//'_'//anspec,exist=lexist)
+ if(lexist.and..not.lstartrel(kp)) then
+ ! open and append to existing file
+ open(unitoutgrid,file=path(2)(1:length(2))//'grid_conc_'//areldate// &
+ areltime//'_'//anspec,form='unformatted',status='old',action='write',access='append')
+ else
+ ! open new file
+ open(unitoutgrid,file=path(2)(1:length(2))//'grid_conc_'//areldate// &
+ areltime//'_'//anspec,form='unformatted',status='replace',action='write')
+ endif
+ else
+ ! residence times
+ inquire(file=path(2)(1:length(2))//'grid_time_'//areldate// &
+ areltime//'_'//anspec,exist=lexist)
+ if(lexist.and..not.lstartrel(kp)) then
+ ! open and append to existing file
+ open(unitoutgrid,file=path(2)(1:length(2))//'grid_time_'//areldate// &
+ areltime//'_'//anspec,form='unformatted',status='old',action='write',access='append')
+ else
+ ! open new file
+ open(unitoutgrid,file=path(2)(1:length(2))//'grid_time_'//areldate// &
+ areltime//'_'//anspec,form='unformatted',status='replace',action='write')
+ ! add part of the filename to a file (similar to dates) for easier post-processing
+ open(unit=unitrelnames, file=path(2)(1:length(2))//'releases_out',form='formatted', &
+ & access='APPEND', iostat=ierr)
+ write(unitrelnames,'(a)') areldate//areltime//'_'//anspec
+ close(unitrelnames)
+ endif
+ endif
+ write(unitoutgrid) jjjjmmdd
+ write(unitoutgrid) ihmmss
+ endif
+
+ if ((iout.eq.2).or.(iout.eq.3)) then
+ ! mixing ratio
+ inquire(file=path(2)(1:length(2))//'grid_pptv_'//areldate// &
+ areltime//'_'//anspec,exist=lexist)
+ if(lexist.and..not.lstartrel(kp)) then
+ ! open and append to existing file
+ open(unitoutgridppt,file=path(2)(1:length(2))//'grid_pptv_'//areldate// &
+ areltime//'_'//anspec,form='unformatted',status='old',action='write',access='append')
+ else
+ ! open new file
+ open(unitoutgridppt,file=path(2)(1:length(2))//'grid_pptv_'//areldate// &
+ areltime//'_'//anspec,form='unformatted',status='replace',action='write')
+ endif
+ write(unitoutgridppt) jjjjmmdd
+ write(unitoutgridppt) ihmmss
+ endif
+
+ lstartrel(kp)=.false.
+
+ do nage=1,nageclass
+
+ do jy=0,numygrid-1
+ do ix=0,numxgrid-1
+
+ ! CONCENTRATION OR MIXING RATIO
+ do kz=1,numzgrid
+ do l=1,nclassunc
+ auxgrid(l)=gridunc(ix,jy,kz,ks,kp,l,nage)
+ end do
+ call mean(auxgrid,grid(ix,jy,kz), &
+ gridsigma(ix,jy,kz),nclassunc)
+ ! Multiply by number of classes to get total concentration
+ grid(ix,jy,kz)= &
+ grid(ix,jy,kz)*nclassunc
+ gridtotal=gridtotal+grid(ix,jy,kz)
+ ! Calculate standard deviation of the mean
+ gridsigma(ix,jy,kz)= &
+ gridsigma(ix,jy,kz)* &
+ sqrt(real(nclassunc))
+ gridsigmatotal=gridsigmatotal+ &
+ gridsigma(ix,jy,kz)
+ end do
+ end do
+ end do
+
+
+ !*******************************************************************
+ ! Generate output: may be in concentration (ng/m3) or in mixing
+ ! ratio (ppt) or both
+ ! Output the position and the values alternated multiplied by
+ ! 1 or -1, first line is number of values, number of positions
+ ! For backward simulations, the unit is seconds, stored in grid_time
+ !*******************************************************************
+
+ if (verbosity.eq.1) then
+ print*,'concoutput_inversion 4 (output)'
+ CALL SYSTEM_CLOCK(count_clock)
+ WRITE(*,*) 'SYSTEM_CLOCK',count_clock - count_clock0
+ endif
+
+ ! Concentration output
+ !*********************
+
+ if ((iout.eq.1).or.(iout.eq.3).or.(iout.eq.5)) then
+
+ if (verbosity.eq.1) then
+ print*,'concoutput_inversion (Wet deposition)'
+ CALL SYSTEM_CLOCK(count_clock)
+ WRITE(*,*) 'SYSTEM_CLOCK',count_clock - count_clock0
+ endif
+
+ if (verbosity.eq.1) then
+ print*,'concoutput_inversion (Concentrations)'
+ CALL SYSTEM_CLOCK(count_clock)
+ WRITE(*,*) 'SYSTEM_CLOCK',count_clock - count_clock0
+ endif
+
+ ! Concentrations
+
+ ! surf_only write only 1st layer
+
+ sp_count_i=0
+ sp_count_r=0
+ sp_fact=-1.
+ sp_zer=.true.
+ do kz=1,1
+ do jy=0,numygrid-1
+ do ix=0,numxgrid-1
+ if (grid(ix,jy,kz).gt.smallnum) then
+ if (sp_zer.eqv..true.) then ! first non zero value
+ sp_count_i=sp_count_i+1
+ sparse_dump_i(sp_count_i)= &
+ ix+jy*numxgrid+kz*numxgrid*numygrid
+ sp_zer=.false.
+ sp_fact=sp_fact*(-1.)
+ endif
+ sp_count_r=sp_count_r+1
+ sparse_dump_r(sp_count_r)= &
+ sp_fact* &
+ grid(ix,jy,kz)* &
+ factor3d(ix,jy,kz)/tot_mu(ks,kp)
+ sparse_dump_u(sp_count_r)= &
+ gridsigma(ix,jy,kz)* &
+ factor3d(ix,jy,kz)/tot_mu(ks,kp)
+
+ else ! concentration is zero
+ sp_zer=.true.
+ endif
+ end do
+ end do
+ end do
+ write(unitoutgrid) sp_count_i
+ write(unitoutgrid) (sparse_dump_i(i),i=1,sp_count_i)
+ write(unitoutgrid) sp_count_r
+ write(unitoutgrid) (sparse_dump_r(i),i=1,sp_count_r)
+
+ endif ! concentration output
+
+ ! Mixing ratio output
+ !********************
+
+ if ((iout.eq.2).or.(iout.eq.3)) then ! mixing ratio
+
+ ! Mixing ratios
+
+ ! surf_only write only 1st layer
+
+ sp_count_i=0
+ sp_count_r=0
+ sp_fact=-1.
+ sp_zer=.true.
+ do kz=1,1
+ do jy=0,numygrid-1
+ do ix=0,numxgrid-1
+ if (grid(ix,jy,kz).gt.smallnum) then
+ if (sp_zer.eqv..true.) then ! first non zero value
+ sp_count_i=sp_count_i+1
+ sparse_dump_i(sp_count_i)= &
+ ix+jy*numxgrid+kz*numxgrid*numygrid
+ sp_zer=.false.
+ sp_fact=sp_fact*(-1.)
+ endif
+ sp_count_r=sp_count_r+1
+ sparse_dump_r(sp_count_r)= &
+ sp_fact* &
+ 1.e12*grid(ix,jy,kz) &
+ /volume(ix,jy,kz)/outnum* &
+ weightair/weightmolar(ks)/densityoutgrid(ix,jy,kz)
+ sparse_dump_u(sp_count_r)= &
+ 1.e12*gridsigma(ix,jy,kz)/volume(ix,jy,kz)/ &
+ outnum*weightair/weightmolar(ks)/ &
+ densityoutgrid(ix,jy,kz)
+ else ! concentration is zero
+ sp_zer=.true.
+ endif
+ end do
+ end do
+ end do
+ write(unitoutgridppt) sp_count_i
+ write(unitoutgridppt) (sparse_dump_i(i),i=1,sp_count_i)
+ write(unitoutgridppt) sp_count_r
+ write(unitoutgridppt) (sparse_dump_r(i),i=1,sp_count_r)
+
+ endif ! output for ppt
+
+ end do ! nageclass
+
+ close(unitoutgridppt)
+ close(unitoutgrid)
+
+ ! itime is outside range
+10 continue
+
+ end do ! maxpointspec_act
+
+ end do ! nspec
+
+ ! RLT Aug 2017
+ ! Write out conversion factor for dry air
+ inquire(file=path(2)(1:length(2))//'factor_drygrid',exist=lexist)
+ if (lexist.and..not.lstart) then
+ ! open and append
+ open(unitoutfactor,file=path(2)(1:length(2))//'factor_drygrid',form='unformatted',&
+ status='old',action='write',access='append')
+ else
+ ! create new
+ open(unitoutfactor,file=path(2)(1:length(2))//'factor_drygrid',form='unformatted',&
+ status='replace',action='write')
+ endif
+ sp_count_i=0
+ sp_count_r=0
+ sp_fact=-1.
+ sp_zer=.true.
+ do kz=1,1
+ do jy=0,numygrid-1
+ do ix=0,numxgrid-1
+ if (factor_drygrid(ix,jy,kz).gt.(1.+smallnum).or.factor_drygrid(ix,jy,kz).lt.(1.-smallnum)) then
+ if (sp_zer.eqv..true.) then ! first value not equal to one
+ sp_count_i=sp_count_i+1
+ sparse_dump_i(sp_count_i)= &
+ ix+jy*numxgrid+kz*numxgrid*numygrid
+ sp_zer=.false.
+ sp_fact=sp_fact*(-1.)
+ endif
+ sp_count_r=sp_count_r+1
+ sparse_dump_r(sp_count_r)= &
+ sp_fact*factor_drygrid(ix,jy,kz)
+ else ! factor is one
+ sp_zer=.true.
+ endif
+ end do
+ end do
+ end do
+ write(unitoutfactor) sp_count_i
+ write(unitoutfactor) (sparse_dump_i(i),i=1,sp_count_i)
+ write(unitoutfactor) sp_count_r
+ write(unitoutfactor) (sparse_dump_r(i),i=1,sp_count_r)
+ close(unitoutfactor)
+
+
+ if (gridtotal.gt.0.) gridtotalunc=gridsigmatotal/gridtotal
+
+ ! Dump of receptor concentrations
+
+ if (numreceptor.gt.0 .and. (iout.eq.2 .or. iout.eq.3) ) then
+ write(unitoutreceptppt) itime
+ do ks=1,nspec
+ write(unitoutreceptppt) (1.e12*creceptor(i,ks)/outnum* &
+ weightair/weightmolar(ks)/densityoutrecept(i),i=1,numreceptor)
+ end do
+ endif
+
+ ! Dump of receptor concentrations
+
+ if (numreceptor.gt.0) then
+ write(unitoutrecept) itime
+ do ks=1,nspec
+ write(unitoutrecept) (1.e12*creceptor(i,ks)/outnum, &
+ i=1,numreceptor)
+ end do
+ endif
+
+ ! RLT Aug 2017
+ ! Write out conversion factor for dry air
+ if (numreceptor.gt.0) then
+ inquire(file=path(2)(1:length(2))//'factor_dryreceptor',exist=lexist)
+ if (lexist.and..not.lstart) then
+ ! open and append
+ open(unitoutfactor,file=path(2)(1:length(2))//'factor_dryreceptor',form='unformatted',&
+ status='old',action='write',access='append')
+ else
+ ! create new
+ open(unitoutfactor,file=path(2)(1:length(2))//'factor_dryreceptor',form='unformatted',&
+ status='replace',action='write')
+ endif
+ write(unitoutfactor) itime
+ write(unitoutfactor) (factor_dryrecept(i),i=1,numreceptor)
+ close(unitoutfactor)
+ endif
+
+ ! reset lstart
+ if (lstart) then
+ lstart=.false.
+ endif
+ print*, 'after writing output files: lstart = ',lstart
+
+
+ ! Reinitialization of grid
+ !*************************
+
+ do ks=1,nspec
+ do kp=1,maxpointspec_act
+ do i=1,numreceptor
+ creceptor(i,ks)=0.
+ end do
+ do jy=0,numygrid-1
+ do ix=0,numxgrid-1
+ do l=1,nclassunc
+ do nage=1,nageclass
+ do kz=1,numzgrid
+ gridunc(ix,jy,kz,ks,kp,l,nage)=0.
+ end do
+ end do
+ end do
+ end do
+ end do
+ end do
+ end do
+end subroutine concoutput_inversion
+
+subroutine concoutput_inversion_nest(itime,outnum)
+ ! i i
+ !*****************************************************************************
+ ! *
+ ! Output of the concentration grid and the receptor concentrations. *
+ ! *
+ ! Author: A. Stohl *
+ ! *
+ ! 24 May 1995 *
+ ! *
+ ! 13 April 1999, Major update: if output size is smaller, dump output *
+ ! in sparse matrix format; additional output of *
+ ! uncertainty *
+ ! *
+ ! 05 April 2000, Major update: output of age classes; output for backward*
+ ! runs is time spent in grid cell times total mass of *
+ ! species. *
+ ! *
+ ! 17 February 2002, Appropriate dimensions for backward and forward runs *
+ ! are now specified in file par_mod *
+ ! *
+ ! June 2006, write grid in sparse matrix with a single write command *
+ ! in order to save disk space *
+ ! *
+ ! 2008 new sparse matrix format *
+ !
+ ! January 2017, Separate files by release but include all timesteps *
+ ! *
+ !*****************************************************************************
+ ! *
+ ! Variables: *
+ ! outnum number of samples *
+ ! ncells number of cells with non-zero concentrations *
+ ! sparse .true. if in sparse matrix format, else .false. *
+ ! tot_mu 1 for forward, initial mass mixing ration for backw. runs *
+ ! *
+ !*****************************************************************************
+
+ use unc_mod
+ use mean_mod
+
+ implicit none
+
+ real(kind=dp) :: jul
+ integer :: itime,i,ix,jy,kz,ks,kp,l,iix,jjy,kzz,nage,jjjjmmdd,ihmmss
+ integer :: sp_count_i,sp_count_r
+ real :: sp_fact
+ real :: outnum,densityoutrecept(maxreceptor),xl,yl
+ ! RLT
+ real :: densitydryrecept(maxreceptor)
+ real :: factor_dryrecept(maxreceptor)
+
+ real(dep_prec) :: auxgrid(nclassunc)
+ real :: halfheight,dz,dz1,dz2,tot_mu(maxspec,maxpointspec_act)
+ real,parameter :: smallnum = tiny(0.0) ! smallest number that can be handled
+ real,parameter :: weightair=28.97
+ logical :: sp_zer
+ logical,save :: lnstart=.true.
+ logical,save,allocatable,dimension(:) :: lnstartrel
+ character :: adate*8,atime*6
+ character(len=3) :: anspec
+ logical :: lexist
+ character :: areldate*8,areltime*6
+
+ if(lnstart) then
+ allocate(lnstartrel(maxpointspec_act))
+ lnstartrel(:)=.true.
+ endif
+ print*, 'lnstartrel = ',lnstartrel
+
+ ! Determine current calendar date, needed for the file name
+ !**********************************************************
+
+ jul=bdate+real(itime,kind=dp)/86400._dp
+ call caldate(jul,jjjjmmdd,ihmmss)
+ write(adate,'(i8.8)') jjjjmmdd
+ write(atime,'(i6.6)') ihmmss
+
+ print*, 'outnum:',outnum
+ print*, 'datetime:',adate//atime
+
+ ! For forward simulations, output fields have dimension MAXSPEC,
+ ! for backward simulations, output fields have dimension MAXPOINT.
+ ! Thus, make loops either about nspec, or about numpoint
+ !*****************************************************************
+
+
+ if (ldirect.eq.1) then
+ do ks=1,nspec
+ do kp=1,maxpointspec_act
+ tot_mu(ks,kp)=1
+ end do
+ end do
+ else
+ do ks=1,nspec
+ do kp=1,maxpointspec_act
+ tot_mu(ks,kp)=xmass(kp,ks)
+ end do
+ end do
+ endif
+
+
+ !*******************************************************************
+ ! Compute air density: sufficiently accurate to take it
+ ! from coarse grid at some time
+ ! Determine center altitude of output layer, and interpolate density
+ ! data to that altitude
+ !*******************************************************************
+
+ do kz=1,numzgrid
+ if (kz.eq.1) then
+ halfheight=outheight(1)/2.
+ else
+ halfheight=(outheight(kz)+outheight(kz-1))/2.
+ endif
+ do kzz=2,nz
+ if ((height(kzz-1).lt.halfheight).and. &
+ (height(kzz).gt.halfheight)) goto 46
+ end do
+46 kzz=max(min(kzz,nz),2)
+ dz1=halfheight-height(kzz-1)
+ dz2=height(kzz)-halfheight
+ dz=dz1+dz2
+ do jy=0,numygridn-1
+ do ix=0,numxgridn-1
+ xl=outlon0n+real(ix)*dxoutn
+ yl=outlat0n+real(jy)*dyoutn
+ xl=(xl-xlon0)/dx
+ yl=(yl-ylat0)/dy
+ iix=max(min(nint(xl),nxmin1),0)
+ jjy=max(min(nint(yl),nymin1),0)
+ densityoutgrid(ix,jy,kz)=(rho(iix,jjy,kzz,2)*dz1+ &
+ rho(iix,jjy,kzz-1,2)*dz2)/dz
+ ! RLT
+ densitydrygrid(ix,jy,kz)=(rho_dry(iix,jjy,kzz,2)*dz1+ &
+ rho_dry(iix,jjy,kzz-1,2)*dz2)/dz
+ end do
+ end do
+ end do
+
+ do i=1,numreceptor
+ xl=xreceptor(i)
+ yl=yreceptor(i)
+ iix=max(min(nint(xl),nxmin1),0)
+ jjy=max(min(nint(yl),nymin1),0)
+ densityoutrecept(i)=rho(iix,jjy,1,2)
+ ! RLT
+ densitydryrecept(i)=rho_dry(iix,jjy,1,2)
+ end do
+
+ ! RLT
+ ! conversion factor for output relative to dry air
+ factor_drygrid=densityoutgrid/densitydrygrid
+ factor_dryrecept=densityoutrecept/densitydryrecept
+
+ ! Output is different for forward and backward simulations
+ do kz=1,numzgrid
+ do jy=0,numygridn-1
+ do ix=0,numxgridn-1
+ if (ldirect.eq.1) then
+ factor3d(ix,jy,kz)=1.e12/volumen(ix,jy,kz)/outnum
+ else
+ factor3d(ix,jy,kz)=real(abs(loutaver))/outnum
+ endif
+ end do
+ end do
+ end do
+
+ !*********************************************************************
+ ! Determine the standard deviation of the mean concentration or mixing
+ ! ratio (uncertainty of the output) and the dry and wet deposition
+ !*********************************************************************
+
+ do ks=1,nspec
+
+ write(anspec,'(i3.3)') ks
+
+ do kp=1,maxpointspec_act
+
+ print*, 'itime = ',itime
+ print*, 'lage(1) = ',lage(1)
+ print*, 'ireleasestart(kp) = ',ireleasestart(kp)
+ print*, 'ireleaseend(kp) = ',ireleaseend(kp)
+
+ ! check itime is within release and backward trajectory length
+ if (nageclass.eq.1) then
+ if ((itime.gt.ireleaseend(kp)).or.(itime.lt.(ireleasestart(kp)-lage(1)))) then
+ go to 10
+ endif
+ endif
+
+ ! calculate date of release
+ jul=bdate+real(ireleasestart(kp),kind=dp)/86400._dp ! this is the current day
+ call caldate(jul,jjjjmmdd,ihmmss)
+ write(areldate,'(i8.8)') jjjjmmdd
+ write(areltime,'(i6.6)') ihmmss
+ print*, areldate//areltime
+
+ ! calculate date of field
+ jul=bdate+real(itime,kind=dp)/86400._dp
+ call caldate(jul,jjjjmmdd,ihmmss)
+ write(adate,'(i8.8)') jjjjmmdd
+ write(atime,'(i6.6)') ihmmss
+ print*, adate//atime
+
+ if ((iout.eq.1).or.(iout.eq.3).or.(iout.eq.5)) then
+ if (ldirect.eq.1) then
+ ! concentrations
+ inquire(file=path(2)(1:length(2))//'grid_conc_nest_'//areldate// &
+ areltime//'_'//anspec,exist=lexist)
+ if(lexist.and..not.lnstartrel(kp)) then
+ ! open and append to existing file
+ open(unitoutgrid,file=path(2)(1:length(2))//'grid_conc_nest_'//areldate// &
+ areltime//'_'//anspec,form='unformatted',status='old',action='write',access='append')
+ else
+ ! open new file
+ open(unitoutgrid,file=path(2)(1:length(2))//'grid_conc_nest_'//areldate// &
+ areltime//'_'//anspec,form='unformatted',status='replace',action='write')
+ endif
+ else
+ ! residence times
+ inquire(file=path(2)(1:length(2))//'grid_time_nest_'//areldate// &
+ areltime//'_'//anspec,exist=lexist)
+ if(lexist.and..not.lnstartrel(kp)) then
+ ! open and append to existing file
+ open(unitoutgrid,file=path(2)(1:length(2))//'grid_time_nest_'//areldate// &
+ areltime//'_'//anspec,form='unformatted',status='old',action='write',access='append')
+ else
+ ! open new file
+ open(unitoutgrid,file=path(2)(1:length(2))//'grid_time_nest_'//areldate// &
+ areltime//'_'//anspec,form='unformatted',status='replace',action='write')
+ endif
+ endif
+ write(unitoutgrid) jjjjmmdd
+ write(unitoutgrid) ihmmss
+ endif
+
+ if ((iout.eq.2).or.(iout.eq.3)) then
+ ! mixing ratio
+ inquire(file=path(2)(1:length(2))//'grid_pptv_nest_'//areldate// &
+ areltime//'_'//anspec,exist=lexist)
+ if(lexist.and..not.lnstartrel(kp)) then
+ ! open and append to existing file
+ open(unitoutgridppt,file=path(2)(1:length(2))//'grid_pptv_nest_'//areldate// &
+ areltime//'_'//anspec,form='unformatted',status='old',action='write',access='append')
+ else
+ ! open new file
+ open(unitoutgridppt,file=path(2)(1:length(2))//'grid_pptv_nest_'//areldate// &
+ areltime//'_'//anspec,form='unformatted',status='replace',action='write')
+ endif
+ write(unitoutgridppt) jjjjmmdd
+ write(unitoutgridppt) ihmmss
+ endif
+
+ lnstartrel(kp)=.false.
+
+ do nage=1,nageclass
+
+ do jy=0,numygridn-1
+ do ix=0,numxgridn-1
+
+ ! CONCENTRATION OR MIXING RATIO
+ do kz=1,numzgrid
+ do l=1,nclassunc
+ auxgrid(l)=griduncn(ix,jy,kz,ks,kp,l,nage)
+ end do
+ call mean(auxgrid,grid(ix,jy,kz), &
+ gridsigma(ix,jy,kz),nclassunc)
+ ! Multiply by number of classes to get total concentration
+ grid(ix,jy,kz)= &
+ grid(ix,jy,kz)*nclassunc
+ ! Calculate standard deviation of the mean
+ gridsigma(ix,jy,kz)= &
+ gridsigma(ix,jy,kz)* &
+ sqrt(real(nclassunc))
+ end do
+ end do
+ end do
+
+
+ !*******************************************************************
+ ! Generate output: may be in concentration (ng/m3) or in mixing
+ ! ratio (ppt) or both
+ ! Output the position and the values alternated multiplied by
+ ! 1 or -1, first line is number of values, number of positions
+ ! For backward simulations, the unit is seconds, stored in grid_time
+ !*******************************************************************
+
+ ! Concentration output
+ !*********************
+
+ if ((iout.eq.1).or.(iout.eq.3).or.(iout.eq.5)) then
+
+ ! Concentrations
+
+ ! surf_only write only 1st layer
+
+ sp_count_i=0
+ sp_count_r=0
+ sp_fact=-1.
+ sp_zer=.true.
+ do kz=1,1
+ do jy=0,numygridn-1
+ do ix=0,numxgridn-1
+ if (grid(ix,jy,kz).gt.smallnum) then
+ if (sp_zer.eqv..true.) then ! first non zero value
+ sp_count_i=sp_count_i+1
+ sparse_dump_i(sp_count_i)= &
+ ix+jy*numxgridn+kz*numxgridn*numygridn
+ sp_zer=.false.
+ sp_fact=sp_fact*(-1.)
+ endif
+ sp_count_r=sp_count_r+1
+ sparse_dump_r(sp_count_r)= &
+ sp_fact* &
+ grid(ix,jy,kz)* &
+ factor3d(ix,jy,kz)/tot_mu(ks,kp)
+ ! if ((factor(ix,jy,kz)/tot_mu(ks,kp)).eq.0)
+ ! + write (*,*) factor(ix,jy,kz),tot_mu(ks,kp),ks,kp
+ sparse_dump_u(sp_count_r)= &
+ gridsigma(ix,jy,kz)* &
+ factor3d(ix,jy,kz)/tot_mu(ks,kp)
+ else ! concentration is zero
+ sp_zer=.true.
+ endif
+ end do
+ end do
+ end do
+ write(unitoutgrid) sp_count_i
+ write(unitoutgrid) (sparse_dump_i(i),i=1,sp_count_i)
+ write(unitoutgrid) sp_count_r
+ write(unitoutgrid) (sparse_dump_r(i),i=1,sp_count_r)
+
+ endif ! concentration output
+
+ ! Mixing ratio output
+ !********************
+
+ if ((iout.eq.2).or.(iout.eq.3)) then ! mixing ratio
+
+
+ ! Mixing ratios
+
+ ! surf_only write only 1st layer
+
+ sp_count_i=0
+ sp_count_r=0
+ sp_fact=-1.
+ sp_zer=.true.
+ do kz=1,1
+ do jy=0,numygridn-1
+ do ix=0,numxgridn-1
+ if (grid(ix,jy,kz).gt.smallnum) then
+ if (sp_zer.eqv..true.) then ! first non zero value
+ sp_count_i=sp_count_i+1
+ sparse_dump_i(sp_count_i)= &
+ ix+jy*numxgridn+kz*numxgridn*numygridn
+ sp_zer=.false.
+ sp_fact=sp_fact*(-1.)
+ endif
+ sp_count_r=sp_count_r+1
+ sparse_dump_r(sp_count_r)= &
+ sp_fact* &
+ 1.e12*grid(ix,jy,kz) &
+ /volumen(ix,jy,kz)/outnum* &
+ weightair/weightmolar(ks)/densityoutgrid(ix,jy,kz)
+ sparse_dump_u(sp_count_r)= &
+ 1.e12*gridsigma(ix,jy,kz)/volumen(ix,jy,kz)/ &
+ outnum*weightair/weightmolar(ks)/ &
+ densityoutgrid(ix,jy,kz)
+ else ! concentration is zero
+ sp_zer=.true.
+ endif
+ end do
+ end do
+ end do
+ write(unitoutgridppt) sp_count_i
+ write(unitoutgridppt) (sparse_dump_i(i),i=1,sp_count_i)
+ write(unitoutgridppt) sp_count_r
+ write(unitoutgridppt) (sparse_dump_r(i),i=1,sp_count_r)
+
+ endif ! output for ppt
+
+ end do ! nageclass
+
+ close(unitoutgridppt)
+ close(unitoutgrid)
+
+ ! itime is outside range
+10 continue
+
+ end do ! maxpointspec_act
+
+ end do ! nspec
+
+
+ ! RLT Aug 2017
+ ! Write out conversion factor for dry air
+ inquire(file=path(2)(1:length(2))//'factor_drygrid_nest',exist=lexist)
+ if (lexist.and..not.lnstart) then
+ ! open and append
+ open(unitoutfactor,file=path(2)(1:length(2))//'factor_drygrid_nest',form='unformatted',&
+ status='old',action='write',access='append')
+ else
+ ! create new
+ open(unitoutfactor,file=path(2)(1:length(2))//'factor_drygrid_nest',form='unformatted',&
+ status='replace',action='write')
+ endif
+ sp_count_i=0
+ sp_count_r=0
+ sp_fact=-1.
+ sp_zer=.true.
+ do kz=1,1
+ do jy=0,numygridn-1
+ do ix=0,numxgridn-1
+ if (factor_drygrid(ix,jy,kz).gt.(1.+smallnum).or.factor_drygrid(ix,jy,kz).lt.(1.-smallnum)) then
+ if (sp_zer.eqv..true.) then ! first value not equal to one
+ sp_count_i=sp_count_i+1
+ sparse_dump_i(sp_count_i)= &
+ ix+jy*numxgridn+kz*numxgridn*numygridn
+ sp_zer=.false.
+ sp_fact=sp_fact*(-1.)
+ endif
+ sp_count_r=sp_count_r+1
+ sparse_dump_r(sp_count_r)= &
+ sp_fact*factor_drygrid(ix,jy,kz)
+ else ! factor is one
+ sp_zer=.true.
+ endif
+ end do
+ end do
+ end do
+ write(unitoutfactor) sp_count_i
+ write(unitoutfactor) (sparse_dump_i(i),i=1,sp_count_i)
+ write(unitoutfactor) sp_count_r
+ write(unitoutfactor) (sparse_dump_r(i),i=1,sp_count_r)
+ close(unitoutfactor)
+
+ ! reset lnstart
+ if (lnstart) then
+ lnstart=.false.
+ endif
+
+ ! Reinitialization of grid
+ !*************************
+
+ do ks=1,nspec
+ do kp=1,maxpointspec_act
+ do i=1,numreceptor
+ creceptor(i,ks)=0.
+ end do
+ do jy=0,numygridn-1
+ do ix=0,numxgridn-1
+ do l=1,nclassunc
+ do nage=1,nageclass
+ do kz=1,numzgrid
+ griduncn(ix,jy,kz,ks,kp,l,nage)=0.
+ end do
+ end do
+ end do
+ end do
+ end do
+ end do
+ end do
+end subroutine concoutput_inversion_nest
+
+subroutine concoutput_surf(itime,outnum,gridtotalunc,wetgridtotalunc, &
+ drygridtotalunc)
+ ! i i o o
+ ! o
+ !*****************************************************************************
+ ! *
+ ! Output of the concentration grid and the receptor concentrations. *
+ ! *
+ ! Author: A. Stohl *
+ ! *
+ ! 24 May 1995 *
+ ! *
+ ! 13 April 1999, Major update: if output size is smaller, dump output *
+ ! in sparse matrix format; additional output of *
+ ! uncertainty *
+ ! *
+ ! 05 April 2000, Major update: output of age classes; output for backward*
+ ! runs is time spent in grid cell times total mass of *
+ ! species. *
+ ! *
+ ! 17 February 2002, Appropriate dimensions for backward and forward runs *
+ ! are now specified in file par_mod *
+ ! *
+ ! June 2006, write grid in sparse matrix with a single write command *
+ ! in order to save disk space *
+ ! *
+ ! 2008 new sparse matrix format *
+ ! *
+ !*****************************************************************************
+ ! *
+ ! Variables: *
+ ! outnum number of samples *
+ ! ncells number of cells with non-zero concentrations *
+ ! sparse .true. if in sparse matrix format, else .false. *
+ ! tot_mu 1 for forward, initial mass mixing ration for backw. runs *
+ ! *
+ !*****************************************************************************
+
+ use unc_mod
+ use mean_mod
+
+ implicit none
+
+ real(kind=dp) :: jul
+ integer :: itime,i,ix,jy,kz,ks,kp,l,iix,jjy,kzz,nage,jjjjmmdd,ihmmss
+ integer :: sp_count_i,sp_count_r
+ real :: sp_fact
+ real :: outnum,densityoutrecept(maxreceptor),xl,yl
+ ! RLT
+ real :: densitydryrecept(maxreceptor)
+ real :: factor_dryrecept(maxreceptor)
+
+ real(dep_prec) :: auxgrid(nclassunc)
+ real(sp) :: gridtotal,gridsigmatotal,gridtotalunc
+ real(dep_prec) :: wetgridtotal,wetgridsigmatotal,wetgridtotalunc
+ real(dep_prec) :: drygridtotal,drygridsigmatotal,drygridtotalunc
+ real :: halfheight,dz,dz1,dz2,tot_mu(maxspec,maxpointspec_act)
+ real,parameter :: smallnum = tiny(0.0) ! smallest number that can be handled
+ real,parameter :: weightair=28.97
+ logical :: sp_zer
+ character :: adate*8,atime*6
+ character(len=3) :: anspec
+ logical :: lexist
+
+
+ if (verbosity.eq.1) then
+ print*,'inside concoutput_surf '
+ CALL SYSTEM_CLOCK(count_clock)
+ WRITE(*,*) 'SYSTEM_CLOCK',count_clock - count_clock0
+ endif
+
+ ! Determine current calendar date, needed for the file name
+ !**********************************************************
+
+ jul=bdate+real(itime,kind=dp)/86400._dp
+ call caldate(jul,jjjjmmdd,ihmmss)
+ write(adate,'(i8.8)') jjjjmmdd
+ write(atime,'(i6.6)') ihmmss
+
+ open(unitdates,file=path(2)(1:length(2))//'dates', ACCESS='APPEND')
+ write(unitdates,'(a)') adate//atime
+ close(unitdates)
+
+ ! For forward simulations, output fields have dimension MAXSPEC,
+ ! for backward simulations, output fields have dimension MAXPOINT.
+ ! Thus, make loops either about nspec, or about numpoint
+ !*****************************************************************
+
+
+ if (ldirect.eq.1) then
+ do ks=1,nspec
+ do kp=1,maxpointspec_act
+ tot_mu(ks,kp)=1
+ end do
+ end do
+ else
+ do ks=1,nspec
+ do kp=1,maxpointspec_act
+ tot_mu(ks,kp)=xmass(kp,ks)
+ end do
+ end do
+ endif
+
+
+ if (verbosity.eq.1) then
+ print*,'concoutput_surf 2'
+ CALL SYSTEM_CLOCK(count_clock)
+ WRITE(*,*) 'SYSTEM_CLOCK',count_clock - count_clock0
+ endif
+
+ !*******************************************************************
+ ! Compute air density: sufficiently accurate to take it
+ ! from coarse grid at some time
+ ! Determine center altitude of output layer, and interpolate density
+ ! data to that altitude
+ !*******************************************************************
+
+ do kz=1,numzgrid
+ if (kz.eq.1) then
+ halfheight=outheight(1)/2.
+ else
+ halfheight=(outheight(kz)+outheight(kz-1))/2.
+ endif
+ do kzz=2,nz
+ if ((height(kzz-1).lt.halfheight).and. &
+ (height(kzz).gt.halfheight)) goto 46
+ end do
+46 kzz=max(min(kzz,nz),2)
+ dz1=halfheight-height(kzz-1)
+ dz2=height(kzz)-halfheight
+ dz=dz1+dz2
+ do jy=0,numygrid-1
+ do ix=0,numxgrid-1
+ xl=outlon0+real(ix)*dxout
+ yl=outlat0+real(jy)*dyout
+ xl=(xl-xlon0)/dx
+ yl=(yl-ylat0)/dy
+ iix=max(min(nint(xl),nxmin1),0)
+ jjy=max(min(nint(yl),nymin1),0)
+ densityoutgrid(ix,jy,kz)=(rho(iix,jjy,kzz,2)*dz1+ &
+ rho(iix,jjy,kzz-1,2)*dz2)/dz
+ ! RLT
+ densitydrygrid(ix,jy,kz)=(rho_dry(iix,jjy,kzz,2)*dz1+ &
+ rho_dry(iix,jjy,kzz-1,2)*dz2)/dz
+ end do
+ end do
+ end do
+
+ do i=1,numreceptor
+ xl=xreceptor(i)
+ yl=yreceptor(i)
+ iix=max(min(nint(xl),nxmin1),0)
+ jjy=max(min(nint(yl),nymin1),0)
+ densityoutrecept(i)=rho(iix,jjy,1,2)
+ ! RLT
+ densitydryrecept(i)=rho_dry(iix,jjy,1,2)
+ end do
+
+ ! RLT
+ ! conversion factor for output relative to dry air
+ factor_drygrid=densityoutgrid/densitydrygrid
+ factor_dryrecept=densityoutrecept/densitydryrecept
+
+ ! Output is different for forward and backward simulations
+ do kz=1,numzgrid
+ do jy=0,numygrid-1
+ do ix=0,numxgrid-1
+ if (ldirect.eq.1) then
+ factor3d(ix,jy,kz)=1.e12/volume(ix,jy,kz)/outnum
+ else
+ factor3d(ix,jy,kz)=real(abs(loutaver))/outnum
+ endif
+ end do
+ end do
+ end do
+
+ !*********************************************************************
+ ! Determine the standard deviation of the mean concentration or mixing
+ ! ratio (uncertainty of the output) and the dry and wet deposition
+ !*********************************************************************
+
+ if (verbosity.eq.1) then
+ print*,'concoutput_surf 3 (sd)'
+ CALL SYSTEM_CLOCK(count_clock)
+ WRITE(*,*) 'SYSTEM_CLOCK',count_clock - count_clock0
+ endif
+ gridtotal=0.
+ gridsigmatotal=0.
+ gridtotalunc=0.
+ wetgridtotal=0.
+ wetgridsigmatotal=0.
+ wetgridtotalunc=0.
+ drygridtotal=0.
+ drygridsigmatotal=0.
+ drygridtotalunc=0.
+
+ do ks=1,nspec
+
+ write(anspec,'(i3.3)') ks
+ if ((iout.eq.1).or.(iout.eq.3).or.(iout.eq.5)) then
+ if (ldirect.eq.1) then
+ open(unitoutgrid,file=path(2)(1:length(2))//'grid_conc_'//adate// &
+ atime//'_'//anspec,form='unformatted')
+ else
+ open(unitoutgrid,file=path(2)(1:length(2))//'grid_time_'//adate// &
+ atime//'_'//anspec,form='unformatted')
+ endif
+ write(unitoutgrid) itime
+ endif
+
+ if ((iout.eq.2).or.(iout.eq.3)) then ! mixing ratio
+ open(unitoutgridppt,file=path(2)(1:length(2))//'grid_pptv_'//adate// &
+ atime//'_'//anspec,form='unformatted')
+
+ write(unitoutgridppt) itime
+ endif
+
+ do kp=1,maxpointspec_act
+ do nage=1,nageclass
+
+ do jy=0,numygrid-1
+ do ix=0,numxgrid-1
+
+ ! WET DEPOSITION
+ if ((WETDEP).and.(ldirect.gt.0)) then
+ do l=1,nclassunc
+ auxgrid(l)=wetgridunc(ix,jy,ks,kp,l,nage)
+ end do
+ call mean(auxgrid,wetgrid(ix,jy), &
+ wetgridsigma(ix,jy),nclassunc)
+ ! Multiply by number of classes to get total concentration
+ wetgrid(ix,jy)=wetgrid(ix,jy) &
+ *nclassunc
+ wetgridtotal=wetgridtotal+wetgrid(ix,jy)
+ ! Calculate standard deviation of the mean
+ wetgridsigma(ix,jy)= &
+ wetgridsigma(ix,jy)* &
+ sqrt(real(nclassunc))
+ wetgridsigmatotal=wetgridsigmatotal+ &
+ wetgridsigma(ix,jy)
+ endif
+
+ ! DRY DEPOSITION
+ if ((DRYDEP).and.(ldirect.gt.0)) then
+ do l=1,nclassunc
+ auxgrid(l)=drygridunc(ix,jy,ks,kp,l,nage)
+ end do
+ call mean(auxgrid,drygrid(ix,jy), &
+ drygridsigma(ix,jy),nclassunc)
+ ! Multiply by number of classes to get total concentration
+ drygrid(ix,jy)=drygrid(ix,jy)* &
+ nclassunc
+ drygridtotal=drygridtotal+drygrid(ix,jy)
+ ! Calculate standard deviation of the mean
+ drygridsigma(ix,jy)= &
+ drygridsigma(ix,jy)* &
+ sqrt(real(nclassunc))
+125 drygridsigmatotal=drygridsigmatotal+ &
+ drygridsigma(ix,jy)
+ endif
+
+ ! CONCENTRATION OR MIXING RATIO
+ do kz=1,numzgrid
+ do l=1,nclassunc
+ auxgrid(l)=gridunc(ix,jy,kz,ks,kp,l,nage)
+ end do
+ call mean(auxgrid,grid(ix,jy,kz), &
+ gridsigma(ix,jy,kz),nclassunc)
+ ! Multiply by number of classes to get total concentration
+ grid(ix,jy,kz)= &
+ grid(ix,jy,kz)*nclassunc
+ gridtotal=gridtotal+grid(ix,jy,kz)
+ ! Calculate standard deviation of the mean
+ gridsigma(ix,jy,kz)= &
+ gridsigma(ix,jy,kz)* &
+ sqrt(real(nclassunc))
+ gridsigmatotal=gridsigmatotal+ &
+ gridsigma(ix,jy,kz)
+ end do
+ end do
+ end do
+
+
+ !*******************************************************************
+ ! Generate output: may be in concentration (ng/m3) or in mixing
+ ! ratio (ppt) or both
+ ! Output the position and the values alternated multiplied by
+ ! 1 or -1, first line is number of values, number of positions
+ ! For backward simulations, the unit is seconds, stored in grid_time
+ !*******************************************************************
+
+ if (verbosity.eq.1) then
+ print*,'concoutput_surf 4 (output)'
+ CALL SYSTEM_CLOCK(count_clock)
+ WRITE(*,*) 'SYSTEM_CLOCK',count_clock - count_clock0
+ endif
+
+ ! Concentration output
+ !*********************
+
+ if ((iout.eq.1).or.(iout.eq.3).or.(iout.eq.5)) then
+
+ if (verbosity.eq.1) then
+ print*,'concoutput_surf (Wet deposition)'
+ CALL SYSTEM_CLOCK(count_clock)
+ WRITE(*,*) 'SYSTEM_CLOCK',count_clock - count_clock0
+ endif
+
+ ! Wet deposition
+ sp_count_i=0
+ sp_count_r=0
+ sp_fact=-1.
+ sp_zer=.true.
+ if ((ldirect.eq.1).and.(WETDEP)) then
+ do jy=0,numygrid-1
+ do ix=0,numxgrid-1
+ ! concentraion greater zero
+ if (wetgrid(ix,jy).gt.smallnum) then
+ if (sp_zer.eqv..true.) then ! first non zero value
+ sp_count_i=sp_count_i+1
+ sparse_dump_i(sp_count_i)=ix+jy*numxgrid
+ sp_zer=.false.
+ sp_fact=sp_fact*(-1.)
+ endif
+ sp_count_r=sp_count_r+1
+ sparse_dump_r(sp_count_r)= &
+ sp_fact*1.e12*wetgrid(ix,jy)/area(ix,jy)
+ sparse_dump_u(sp_count_r)= &
+ 1.e12*wetgridsigma(ix,jy)/area(ix,jy)
+ else ! concentration is zero
+ sp_zer=.true.
+ endif
+ end do
+ end do
+ else
+ sp_count_i=0
+ sp_count_r=0
+ endif
+ write(unitoutgrid) sp_count_i
+ write(unitoutgrid) (sparse_dump_i(i),i=1,sp_count_i)
+ write(unitoutgrid) sp_count_r
+ write(unitoutgrid) (sparse_dump_r(i),i=1,sp_count_r)
+
+ if (verbosity.eq.1) then
+ print*,'concoutput_surf (Dry deposition)'
+ CALL SYSTEM_CLOCK(count_clock)
+ WRITE(*,*) 'SYSTEM_CLOCK',count_clock - count_clock0
+ endif
+ ! Dry deposition
+ sp_count_i=0
+ sp_count_r=0
+ sp_fact=-1.
+ sp_zer=.true.
+ if ((ldirect.eq.1).and.(DRYDEP)) then
+ do jy=0,numygrid-1
+ do ix=0,numxgrid-1
+ if (drygrid(ix,jy).gt.smallnum) then
+ if (sp_zer.eqv..true.) then ! first non zero value
+ sp_count_i=sp_count_i+1
+ sparse_dump_i(sp_count_i)=ix+jy*numxgrid
+ sp_zer=.false.
+ sp_fact=sp_fact*(-1.)
+ endif
+ sp_count_r=sp_count_r+1
+ sparse_dump_r(sp_count_r)= &
+ sp_fact* &
+ 1.e12*drygrid(ix,jy)/area(ix,jy)
+ sparse_dump_u(sp_count_r)= &
+ 1.e12*drygridsigma(ix,jy)/area(ix,jy)
+ else ! concentration is zero
+ sp_zer=.true.
+ endif
+ end do
+ end do
+ else
+ sp_count_i=0
+ sp_count_r=0
+ endif
+ write(unitoutgrid) sp_count_i
+ write(unitoutgrid) (sparse_dump_i(i),i=1,sp_count_i)
+ write(unitoutgrid) sp_count_r
+ write(unitoutgrid) (sparse_dump_r(i),i=1,sp_count_r)
+
+ if (verbosity.eq.1) then
+ print*,'concoutput_surf (Concentrations)'
+ CALL SYSTEM_CLOCK(count_clock)
+ WRITE(*,*) 'SYSTEM_CLOCK',count_clock - count_clock0
+ endif
+
+ ! Concentrations
+
+ ! surf_only write only 1st layer
+
+ sp_count_i=0
+ sp_count_r=0
+ sp_fact=-1.
+ sp_zer=.true.
+ do kz=1,1
+ do jy=0,numygrid-1
+ do ix=0,numxgrid-1
+ if (grid(ix,jy,kz).gt.smallnum) then
+ if (sp_zer.eqv..true.) then ! first non zero value
+ sp_count_i=sp_count_i+1
+ sparse_dump_i(sp_count_i)= &
+ ix+jy*numxgrid+kz*numxgrid*numygrid
+ sp_zer=.false.
+ sp_fact=sp_fact*(-1.)
+ endif
+ sp_count_r=sp_count_r+1
+ sparse_dump_r(sp_count_r)= &
+ sp_fact* &
+ grid(ix,jy,kz)* &
+ factor3d(ix,jy,kz)/tot_mu(ks,kp)
+ sparse_dump_u(sp_count_r)= &
+ gridsigma(ix,jy,kz)* &
+ factor3d(ix,jy,kz)/tot_mu(ks,kp)
+ else ! concentration is zero
+ sp_zer=.true.
+ endif
+ end do
+ end do
+ end do
+ write(unitoutgrid) sp_count_i
+ write(unitoutgrid) (sparse_dump_i(i),i=1,sp_count_i)
+ write(unitoutgrid) sp_count_r
+ write(unitoutgrid) (sparse_dump_r(i),i=1,sp_count_r)
+ endif ! concentration output
+
+ ! Mixing ratio output
+ !********************
+
+ if ((iout.eq.2).or.(iout.eq.3)) then ! mixing ratio
+
+ ! Wet deposition
+ sp_count_i=0
+ sp_count_r=0
+ sp_fact=-1.
+ sp_zer=.true.
+ if ((ldirect.eq.1).and.(WETDEP)) then
+ do jy=0,numygrid-1
+ do ix=0,numxgrid-1
+ if (wetgrid(ix,jy).gt.smallnum) then
+ if (sp_zer.eqv..true.) then ! first non zero value
+ sp_count_i=sp_count_i+1
+ sparse_dump_i(sp_count_i)= &
+ ix+jy*numxgrid
+ sp_zer=.false.
+ sp_fact=sp_fact*(-1.)
+ endif
+ sp_count_r=sp_count_r+1
+ sparse_dump_r(sp_count_r)= &
+ sp_fact* &
+ 1.e12*wetgrid(ix,jy)/area(ix,jy)
+ sparse_dump_u(sp_count_r)= &
+ 1.e12*wetgridsigma(ix,jy)/area(ix,jy)
+ else ! concentration is zero
+ sp_zer=.true.
+ endif
+ end do
+ end do
+ else
+ sp_count_i=0
+ sp_count_r=0
+ endif
+ write(unitoutgridppt) sp_count_i
+ write(unitoutgridppt) (sparse_dump_i(i),i=1,sp_count_i)
+ write(unitoutgridppt) sp_count_r
+ write(unitoutgridppt) (sparse_dump_r(i),i=1,sp_count_r)
+
+ ! Dry deposition
+ sp_count_i=0
+ sp_count_r=0
+ sp_fact=-1.
+ sp_zer=.true.
+ if ((ldirect.eq.1).and.(DRYDEP)) then
+ do jy=0,numygrid-1
+ do ix=0,numxgrid-1
+ if (drygrid(ix,jy).gt.smallnum) then
+ if (sp_zer.eqv..true.) then ! first non zero value
+ sp_count_i=sp_count_i+1
+ sparse_dump_i(sp_count_i)= &
+ ix+jy*numxgrid
+ sp_zer=.false.
+ sp_fact=sp_fact*(-1)
+ endif
+ sp_count_r=sp_count_r+1
+ sparse_dump_r(sp_count_r)= &
+ sp_fact* &
+ 1.e12*drygrid(ix,jy)/area(ix,jy)
+ sparse_dump_u(sp_count_r)= &
+ 1.e12*drygridsigma(ix,jy)/area(ix,jy)
+ else ! concentration is zero
+ sp_zer=.true.
+ endif
+ end do
+ end do
+ else
+ sp_count_i=0
+ sp_count_r=0
+ endif
+ write(unitoutgridppt) sp_count_i
+ write(unitoutgridppt) (sparse_dump_i(i),i=1,sp_count_i)
+ write(unitoutgridppt) sp_count_r
+ write(unitoutgridppt) (sparse_dump_r(i),i=1,sp_count_r)
+
+ ! Mixing ratios
+
+ ! surf_only write only 1st layer
+
+ sp_count_i=0
+ sp_count_r=0
+ sp_fact=-1.
+ sp_zer=.true.
+ do kz=1,1
+ do jy=0,numygrid-1
+ do ix=0,numxgrid-1
+ if (grid(ix,jy,kz).gt.smallnum) then
+ if (sp_zer.eqv..true.) then ! first non zero value
+ sp_count_i=sp_count_i+1
+ sparse_dump_i(sp_count_i)= &
+ ix+jy*numxgrid+kz*numxgrid*numygrid
+ sp_zer=.false.
+ sp_fact=sp_fact*(-1.)
+ endif
+ sp_count_r=sp_count_r+1
+ sparse_dump_r(sp_count_r)= &
+ sp_fact* &
+ 1.e12*grid(ix,jy,kz) &
+ /volume(ix,jy,kz)/outnum* &
+ weightair/weightmolar(ks)/densityoutgrid(ix,jy,kz)
+ sparse_dump_u(sp_count_r)= &
+ 1.e12*gridsigma(ix,jy,kz)/volume(ix,jy,kz)/ &
+ outnum*weightair/weightmolar(ks)/ &
+ densityoutgrid(ix,jy,kz)
+ else ! concentration is zero
+ sp_zer=.true.
+ endif
+ end do
+ end do
+ end do
+ write(unitoutgridppt) sp_count_i
+ write(unitoutgridppt) (sparse_dump_i(i),i=1,sp_count_i)
+ write(unitoutgridppt) sp_count_r
+ write(unitoutgridppt) (sparse_dump_r(i),i=1,sp_count_r)
+ endif ! output for ppt
+
+ end do
+ end do
+
+ close(unitoutgridppt)
+ close(unitoutgrid)
+
+ end do
+
+ ! RLT Aug 2017
+ ! Write out conversion factor for dry air
+ inquire(file=path(2)(1:length(2))//'factor_drygrid',exist=lexist)
+ if (lexist) then
+ ! open and append
+ open(unitoutfactor,file=path(2)(1:length(2))//'factor_drygrid',form='unformatted',&
+ status='old',action='write',access='append')
+ else
+ ! create new
+ open(unitoutfactor,file=path(2)(1:length(2))//'factor_drygrid',form='unformatted',&
+ status='new',action='write')
+ endif
+ sp_count_i=0
+ sp_count_r=0
+ sp_fact=-1.
+ sp_zer=.true.
+ do kz=1,1
+ do jy=0,numygrid-1
+ do ix=0,numxgrid-1
+ if (factor_drygrid(ix,jy,kz).gt.(1.+smallnum).or.factor_drygrid(ix,jy,kz).lt.(1.-smallnum)) then
+ if (sp_zer.eqv..true.) then ! first value not equal to one
+ sp_count_i=sp_count_i+1
+ sparse_dump_i(sp_count_i)= &
+ ix+jy*numxgrid+kz*numxgrid*numygrid
+ sp_zer=.false.
+ sp_fact=sp_fact*(-1.)
+ endif
+ sp_count_r=sp_count_r+1
+ sparse_dump_r(sp_count_r)= &
+ sp_fact*factor_drygrid(ix,jy,kz)
+ else ! factor is one
+ sp_zer=.true.
+ endif
+ end do
+ end do
+ end do
+ write(unitoutfactor) sp_count_i
+ write(unitoutfactor) (sparse_dump_i(i),i=1,sp_count_i)
+ write(unitoutfactor) sp_count_r
+ write(unitoutfactor) (sparse_dump_r(i),i=1,sp_count_r)
+ close(unitoutfactor)
+
+
+ if (gridtotal.gt.0.) gridtotalunc=gridsigmatotal/gridtotal
+ if (wetgridtotal.gt.0.) wetgridtotalunc=wetgridsigmatotal/ &
+ wetgridtotal
+ if (drygridtotal.gt.0.) drygridtotalunc=drygridsigmatotal/ &
+ drygridtotal
+
+ ! Dump of receptor concentrations
+
+ if (numreceptor.gt.0 .and. (iout.eq.2 .or. iout.eq.3) ) then
+ write(unitoutreceptppt) itime
+ do ks=1,nspec
+ write(unitoutreceptppt) (1.e12*creceptor(i,ks)/outnum* &
+ weightair/weightmolar(ks)/densityoutrecept(i),i=1,numreceptor)
+ end do
+ endif
+
+ ! Dump of receptor concentrations
+
+ if (numreceptor.gt.0) then
+ write(unitoutrecept) itime
+ do ks=1,nspec
+ write(unitoutrecept) (1.e12*creceptor(i,ks)/outnum, &
+ i=1,numreceptor)
+ end do
+ endif
+
+ ! RLT Aug 2017
+ ! Write out conversion factor for dry air
+ if (numreceptor.gt.0) then
+ inquire(file=path(2)(1:length(2))//'factor_dryreceptor',exist=lexist)
+ if (lexist) then
+ ! open and append
+ open(unitoutfactor,file=path(2)(1:length(2))//'factor_dryreceptor',form='unformatted',&
+ status='old',action='write',access='append')
+ else
+ ! create new
+ open(unitoutfactor,file=path(2)(1:length(2))//'factor_dryreceptor',form='unformatted',&
+ status='new',action='write')
+ endif
+ write(unitoutfactor) itime
+ write(unitoutfactor) (factor_dryrecept(i),i=1,numreceptor)
+ close(unitoutfactor)
+ endif
+
+ ! Reinitialization of grid
+ !*************************
+
+ do ks=1,nspec
+ do kp=1,maxpointspec_act
+ do i=1,numreceptor
+ creceptor(i,ks)=0.
+ end do
+ do jy=0,numygrid-1
+ do ix=0,numxgrid-1
+ do l=1,nclassunc
+ do nage=1,nageclass
+ do kz=1,numzgrid
+ gridunc(ix,jy,kz,ks,kp,l,nage)=0.
+ end do
+ end do
+ end do
+ end do
+ end do
+ end do
+ end do
+end subroutine concoutput_surf
+
+subroutine concoutput_surf_nest(itime,outnum)
+ ! i i
+ !*****************************************************************************
+ ! *
+ ! Output of the concentration grid and the receptor concentrations. *
+ ! *
+ ! Author: A. Stohl *
+ ! *
+ ! 24 May 1995 *
+ ! *
+ ! 13 April 1999, Major update: if output size is smaller, dump output *
+ ! in sparse matrix format; additional output of *
+ ! uncertainty *
+ ! *
+ ! 05 April 2000, Major update: output of age classes; output for backward*
+ ! runs is time spent in grid cell times total mass of *
+ ! species. *
+ ! *
+ ! 17 February 2002, Appropriate dimensions for backward and forward runs *
+ ! are now specified in file par_mod *
+ ! *
+ ! June 2006, write grid in sparse matrix with a single write command *
+ ! in order to save disk space *
+ ! *
+ ! 2008 new sparse matrix format *
+ ! *
+ !*****************************************************************************
+ ! *
+ ! Variables: *
+ ! outnum number of samples *
+ ! ncells number of cells with non-zero concentrations *
+ ! sparse .true. if in sparse matrix format, else .false. *
+ ! tot_mu 1 for forward, initial mass mixing ration for backw. runs *
+ ! *
+ !*****************************************************************************
+
+ use unc_mod
+ use mean_mod
+
+ implicit none
+
+ real(kind=dp) :: jul
+ integer :: itime,i,ix,jy,kz,ks,kp,l,iix,jjy,kzz,nage,jjjjmmdd,ihmmss
+ integer :: sp_count_i,sp_count_r
+ real :: sp_fact
+ real :: outnum,densityoutrecept(maxreceptor),xl,yl
+ ! RLT
+ real :: densitydryrecept(maxreceptor)
+ real :: factor_dryrecept(maxreceptor)
+
+ real(dep_prec) :: auxgrid(nclassunc)
+ real :: halfheight,dz,dz1,dz2,tot_mu(maxspec,maxpointspec_act)
+ real,parameter :: smallnum = tiny(0.0) ! smallest number that can be handled
+ real,parameter :: weightair=28.97
+ logical :: sp_zer
+ character :: adate*8,atime*6
+ character(len=3) :: anspec
+ logical :: lexist
+
+ ! Determine current calendar date, needed for the file name
+ !**********************************************************
+
+ jul=bdate+real(itime,kind=dp)/86400._dp
+ call caldate(jul,jjjjmmdd,ihmmss)
+ write(adate,'(i8.8)') jjjjmmdd
+ write(atime,'(i6.6)') ihmmss
+
+
+ ! For forward simulations, output fields have dimension MAXSPEC,
+ ! for backward simulations, output fields have dimension MAXPOINT.
+ ! Thus, make loops either about nspec, or about numpoint
+ !*****************************************************************
+
+
+ if (ldirect.eq.1) then
+ do ks=1,nspec
+ do kp=1,maxpointspec_act
+ tot_mu(ks,kp)=1
+ end do
+ end do
+ else
+ do ks=1,nspec
+ do kp=1,maxpointspec_act
+ tot_mu(ks,kp)=xmass(kp,ks)
+ end do
+ end do
+ endif
+
+
+ !*******************************************************************
+ ! Compute air density: sufficiently accurate to take it
+ ! from coarse grid at some time
+ ! Determine center altitude of output layer, and interpolate density
+ ! data to that altitude
+ !*******************************************************************
+
+ do kz=1,numzgrid
+ if (kz.eq.1) then
+ halfheight=outheight(1)/2.
+ else
+ halfheight=(outheight(kz)+outheight(kz-1))/2.
+ endif
+ do kzz=2,nz
+ if ((height(kzz-1).lt.halfheight).and. &
+ (height(kzz).gt.halfheight)) goto 46
+ end do
+46 kzz=max(min(kzz,nz),2)
+ dz1=halfheight-height(kzz-1)
+ dz2=height(kzz)-halfheight
+ dz=dz1+dz2
+ do jy=0,numygridn-1
+ do ix=0,numxgridn-1
+ xl=outlon0n+real(ix)*dxoutn
+ yl=outlat0n+real(jy)*dyoutn
+ xl=(xl-xlon0)/dx
+ yl=(yl-ylat0)/dy
+ iix=max(min(nint(xl),nxmin1),0)
+ jjy=max(min(nint(yl),nymin1),0)
+ densityoutgrid(ix,jy,kz)=(rho(iix,jjy,kzz,2)*dz1+ &
+ rho(iix,jjy,kzz-1,2)*dz2)/dz
+ ! RLT
+ densitydrygrid(ix,jy,kz)=(rho_dry(iix,jjy,kzz,2)*dz1+ &
+ rho_dry(iix,jjy,kzz-1,2)*dz2)/dz
+ end do
+ end do
+ end do
+
+ do i=1,numreceptor
+ xl=xreceptor(i)
+ yl=yreceptor(i)
+ iix=max(min(nint(xl),nxmin1),0)
+ jjy=max(min(nint(yl),nymin1),0)
+ densityoutrecept(i)=rho(iix,jjy,1,2)
+ ! RLT
+ densitydryrecept(i)=rho_dry(iix,jjy,1,2)
+ end do
+
+ ! RLT
+ ! conversion factor for output relative to dry air
+ factor_drygrid=densityoutgrid/densitydrygrid
+ factor_dryrecept=densityoutrecept/densitydryrecept
+
+ ! Output is different for forward and backward simulations
+ do kz=1,numzgrid
+ do jy=0,numygridn-1
+ do ix=0,numxgridn-1
+ if (ldirect.eq.1) then
+ factor3d(ix,jy,kz)=1.e12/volumen(ix,jy,kz)/outnum
+ else
+ factor3d(ix,jy,kz)=real(abs(loutaver))/outnum
+ endif
+ end do
+ end do
+ end do
+
+ !*********************************************************************
+ ! Determine the standard deviation of the mean concentration or mixing
+ ! ratio (uncertainty of the output) and the dry and wet deposition
+ !*********************************************************************
+
+ do ks=1,nspec
+
+ write(anspec,'(i3.3)') ks
+ if ((iout.eq.1).or.(iout.eq.3).or.(iout.eq.5)) then
+ if (ldirect.eq.1) then
+ open(unitoutgrid,file=path(2)(1:length(2))//'grid_conc_nest_' &
+ //adate// &
+ atime//'_'//anspec,form='unformatted')
+ else
+ open(unitoutgrid,file=path(2)(1:length(2))//'grid_time_nest_' &
+ //adate// &
+ atime//'_'//anspec,form='unformatted')
+ endif
+ write(unitoutgrid) itime
+ endif
+
+ if ((iout.eq.2).or.(iout.eq.3)) then ! mixing ratio
+ open(unitoutgridppt,file=path(2)(1:length(2))//'grid_pptv_nest_' &
+ //adate// &
+ atime//'_'//anspec,form='unformatted')
+
+ write(unitoutgridppt) itime
+ endif
+
+ do kp=1,maxpointspec_act
+ do nage=1,nageclass
+
+ do jy=0,numygridn-1
+ do ix=0,numxgridn-1
+
+ ! WET DEPOSITION
+ if ((WETDEP).and.(ldirect.gt.0)) then
+ do l=1,nclassunc
+ auxgrid(l)=wetgriduncn(ix,jy,ks,kp,l,nage)
+ end do
+ call mean(auxgrid,wetgrid(ix,jy), &
+ wetgridsigma(ix,jy),nclassunc)
+ ! Multiply by number of classes to get total concentration
+ wetgrid(ix,jy)=wetgrid(ix,jy) &
+ *nclassunc
+ ! Calculate standard deviation of the mean
+ wetgridsigma(ix,jy)= &
+ wetgridsigma(ix,jy)* &
+ sqrt(real(nclassunc))
+ endif
+
+ ! DRY DEPOSITION
+ if ((DRYDEP).and.(ldirect.gt.0)) then
+ do l=1,nclassunc
+ auxgrid(l)=drygriduncn(ix,jy,ks,kp,l,nage)
+ end do
+ call mean(auxgrid,drygrid(ix,jy), &
+ drygridsigma(ix,jy),nclassunc)
+ ! Multiply by number of classes to get total concentration
+ drygrid(ix,jy)=drygrid(ix,jy)* &
+ nclassunc
+ ! Calculate standard deviation of the mean
+ drygridsigma(ix,jy)= &
+ drygridsigma(ix,jy)* &
+ sqrt(real(nclassunc))
+ endif
+
+ ! CONCENTRATION OR MIXING RATIO
+ do kz=1,numzgrid
+ do l=1,nclassunc
+ auxgrid(l)=griduncn(ix,jy,kz,ks,kp,l,nage)
+ end do
+ call mean(auxgrid,grid(ix,jy,kz), &
+ gridsigma(ix,jy,kz),nclassunc)
+ ! Multiply by number of classes to get total concentration
+ grid(ix,jy,kz)= &
+ grid(ix,jy,kz)*nclassunc
+ ! Calculate standard deviation of the mean
+ gridsigma(ix,jy,kz)= &
+ gridsigma(ix,jy,kz)* &
+ sqrt(real(nclassunc))
+ end do
+ end do
+ end do
+
+
+ !*******************************************************************
+ ! Generate output: may be in concentration (ng/m3) or in mixing
+ ! ratio (ppt) or both
+ ! Output the position and the values alternated multiplied by
+ ! 1 or -1, first line is number of values, number of positions
+ ! For backward simulations, the unit is seconds, stored in grid_time
+ !*******************************************************************
+
+ ! Concentration output
+ !*********************
+ if ((iout.eq.1).or.(iout.eq.3).or.(iout.eq.5)) then
+
+ ! Wet deposition
+ sp_count_i=0
+ sp_count_r=0
+ sp_fact=-1.
+ sp_zer=.true.
+ if ((ldirect.eq.1).and.(WETDEP)) then
+ do jy=0,numygridn-1
+ do ix=0,numxgridn-1
+ !oncentraion greater zero
+ if (wetgrid(ix,jy).gt.smallnum) then
+ if (sp_zer.eqv..true.) then ! first non zero value
+ sp_count_i=sp_count_i+1
+ sparse_dump_i(sp_count_i)=ix+jy*numxgridn
+ sp_zer=.false.
+ sp_fact=sp_fact*(-1.)
+ endif
+ sp_count_r=sp_count_r+1
+ sparse_dump_r(sp_count_r)= &
+ sp_fact*1.e12*wetgrid(ix,jy)/arean(ix,jy)
+ sparse_dump_u(sp_count_r)= &
+ 1.e12*wetgridsigma(ix,jy)/area(ix,jy)
+ else ! concentration is zero
+ sp_zer=.true.
+ endif
+ end do
+ end do
+ else
+ sp_count_i=0
+ sp_count_r=0
+ endif
+ write(unitoutgrid) sp_count_i
+ write(unitoutgrid) (sparse_dump_i(i),i=1,sp_count_i)
+ write(unitoutgrid) sp_count_r
+ write(unitoutgrid) (sparse_dump_r(i),i=1,sp_count_r)
+ ! Dry deposition
+ sp_count_i=0
+ sp_count_r=0
+ sp_fact=-1.
+ sp_zer=.true.
+ if ((ldirect.eq.1).and.(DRYDEP)) then
+ do jy=0,numygridn-1
+ do ix=0,numxgridn-1
+ if (drygrid(ix,jy).gt.smallnum) then
+ if (sp_zer.eqv..true.) then ! first non zero value
+ sp_count_i=sp_count_i+1
+ sparse_dump_i(sp_count_i)=ix+jy*numxgridn
+ sp_zer=.false.
+ sp_fact=sp_fact*(-1.)
+ endif
+ sp_count_r=sp_count_r+1
+ sparse_dump_r(sp_count_r)= &
+ sp_fact* &
+ 1.e12*drygrid(ix,jy)/arean(ix,jy)
+ sparse_dump_u(sp_count_r)= &
+ 1.e12*drygridsigma(ix,jy)/area(ix,jy)
+ else ! concentration is zero
+ sp_zer=.true.
+ endif
+ end do
+ end do
+ else
+ sp_count_i=0
+ sp_count_r=0
+ endif
+ write(unitoutgrid) sp_count_i
+ write(unitoutgrid) (sparse_dump_i(i),i=1,sp_count_i)
+ write(unitoutgrid) sp_count_r
+ write(unitoutgrid) (sparse_dump_r(i),i=1,sp_count_r)
+
+ ! Concentrations
+
+ ! if surf_only write only 1st layer
+
+ if(surf_only.eq.1) then
+ sp_count_i=0
+ sp_count_r=0
+ sp_fact=-1.
+ sp_zer=.true.
+ do kz=1,1
+ do jy=0,numygridn-1
+ do ix=0,numxgridn-1
+ if (grid(ix,jy,kz).gt.smallnum) then
+ if (sp_zer.eqv..true.) then ! first non zero value
+ sp_count_i=sp_count_i+1
+ sparse_dump_i(sp_count_i)= &
+ ix+jy*numxgridn+kz*numxgridn*numygridn
+ sp_zer=.false.
+ sp_fact=sp_fact*(-1.)
+ endif
+ sp_count_r=sp_count_r+1
+ sparse_dump_r(sp_count_r)= &
+ sp_fact* &
+ grid(ix,jy,kz)* &
+ factor3d(ix,jy,kz)/tot_mu(ks,kp)
+ ! if ((factor(ix,jy,kz)/tot_mu(ks,kp)).eq.0)
+ ! + write (*,*) factor(ix,jy,kz),tot_mu(ks,kp),ks,kp
+ sparse_dump_u(sp_count_r)= &
+ gridsigma(ix,jy,kz)* &
+ factor3d(ix,jy,kz)/tot_mu(ks,kp)
+ else ! concentration is zero
+ sp_zer=.true.
+ endif
+ end do
+ end do
+ end do
+ write(unitoutgrid) sp_count_i
+ write(unitoutgrid) (sparse_dump_i(i),i=1,sp_count_i)
+ write(unitoutgrid) sp_count_r
+ write(unitoutgrid) (sparse_dump_r(i),i=1,sp_count_r)
+ else
+
+ ! write full vertical resolution
+
+ sp_count_i=0
+ sp_count_r=0
+ sp_fact=-1.
+ sp_zer=.true.
+ do kz=1,numzgrid
+ do jy=0,numygridn-1
+ do ix=0,numxgridn-1
+ if (grid(ix,jy,kz).gt.smallnum) then
+ if (sp_zer.eqv..true.) then ! first non zero value
+ sp_count_i=sp_count_i+1
+ sparse_dump_i(sp_count_i)= &
+ ix+jy*numxgridn+kz*numxgridn*numygridn
+ sp_zer=.false.
+ sp_fact=sp_fact*(-1.)
+ endif
+ sp_count_r=sp_count_r+1
+ sparse_dump_r(sp_count_r)= &
+ sp_fact* &
+ grid(ix,jy,kz)* &
+ factor3d(ix,jy,kz)/tot_mu(ks,kp)
+ sparse_dump_u(sp_count_r)= &
+ gridsigma(ix,jy,kz)* &
+ factor3d(ix,jy,kz)/tot_mu(ks,kp)
+ else ! concentration is zero
+ sp_zer=.true.
+ endif
+ end do
+ end do
+ end do
+ write(unitoutgrid) sp_count_i
+ write(unitoutgrid) (sparse_dump_i(i),i=1,sp_count_i)
+ write(unitoutgrid) sp_count_r
+ write(unitoutgrid) (sparse_dump_r(i),i=1,sp_count_r)
+ endif ! surf_only
+
+
+ endif ! concentration output
+
+ ! Mixing ratio output
+ !********************
+
+ if ((iout.eq.2).or.(iout.eq.3)) then ! mixing ratio
+
+ ! Wet deposition
+ sp_count_i=0
+ sp_count_r=0
+ sp_fact=-1.
+ sp_zer=.true.
+ if ((ldirect.eq.1).and.(WETDEP)) then
+ do jy=0,numygridn-1
+ do ix=0,numxgridn-1
+ if (wetgrid(ix,jy).gt.smallnum) then
+ if (sp_zer.eqv..true.) then ! first non zero value
+ sp_count_i=sp_count_i+1
+ sparse_dump_i(sp_count_i)= &
+ ix+jy*numxgridn
+ sp_zer=.false.
+ sp_fact=sp_fact*(-1.)
+ endif
+ sp_count_r=sp_count_r+1
+ sparse_dump_r(sp_count_r)= &
+ sp_fact* &
+ 1.e12*wetgrid(ix,jy)/arean(ix,jy)
+ sparse_dump_u(sp_count_r)= &
+ 1.e12*wetgridsigma(ix,jy)/area(ix,jy)
+ else ! concentration is zero
+ sp_zer=.true.
+ endif
+ end do
+ end do
+ else
+ sp_count_i=0
+ sp_count_r=0
+ endif
+ write(unitoutgridppt) sp_count_i
+ write(unitoutgridppt) (sparse_dump_i(i),i=1,sp_count_i)
+ write(unitoutgridppt) sp_count_r
+ write(unitoutgridppt) (sparse_dump_r(i),i=1,sp_count_r)
+
+ ! Dry deposition
+ sp_count_i=0
+ sp_count_r=0
+ sp_fact=-1.
+ sp_zer=.true.
+ if ((ldirect.eq.1).and.(DRYDEP)) then
+ do jy=0,numygridn-1
+ do ix=0,numxgridn-1
+ if (drygrid(ix,jy).gt.smallnum) then
+ if (sp_zer.eqv..true.) then ! first non zero value
+ sp_count_i=sp_count_i+1
+ sparse_dump_i(sp_count_i)= &
+ ix+jy*numxgridn
+ sp_zer=.false.
+ sp_fact=sp_fact*(-1)
+ endif
+ sp_count_r=sp_count_r+1
+ sparse_dump_r(sp_count_r)= &
+ sp_fact* &
+ 1.e12*drygrid(ix,jy)/arean(ix,jy)
+ sparse_dump_u(sp_count_r)= &
+ 1.e12*drygridsigma(ix,jy)/area(ix,jy)
+ else ! concentration is zero
+ sp_zer=.true.
+ endif
+ end do
+ end do
+ else
+ sp_count_i=0
+ sp_count_r=0
+ endif
+ write(unitoutgridppt) sp_count_i
+ write(unitoutgridppt) (sparse_dump_i(i),i=1,sp_count_i)
+ write(unitoutgridppt) sp_count_r
+ write(unitoutgridppt) (sparse_dump_r(i),i=1,sp_count_r)
+
+ ! Mixing ratios
+
+ ! if surf_only write only 1st layer
+
+ if(surf_only.eq.1) then
+ sp_count_i=0
+ sp_count_r=0
+ sp_fact=-1.
+ sp_zer=.true.
+ do kz=1,1
+ do jy=0,numygridn-1
+ do ix=0,numxgridn-1
+ if (grid(ix,jy,kz).gt.smallnum) then
+ if (sp_zer.eqv..true.) then ! first non zero value
+ sp_count_i=sp_count_i+1
+ sparse_dump_i(sp_count_i)= &
+ ix+jy*numxgridn+kz*numxgridn*numygridn
+ sp_zer=.false.
+ sp_fact=sp_fact*(-1.)
+ endif
+ sp_count_r=sp_count_r+1
+ sparse_dump_r(sp_count_r)= &
+ sp_fact* &
+ 1.e12*grid(ix,jy,kz) &
+ /volumen(ix,jy,kz)/outnum* &
+ weightair/weightmolar(ks)/densityoutgrid(ix,jy,kz)
+ sparse_dump_u(sp_count_r)= &
+ 1.e12*gridsigma(ix,jy,kz)/volumen(ix,jy,kz)/ &
+ outnum*weightair/weightmolar(ks)/ &
+ densityoutgrid(ix,jy,kz)
+ else ! concentration is zero
+ sp_zer=.true.
+ endif
+ end do
+ end do
+ end do
+ write(unitoutgridppt) sp_count_i
+ write(unitoutgridppt) (sparse_dump_i(i),i=1,sp_count_i)
+ write(unitoutgridppt) sp_count_r
+ write(unitoutgridppt) (sparse_dump_r(i),i=1,sp_count_r)
+ else
+
+ ! write full vertical resolution
+
+ sp_count_i=0
+ sp_count_r=0
+ sp_fact=-1.
+ sp_zer=.true.
+ do kz=1,numzgrid
+ do jy=0,numygridn-1
+ do ix=0,numxgridn-1
+ if (grid(ix,jy,kz).gt.smallnum) then
+ if (sp_zer.eqv..true.) then ! first non zero value
+ sp_count_i=sp_count_i+1
+ sparse_dump_i(sp_count_i)= &
+ ix+jy*numxgridn+kz*numxgridn*numygridn
+ sp_zer=.false.
+ sp_fact=sp_fact*(-1.)
+ endif
+ sp_count_r=sp_count_r+1
+ sparse_dump_r(sp_count_r)= &
+ sp_fact* &
+ 1.e12*grid(ix,jy,kz) &
+ /volumen(ix,jy,kz)/outnum* &
+ weightair/weightmolar(ks)/densityoutgrid(ix,jy,kz)
+ sparse_dump_u(sp_count_r)= &
+ 1.e12*gridsigma(ix,jy,kz)/volumen(ix,jy,kz)/ &
+ outnum*weightair/weightmolar(ks)/ &
+ densityoutgrid(ix,jy,kz)
+ else ! concentration is zero
+ sp_zer=.true.
+ endif
+ end do
+ end do
+ end do
+ write(unitoutgridppt) sp_count_i
+ write(unitoutgridppt) (sparse_dump_i(i),i=1,sp_count_i)
+ write(unitoutgridppt) sp_count_r
+ write(unitoutgridppt) (sparse_dump_r(i),i=1,sp_count_r)
+ endif ! surf_only
+
+ endif ! output for ppt
+
+ end do
+ end do
+
+ close(unitoutgridppt)
+ close(unitoutgrid)
+
+ end do
+
+ ! RLT Aug 2017
+ ! Write out conversion factor for dry air
+ inquire(file=path(2)(1:length(2))//'factor_drygrid_nest',exist=lexist)
+ if (lexist) then
+ ! open and append
+ open(unitoutfactor,file=path(2)(1:length(2))//'factor_drygrid_nest',form='unformatted',&
+ status='old',action='write',access='append')
+ else
+ ! create new
+ open(unitoutfactor,file=path(2)(1:length(2))//'factor_drygrid_nest',form='unformatted',&
+ status='new',action='write')
+ endif
+ sp_count_i=0
+ sp_count_r=0
+ sp_fact=-1.
+ sp_zer=.true.
+ do kz=1,1
+ do jy=0,numygridn-1
+ do ix=0,numxgridn-1
+ if (factor_drygrid(ix,jy,kz).gt.(1.+smallnum).or.factor_drygrid(ix,jy,kz).lt.(1.-smallnum)) then
+ if (sp_zer.eqv..true.) then ! first value not equal to one
+ sp_count_i=sp_count_i+1
+ sparse_dump_i(sp_count_i)= &
+ ix+jy*numxgridn+kz*numxgridn*numygridn
+ sp_zer=.false.
+ sp_fact=sp_fact*(-1.)
+ endif
+ sp_count_r=sp_count_r+1
+ sparse_dump_r(sp_count_r)= &
+ sp_fact*factor_drygrid(ix,jy,kz)
+ else ! factor is one
+ sp_zer=.true.
+ endif
+ end do
+ end do
+ end do
+ write(unitoutfactor) sp_count_i
+ write(unitoutfactor) (sparse_dump_i(i),i=1,sp_count_i)
+ write(unitoutfactor) sp_count_r
+ write(unitoutfactor) (sparse_dump_r(i),i=1,sp_count_r)
+ close(unitoutfactor)
+
+
+
+ ! Reinitialization of grid
+ !*************************
+
+ do ks=1,nspec
+ do kp=1,maxpointspec_act
+ do i=1,numreceptor
+ creceptor(i,ks)=0.
+ end do
+ do jy=0,numygridn-1
+ do ix=0,numxgridn-1
+ do l=1,nclassunc
+ do nage=1,nageclass
+ do kz=1,numzgrid
+ griduncn(ix,jy,kz,ks,kp,l,nage)=0.
+ end do
+ end do
+ end do
+ end do
+ end do
+ end do
+ end do
+end subroutine concoutput_surf_nest
+
+subroutine initial_cond_output(itime)
+ ! i
+ !*****************************************************************************
+ ! *
+ ! Output of the initial condition sensitivity field. *
+ ! *
+ ! Author: A. Stohl *
+ ! *
+ ! 24 May 1995 *
+ ! *
+ ! 13 April 1999, Major update: if output size is smaller, dump output *
+ ! in sparse matrix format; additional output of *
+ ! uncertainty *
+ ! *
+ ! 05 April 2000, Major update: output of age classes; output for backward*
+ ! runs is time spent in grid cell times total mass of *
+ ! species. *
+ ! *
+ ! 17 February 2002, Appropriate dimensions for backward and forward runs *
+ ! are now specified in file par_mod *
+ ! *
+ ! June 2006, write grid in sparse matrix with a single write command *
+ ! in order to save disk space *
+ ! *
+ ! 2008 new sparse matrix format *
+ ! *
+ !*****************************************************************************
+ ! *
+ ! Variables: *
+ ! ncells number of cells with non-zero concentrations *
+ ! sparse .true. if in sparse matrix format, else .false. *
+ ! *
+ !*****************************************************************************
+
+ use unc_mod
+
+ implicit none
+
+ integer :: itime,i,ix,jy,kz,ks,kp,sp_count_i,sp_count_r
+ real :: sp_fact,fact_recept
+ real,parameter :: smallnum = tiny(0.0) ! smallest number that can be handled
+ logical :: sp_zer
+ character(len=3) :: anspec
+
+
+ !*********************************************************************
+ ! Determine the standard deviation of the mean concentration or mixing
+ ! ratio (uncertainty of the output) and the dry and wet deposition
+ !*********************************************************************
+
+ do ks=1,nspec
+
+ write(anspec,'(i3.3)') ks
+ open(97,file=path(2)(1:length(2))//'grid_initial'// &
+ '_'//anspec,form='unformatted')
+ write(97) itime
+
+ do kp=1,maxpointspec_act
+
+ if (ind_rel.eq.1) then
+ fact_recept=rho_rel(kp)
+ else
+ fact_recept=1.
+ endif
+
+ !*******************************************************************
+ ! Generate output: may be in concentration (ng/m3) or in mixing
+ ! ratio (ppt) or both
+ ! Output the position and the values alternated multiplied by
+ ! 1 or -1, first line is number of values, number of positions
+ ! For backward simulations, the unit is seconds, stored in grid_time
+ !*******************************************************************
+
+ ! Write out dummy "wet and dry deposition" fields, to keep same format
+ ! as for concentration output
+ sp_count_i=0
+ sp_count_r=0
+ write(97) sp_count_i
+ write(97) (sparse_dump_i(i),i=1,sp_count_i)
+ write(97) sp_count_r
+ write(97) (sparse_dump_r(i),i=1,sp_count_r)
+ write(97) sp_count_i
+ write(97) (sparse_dump_i(i),i=1,sp_count_i)
+ write(97) sp_count_r
+ write(97) (sparse_dump_r(i),i=1,sp_count_r)
+
+
+ ! Write out sensitivity to initial conditions
+ sp_count_i=0
+ sp_count_r=0
+ sp_fact=-1.
+ sp_zer=.true.
+ do kz=1,numzgrid
+ do jy=0,numygrid-1
+ do ix=0,numxgrid-1
+ if (init_cond(ix,jy,kz,ks,kp).gt.smallnum) then
+ if (sp_zer.eqv..true.) then ! first non zero value
+ sp_count_i=sp_count_i+1
+ sparse_dump_i(sp_count_i)= &
+ ix+jy*numxgrid+kz*numxgrid*numygrid
+ sp_zer=.false.
+ sp_fact=sp_fact*(-1.)
+ endif
+ sp_count_r=sp_count_r+1
+ sparse_dump_r(sp_count_r)=sp_fact* &
+ init_cond(ix,jy,kz,ks,kp)/xmass(kp,ks)*fact_recept
+ else ! concentration is zero
+ sp_zer=.true.
+ endif
+ end do
+ end do
+ end do
+ write(97) sp_count_i
+ write(97) (sparse_dump_i(i),i=1,sp_count_i)
+ write(97) sp_count_r
+ write(97) (sparse_dump_r(i),i=1,sp_count_r)
+
+
+ end do
+
+ close(97)
+
+ end do
+end subroutine initial_cond_output
+
+subroutine initial_cond_output_inversion(itime)
+ ! i
+ !*****************************************************************************
+ ! *
+ ! Output of the initial condition sensitivity field. *
+ ! *
+ ! Author: A. Stohl *
+ ! *
+ ! 24 May 1995 *
+ ! *
+ ! 13 April 1999, Major update: if output size is smaller, dump output *
+ ! in sparse matrix format; additional output of *
+ ! uncertainty *
+ ! *
+ ! 05 April 2000, Major update: output of age classes; output for backward*
+ ! runs is time spent in grid cell times total mass of *
+ ! species. *
+ ! *
+ ! 17 February 2002, Appropriate dimensions for backward and forward runs *
+ ! are now specified in file par_mod *
+ ! *
+ ! June 2006, write grid in sparse matrix with a single write command *
+ ! in order to save disk space *
+ ! *
+ ! 2008 new sparse matrix format *
+ ! *
+ !*****************************************************************************
+ ! *
+ ! Variables: *
+ ! ncells number of cells with non-zero concentrations *
+ ! sparse .true. if in sparse matrix format, else .false. *
+ ! *
+ !*****************************************************************************
+
+ use unc_mod
+
+ implicit none
+
+ integer :: itime,i,ix,jy,kz,ks,kp,sp_count_i,sp_count_r
+ integer :: jjjjmmdd, ihmmss
+ real(kind=dp) :: jul
+ real :: sp_fact,fact_recept
+ real,parameter :: smallnum = tiny(0.0) ! smallest number that can be handled
+ logical :: sp_zer,lexist
+ logical,save :: listart=.true.
+ logical,save,allocatable,dimension(:) :: listartrel
+ character :: adate*8,atime*6
+ character :: areldate*8,areltime*6
+ character(len=3) :: anspec
+
+ if(listart) then
+ allocate(listartrel(maxpointspec_act))
+ listartrel(:)=.true.
+ endif
+ print*, 'listartrel = ',listartrel
+
+ !*********************************************************************
+ ! Determine the standard deviation of the mean concentration or mixing
+ ! ratio (uncertainty of the output) and the dry and wet deposition
+ !*********************************************************************
+
+ do ks=1,nspec
+
+ write(anspec,'(i3.3)') ks
+
+ do kp=1,maxpointspec_act
+
+ ! calculate date of release
+ jul=bdate+real(ireleasestart(kp),kind=dp)/86400._dp ! this is the current day
+ call caldate(jul,jjjjmmdd,ihmmss)
+ write(areldate,'(i8.8)') jjjjmmdd
+ write(areltime,'(i6.6)') ihmmss
+ print*, areldate//areltime
+
+ ! calculate date of field
+ jul=bdate+real(itime,kind=dp)/86400._dp
+ call caldate(jul,jjjjmmdd,ihmmss)
+ write(adate,'(i8.8)') jjjjmmdd
+ write(atime,'(i6.6)') ihmmss
+ print*, adate//atime
+
+ inquire(file=path(2)(1:length(2))//'grid_initial_'//areldate// &
+ areltime//'_'//anspec,exist=lexist)
+ if(lexist.and..not.listartrel(kp)) then
+ ! open and append to existing file
+ open(97,file=path(2)(1:length(2))//'grid_initial_'//areldate// &
+ areltime//'_'//anspec,form='unformatted',status='old',action='write',access='append')
+ else
+ ! open new file
+ open(97,file=path(2)(1:length(2))//'grid_initial_'//areldate// &
+ areltime//'_'//anspec,form='unformatted',status='replace',action='write')
+ endif
+ write(97) jjjjmmdd
+ write(97) ihmmss
+
+ listartrel(kp)=.false.
+
+ if (ind_rel.eq.1) then
+ fact_recept=rho_rel(kp)
+ else
+ fact_recept=1.
+ endif
+
+ !*******************************************************************
+ ! Generate output: may be in concentration (ng/m3) or in mixing
+ ! ratio (ppt) or both
+ ! Output the position and the values alternated multiplied by
+ ! 1 or -1, first line is number of values, number of positions
+ ! For backward simulations, the unit is seconds, stored in grid_time
+ !*******************************************************************
+
+ ! Write out dummy "wet and dry deposition" fields, to keep same format
+ ! as for concentration output
+
+ ! Write out sensitivity to initial conditions
+ sp_count_i=0
+ sp_count_r=0
+ sp_fact=-1.
+ sp_zer=.true.
+ do kz=1,numzgrid
+ do jy=0,numygrid-1
+ do ix=0,numxgrid-1
+ if (init_cond(ix,jy,kz,ks,kp).gt.smallnum) then
+ if (sp_zer.eqv..true.) then ! first non zero value
+ sp_count_i=sp_count_i+1
+ sparse_dump_i(sp_count_i)= &
+ ix+jy*numxgrid+kz*numxgrid*numygrid
+ sp_zer=.false.
+ sp_fact=sp_fact*(-1.)
+ endif
+ sp_count_r=sp_count_r+1
+ sparse_dump_r(sp_count_r)=sp_fact* &
+ init_cond(ix,jy,kz,ks,kp)/xmass(kp,ks)*fact_recept
+ else ! concentration is zero
+ sp_zer=.true.
+ endif
+ end do
+ end do
+ end do
+ write(97) sp_count_i
+ write(97) (sparse_dump_i(i),i=1,sp_count_i)
+ write(97) sp_count_r
+ write(97) (sparse_dump_r(i),i=1,sp_count_r)
+
+ close(97)
+
+ end do
+
+ end do
+
+ ! reset listart
+ if (listart) then
+ listart=.false.
+ endif
+end subroutine initial_cond_output_inversion
+
+end module binary_output_mod
\ No newline at end of file
diff --git a/src/calcpar.f90 b/src/calcpar.f90
deleted file mode 100644
index 50b6e46a..00000000
--- a/src/calcpar.f90
+++ /dev/null
@@ -1,269 +0,0 @@
-! SPDX-FileCopyrightText: FLEXPART 1998-2019, see flexpart_license.txt
-! SPDX-License-Identifier: GPL-3.0-or-later
-
-subroutine calcpar(n,uuh,vvh,pvh,metdata_format)
- ! i i i o
- !*****************************************************************************
- ! *
- ! Computation of several boundary layer parameters needed for the *
- ! dispersion calculation and calculation of dry deposition velocities. *
- ! All parameters are calculated over the entire grid. *
- ! *
- ! Author: A. Stohl *
- ! *
- ! 21 May 1995 *
- ! *
- ! ------------------------------------------------------------------ *
- ! Petra Seibert, Feb 2000: *
- ! convection scheme: *
- ! new variables in call to richardson *
- ! *
- ! CHANGE 17/11/2005 Caroline Forster NCEP GFS version *
- ! *
- ! Changes, Bernd C. Krueger, Feb. 2001: *
- ! Variables tth and qvh (on eta coordinates) in common block *
- ! *
- ! Unified ECMWF and GFS builds *
- ! Marian Harustak, 12.5.2017 *
- ! - Merged calcpar and calcpar_gfs into one routine using if-then *
- ! for meteo-type dependent code *
- !*****************************************************************************
-
- !*****************************************************************************
- ! *
- ! Variables: *
- ! n temporal index for meteorological fields (1 to 3) *
- ! uuh *
- ! vvh *
- ! pvh *
- ! metdata_format format of metdata (ecmwf/gfs) *
- ! *
- ! Constants: *
- ! *
- ! *
- ! Functions: *
- ! scalev computation of ustar *
- ! obukhov computatio of Obukhov length *
- ! *
- !*****************************************************************************
-
- use par_mod
- use com_mod
- use class_gribfile
-
- implicit none
-
- integer :: metdata_format
- integer :: n,ix,jy,i,kz,lz,kzmin,llev,loop_start
- real :: ttlev(nuvzmax),qvlev(nuvzmax),obukhov,scalev,ol,hmixplus
- real :: ulev(nuvzmax),vlev(nuvzmax),ew,rh,vd(maxspec),subsceff,ylat
- real :: altmin,tvold,pold,zold,pint,tv,zlev(nuvzmax),hmixdummy,akzdummy
- real :: uuh(0:nxmax-1,0:nymax-1,nuvzmax)
- real :: vvh(0:nxmax-1,0:nymax-1,nuvzmax)
- real :: pvh(0:nxmax-1,0:nymax-1,nuvzmax)
- real,parameter :: const=r_air/ga
-
- !write(*,*) 'in calcpar writting snowheight'
- !***********************************
- ! for test: write out snow depths
-
- ! open(4,file='slandusetest',form='formatted')
- ! do 5 ix=0,nxmin1
- !5 write (4,*) (sd(ix,jy,1,n),jy=0,nymin1)
- ! close(4)
-
-
- ! Loop over entire grid
- !**********************
-
- do jy=0,nymin1
-
- ! Set minimum height for tropopause
- !**********************************
-
- ylat=ylat0+real(jy)*dy
- if ((ylat.ge.-20.).and.(ylat.le.20.)) then
- altmin = 5000.
- else
- if ((ylat.gt.20.).and.(ylat.lt.40.)) then
- altmin=2500.+(40.-ylat)*125.
- else if ((ylat.gt.-40.).and.(ylat.lt.-20.)) then
- altmin=2500.+(40.+ylat)*125.
- else
- altmin=2500.
- endif
- endif
-
- do ix=0,nxmin1
-
- ! 1) Calculation of friction velocity
- !************************************
-
- ustar(ix,jy,1,n)=scalev(ps(ix,jy,1,n),tt2(ix,jy,1,n), &
- td2(ix,jy,1,n),surfstr(ix,jy,1,n))
- if (ustar(ix,jy,1,n).le.1.e-8) ustar(ix,jy,1,n)=1.e-8
-
- ! 2) Calculation of inverse Obukhov length scale
- !***********************************************
-
- if (metdata_format.eq.GRIBFILE_CENTRE_NCEP) then
- ! NCEP version: find first level above ground
- llev = 0
- do i=1,nuvz
- if (ps(ix,jy,1,n).lt.akz(i)) llev=i
- end do
- llev = llev+1
- if (llev.gt.nuvz) llev = nuvz-1
- ! NCEP version
-
- ! calculate inverse Obukhov length scale with tth(llev)
- ol=obukhov(ps(ix,jy,1,n),tt2(ix,jy,1,n),td2(ix,jy,1,n), &
- tth(ix,jy,llev,n),ustar(ix,jy,1,n),sshf(ix,jy,1,n),akm,bkm,akz(llev),metdata_format)
- else
- llev=0
- ol=obukhov(ps(ix,jy,1,n),tt2(ix,jy,1,n),td2(ix,jy,1,n), &
- tth(ix,jy,2,n),ustar(ix,jy,1,n),sshf(ix,jy,1,n),akm,bkm,akzdummy,metdata_format)
- end if
-
- if (ol.ne.0.) then
- oli(ix,jy,1,n)=1./ol
- else
- oli(ix,jy,1,n)=99999.
- endif
-
-
- ! 3) Calculation of convective velocity scale and mixing height
- !**************************************************************
-
- do i=1,nuvz
- ulev(i)=uuh(ix,jy,i)
- vlev(i)=vvh(ix,jy,i)
- ttlev(i)=tth(ix,jy,i,n)
- qvlev(i)=qvh(ix,jy,i,n)
- end do
-
- if (metdata_format.eq.GRIBFILE_CENTRE_NCEP) then
- ! NCEP version hmix has been read in in readwind.f, is therefore not calculated here
- call richardson(ps(ix,jy,1,n),ustar(ix,jy,1,n),ttlev,qvlev, &
- ulev,vlev,nuvz,akz,bkz,sshf(ix,jy,1,n),tt2(ix,jy,1,n), &
- td2(ix,jy,1,n),hmixdummy,wstar(ix,jy,1,n),hmixplus,metdata_format)
- else
- call richardson(ps(ix,jy,1,n),ustar(ix,jy,1,n),ttlev,qvlev, &
- ulev,vlev,nuvz,akz,bkz,sshf(ix,jy,1,n),tt2(ix,jy,1,n), &
- td2(ix,jy,1,n),hmix(ix,jy,1,n),wstar(ix,jy,1,n),hmixplus,metdata_format)
- end if
-
- if(lsubgrid.eq.1) then
- subsceff=min(excessoro(ix,jy),hmixplus)
- else
- subsceff=0.0
- endif
- !
- ! CALCULATE HMIX EXCESS ACCORDING TO SUBGRIDSCALE VARIABILITY AND STABILITY
- !
- hmix(ix,jy,1,n)=hmix(ix,jy,1,n)+subsceff
- hmix(ix,jy,1,n)=max(hmixmin,hmix(ix,jy,1,n)) ! set minimum PBL height
- hmix(ix,jy,1,n)=min(hmixmax,hmix(ix,jy,1,n)) ! set maximum PBL height
-
- ! 4) Calculation of dry deposition velocities
- !********************************************
-
- if (DRYDEP) then
- ! Sabine Eckhardt, Dec 06: use new index for z0 for water depending on
- ! windspeed
- z0(7)=0.016*ustar(ix,jy,1,n)*ustar(ix,jy,1,n)/ga
-
- ! Calculate relative humidity at surface
- !***************************************
- rh=ew(td2(ix,jy,1,n))/ew(tt2(ix,jy,1,n))
-
- call getvdep(n,ix,jy,ustar(ix,jy,1,n), &
- tt2(ix,jy,1,n),ps(ix,jy,1,n),1./oli(ix,jy,1,n), &
- ssr(ix,jy,1,n),rh,lsprec(ix,jy,1,n)+convprec(ix,jy,1,n), &
- sd(ix,jy,1,n),vd)
-
- do i=1,nspec
- vdep(ix,jy,i,n)=vd(i)
- end do
-
- endif
-
- !******************************************************
- ! Calculate height of thermal tropopause (Hoinka, 1997)
- !******************************************************
-
- ! 1) Calculate altitudes of model levels
- !***************************************
-
- tvold=tt2(ix,jy,1,n)*(1.+0.378*ew(td2(ix,jy,1,n))/ &
- ps(ix,jy,1,n))
- pold=ps(ix,jy,1,n)
- zold=0.
- if (metdata_format.eq.GRIBFILE_CENTRE_ECMWF) then
- loop_start=2
- else
- loop_start=llev
- end if
- do kz=loop_start,nuvz
- pint=akz(kz)+bkz(kz)*ps(ix,jy,1,n) ! pressure on model layers
- tv=tth(ix,jy,kz,n)*(1.+0.608*qvh(ix,jy,kz,n))
-
- if (abs(tv-tvold).gt.0.2) then
- zlev(kz)=zold+const*log(pold/pint)*(tv-tvold)/log(tv/tvold)
- else
- zlev(kz)=zold+const*log(pold/pint)*tv
- endif
- tvold=tv
- pold=pint
- zold=zlev(kz)
- end do
-
- ! 2) Define a minimum level kzmin, from which upward the tropopause is
- ! searched for. This is to avoid inversions in the lower troposphere
- ! to be identified as the tropopause
- !************************************************************************
-
- if (metdata_format.eq.GRIBFILE_CENTRE_ECMWF) then
- loop_start=1
- else
- loop_start=llev
- end if
-
- do kz=loop_start,nuvz
- if (zlev(kz).ge.altmin) then
- kzmin=kz
- goto 45
- endif
- end do
-45 continue
-
- ! 3) Search for first stable layer above minimum height that fulfills the
- ! thermal tropopause criterion
- !************************************************************************
-
- do kz=kzmin,nuvz
- do lz=kz+1,nuvz
- if ((zlev(lz)-zlev(kz)).gt.2000.) then
- if (((tth(ix,jy,kz,n)-tth(ix,jy,lz,n))/ &
- (zlev(lz)-zlev(kz))).lt.0.002) then
- tropopause(ix,jy,1,n)=zlev(kz)
- goto 51
- endif
- goto 50
- endif
- end do
-50 continue
- end do
-51 continue
-
-
- end do
- end do
-
- ! Calculation of potential vorticity on 3-d grid
- !***********************************************
-
- call calcpv(n,uuh,vvh,pvh)
-
-
-end subroutine calcpar
diff --git a/src/calcpv.f90 b/src/calcpv.f90
deleted file mode 100644
index 74275289..00000000
--- a/src/calcpv.f90
+++ /dev/null
@@ -1,315 +0,0 @@
-! SPDX-FileCopyrightText: FLEXPART 1998-2019, see flexpart_license.txt
-! SPDX-License-Identifier: GPL-3.0-or-later
-
-subroutine calcpv(n,uuh,vvh,pvh)
- ! i i i o
- !*****************************************************************************
- ! *
- ! Calculation of potential vorticity on 3-d grid. *
- ! *
- ! Author: P. James *
- ! 3 February 2000 *
- ! *
- ! Adaptation to FLEXPART, A. Stohl, 1 May 2000 *
- ! *
- !*****************************************************************************
- ! *
- ! Variables: *
- ! n temporal index for meteorological fields (1 to 2) *
- ! *
- ! Constants: *
- ! *
- !*****************************************************************************
-
- use par_mod
- use com_mod
-
- implicit none
-
- integer :: n,ix,jy,i,j,k,kl,ii,jj,klvrp,klvrm,klpt,kup,kdn,kch
- integer :: jyvp,jyvm,ixvp,ixvm,jumpx,jumpy,jux,juy,ivrm,ivrp,ivr
- integer :: nlck
- real :: vx(2),uy(2),phi,tanphi,cosphi,dvdx,dudy,f
- real :: theta,thetap,thetam,dthetadp,dt1,dt2,dt
- real :: pvavr,ppml(0:nxmax-1,0:nymax-1,nuvzmax),ppmk(0:nxmax-1,0:nymax-1,nuvzmax)
- real :: thup,thdn
- real,parameter :: eps=1.e-5, p0=101325
- real :: uuh(0:nxmax-1,0:nymax-1,nuvzmax)
- real :: vvh(0:nxmax-1,0:nymax-1,nuvzmax)
- real :: pvh(0:nxmax-1,0:nymax-1,nuvzmax)
-
- ! Set number of levels to check for adjacent theta
- nlck=nuvz/3
- !
- ! Loop over entire grid
- !**********************
- do kl=1,nuvz
- do jy=0,nymin1
- do ix=0,nxmin1
- ppml(ix,jy,kl)=akz(kl)+bkz(kl)*ps(ix,jy,1,n)
- enddo
- enddo
- enddo
-
-! ppmk(:,:,1:nuvz)=(100000./ppml(:,:,1:nuvz))**kappa
- ppmk(0:nxmin1,0:nymin1,1:nuvz)=(100000./ppml(0:nxmin1,0:nymin1,1:nuvz))**kappa
-
- do jy=0,nymin1
- if (sglobal.and.jy.eq.0) goto 10
- if (nglobal.and.jy.eq.nymin1) goto 10
- phi = (ylat0 + jy * dy) * pi / 180.
- f = 0.00014585 * sin(phi)
- tanphi = tan(phi)
- cosphi = cos(phi)
- ! Provide a virtual jy+1 and jy-1 in case we are on domain edge (Lat)
- jyvp=jy+1
- jyvm=jy-1
- if (jy.eq.0) jyvm=0
- if (jy.eq.nymin1) jyvp=nymin1
- ! Define absolute gap length
- jumpy=2
- if (jy.eq.0.or.jy.eq.nymin1) jumpy=1
- if (sglobal.and.jy.eq.1) then
- jyvm=1
- jumpy=1
- end if
- if (nglobal.and.jy.eq.ny-2) then
- jyvp=ny-2
- jumpy=1
- end if
- juy=jumpy
- !
- do ix=0,nxmin1
- ! Provide a virtual ix+1 and ix-1 in case we are on domain edge (Long)
- ixvp=ix+1
- ixvm=ix-1
- jumpx=2
- if (xglobal) then
- ivrp=ixvp
- ivrm=ixvm
- if (ixvm.lt.0) ivrm=ixvm+nxmin1
- if (ixvp.ge.nx) ivrp=ixvp-nx+1
- else
- if (ix.eq.0) ixvm=0
- if (ix.eq.nxmin1) ixvp=nxmin1
- ivrp=ixvp
- ivrm=ixvm
- ! Define absolute gap length
- if (ix.eq.0.or.ix.eq.nxmin1) jumpx=1
- end if
- jux=jumpx
- !
- ! Loop over the vertical
- !***********************
-
- do kl=1,nuvz
- theta=tth(ix,jy,kl,n)*ppmk(ix,jy,kl)
- klvrp=kl+1
- klvrm=kl-1
- klpt=kl
- ! If top or bottom level, dthetadp is evaluated between the current
- ! level and the level inside, otherwise between level+1 and level-1
- !
- if (klvrp.gt.nuvz) klvrp=nuvz
- if (klvrm.lt.1) klvrm=1
- thetap=tth(ix,jy,klvrp,n)*ppmk(ix,jy,klvrp)
- thetam=tth(ix,jy,klvrm,n)*ppmk(ix,jy,klvrm)
- dthetadp=(thetap-thetam)/(ppml(ix,jy,klvrp)-ppml(ix,jy,klvrm))
-
- ! Compute vertical position at pot. temperature surface on subgrid
- ! and the wind at that position
- !*****************************************************************
- ! a) in x direction
- ii=0
- do i=ixvm,ixvp,jumpx
- ivr=i
- if (xglobal) then
- if (i.lt.0) ivr=ivr+nxmin1
- if (i.ge.nx) ivr=ivr-nx+1
- end if
- ii=ii+1
- ! Search adjacent levels for current theta value
- ! Spiral out from current level for efficiency
- kup=klpt-1
- kdn=klpt
- kch=0
-40 continue
- ! Upward branch
- kup=kup+1
- if (kch.ge.nlck) goto 21 ! No more levels to check,
- ! ! and no values found
- if (kup.ge.nuvz) goto 41
- kch=kch+1
- k=kup
- thdn=tth(ivr,jy,k,n)*ppmk(ivr,jy,k)
- thup=tth(ivr,jy,k+1,n)*ppmk(ivr,jy,k+1)
-
-
- if (((thdn.ge.theta).and.(thup.le.theta)).or. &
- ((thdn.le.theta).and.(thup.ge.theta))) then
- dt1=abs(theta-thdn)
- dt2=abs(theta-thup)
- dt=dt1+dt2
- if (dt.lt.eps) then ! Avoid division by zero error
- dt1=0.5 ! G.W., 10.4.1996
- dt2=0.5
- dt=1.0
- endif
- vx(ii)=(vvh(ivr,jy,k)*dt2+vvh(ivr,jy,k+1)*dt1)/dt
- goto 20
- endif
-41 continue
- ! Downward branch
- kdn=kdn-1
- if (kdn.lt.1) goto 40
- kch=kch+1
- k=kdn
- thdn=tth(ivr,jy,k,n)*ppmk(ivr,jy,k)
- thup=tth(ivr,jy,k+1,n)*ppmk(ivr,jy,k+1)
-
- if (((thdn.ge.theta).and.(thup.le.theta)).or. &
- ((thdn.le.theta).and.(thup.ge.theta))) then
- dt1=abs(theta-thdn)
- dt2=abs(theta-thup)
- dt=dt1+dt2
- if (dt.lt.eps) then ! Avoid division by zero error
- dt1=0.5 ! G.W., 10.4.1996
- dt2=0.5
- dt=1.0
- endif
- vx(ii)=(vvh(ivr,jy,k)*dt2+vvh(ivr,jy,k+1)*dt1)/dt
- goto 20
- endif
- goto 40
- ! This section used when no values were found
-21 continue
- ! Must use vv at current level and long. jux becomes smaller by 1
- vx(ii)=vvh(ix,jy,kl)
- jux=jux-1
- ! Otherwise OK
-20 continue
- end do
- if (jux.gt.0) then
- dvdx=(vx(2)-vx(1))/real(jux)/(dx*pi/180.)
- else
- dvdx=vvh(ivrp,jy,kl)-vvh(ivrm,jy,kl)
- dvdx=dvdx/real(jumpx)/(dx*pi/180.)
- ! Only happens if no equivalent theta value
- ! can be found on either side, hence must use values
- ! from either side, same pressure level.
- end if
-
- ! b) in y direction
-
- jj=0
- do j=jyvm,jyvp,jumpy
- jj=jj+1
- ! Search adjacent levels for current theta value
- ! Spiral out from current level for efficiency
- kup=klpt-1
- kdn=klpt
- kch=0
-70 continue
- ! Upward branch
- kup=kup+1
- if (kch.ge.nlck) goto 51 ! No more levels to check,
- ! ! and no values found
- if (kup.ge.nuvz) goto 71
- kch=kch+1
- k=kup
- thdn=tth(ix,j,k,n)*ppmk(ix,j,k)
- thup=tth(ix,j,k+1,n)*ppmk(ix,j,k+1)
- if (((thdn.ge.theta).and.(thup.le.theta)).or. &
- ((thdn.le.theta).and.(thup.ge.theta))) then
- dt1=abs(theta-thdn)
- dt2=abs(theta-thup)
- dt=dt1+dt2
- if (dt.lt.eps) then ! Avoid division by zero error
- dt1=0.5 ! G.W., 10.4.1996
- dt2=0.5
- dt=1.0
- endif
- uy(jj)=(uuh(ix,j,k)*dt2+uuh(ix,j,k+1)*dt1)/dt
- goto 50
- endif
-71 continue
- ! Downward branch
- kdn=kdn-1
- if (kdn.lt.1) goto 70
- kch=kch+1
- k=kdn
- thdn=tth(ix,j,k,n)*ppmk(ix,j,k)
- thup=tth(ix,j,k+1,n)*ppmk(ix,j,k+1)
- if (((thdn.ge.theta).and.(thup.le.theta)).or. &
- ((thdn.le.theta).and.(thup.ge.theta))) then
- dt1=abs(theta-thdn)
- dt2=abs(theta-thup)
- dt=dt1+dt2
- if (dt.lt.eps) then ! Avoid division by zero error
- dt1=0.5 ! G.W., 10.4.1996
- dt2=0.5
- dt=1.0
- endif
- uy(jj)=(uuh(ix,j,k)*dt2+uuh(ix,j,k+1)*dt1)/dt
- goto 50
- endif
- goto 70
- ! This section used when no values were found
-51 continue
- ! Must use uu at current level and lat. juy becomes smaller by 1
- uy(jj)=uuh(ix,jy,kl)
- juy=juy-1
- ! Otherwise OK
-50 continue
- end do
- if (juy.gt.0) then
- dudy=(uy(2)-uy(1))/real(juy)/(dy*pi/180.)
- else
- dudy=uuh(ix,jyvp,kl)-uuh(ix,jyvm,kl)
- dudy=dudy/real(jumpy)/(dy*pi/180.)
- end if
- !
- pvh(ix,jy,kl)=dthetadp*(f+(dvdx/cosphi-dudy &
- +uuh(ix,jy,kl)*tanphi)/r_earth)*(-1.e6)*9.81
-
-
- !
- ! Resest jux and juy
- jux=jumpx
- juy=jumpy
- end do
- end do
-10 continue
- end do
- !
- ! Fill in missing PV values on poles, if present
- ! Use mean PV of surrounding latitude ring
- !
- if (sglobal) then
- do kl=1,nuvz
- pvavr=0.
- do ix=0,nxmin1
- pvavr=pvavr+pvh(ix,1,kl)
- end do
- pvavr=pvavr/real(nx)
- jy=0
- do ix=0,nxmin1
- pvh(ix,jy,kl)=pvavr
- end do
- end do
- end if
- if (nglobal) then
- do kl=1,nuvz
- pvavr=0.
- do ix=0,nxmin1
- pvavr=pvavr+pvh(ix,ny-2,kl)
- end do
- pvavr=pvavr/real(nx)
- jy=nymin1
- do ix=0,nxmin1
- pvh(ix,jy,kl)=pvavr
- end do
- end do
- end if
-
-end subroutine calcpv
diff --git a/src/cbl.f90 b/src/cbl_mod.f90
similarity index 51%
rename from src/cbl.f90
rename to src/cbl_mod.f90
index 971d746d..c1fa2887 100644
--- a/src/cbl.f90
+++ b/src/cbl_mod.f90
@@ -1,5 +1,14 @@
! SPDX-FileCopyrightText: FLEXPART 1998-2019, see flexpart_license.txt
! SPDX-License-Identifier: GPL-3.0-or-later
+module cbl_mod
+
+ implicit none
+
+ private :: cuberoot
+
+ public :: cbl,re_initialize_particle,initialize_cbl_vel
+
+contains
subroutine cbl(wp,zp,ust,wst,h,rhoa,rhograd,sigmaw,dsigmawdz,tlw,ptot,Q,phi,ath,bth,ol,flagrein)
! i i i i i i i i i i o o o o o i o
@@ -8,11 +17,14 @@ subroutine cbl(wp,zp,ust,wst,h,rhoa,rhograd,sigmaw,dsigmawdz,tlw,ptot,Q,phi,ath,
use com_mod, only:ldirect
implicit none
-!=======================================================================================================================================================
-!=============== CBL skewed vertical profiles and formulation of LHH 1996 with profile of w3 from LHB 2000 ========
-!=============== LHH formulation has been modified to account for variable density profiles and backward in time or forward in time simulations ========
-!=============== see Cassiani et al. BLM 2014 doi for explanations and references ========
-!=======================================================================================================================================================
+
+!*******************************************************************************
+! CBL skewed vertical profiles and formulation of LHH 1996 with profile of w^3
+! from LHB 2000
+! LHH formulation has been modified to account for variable density profiles
+! and backward in time or forward in time simulations
+! see Cassiani et al. BLM 2014 doi for explanations and references
+!*******************************************************************************
real :: usurad2,usurad2p,C0,costluar4,eps
parameter (usurad2=0.7071067812,usurad2p=0.3989422804,C0=3,costluar4=0.66667,eps=0.000001)
@@ -29,7 +41,6 @@ subroutine cbl(wp,zp,ust,wst,h,rhoa,rhograd,sigmaw,dsigmawdz,tlw,ptot,Q,phi,ath,
real ::pa,pb,alfa
real ::Phi,Q,ptot
real :: timedir
- real ::cuberoot
real ::z0,ol,transition
@@ -72,15 +83,15 @@ subroutine cbl(wp,zp,ust,wst,h,rhoa,rhograd,sigmaw,dsigmawdz,tlw,ptot,Q,phi,ath,
timedir=ldirect !ldirect contains direction of time forward (1) or backward(-1)
- !========================= assegnazione z ===========================================================
+ ! assegnazione z
z=(zp/h)
- !================== stability transition function see Cassiani et al(2015) BLM ======================
+ ! stability transition function see Cassiani et al(2015) BLM
transition=1.
!if (ol.lt.-50) transition=((sin(((ol+100.)/100.)*pi))-1.)/2.
if (-h/ol.lt.15) transition=((sin((((-h/ol)+10.)/10.)*pi)))/2.+0.5
- !========================= momento secondo ==========================================================
+ ! momento secondo
w2=(sigmaw*sigmaw)
dw2=(2.*sigmaw*dsigmawdz)
@@ -99,8 +110,8 @@ subroutine cbl(wp,zp,ust,wst,h,rhoa,rhograd,sigmaw,dsigmawdz,tlw,ptot,Q,phi,ath,
w3=((1.2*z*((1.-z)**(3./2.)))+eps)*(wst**3)*transition
dw3=(1.2*(((1.-z)**(3./2.))+z*1.5*((1.-z)**(1./2.))*(-1.)))*(wst**3)*(1./h)*transition
-
- !===========================================================================0
+
+!===========================================================================0
skew=w3/(w2**1.5)
skew2=skew*skew
@@ -211,43 +222,198 @@ subroutine cbl(wp,zp,ust,wst,h,rhoa,rhograd,sigmaw,dsigmawdz,tlw,ptot,Q,phi,ath,
!bth=sngl(sigmaw*sqrt(2.*tlw))
return
- end
-
-
-
-
-
- FUNCTION CUBEROOT (X) RESULT (Y)
-
- IMPLICIT NONE
-
- real, INTENT(IN) :: X
- real:: Y
-
- real, PARAMETER :: THIRD = 0.333333333
+end subroutine cbl
-
- Y = SIGN((ABS(X))**THIRD, X)
-
- RETURN
-
- END FUNCTION CUBEROOT
-
+function cuberoot(x) result(y)
-
-
- FUNCTION CUBEROOTD (X) RESULT (Y)
-
- IMPLICIT NONE
-
- DOUBLE PRECISION, INTENT(IN) :: X
- DOUBLE PRECISION :: Y
-
- DOUBLE PRECISION, PARAMETER :: THIRD = 0.33333333333333333333333333333333333333333333333333333333333333333333333333333333333D0
-
-
- Y = SIGN((ABS(X))**THIRD, X)
-
- RETURN
+ implicit none
- END FUNCTION CUBEROOTD
+ real, intent(in) :: x
+ real :: y
+ real, parameter :: third=0.333333333
+
+ y=sign((abs(x))**third,x)
+end function cuberoot
+
+subroutine re_initialize_particle(zp,ust,wst,h,sigmaw,wp,nrand,ol)
+! i i i i i io io i
+
+!******************************************************************************
+! CBL skewed vertical profiles and formulation of LHH 1996 with profile of w^3
+! from lHB 2000
+! LHH formulation has been modified to account for variable density profiles
+! and backward in time or forward in time simulations
+! This routine re-initialize particle velocity if a numerical instability
+! in the cbl scheme generated a NaN value
+! The particle velocity is extracted from the updraft and downdraft
+! distribution as required
+! The re-initialization si not perfect
+! See e.g. Cassiani et al(2015) BLM
+!******************************************************************************
+ use par_mod, only:pi
+ use com_mod, only:ldirect,rannumb
+
+ implicit none
+
+
+ real :: usurad2,usurad2p,C0,costluar4,eps
+ parameter (usurad2=0.7071067812,usurad2p=0.3989422804,C0=2,costluar4=0.66667,eps=0.000001)
+
+ integer idum,nrand
+ real :: wp,zp,ust,wst,h,dens,ddens,sigmaw,dsigmawdz,tlw,dcas,dcas1 !,ran3,gasdev
+ real :: w3,w2
+ real :: z, &
+ skew, &
+ skew2, &
+ radw2, &
+ fluarw,fluarw2, &
+ rluarw, &
+ xluarw, &
+ aluarw, &
+ bluarw, &
+ sigmawa, &
+ sigmawb, &
+ ath, &
+ bth, &
+ wb,wa
+ real timedir
+ real ol,transition
+
+!---------------------------------------------------------------------------
+!timedir direction of time forward (1) or backward(-1)
+ nrand=nrand+1
+ dcas1=rannumb(nrand)
+ timedir=ldirect
+ z=zp/h
+ transition=1.
+
+ if (-h/ol.lt.15) transition=((sin((((-h/ol)+10.)/10.)*pi)))/2.+0.5
+
+ w2=sigmaw*sigmaw
+ w3=(((1.2*z*((1.-z)**(3./2.)))+eps)*wst**3)*transition
+ skew=w3/(w2**1.5)
+ skew2=skew*skew
+ radw2=sqrt(w2) !sigmaw
+
+ fluarw=costluar4*skew**0.333333333333333
+ fluarw2=fluarw*fluarw
+ rluarw=(1.+fluarw2)**3.*skew2/((3.+fluarw2)**2.*fluarw2) !-> r
+ xluarw=rluarw**0.5 !(1.+fluarw2)**1.5*skew/((3.+fluarw2)*fluarw) !----> r^1/2
+
+ aluarw=0.5*(1.-xluarw/(4.+rluarw)**0.5)
+ bluarw=1.-aluarw
+
+ sigmawa=radw2*(bluarw/(aluarw*(1.+fluarw2)))**0.5
+ sigmawb=radw2*(aluarw/(bluarw*(1.+fluarw2)))**0.5
+
+ wa=(fluarw*sigmawa)
+ wb=(fluarw*sigmawb)
+
+
+
+ if ((sign(1.,wp)*timedir).gt.0) then !updraft
+100 wp=(dcas1*sigmawa+wa)
+ if (wp.lt.0) then
+ nrand=nrand+1
+ dcas1=rannumb(nrand)
+ goto 100
+ end if
+ wp=wp*timedir
+ else if ((sign(1.,wp)*timedir).lt.0) then !downdraft
+101 wp=(dcas1*sigmawb-wb)
+ if (wp.gt.0) then
+ nrand=nrand+1
+ dcas1=rannumb(nrand)
+ goto 101
+ end if
+ wp=wp*timedir
+ end if
+
+ return
+end subroutine re_initialize_particle
+
+subroutine initialize_cbl_vel(idum,zp,ust,wst,h,sigmaw,wp,ol,ithread)
+ ! i/o i i i i i o i
+
+ use par_mod, only:pi
+ use com_mod, only:ldirect
+ use random_mod, only: gasdev, ran3
+
+ implicit none
+ !===============================================================================
+ ! CBL skewed vertical profiles and formulation of LHH 1996 with profile of w3
+ ! from LHB 2000
+ ! LHH formulation has been modified to account for variable density profiles and
+ ! backward in time or forward in time simulations
+ ! see Cassiani et al. BLM 2014 doi for explanations and references
+ !===============================================================================
+
+ integer,intent(in) :: ithread
+ real :: usurad2,usurad2p,C0,costluar4,eps
+ parameter (usurad2=0.7071067812,usurad2p=0.3989422804,C0=2,costluar4=0.66667,eps=0.000001)
+
+
+ real :: wp,zp,ust,wst,h,dens,ddens,sigmaw,dsigmawdz,tlw,dcas,dcas1!,ran3,gasdev
+ real :: w3,w2
+ real :: z, &
+ skew, &
+ skew2, &
+ radw2, &
+ fluarw,fluarw2, &
+ rluarw, &
+ xluarw, &
+ aluarw, &
+ bluarw, &
+ sigmawa, &
+ sigmawb, &
+ ath, &
+ bth, &
+ wb,wa
+ real timedir
+ real ol, transition
+ integer :: idum
+
+ !---------------------------------------------------------------------------
+ timedir=ldirect !direction of time forward (1) or backward(-1)
+ z=zp/h
+
+
+ transition=1.
+ if (-h/ol.lt.15) transition=((sin((((-h/ol)+10.)/10.)*pi)))/2.+0.5 !see also in cbl.f90
+
+ w2=sigmaw*sigmaw
+ w3=(((1.2*z*((1.-z)**(3./2.)))+eps)*wst**3) *transition
+
+ skew=w3/(w2**1.5)
+ skew2=skew*skew
+
+ radw2=sqrt(w2) !sigmaw
+
+ fluarw=costluar4*skew**0.333333333333333
+ fluarw2=fluarw*fluarw
+ rluarw=(1.+fluarw2)**3.*skew2/((3.+fluarw2)**2.*fluarw2) !-> r
+ xluarw=rluarw**0.5 !----> r^1/2
+
+ aluarw=0.5*(1.-xluarw/(4.+rluarw)**0.5)
+ bluarw=1.-aluarw
+
+ sigmawa=radw2*(bluarw/(aluarw*(1.+fluarw2)))**0.5
+ sigmawb=radw2*(aluarw/(bluarw*(1.+fluarw2)))**0.5
+
+ wa=(fluarw*sigmawa)
+ wb=(fluarw*sigmawb)
+
+ dcas=ran3(idum,ithread)
+
+ if (dcas.le.aluarw) then
+ dcas1=gasdev(idum,ithread)
+ wp=timedir*(dcas1*sigmawa+wa)
+ else
+ dcas1=gasdev(idum,ithread)
+ wp=timedir*(dcas1*sigmawb-wb)
+ end if
+
+ return
+end subroutine initialize_cbl_vel
+
+end module cbl_mod
diff --git a/src/gributils/class_gribfile_mod.f90 b/src/class_gribfile_mod.f90
similarity index 100%
rename from src/gributils/class_gribfile_mod.f90
rename to src/class_gribfile_mod.f90
diff --git a/src/com_mod.f90 b/src/com_mod.f90
index b165b07e..9063711a 100644
--- a/src/com_mod.f90
+++ b/src/com_mod.f90
@@ -12,13 +12,25 @@
module com_mod
- use par_mod, only: dp, numpath, maxnests, maxageclass, maxspec, ni, &
- numclass, nymax, nxmax, maxcolumn, maxwf, nzmax, nxmaxn, nymaxn, &
- maxreceptor, maxpart, maxrand, nwzmax, nuvzmax, numwfmem
+ use par_mod, only: dp, numpath, maxnests, maxageclass, maxspec, maxndia, &
+ numclass, maxcolumn, maxwf, nxmaxn, nymaxn, &
+ maxreceptor, maxrand, numwfmem
implicit none
+ ! Partoptions derived type. This decides which fields are being computed and output
+ !**********************************************************************************
+ type :: particleoptions
+ character(2) :: name
+ character(20) :: long_name
+ logical :: print
+ logical :: average=.false.
+ integer :: i_average=0
+ end type particleoptions
+ integer :: num_partopt=34
+ integer :: n_average
+ type(particleoptions),allocatable :: partopt(:)
!****************************************************************
! Variables defining where FLEXPART input/output files are stored
@@ -41,7 +53,8 @@ module com_mod
! Variables defining the general model run specifications
!********************************************************
- integer :: ibdate,ibtime,iedate,ietime
+ integer :: ibdate,ibtime,iedate,ietime,itime_init,loutnext_init
+ real :: outnum_init
real(kind=dp) :: bdate,edate
@@ -49,8 +62,11 @@ module com_mod
! ibtime beginning time (HHMISS)
! iedate ending date (YYYYMMDD)
! ietime ending time (HHMISS)
+ ! itime_init starting time in [s] in case of a restart
! bdate beginning date of simulation (julian date)
! edate ending date of simulation (julian date)
+ ! outnum_init concentration calculation sample number after restart
+ ! loutnext_init first writing time after restart
integer :: ldirect,ideltas
@@ -59,19 +75,20 @@ module com_mod
! ideltas length of trajectory loop from beginning to
! ending date (s)
- integer :: loutstep,loutaver,loutsample,method,lsynctime
+ integer :: loutstep,loutaver,loutsample,loutrestart,method,lsynctime
real :: outstep
! loutstep [s] gridded concentration output every loutstep seconds
! loutaver [s] concentration output is an average over [s] seconds
! loutsample [s] sampling interval of gridded concentration output
+ ! loutrestart [s] time interval for writing restart files
! lsynctime [s] synchronisation time of all particles
! method indicator which dispersion method is to be used
! outstep = real(abs(loutstep))
real :: ctl,fine
integer :: ifine,iout,ipout,ipin,iflux,mdomainfill,ipoutfac
- integer :: mquasilag,nested_output,ind_source,ind_receptor
+ integer :: mquasilag,nested_output,ind_source,ind_receptor,nxshift
integer :: ind_rel,ind_samp,ioutputforeachrelease,linit_cond,surf_only
logical :: turbswitch
integer :: cblflag !added by mc for cbl
@@ -104,6 +121,10 @@ module com_mod
! 0=no (full vertical resolution), 1=yes (surface only)
! nested_output: 0 no, 1 yes
! turbswitch determines how the Markov chain is formulated
+ ! nxshift for global grids (in x), the grid can be shifted by
+ ! nxshift grid points, in order to accomodate nested
+ ! grids, and output grids overlapping the domain "boundary"
+ ! nxshift must not be negative; "normal" setting would be 0
! ind_rel and ind_samp are used within the code to change between mass and mass-mix (see readcommand.f)
! cblflag !: 1 activate cbl skewed pdf routines with bi-gaussina pdf whan OL<0 added by mc
@@ -174,12 +195,16 @@ module com_mod
real :: ccn_aero(maxspec),in_aero(maxspec)
real :: reldiff(maxspec),henry(maxspec),f0(maxspec)
real :: density(maxspec),dquer(maxspec),dsigma(maxspec)
+ integer :: ndia(maxspec)
real :: vsetaver(maxspec),cunningham(maxspec),weightmolar(maxspec)
- real :: vset(maxspec,ni),schmi(maxspec,ni),fract(maxspec,ni)
+ real :: vset(maxspec,maxndia),schmi(maxspec,maxndia),fract(maxspec,maxndia)
real :: ri(5,numclass),rac(5,numclass),rcl(maxspec,5,numclass)
real :: rgs(maxspec,5,numclass),rlu(maxspec,5,numclass)
real :: rm(maxspec),dryvel(maxspec),kao(maxspec)
real :: ohcconst(maxspec),ohdconst(maxspec),ohnconst(maxspec)
+ ! Daria Tatsii: species shape properties
+ real :: Fn(maxspec),Fs(maxspec) ! Newton and Stokes' regime
+ integer :: shape(maxspec),orient(maxspec)
real :: area_hour(maxspec,24),point_hour(maxspec,24)
real :: area_dow(maxspec,7),point_dow(maxspec,7)
@@ -236,222 +261,16 @@ module com_mod
! area_hour, point_hour daily variation of emission strengths for area and point sources
! area_dow, point_dow day-of-week variation of emission strengths for area and point sources
-
-
- !**********************************************************
- ! Variables used for domain-filling trajectory calculations
- !**********************************************************
-
- integer :: nx_we(2),ny_sn(2)
- integer :: numcolumn
- integer :: numcolumn_we(2,0:nymax-1),numcolumn_sn(2,0:nxmax-1)
- real :: zcolumn_we(2,0:nymax-1,maxcolumn)
- real :: zcolumn_sn(2,0:nxmax-1,maxcolumn)
- real :: xmassperparticle
- real :: acc_mass_we(2,0:nymax-1,maxcolumn)
- real :: acc_mass_sn(2,0:nxmax-1,maxcolumn)
-
- ! nx_we(2) x indices of western and eastern boundary of domain-filling
- ! ny_sn(2) y indices of southern and northern boundary of domain-filling
- ! numcolumn_we number of particles to be released within one column
- ! at the western and eastern boundary surfaces
- ! numcolumn_sn same as numcolumn_we, but for southern and northern domain boundary
- ! numcolumn maximum number of particles to be released within a single
- ! column
- ! zcolumn_we altitudes where particles are to be released
- ! at the western and eastern boundary surfaces
- ! zcolumn_sn same as zcolumn_we, but for southern and northern domain boundary
- ! xmassperparticle air mass per particle in the domain-filling traj. option
- ! acc_mass_we mass that has accumulated at the western and eastern boundary;
- ! if it exceeds xmassperparticle, a particle is released and
- ! acc_mass_we is reduced accordingly
- ! acc_mass_sn same as acc_mass_we, but for southern and northern domain boundary
-
-
-
!******************************************************************************
! Variables associated with the ECMWF meteorological input data ("wind fields")
!******************************************************************************
- integer :: numbwf,wftime(maxwf),lwindinterv
- character(len=255) :: wfname(maxwf),wfspec(maxwf)
-
- ! lwindinterv [s] Interval between wind fields currently in memory
- ! numbwf actual number of wind fields
- ! wftime(maxwf) [s] times relative to beginning time of wind fields
- ! wfname(maxwf) file names of wind fields
- ! wfspec(maxwf) specifications of wind field file, e.g. if on hard
- ! disc or on tape
-
- integer :: memtime(numwfmem),memind(3) ! eso: or memind(numwfmem)
+ integer :: memtime(numwfmem),memind(3),lwindinterv ! eso: or memind(numwfmem)
! memtime [s] validation times of wind fields in memory
! memind pointer to wind field, in order to avoid shuffling
! of wind fields
-
-
-
- !****************************************************************************
- ! Variables defining actual size and geographical location of the wind fields
- !****************************************************************************
-
- integer :: nx,ny,nxmin1,nymin1,nxfield,nuvz,nwz,nz,nmixz,nlev_ec
- real :: dx,dy,xlon0,ylat0,dxconst,dyconst,height(nzmax)
-
- ! nx,ny,nz actual dimensions of wind fields in x,y and z
- ! direction, respectively
- ! nxmin1,nymin1 nx-1, ny-1, respectively
- ! nuvz,nwz vertical dimension of original ECMWF data
- ! nxfield same as nx for limited area fields,
- ! but for global fields nx=nxfield+1
- ! nmixz number of levels up to maximum PBL height (3500 m)
-
- ! nuvz is used for u,v components
- ! nwz is used for w components (staggered grid)
- ! nz is used for the levels in transformed coordinates (terrain-following Cartesian
- ! coordinates)
-
- ! nlev_ec number of levels ECMWF model
- ! dx grid distance in x direction
- ! dy grid distance in y direction
- ! dxconst,dyconst auxiliary variables for utransform,vtransform
- ! height heights of all levels
- ! xlon0 geographical longitude and
- ! ylat0 geographical latitude of lower left grid point
-
-
-
- !*************************************************
- ! Variables used for vertical model discretization
- !*************************************************
-
- real :: akm(nwzmax),bkm(nwzmax)
- real :: akz(nuvzmax),bkz(nuvzmax)
- real :: aknew(nzmax),bknew(nzmax)
-
- ! akm,bkm: coeffizients which regulate vertical discretization of ecmwf model
- ! (at the border of model layers)
- ! akz,bkz: model discretization coeffizients at the centre of the layers
- ! aknew,bknew model discretization coeffizients at the interpolated levels
-
-
-
- ! Fixed fields, unchangeable with time
- !*************************************
-
- real :: oro(0:nxmax-1,0:nymax-1)
- real :: excessoro(0:nxmax-1,0:nymax-1)
- real :: lsm(0:nxmax-1,0:nymax-1)
- real :: xlanduse(0:nxmax-1,0:nymax-1,numclass)
-
- ! oro [m] orography of the ECMWF model
- ! excessoro excess orography mother domain
- ! lsm land sea mask of the ECMWF model
- ! xlanduse [0-1] area fractions in percent
-
- ! 3d fields
- !**********
-
- real :: uu(0:nxmax-1,0:nymax-1,nzmax,numwfmem)
- real :: vv(0:nxmax-1,0:nymax-1,nzmax,numwfmem)
- real :: uupol(0:nxmax-1,0:nymax-1,nzmax,numwfmem)
- real :: vvpol(0:nxmax-1,0:nymax-1,nzmax,numwfmem)
- real :: ww(0:nxmax-1,0:nymax-1,nzmax,numwfmem)
- real :: tt(0:nxmax-1,0:nymax-1,nzmax,numwfmem)
- real :: qv(0:nxmax-1,0:nymax-1,nzmax,numwfmem)
-!ZHG adding cloud water
- real :: clwc(0:nxmax-1,0:nymax-1,nzmax,numwfmem)=0.0 !liquid [kg/kg]
- real :: ciwc(0:nxmax-1,0:nymax-1,nzmax,numwfmem)=0.0 !ice [kg/kg]
- real :: clw(0:nxmax-1,0:nymax-1,nzmax,numwfmem)=0.0 !combined [m3/m3]
-! RLT add pressure and dry air density
- real :: prs(0:nxmax-1,0:nymax-1,nzmax,numwfmem)
- real :: rho_dry(0:nxmax-1,0:nymax-1,nzmax,numwfmem)
- real :: pv(0:nxmax-1,0:nymax-1,nzmax,numwfmem)
- real :: rho(0:nxmax-1,0:nymax-1,nzmax,numwfmem)
- real :: drhodz(0:nxmax-1,0:nymax-1,nzmax,numwfmem)
- real :: tth(0:nxmax-1,0:nymax-1,nuvzmax,numwfmem)
- real :: qvh(0:nxmax-1,0:nymax-1,nuvzmax,numwfmem)
- real :: clwch(0:nxmax-1,0:nymax-1,nuvzmax,numwfmem)=0.0
- real :: ciwch(0:nxmax-1,0:nymax-1,nuvzmax,numwfmem)=0.0
-
- real :: pplev(0:nxmax-1,0:nymax-1,nuvzmax,numwfmem)
- !scavenging NIK, PS
- integer(kind=1) :: clouds(0:nxmax-1,0:nymax-1,nzmax,numwfmem)
- integer :: cloudsh(0:nxmax-1,0:nymax-1,numwfmem)
-
-!ZHG Sep 2015
-! real :: icloud_stats(0:nxmax-1,0:nymax-1,5,numwfmem)
- real :: ctwc(0:nxmax-1,0:nymax-1,numwfmem) ! ESO: =icloud_stats(:,:,4,:)
-
-
- ! uu,vv,ww [m/2] wind components in x,y and z direction
- ! uupol,vvpol [m/s] wind components in polar stereographic projection
- ! tt [K] temperature data
- ! prs air pressure
- ! qv specific humidity data
- ! pv (pvu) potential vorticity
- ! rho [kg/m3] air density
- ! drhodz [kg/m2] vertical air density gradient
- ! tth,qvh tth,qvh on original eta levels
- ! clouds: no cloud, no precipitation 0
- ! cloud, no precipitation 1
- ! rainout conv/lsp dominated 2/3
- ! washout conv/lsp dominated 4/5
- ! PS 2013
- !c icloudbot (m) cloud bottom height
- !c icloudthck (m) cloud thickness
-
- ! pplev for the GFS version
- ! ctwc total cloud water content
-
- ! 2d fields
- !**********
-
- real :: ps(0:nxmax-1,0:nymax-1,1,numwfmem)
- real :: sd(0:nxmax-1,0:nymax-1,1,numwfmem)
- real :: msl(0:nxmax-1,0:nymax-1,1,numwfmem)
- real :: tcc(0:nxmax-1,0:nymax-1,1,numwfmem)
- real :: u10(0:nxmax-1,0:nymax-1,1,numwfmem)
- real :: v10(0:nxmax-1,0:nymax-1,1,numwfmem)
- real :: tt2(0:nxmax-1,0:nymax-1,1,numwfmem)
- real :: td2(0:nxmax-1,0:nymax-1,1,numwfmem)
- real :: lsprec(0:nxmax-1,0:nymax-1,1,numwfmem)
- real :: convprec(0:nxmax-1,0:nymax-1,1,numwfmem)
- real :: sshf(0:nxmax-1,0:nymax-1,1,numwfmem)
- real :: ssr(0:nxmax-1,0:nymax-1,1,numwfmem)
- real :: surfstr(0:nxmax-1,0:nymax-1,1,numwfmem)
- real :: ustar(0:nxmax-1,0:nymax-1,1,numwfmem)
- real :: wstar(0:nxmax-1,0:nymax-1,1,numwfmem)
- real :: hmix(0:nxmax-1,0:nymax-1,1,numwfmem)
- real :: tropopause(0:nxmax-1,0:nymax-1,1,numwfmem)
- real :: oli(0:nxmax-1,0:nymax-1,1,numwfmem)
-! real :: diffk(0:nxmax-1,0:nymax-1,1,numwfmem) ESO: this is not in use?
-! logical :: beneath_cloud=.true.
- ! ps surface pressure
- ! sd snow depth
- ! msl mean sea level pressure
- ! tcc total cloud cover
- ! u10 10 meter u
- ! v10 10 meter v
- ! tt2 2 meter temperature
- ! td2 2 meter dew point
- ! lsprec [mm/h] large scale total precipitation
- ! convprec [mm/h] convective precipitation
- ! sshf surface sensible heat flux
- ! ssr surface solar radiation
- ! surfstr surface stress
- ! ustar [m/s] friction velocity
- ! wstar [m/s] convective velocity scale
- ! hmix [m] mixing height
- ! tropopause [m] altitude of thermal tropopause
- ! oli [m] inverse Obukhov length (1/L)
- ! diffk [m2/s] diffusion coefficient at reference height
-
-
- real :: vdep(0:nxmax-1,0:nymax-1,maxspec,numwfmem)
-
- ! vdep [m/s] deposition velocities
-
+ ! lwindinterv [s] Interval between wind fields currently in memory
!********************************************************************
! Variables associated with the ECMWF input data (nested wind fields)
@@ -465,85 +284,6 @@ module com_mod
! numbnests number of nested grids
- character(len=255) :: wfnamen(maxnests,maxwf)
- character(len=18) :: wfspecn(maxnests,maxwf)
-
- ! wfnamen nested wind field names
- ! wfspecn specifications of wind field file, e.g. if on hard
- ! disc or on tape
-
-
- !*********************************************************************
- ! Variables characterizing size and location of the nested wind fields
- !*********************************************************************
-
- integer :: nxn(maxnests),nyn(maxnests)
- real :: dxn(maxnests),dyn(maxnests),xlon0n(maxnests),ylat0n(maxnests)
-
- ! nxn,nyn actual dimensions of nested wind fields in x and y direction
- ! dxn,dyn grid distances in x,y direction for the nested grids
- ! xlon0n geographical longitude of lower left grid point of nested wind fields
- ! ylat0n geographical latitude of lower left grid point of nested wind fields
-
-
- ! Nested fields, unchangeable with time
- !**************************************
-
- real :: oron(0:nxmaxn-1,0:nymaxn-1,maxnests)
- real :: excessoron(0:nxmaxn-1,0:nymaxn-1,maxnests)
- real :: lsmn(0:nxmaxn-1,0:nymaxn-1,maxnests)
- real :: xlandusen(0:nxmaxn-1,0:nymaxn-1,numclass,maxnests)
-
-
- ! 3d nested fields
- !*****************
-
- real,allocatable,dimension(:,:,:,:,:) :: uun, vvn, wwn, ttn, qvn, pvn,&
- & rhon, drhodzn, tthn, qvhn, clwcn, ciwcn, clwn, clwchn, ciwchn
- real,allocatable,dimension(:,:,:,:) :: ctwcn
- integer,allocatable,dimension(:,:,:,:) :: cloudshn
- integer(kind=1),allocatable,dimension(:,:,:,:,:) :: cloudsn
-
- ! 2d nested fields
- !*****************
-
- real :: psn(0:nxmaxn-1,0:nymaxn-1,1,numwfmem,maxnests)
- real :: sdn(0:nxmaxn-1,0:nymaxn-1,1,numwfmem,maxnests)
- real :: msln(0:nxmaxn-1,0:nymaxn-1,1,numwfmem,maxnests)
- real :: tccn(0:nxmaxn-1,0:nymaxn-1,1,numwfmem,maxnests)
- real :: u10n(0:nxmaxn-1,0:nymaxn-1,1,numwfmem,maxnests)
- real :: v10n(0:nxmaxn-1,0:nymaxn-1,1,numwfmem,maxnests)
- real :: tt2n(0:nxmaxn-1,0:nymaxn-1,1,numwfmem,maxnests)
- real :: td2n(0:nxmaxn-1,0:nymaxn-1,1,numwfmem,maxnests)
- real :: lsprecn(0:nxmaxn-1,0:nymaxn-1,1,numwfmem,maxnests)
- real :: convprecn(0:nxmaxn-1,0:nymaxn-1,1,numwfmem,maxnests)
- real :: sshfn(0:nxmaxn-1,0:nymaxn-1,1,numwfmem,maxnests)
- real :: ssrn(0:nxmaxn-1,0:nymaxn-1,1,numwfmem,maxnests)
- real :: surfstrn(0:nxmaxn-1,0:nymaxn-1,1,numwfmem,maxnests)
- real :: ustarn(0:nxmaxn-1,0:nymaxn-1,1,numwfmem,maxnests)
- real :: wstarn(0:nxmaxn-1,0:nymaxn-1,1,numwfmem,maxnests)
- real :: hmixn(0:nxmaxn-1,0:nymaxn-1,1,numwfmem,maxnests)
- real :: tropopausen(0:nxmaxn-1,0:nymaxn-1,1,numwfmem,maxnests)
- real :: olin(0:nxmaxn-1,0:nymaxn-1,1,numwfmem,maxnests)
- ! real :: diffkn(0:nxmaxn-1,0:nymaxn-1,1,numwfmem,maxnests) ! not in use?
- real :: vdepn(0:nxmaxn-1,0:nymaxn-1,maxspec,numwfmem,maxnests)
-
-
- !*************************************************
- ! Certain auxiliary variables needed for the nests
- !*************************************************
-
- real :: xresoln(0:maxnests),yresoln(0:maxnests)
-
- ! xresoln, yresoln Factors by which the resolutions in the nests
- ! are enhanced compared to mother grid
-
- real :: xln(maxnests),yln(maxnests),xrn(maxnests),yrn(maxnests)
-
- ! xln,yln,xrn,yrn Corner points of nested grids in grid coordinates
- ! of mother grid
-
-
!******************************************************
! Variables defining the polar stereographic projection
!******************************************************
@@ -571,6 +311,8 @@ module com_mod
integer(kind=1) :: landinvent(1200,600,6)
real :: z0(numclass)
+!$OMP THREADPRIVATE (z0)
+
! landinvent landuse inventory (numclass=11 classes)
! z0 roughness length for the landuse classes
@@ -618,30 +360,6 @@ module com_mod
! the OUTGRID is moved to the module outg_mod
!******************************************************************************
- !real gridunc(0:maxxgrid-1,0:maxygrid-1,maxzgrid,maxspec,
- ! + maxpointspec_act,nclassunc,maxageclass)
- !real griduncn(0:maxxgridn-1,0:maxygridn-1,maxzgrid,maxspec,
- ! + maxpointspec_act,nclassunc,maxageclass)
- !real wetgridunc(0:maxxgrid-1,0:maxygrid-1,maxspec,
- ! + maxpointspec_act,nclassunc,maxageclass)
- !real wetgriduncn(0:maxxgridn-1,0:maxygridn-1,maxspec,
- ! +ct maxpointspec,nclassunc,maxageclass)
- !real drygridunc(0:maxxgrid-1,0:maxygrid-1,maxspec,maxpointspec,
- ! + nclassunc,maxageclass)
- !real drygriduncn(0:maxxgridn-1,0:maxygridn-1,maxspec,
- ! + maxpointspec,nclassunc,maxageclass)
-
- !real oroout(0:maxxgrid-1,0:maxygrid-1)
- !real orooutn(0:maxxgridn-1,0:maxygridn-1)
- ! real area(0:maxxgrid-1,0:maxygrid-1)
- !real arean(0:maxxgridn-1,0:maxygridn-1)
- !real volume(0:maxxgrid-1,0:maxygrid-1,maxzgrid)
- !real volumen(0:maxxgridn-1,0:maxygridn-1,maxzgrid)
-
- !real areaeast(0:maxxgrid-1,0:maxygrid-1,maxzgrid)
- !real areanorth(0:maxxgrid-1,0:maxygrid-1,maxzgrid)
-
-
! gridunc,griduncn uncertainty of outputted concentrations
! wetgridunc,wetgriduncn uncertainty of accumulated wet deposited mass on output grid
! drygridunc,drygriduncn uncertainty of accumulated dry deposited mass on output grid
@@ -675,26 +393,17 @@ module com_mod
integer :: numpart=0
integer :: numparticlecount
- integer, allocatable, dimension(:) :: itra1, npoint, nclass, idt, itramem, itrasplit
+ !real, allocatable, dimension(:,:) :: xscav_frac1
- real(kind=dp), allocatable, dimension(:) :: xtra1, ytra1
- real, allocatable, dimension(:) :: ztra1
- real, allocatable, dimension(:,:) :: xmass1
- real, allocatable, dimension(:,:) :: xscav_frac1
-
-! Variables used for writing out interval averages for partoutput
-!****************************************************************
+ !****************************************************************
+ ! Variables used for writing out interval averages for partoutput
+ !****************************************************************
integer, allocatable, dimension(:) :: npart_av
real, allocatable, dimension(:) :: part_av_cartx,part_av_carty,part_av_cartz,part_av_z,part_av_topo
real, allocatable, dimension(:) :: part_av_pv,part_av_qv,part_av_tt,part_av_rho,part_av_tro,part_av_hmix
real, allocatable, dimension(:) :: part_av_uu,part_av_vv,part_av_energy
- ! eso: Moved from timemanager
- real, allocatable, dimension(:) :: uap,ucp,uzp,us,vs,ws
- integer(kind=2), allocatable, dimension(:) :: cbt
-
-
!CGZ-lifetime
real, allocatable, dimension(:,:) ::checklifetime, species_lifetime
!CGZ-lifetime
@@ -741,7 +450,7 @@ module com_mod
! Random number field
!********************
- real :: rannumb(maxrand)
+ real :: rannumb(maxrand+2)
! rannumb field of normally distributed random numbers
@@ -749,7 +458,8 @@ module com_mod
! variables to control stability of CBL scheme under variation
! of statistics in time and space
!********************************************************************
- integer :: nan_count,nan_count2,sum_nan_count(3600),maxtl=1200
+ integer :: sum_nan_count(3600),maxtl=1200
+ integer,allocatable,dimension(:) :: nan_count
!added by mc , note that for safety sum_nan_count(N) with N>maxtl
!********************************************************************
@@ -768,6 +478,7 @@ module com_mod
real :: tins
logical, parameter :: nmlout=.true.
+ !**************************************************************
! These variables are used to avoid having separate versions of
! files in cases where differences with MPI version are minor (eso)
!*****************************************************************
@@ -776,8 +487,17 @@ module com_mod
logical, parameter :: interpolhmix=.false. ! true if the hmix shall be interpolated
logical, parameter :: turboff=.false. ! true if the turbulence shall be switched off
+
+ integer :: numthreads,numthreads_grid ! number of available threads in parallel sections
+ !integer :: nclassunc2, nrecclunc, ngriclunc
-
+ !*********************************************************
+ !LB 04.05.2021, simple timing of IO and total running time
+ !*********************************************************
+ real :: s_readwind=0, s_writepartav=0, s_writepart=0, s_temp=0, s_total=0, s_firstt=0
+
+
+
contains
subroutine com_mod_allocate_part(nmpart)
!*******************************************************************************
@@ -792,13 +512,6 @@ contains
implicit none
integer, intent(in) :: nmpart ! maximum number of particles (per process)
-
-! Arrays, previously static of size maxpart
- allocate(itra1(nmpart),npoint(nmpart),nclass(nmpart),&
- & idt(nmpart),itramem(nmpart),itrasplit(nmpart),&
- & xtra1(nmpart),ytra1(nmpart),ztra1(nmpart),&
- & xmass1(nmpart, maxspec)) ! ,&
-! & checklifetime(nmpart,maxspec), species_lifetime(maxspec,2))!CGZ-lifetime
if (ipout.eq.3) then
allocate(npart_av(nmpart),part_av_cartx(nmpart),part_av_carty(nmpart),&
@@ -808,48 +521,6 @@ contains
allocate(part_av_uu(nmpart),part_av_vv(nmpart),part_av_energy(nmpart))
end if
-
- allocate(uap(nmpart),ucp(nmpart),uzp(nmpart),us(nmpart),&
- & vs(nmpart),ws(nmpart),cbt(nmpart))
-
end subroutine com_mod_allocate_part
-
- subroutine com_mod_allocate_nests
- !*******************************************************************************
- ! Dynamic allocation of arrays
- !
- ! For nested wind fields.
- !
- !*******************************************************************************
- implicit none
-
- allocate(uun(0:nxmaxn-1,0:nymaxn-1,nzmax,numwfmem,numbnests))
- allocate(vvn(0:nxmaxn-1,0:nymaxn-1,nzmax,numwfmem,numbnests))
- allocate(wwn(0:nxmaxn-1,0:nymaxn-1,nzmax,numwfmem,numbnests))
- allocate(ttn(0:nxmaxn-1,0:nymaxn-1,nzmax,numwfmem,numbnests))
- allocate(qvn(0:nxmaxn-1,0:nymaxn-1,nzmax,numwfmem,numbnests))
- allocate(pvn(0:nxmaxn-1,0:nymaxn-1,nzmax,numwfmem,numbnests))
- allocate(clwcn(0:nxmaxn-1,0:nymaxn-1,nzmax,numwfmem,numbnests))
- allocate(ciwcn(0:nxmaxn-1,0:nymaxn-1,nzmax,numwfmem,numbnests))
- allocate(clwn(0:nxmaxn-1,0:nymaxn-1,nzmax,numwfmem,numbnests))
-
- allocate(cloudsn(0:nxmaxn-1,0:nymaxn-1,nzmax,numwfmem,numbnests))
- allocate(cloudshn(0:nxmaxn-1,0:nymaxn-1,numwfmem,numbnests))
- allocate(rhon(0:nxmaxn-1,0:nymaxn-1,nzmax,numwfmem,numbnests))
- allocate(drhodzn(0:nxmaxn-1,0:nymaxn-1,nzmax,numwfmem,numbnests))
- allocate(tthn(0:nxmaxn-1,0:nymaxn-1,nuvzmax,numwfmem,numbnests))
- allocate(qvhn(0:nxmaxn-1,0:nymaxn-1,nuvzmax,numwfmem,numbnests))
- allocate(clwchn(0:nxmaxn-1,0:nymaxn-1,nuvzmax,numwfmem,numbnests))
- allocate(ciwchn(0:nxmaxn-1,0:nymaxn-1,nuvzmax,numwfmem,numbnests))
- allocate(ctwcn(0:nxmaxn-1,0:nymaxn-1,numwfmem,numbnests))
-
- clwcn(:,:,:,:,:)=0.
- ciwcn(:,:,:,:,:)=0.
- clwchn(:,:,:,:,:)=0.
- ciwchn(:,:,:,:,:)=0.
-
- end subroutine com_mod_allocate_nests
-
-
end module com_mod
diff --git a/src/conv_mod.f90 b/src/conv_mod.f90
index 7b1bbc89..c51b51d8 100644
--- a/src/conv_mod.f90
+++ b/src/conv_mod.f90
@@ -6,29 +6,2192 @@
!
! Feb 2001
!
+! Changes
+! 2021 L. Bakels:
+! - Array operations in convect subroutine
+! - OpenMP parallelisation in convmix and redist
+! - Moved all subroutines related to the convection to this module
+! 2022 M. Duetsch:
+! - Removed goto statements in sort2 subroutine
!*******************************************************************************
module conv_mod
- use par_mod, only: nconvlevmax, na, nxmax, nymax, nxmaxn, nymaxn, maxnests
-
+ use par_mod, only: nxmaxn, nymaxn, maxnests,nxmax,nymax,nconvlevmax,na,nuvzmax
+ use com_mod, only: lconvection
+ use windfields_mod, only: metdata_format,akz,bkz,akm,bkm,nuvz, &
+ uvheight,ps,tt2,td2,tth,qvh,pplev,tt,qv,nx,ny,tt2n,td2n,psn,tthn,qvhn, &
+ yln,yrn,xln,xrn,yresoln,xresoln,nxn,nyn,dxn,dyn
implicit none
!integer,parameter :: nconvlevmax = nuvzmax-1, &
! na = nconvlevmax+1
!these parameters are defined in par_mod now!
+ ! I do not know how to allocate each array for each thread, not automaticaly done...
+ real :: &!,allocatable,dimension(:) :: &
+ pconv(nconvlevmax), & !
+ phconv(na), & !
+ dpr(nconvlevmax), & !
+ pconv_hpa(nconvlevmax), & !
+ phconv_hpa(na), & !
+ ft(nconvlevmax), & !
+ fq(nconvlevmax), & !
+ sub(nconvlevmax), & ! subsidence
+ tconv(na), & !
+ qconv(na), & !
+ qsconv(na)
+ real :: &!,allocatable,dimension(:,:) :: & !
+ fmass(nconvlevmax,nconvlevmax), & !
+ fmassfrac(nconvlevmax,nconvlevmax), & !
+ cbaseflux(0:nxmax-1,0:nymax-1)
+ real :: &!,allocatable,dimension(:,:,:) :: &
+ cbasefluxn(0:nxmaxn-1,0:nymaxn-1,maxnests)
+ ! integer,dimension(na) :: &
+ ! NENT
+ ! real,dimension(na,na) :: &
+ ! MENT,QENT,ELIJ,SIJ
+ ! real,dimension(na) :: &
+ ! fup,fdown,M,MP,TVP,TV, &
+ ! WATER,QP,EP,TH,WT, &
+ ! EVAP,CLW,SIGP,TP,CPN, &
+ ! LV,LVCP,H,HP,GZ,HM
+ real,dimension(na) :: &
+ uvzlev(nuvzmax),wsub(nuvzmax)
+ real :: psconv,tt2conv,td2conv
+
+ integer :: nconvlev,nconvtop
- real :: pconv(nconvlevmax),phconv(na),dpr(nconvlevmax)
- real :: pconv_hpa(nconvlevmax),phconv_hpa(na)
+ save :: uvzlev
- real :: ft(nconvlevmax), fq(nconvlevmax)
- real :: fmass(nconvlevmax,nconvlevmax),sub(nconvlevmax)
- real :: fmassfrac(nconvlevmax,nconvlevmax)
- real :: cbaseflux(0:nxmax-1,0:nymax-1)
- real :: cbasefluxn(0:nxmaxn-1,0:nymaxn-1,maxnests)
- real :: tconv(na),qconv(na),qsconv(na)
- real :: psconv,tt2conv,td2conv
+!$OMP THREADPRIVATE( ft, fq, fmass, sub, fmassfrac, &
+!$OMP pconv, phconv, dpr, pconv_hpa, phconv_hpa, &
+!$OMP tconv, qconv, qsconv, psconv, tt2conv, td2conv, &
+!$OMP nconvtop,uvzlev,wsub,cbaseflux,cbasefluxn)
+! , &
+! !$OMP fup,fdown,MENT,NENT,M,MP,QENT,ELIJ,SIJ,TVP,TV, &
+! !$OMP WATER,QP,EP,TH,WT,EVAP,CLW,SIGP,TP,CPN,LV,LVCP, &
+! !$OMP H,HP,GZ,HM)
- integer :: nconvlev,nconvtop
+contains
+
+subroutine convection_allocate
+ implicit none
+ if (.not.lconvection.eq.1) return
+ ! ! nconvlevmax=nuvzmax-1
+ ! ! na=nconvlevmax+1
+ ! allocate(pconv(nconvlevmax),phconv(na),dpr(nconvlevmax), &
+ ! pconv_hpa(nconvlevmax),phconv_hpa(na),ft(nconvlevmax), &
+ ! fq(nconvlevmax),fmass(nconvlevmax,nconvlevmax), &
+ ! sub(nconvlevmax),fmassfrac(nconvlevmax,nconvlevmax), &
+ ! cbaseflux(0:nxmax-1,0:nymax-1), &
+ ! cbasefluxn(0:nxmaxn-1,0:nymaxn-1,maxnests), &
+ ! tconv(na),qconv(na),qsconv(na))
+
+ ! allocate(uvzlev(nuvzmax),wsub(nuvzmax))
+
+ ! allocate(FUP(NA),FDOWN(NA),NENT(NA), &
+ ! M(NA),MP(NA),MENT(NA,NA),QENT(NA,NA),ELIJ(NA,NA), &
+ ! SIJ(NA,NA),TVP(NA),TV(NA),WATER(NA), &
+ ! QP(NA),EP(NA),TH(NA),WT(NA),EVAP(NA),CLW(NA), &
+ ! SIGP(NA),TP(NA),CPN(NA), &
+ ! LV(NA),LVCP(NA),H(NA),HP(NA),GZ(NA),HM(NA))
+end subroutine convection_allocate
+
+subroutine convection_deallocate
+ implicit none
+ if (.not.lconvection.eq.1) return
+ ! deallocate(pconv,phconv,dpr,pconv_hpa,phconv_hpa,ft,fq,sub, &
+ ! tconv,qconv,qsconv,fmass,fmassfrac,cbaseflux,cbasefluxn)
+ ! deallocate(uvzlev,wsub)
+ ! deallocate(fup,fdown,ment,M,MP,QENT,ELIJ,SIJ,TVP,TV, &
+ ! WATER,QP,EP,TH,WT,EVAP,CLW,SIGP,TP,CPN,LV,LVCP, &
+ ! H,HP,GZ,HM)
+end subroutine convection_deallocate
+
+subroutine set_upperlevel_convect()
+ ! Determine the uppermost level for which the convection scheme shall be applied
+ ! by assuming that there is no convection above 50 hPa (for standard SLP)
+ !*****************************************************************************
+ implicit none
+
+ integer :: i
+ real :: pint
+
+ do i=1,nuvz-2
+ pint=akz(i)+bkz(i)*101325.
+ if (pint.lt.5000.) exit
+ end do
+ nconvlev=i
+ if (nconvlev.gt.nconvlevmax-1) then
+ nconvlev=nconvlevmax-1
+ write(*,*) 'Attention, convection only calculated up to ', &
+ akz(nconvlev)+bkz(nconvlev)*1013.25,' hPa'
+ endif
+end subroutine set_upperlevel_convect
+
+subroutine convmix(itime)
+ ! i
+ !**************************************************************
+ !handles all the calculations related to convective mixing
+ !Petra Seibert, Bernd C. Krueger, Feb 2001
+ !nested grids included, Bernd C. Krueger, May 2001
+ !
+ !Changes by Caroline Forster, April 2004 - February 2005:
+ ! convmix called every lsynctime seconds
+ !CHANGES by A. Stohl:
+ ! various run-time optimizations - February 2005
+ ! CHANGES by C. Forster, November 2005, NCEP GFS version
+ ! in the ECMWF version convection is calculated on the
+ ! original eta-levels
+ ! in the GFS version convection is calculated on the
+ ! FLEXPART levels
+ !
+ ! Unified ECMWF and GFS builds
+ ! Marian Harustak, 12.5.2017
+ ! - Merged convmix and convmix_gfs into one routine using if-then
+ ! for meteo-type dependent code
+ !**************************************************************
+ use omp_lib
+ use flux_mod
+ use par_mod
+ use com_mod
+ use class_gribfile
+ use particle_mod
+
+ implicit none
+
+ integer :: igr,igrold, ipart, itime, ix, j, inest
+ integer :: ipconv,thread,ithread
+ integer :: jy, kpart, ktop, ngrid,kz
+ integer,allocatable :: igrid(:), ipoint(:), igridn(:,:)
+
+ ! itime [s] current time
+ ! igrid(maxpart) horizontal grid position of each particle
+ ! igridn(maxpart,maxnests) dto. for nested grids
+ ! ipoint(maxpart) pointer to access particles according to grid position
+
+ logical :: lconv
+ real :: x, y, xtn,ytn, ztold, delt
+ real :: dt1,dt2,dtt
+ integer :: mind1,mind2
+ ! dt1,dt2,dtt,mind1,mind2 variables used for time interpolation
+ integer :: itage,nage,inage
+
+ ! OMP changes
+ integer :: cnt,kk
+ integer,allocatable,dimension(:) :: frst
+ double precision :: tmarray(2)
+
+ integer :: totpart,alivepart
+ real:: eps
+ eps=nxmax/3.e5
+ ! Calculate auxiliary variables for time interpolation
+ !*****************************************************
+
+ dt1=real(itime-memtime(1))
+ dt2=real(memtime(2)-itime)
+ dtt=1./(dt1+dt2)
+ mind1=memind(1)
+ mind2=memind(2)
+ delt=real(abs(lsynctime))
+
+ lconv = .false.
+
+ ! if no particles are present return after initialization
+ !********************************************************
+ call get_alive_part_num(alivepart)
+ if (alivepart.le.0 ) return
+
+ call get_total_part_num(totpart)
+ allocate( igrid(totpart) )
+ allocate( ipoint(totpart) )
+ allocate( igridn(totpart,maxnests) )
+
+ ! Assign igrid and igridn, which are pseudo grid numbers indicating particles
+ ! that are outside the part of the grid under consideration
+ ! (e.g. particles near the poles or particles in other nests).
+ ! Do this for all nests but use only the innermost nest; for all others
+ ! igrid shall be -1
+ ! Also, initialize index vector ipoint
+ !************************************************************************
+!$OMP PARALLEL PRIVATE(ipart, j, x, y, ngrid, xtn, ytn, ix, jy)
+!$OMP DO
+ do ipart=1,numpart
+ igrid(ipart)=-1
+ do j=numbnests,1,-1
+ igridn(ipart,j)=-1
+ end do
+ ipoint(ipart)=ipart
+ ! do not consider particles that are not (yet) part of simulation
+ if (.not. part(ipart)%alive) cycle
+ x = part(ipart)%xlon
+ y = part(ipart)%ylat
+
+ ! Determine which nesting level to be used
+ !**********************************************************
+
+ ngrid=0
+ if (metdata_format.eq.GRIBFILE_CENTRE_ECMWF) then
+ do j=numbnests,1,-1
+ ! Temporary fix for nested layer edges: replaced eps with dxn and dyn (LB)
+ if ( x.gt.xln(j)+dxn(j) .and. x.lt.xrn(j)-dxn(j) .and. &
+ y.gt.yln(j)+dyn(j) .and. y.lt.yrn(j)-dyn(j) ) then
+ ngrid=j
+ exit
+ endif
+ end do
+ else
+ do j=numbnests,1,-1
+ if ( x.gt.xln(j) .and. x.lt.xrn(j) .and. &
+ y.gt.yln(j) .and. y.lt.yrn(j) ) then
+ ngrid=j
+ exit
+ endif
+ end do
+ endif
+ ! 23 continue
+
+ ! Determine nested grid coordinates
+ !**********************************
+
+ if (ngrid.gt.0) then
+ ! nested grids
+ xtn=(x-xln(ngrid))*xresoln(ngrid)
+ ytn=(y-yln(ngrid))*yresoln(ngrid)
+ ix=nint(xtn)
+ jy=nint(ytn)
+ ! igridn(ipart,ngrid) = 1 + jy*nxn(ngrid) + ix
+ igridn(ipart,ngrid) = 1 + ix*nyn(ngrid) + jy
+ else if(ngrid.eq.0) then
+ ! mother grid
+ ix=nint(x)
+ jy=nint(y)
+ !igrid(ipart) = 1 + jy*nx + ix
+ igrid(ipart) = 1 + ix*ny + jy
+ endif
+ end do
+!$OMP END DO
+!$OMP END PARALLEL
+
+ ! sumall = 0.
+ ! sumconv = 0.
+
+ !*****************************************************************************
+ ! 1. Now, do everything for the mother domain and, later, for all of the nested domains
+ ! While all particles have to be considered for redistribution, the Emanuel convection
+ ! scheme only needs to be called once for every grid column where particles are present.
+ ! Therefore, particles are sorted according to their grid position. Whenever a new grid
+ ! cell is encountered by looping through the sorted particles, the convection scheme is called.
+ !*****************************************************************************
+
+ ! sort particles according to horizontal position and calculate index vector IPOINT
+
+ call sort2(numpart,igrid,ipoint)
+
+ ! Now visit all grid columns where particles are present
+ ! by going through the sorted particles
+
+ !LB changes following the CTM version
+ allocate(frst(nx*(ny+1)+1))
+ frst(1) = 1
+ cnt = 2
+ igrold = igrid(1)
+ ! Looping over all particles and counting how many in each igrid reside.
+ ! This is saved in frst. The number of consecutive particles in igrid is saved in frst(i)
+ do kpart=1,numpart
+ if (igrold.ne.igrid(kpart)) then
+ frst(cnt) = kpart
+ igrold=igrid(kpart)
+ cnt=cnt+1
+ endif
+ end do
+ frst(cnt) = numpart+1
+
+!$OMP PARALLEL PRIVATE(kk,jy,ix,tmarray,j,kz,ktop,lconv,kpart,ipart,&
+!$OMP ztold,nage,ipconv,itage,thread)
+
+#if (defined _OPENMP)
+ thread = OMP_GET_THREAD_NUM() ! Starts at 0
+#else
+ thread = 0
+#endif
+
+!$OMP DO SCHEDULE(static)
+ do kk=1,cnt-1
+ ! Only consider grids that have particles inside
+ if (igrid(frst(kk)).eq.-1) cycle
+
+ ! Find horizontal location of grid column
+ ix = (igrid(frst(kk))-1)/ny
+ jy = igrid(frst(kk)) - ix*ny - 1
+ ! jy = (igrid(frst(kk))-1)/nx
+ ! ix = igrid(frst(kk)) - jy*nx - 1
+
+ ! Interpolate all meteorological data needed for the convection scheme
+ psconv=(ps(ix,jy,1,mind1)*dt2+ps(ix,jy,1,mind2)*dt1)*dtt
+ tt2conv=(tt2(ix,jy,1,mind1)*dt2+tt2(ix,jy,1,mind2)*dt1)*dtt
+ td2conv=(td2(ix,jy,1,mind1)*dt2+td2(ix,jy,1,mind2)*dt1)*dtt
+
+ if (metdata_format.eq.GRIBFILE_CENTRE_ECMWF) then
+ do kz=1,nuvz-1 !bugfix
+ tconv(kz)=(tth(ix,jy,kz+1,mind1)*dt2+ &
+ tth(ix,jy,kz+1,mind2)*dt1)*dtt
+ qconv(kz)=(qvh(ix,jy,kz+1,mind1)*dt2+ &
+ qvh(ix,jy,kz+1,mind2)*dt1)*dtt
+ end do
+ else
+ do kz=1,nuvz-1 !bugfix
+ pconv(kz)=(pplev(ix,jy,kz,mind1)*dt2+ &
+ pplev(ix,jy,kz,mind2)*dt1)*dtt
+ tconv(kz)=(tt(ix,jy,kz,mind1)*dt2+ &
+ tt(ix,jy,kz,mind2)*dt1)*dtt
+ qconv(kz)=(qv(ix,jy,kz,mind1)*dt2+ &
+ qv(ix,jy,kz,mind2)*dt1)*dtt
+ end do
+ end if
+
+ ! Calculate translocation matrix
+ call calcmatrix(lconv,delt,cbaseflux(ix,jy))
+
+ ! treat particle only if column has convection
+ if (lconv .eqv. .true.) then
+ ktop = 0
+ ! assign new vertical position to particle
+ do kpart=frst(kk), frst(kk+1)-1
+ ipart = ipoint(kpart)
+ ztold=real(part(ipart)%z)
+ call redist(itime,ipart,ktop,ipconv)
+ ! if (ipconv.le.0) sumconv = sumconv+1
+
+ ! Calculate the gross fluxes across layer interfaces
+ !***************************************************
+
+ if (iflux.eq.1) then
+ itage=abs(itime-part(ipart)%tstart)
+ nage=1
+ do inage=1,nageclass
+ nage=inage
+ if ((itage.lt.lage(nage)).or.(.not.part(ipart)%alive)) exit
+ end do
+
+ if (nage.le.nageclass) &
+ call calcfluxes(itime,nage,ipart,real(part(ipart)%xlon), &
+ real(part(ipart)%ylat),ztold,thread+1)
+ endif
+ enddo
+
+ endif !(lconv .eqv. .true)
+ end do
+!$OMP END DO
+!$OMP END PARALLEL
+
+ deallocate(frst)
+
+ ! OpenMP Reduction for dynamically allocated arrays. This is done manually since this
+ ! is not yet supported in most OpenMP versions
+ !************************************************************************************
+ if (iflux.eq.1) then
+ do ithread=1,numthreads
+ flux(:,:,:,:,:,:,:)=flux(:,:,:,:,:,:,:)+flux_omp(:,:,:,:,:,:,:,ithread)
+ end do
+ endif
+
+ !*****************************************************************************
+ ! 2. Nested domains
+ !*****************************************************************************
+
+ ! sort particles according to horizontal position and calculate index vector IPOINT
+ do inest=1,numbnests
+ do ipart=1,numpart
+ ipoint(ipart)=ipart
+ igrid(ipart) = igridn(ipart,inest)
+ enddo
+ call sort2(numpart,igrid,ipoint)
+
+ ! Now visit all grid columns where particles are present
+ ! by going through the sorted particles
+!$OMP PARALLEL PRIVATE (igrold,kpart,ipart,igr,jy,ix,kz,lconv, &
+!$OMP ktop,ztold,nage,ipconv,itage)
+ igrold = -1
+!$OMP DO
+ do kpart=1,numpart
+ igr = igrid(kpart)
+ if (igr .eq. -1) cycle
+ ipart = ipoint(kpart)
+ ! sumall = sumall + 1
+ if (igr .ne. igrold) then
+ ! we are in a new grid column
+ jy = (igr-1)/nxn(inest)
+ ix = igr - jy*nxn(inest) - 1
+
+ ! Interpolate all meteorological data needed for the convection scheme
+ psconv=(psn(ix,jy,1,mind1,inest)*dt2+ &
+ psn(ix,jy,1,mind2,inest)*dt1)*dtt
+ tt2conv=(tt2n(ix,jy,1,mind1,inest)*dt2+ &
+ tt2n(ix,jy,1,mind2,inest)*dt1)*dtt
+ td2conv=(td2n(ix,jy,1,mind1,inest)*dt2+ &
+ td2n(ix,jy,1,mind2,inest)*dt1)*dtt
+!!$ do kz=1,nconvlev+1 !old
+ do kz=1,nuvz-1 !bugfix
+ tconv(kz)=(tthn(ix,jy,kz+1,mind1,inest)*dt2+ &
+ tthn(ix,jy,kz+1,mind2,inest)*dt1)*dtt
+ qconv(kz)=(qvhn(ix,jy,kz+1,mind1,inest)*dt2+ &
+ qvhn(ix,jy,kz+1,mind2,inest)*dt1)*dtt
+ end do
+
+ ! calculate translocation matrix
+ !*******************************
+ call calcmatrix(lconv,delt,cbasefluxn(ix,jy,inest))
+ igrold = igr
+ ktop = 0
+ endif
+
+ ! treat particle only if column has convection
+ if (lconv .eqv. .true.) then
+ ! assign new vertical position to particle
+ ztold=part(ipart)%z
+ call redist(itime,ipart,ktop,ipconv)
+ ! if (ipconv.le.0) sumconv = sumconv+1
+
+ ! Calculate the gross fluxes across layer interfaces
+ !***************************************************
+
+ if (iflux.eq.1) then
+ itage=abs(itime-part(ipart)%tstart)
+ nage=1
+ do inage=1,nageclass
+ nage=inage
+ if ((itage.lt.lage(nage)).or.(.not.part(ipart)%alive)) exit
+ end do
+
+ if (nage.le.nageclass) &
+ call calcfluxes(itime,nage,ipart,real(part(ipart)%xlon), &
+ real(part(ipart)%ylat),ztold,1)
+ endif
+
+ endif !(lconv .eqv. .true.)
+
+ end do
+!$OMP END DO
+!$OMP END PARALLEL
+ end do
+ ! OpenMP Reduction for dynamically allocated arrays. This is done manually since this
+ ! is not yet supported in most OpenMP versions
+ !************************************************************************************
+ if (iflux.eq.1) then
+ do ithread=1,numthreads
+ flux(:,:,:,:,:,:,:)=flux(:,:,:,:,:,:,:)+flux_omp(:,:,:,:,:,:,:,ithread)
+ end do
+ endif
+ !--------------------------------------------------------------------------
+ ! write(*,*)'############################################'
+ ! write(*,*)'TIME=',&
+ ! & itime
+ ! write(*,*)'fraction of particles under convection',&
+ ! & sumconv/(sumall+0.001)
+ ! write(*,*)'total number of particles',&
+ ! & sumall
+ ! write(*,*)'number of particles under convection',&
+ ! & sumconv
+ ! write(*,*)'############################################'
+
+ deallocate( igrid )
+ deallocate( ipoint )
+ deallocate( igridn )
+
+ return
+end subroutine convmix
+
+subroutine calcmatrix(lconv,delt,cbmf)
+ ! o i o
+ !*****************************************************************************
+ ! *
+ ! This subroutine calculates the matrix describing convective *
+ ! redistribution of mass in a grid column, using the subroutine *
+ ! convect43c.f provided by Kerry Emanuel. *
+ ! *
+ ! Petra Seibert, Bernd C. Krueger, 2000-2001 *
+ ! *
+ !*****************************************************************************
+ ! Changes: *
+ ! changed by C. Forster, November 2003 - February 2004 *
+ ! array fmassfrac(nconvlevmax,nconvlevmax) represents *
+ ! the convective redistribution matrix for the particles *
+ ! *
+ ! Unified ECMWF and GFS builds *
+ ! Marian Harustak, 12.5.2017 *
+ ! - Merged calcmatrix and calcmatrix_gfs into one routine using if-then *
+ ! for meteo-type dependent code *
+ !*****************************************************************************
+ ! *
+ ! lconv indicates whether there is convection in this cell, or not *
+ ! delt time step for convection [s] *
+ ! cbmf cloud base mass flux *
+ ! metdata_format format of metdata (ecmwf/gfs) *
+ ! *
+ !*****************************************************************************
+
+ use par_mod
+ use com_mod
+ use class_gribfile
+ use qvsat_mod
+
+ implicit none
+
+ real :: rlevmass,summe
+
+ integer :: iflag, k, kk, kuvz
+
+ !1-d variables for convection
+ !variables for redistribution matrix
+ real :: cbmfold, precip, qprime
+ real :: tprime, wd
+ real :: delt,cbmf
+ logical :: lconv
+
+ lconv = .false.
+
+
+ ! calculate pressure at eta levels for use in convect
+ ! and assign temp & spec. hum. to 1D workspace
+ ! -------------------------------------------------------
+
+ ! pconv(1) is the pressure at the first level above ground
+ ! phconv(k) is the pressure between levels k-1 and k
+ ! dpr(k) is the pressure difference "around" tconv(k)
+ ! phconv(kmax) must also be defined 1/2 level above pconv(kmax)
+ ! Therefore, we define k = kuvz-1 and let kuvz start from 2
+ ! top layer cannot be used for convection because p at top of this layer is
+ ! not given
+
+
+ phconv(1) = psconv
+ ! Emanuel subroutine needs pressure in hPa, therefore convert all pressures
+ ! do kuvz = 2,nuvz
+ ! k = kuvz-1
+ ! if (metdata_format.eq.GRIBFILE_CENTRE_ECMWF) then
+ ! pconv(k) = (akz(kuvz) + bkz(kuvz)*psconv)
+ ! phconv(kuvz) = (akm(kuvz) + bkm(kuvz)*psconv)
+ ! else
+ ! phconv(kuvz) = 0.5*(pconv(kuvz)+pconv(k))
+ ! endif
+ ! dpr(k) = phconv(k) - phconv(kuvz)
+ ! qsconv(k) = f_qvsat( pconv(k), tconv(k) )
+
+ ! initialize mass fractions
+ ! do kk=1,nconvlev
+ ! fmassfrac(k,kk)=0.
+ ! end do
+ ! end do
+ ! LB 04.05.2021, replace above with array operations
+ if (metdata_format.eq.GRIBFILE_CENTRE_ECMWF) then
+ pconv(1:nuvz-1) = (akz(2:nuvz) + bkz(2:nuvz)*psconv)
+ phconv(2:nuvz) = (akm(2:nuvz) + bkm(2:nuvz)*psconv)
+ else
+ phconv(2:nuvz) = 0.5*(pconv(2:nuvz)+pconv(1:nuvz-1))
+ endif
+ dpr(1:nuvz-1) = phconv(1:nuvz-1) - phconv(2:nuvz)
+ do k = 1,nuvz-1
+ qsconv(k) = f_qvsat( pconv(k), tconv(k) )
+ end do
+ fmassfrac(1:nuvz-1,1:nconvlev)=0.
+ ! LB end
+
+ !note that Emanuel says it is important
+ !a. to set this =0. every grid point
+ !b. to keep this value in the calling programme in the iteration
+
+ ! CALL CONVECTION
+ !******************
+
+ cbmfold = cbmf
+ ! Convert pressures to hPa, as required by Emanuel scheme
+ !********************************************************
+ !!$ do k=1,nconvlev !old
+ ! do k=1,nconvlev+1 !bugfix
+ ! pconv_hpa(k)=pconv(k)/100.
+ ! phconv_hpa(k)=phconv(k)/100.
+ ! end do
+ ! phconv_hpa(nconvlev+1)=phconv(nconvlev+1)/100.
+ ! LB 04.05.2021, replace above with array operations
+ pconv_hpa(1:nconvlev+1)=pconv(1:nconvlev+1)/100.
+ phconv_hpa(1:nconvlev+1)=phconv(1:nconvlev+1)/100.
+ ! LB end
+
+ call convect(nconvlevmax, nconvlev, delt, iflag, &
+ precip, wd, tprime, qprime, cbmf)
+
+ ! do not update fmassfrac and cloudbase massflux
+ ! if no convection takes place or
+ ! if a CFL criterion is violated in convect43c.f
+ if (iflag .ne. 1 .and. iflag .ne. 4) then
+ cbmf=cbmfold
+ return
+ endif
+
+ ! do not update fmassfrac and cloudbase massflux
+ ! if the old and the new cloud base mass
+ ! fluxes are zero
+ if (cbmf.le.0..and.cbmfold.le.0.) then
+ cbmf=cbmfold
+ return
+ endif
+
+ ! Update fmassfrac
+ ! account for mass displaced from level k to level k
+
+ lconv = .true.
+ do k=1,nconvtop
+ rlevmass = dpr(k)/ga
+ summe = 0.
+ do kk=1,nconvtop
+ fmassfrac(k,kk) = delt*fmass(k,kk)
+ summe = summe + fmassfrac(k,kk)
+ end do
+ fmassfrac(k,k)=fmassfrac(k,k) + rlevmass - summe
+ end do
+ ! LB 04.05.2021, replace above with array operations (not the problem)
+ ! fmassfrac(1:nconvtop,1:nconvtop) = delt*fmass(1:nconvtop,1:nconvtop)
+ ! do k=1, nconvtop
+ ! fmassfrac(k, k) = fmassfrac(k, k) + dpr(k)/ga - sum(fmassfrac(k, 1:nconvtop))
+ ! end do
+ ! LB end
+end subroutine calcmatrix
+
+subroutine redist(itime,ipart,ktop,ipconv)
+
+ !**************************************************************************
+ ! Do the redistribution of particles due to convection
+ ! This subroutine is called for each particle which is assigned
+ ! a new vertical position randomly, based on the convective redistribution
+ ! matrix
+ !**************************************************************************
+
+ ! Petra Seibert, Feb 2001, Apr 2001, May 2001, Jan 2002, Nov 2002 and
+ ! Andreas Frank, Nov 2002
+
+ ! Caroline Forster: November 2004 - February 2005
+
+ use par_mod
+ use com_mod
+ use random_mod
+ use omp_lib
+ use interpol_mod
+ use coordinates_ecmwf_mod
+ use particle_mod
+ use qvsat_mod
+
+ implicit none
+
+ real,parameter :: const=r_air/ga
+ integer :: ipart, ktop,ipconv,itime
+ integer :: k, kz, levnew, levold,ithread
+
+ real :: totlevmass, wsubpart
+ real :: temp_levold,temp_levold1
+ real :: sub_levold,sub_levold1
+ real :: pint, pold, rn, tv, tvold, dlevfrac
+ real :: ztold,ffraction
+ real :: tv1, tv2, dlogp, dz, dz1, dz2
+
+#ifdef _OPENMP
+ ithread = OMP_GET_THREAD_NUM() ! Starts at 0
+#else
+ ithread=0
+#endif
+
+ ! ipart ... number of particle to be treated
+
+ ipconv=1
+
+ ! ! determine vertical grid position of particle in the eta system
+ ! !****************************************************************
+ select case (wind_coord_type)
+
+ case ('ETA')
+ ztold = real(part(abs(ipart))%zeta)
+ ! find old particle grid position
+ levold = nconvtop
+ do kz = 2, nconvtop
+ if (wheight(kz) .le. ztold ) then
+ levold = kz-1
+ exit
+ endif
+ end do
+
+ case ('METER')
+
+ ! determine height of the eta half-levels (uvzlev)
+ ! do that only once for each grid column
+ ! i.e. when ktop.eq.1
+ !**************************************************************
+
+ if (ktop .le. 1) then
+
+ tvold=tt2conv*(1.+0.378*ew(td2conv,psconv)/psconv)
+ pold=psconv
+ uvzlev(1)=0.
+
+ pint = phconv(2)
+ ! determine next virtual temperatures
+ tv1 = tconv(1)*(1.+0.608*qconv(1))
+ tv2 = tconv(2)*(1.+0.608*qconv(2))
+ ! interpolate virtual temperature to half-level
+ tv = tv1 + (tv2-tv1)*(pconv(1)-phconv(2))/(pconv(1)-pconv(2))
+ tv = tv1 + (tv2-tv1)*(pconv(1)-phconv(2))/(pconv(1)-pconv(2))
+ if (abs(tv-tvold).gt.0.2) then
+ uvzlev(2) = uvzlev(1) + &
+ const*log(pold/pint)* &
+ (tv-tvold)/log(tv/tvold)
+ else
+ uvzlev(2) = uvzlev(1)+ &
+ const*log(pold/pint)*tv
+ endif
+ tvold=tv
+ tv1=tv2
+ pold=pint
+
+ ! integrate profile (calculation of height agl of eta layers) as required
+ do kz = 3, nconvtop+1
+ ! note that variables defined in calcmatrix.f (pconv,tconv,qconv)
+ ! start at the first real ECMWF model level whereas kz and
+ ! thus uvzlev(kz) starts at the surface. uvzlev is defined at the
+ ! half-levels (between the tconv, qconv etc. values !)
+ ! Thus, uvzlev(kz) is the lower boundary of the tconv(kz) cell.
+ pint = phconv(kz)
+ ! determine next virtual temperatures
+ tv2 = tconv(kz)*(1.+0.608*qconv(kz))
+ ! interpolate virtual temperature to half-level
+ tv = tv1 + (tv2-tv1)*(pconv(kz-1)-phconv(kz))/ &
+ (pconv(kz-1)-pconv(kz))
+ tv = tv1 + (tv2-tv1)*(pconv(kz-1)-phconv(kz))/ &
+ (pconv(kz-1)-pconv(kz))
+ if (abs(tv-tvold).gt.0.2) then
+ uvzlev(kz) = uvzlev(kz-1) + &
+ const*log(pold/pint)* &
+ (tv-tvold)/log(tv/tvold)
+ else
+ uvzlev(kz) = uvzlev(kz-1)+ &
+ const*log(pold/pint)*tv
+ endif
+ tvold=tv
+ tv1=tv2
+ pold=pint
+
+
+ end do
+
+ ktop = 2
+
+ endif
+
+ ztold = real(part(abs(ipart))%z)
+ ! find old particle grid position
+ levold = nconvtop
+ do kz = 2, nconvtop
+ if (uvzlev(kz) .ge. ztold ) then
+ levold = kz-1
+ exit
+ endif
+ end do
+ case default
+ write(*,*) 'The wind_coord_type is not defined in redist.f90'
+ stop
+
+ end select
+
+ ! If the particle is above the potentially convective domain, it will be skipped
+ if (levold.ne.nconvtop) then
+
+ ! now redistribute particles
+ !****************************
+
+ ! Choose a random number and find corresponding level of destination
+ ! Random numbers to be evenly distributed in [0,1]
+
+ rn = ran3(iseed2(ithread),ithread)
+
+ ! initialize levnew
+
+ levnew = levold
+
+ ffraction = 0.
+ totlevmass=dpr(levold)/ga
+ loop1: do k = 1,nconvtop
+ ! for backward runs use the transposed matrix
+ if (ldirect.eq.1) then
+ ffraction=ffraction+fmassfrac(levold,k) &
+ /totlevmass
+ else
+ ffraction=ffraction+fmassfrac(k,levold) &
+ /totlevmass
+ endif
+ if (rn.le.ffraction) then
+ levnew=k
+ ! avoid division by zero or a too small number
+ ! if division by zero or a too small number happens the
+ ! particle is assigned to the center of the grid cell
+ if (ffraction.gt.1.e-20) then
+ if (ldirect.eq.1) then
+ dlevfrac = (ffraction-rn) / fmassfrac(levold,k) * totlevmass
+ else
+ dlevfrac = (ffraction-rn) / fmassfrac(k,levold) * totlevmass
+ endif
+ else
+ dlevfrac = 0.5
+ endif
+ exit loop1
+ endif
+ end do loop1
+
+ ! now assign new position to particle
+ select case (wind_coord_type)
+
+ case ('ETA')
+ if ((levnew.le.nconvtop).and.(levnew.ne.levold)) then
+ dlogp = (1.-dlevfrac) * (wheight(levnew+1)-wheight(levnew))
+ call set_zeta(ipart,wheight(levnew)+dlogp)
+ if (part(abs(ipart))%zeta.ge.1.) call set_zeta(ipart,1.-(part(abs(ipart))%zeta-1.))
+ if (part(abs(ipart))%zeta.eq.1.) call update_zeta(ipart,-1.e-4)
+ if (ipconv.gt.0) ipconv=-1
+ endif
+
+ case ('METER')
+ if ((levnew.le.nconvtop).and.(levnew.ne.levold)) then
+ dlogp = (1.-dlevfrac)* (log(phconv(levnew+1))-log(phconv(levnew)))
+ pint = log(phconv(levnew))+dlogp
+ dz1 = pint - log(phconv(levnew))
+ dz2 = log(phconv(levnew+1)) - pint
+ dz = dz1 + dz2
+ call set_z(ipart,(uvzlev(levnew)*dz2+uvzlev(levnew+1)*dz1)/dz)
+ if (part(abs(ipart))%z.lt.0.) call set_z(ipart,-1.*part(abs(ipart))%z)
+ if (ipconv.gt.0) ipconv=-1
+ endif
+
+ case default
+ write(*,*) 'The chosen wind_coord_type is not defined in redist.f90'
+ stop
+
+ end select
+
+ ! displace particle according to compensating subsidence
+ ! this is done to those particles, that were not redistributed
+ ! by the matrix
+ !**************************************************************
+
+ if ((levnew.le.nconvtop).and.(levnew.eq.levold)) then
+
+ ! determine compensating vertical velocity at the levels
+ ! above and below the particel position
+ ! increase compensating subsidence by the fraction that
+ ! is displaced by convection to this level
+
+ if (levold.gt.1) then
+ temp_levold = tconv(levold-1) + &
+ (tconv(levold)-tconv(levold-1)) &
+ *(pconv(levold-1)-phconv(levold))/ &
+ (pconv(levold-1)-pconv(levold))
+ ! Bug fix: Added lsynctime to make units correct
+ sub_levold = sub(levold)/(1.-ga*sub(levold)*lsynctime/dpr(levold))
+ wsub(levold)=-1.*sub_levold*r_air*temp_levold/(phconv(levold))
+ else
+ wsub(levold)=0.
+ endif
+
+ temp_levold1 = tconv(levold) + &
+ (tconv(levold+1)-tconv(levold)) &
+ *(pconv(levold)-phconv(levold+1))/ &
+ (pconv(levold)-pconv(levold+1))
+ ! Bug fix: Added lsynctime to make units correct
+ sub_levold1 = sub(levold+1)/(1.-ga*sub(levold+1)*lsynctime/dpr(levold+1))
+ wsub(levold+1)=-1.*sub_levold1*r_air*temp_levold1/ &
+ (phconv(levold+1))
+
+ ! interpolate wsub to the vertical particle position
+ select case (wind_coord_type)
+ case ('ETA')
+ ztold = real(part(abs(ipart))%zeta)
+ dz1 = ztold - wheight(levold)
+ dz2 = wheight(levold+1) - ztold
+ dz = dz1 + dz2
+
+ ! Convert z(eta) to z(m) in order to add subsidence
+ call update_zeta_to_z(itime, ipart)
+ ! call zeta_to_z(itime,part(abs(ipart))%xlon,part(abs(ipart))%ylat, &
+ ! part(abs(ipart))%zeta,part(abs(ipart))%z)
+
+ wsubpart = (dz2*wsub(levold)+dz1*wsub(levold+1))/dz
+
+ call update_z(ipart,wsubpart*real(lsynctime))
+
+ if (part(abs(ipart))%z.lt.0.) call set_z(ipart,-1.*part(abs(ipart))%z)
+
+ ! Convert new z(m) back to z(eta)
+ call update_z_to_zeta(itime, ipart)
+
+ case ('METER')
+ ztold = real(part(abs(ipart))%z)
+ dz1 = ztold - uvzlev(levold)
+ dz2 = uvzlev(levold+1) - ztold
+ dz = dz1 + dz2
+
+ wsubpart = (dz2*wsub(levold)+dz1*wsub(levold+1))/dz
+
+ call update_z(ipart,wsubpart*real(lsynctime))
+
+ if (part(abs(ipart))%z.lt.0.) call set_z(ipart,-1.*part(abs(ipart))%z)
+
+ case default
+ write(*,*) 'The wind_coord_type is not defined in redist.f90'
+ stop
+ end select
+ endif !(levnew.le.nconvtop.and.levnew.eq.levold)
+ endif
+ ! Maximum altitude .5 meter below uppermost model level
+ !*******************************************************
+
+ select case (wind_coord_type)
+ case ('ETA')
+ if (part(abs(ipart))%zeta .lt. uvheight(nz)) call set_zeta(ipart,uvheight(nz)+1.e-4)
+ if (part(abs(ipart))%zeta.ge.1.) call set_zeta(ipart,1.-(part(abs(ipart))%zeta-1.))
+ if (part(abs(ipart))%zeta.eq.1.) call update_zeta(ipart,-1.e-4)
+ case ('METER')
+ if (part(abs(ipart))%z .gt. height(nz)-0.5) call set_z(ipart,height(nz)-0.5)
+ case default
+ write(*,*) 'The wind_coord_type is not defined in redist.f90'
+ stop
+ end select
+
+end subroutine redist
+
+!**************************************************************************
+!**** SUBROUTINE CONVECT *****
+!**** VERSION 4.3c *****
+!**** 20 May, 2002 *****
+!**** Kerry Emanuel *****
+!**************************************************************************
+!
+ SUBROUTINE CONVECT &
+ (ND, NL, DELT, IFLAG, &
+ PRECIP, WD, TPRIME, QPRIME, CBMF )
+ !
+ !-cv *************************************************************************
+ !-cv C. Forster, November 2003 - May 2004:
+ !-cv
+ !-cv The subroutine has been downloaded from Kerry Emanuel's homepage,
+ !-cv where further infos on the convection scheme can be found
+ !-cv http://www-paoc.mit.edu/~emanuel/home.html
+ !-cv
+ !-cv The following changes have been made to integrate this subroutine
+ !-cv into FLEXPART
+ !-cv
+ !-cv Putting most of the variables in a new common block
+ !-cv renaming eps to eps0 because there is some eps already in includepar
+ !-cv
+ !-cv removing the arrays U,V,TRA and related arrays
+ !-cv
+ !-cv renaming the original arrays T,Q,QS,P,PH to
+ !-cv TCONV,QCONV,QSCONV,PCONV_HPA,PHCONV_HPA
+ !-cv
+ !-cv Initialization of variables has been put into parameter statements
+ !-cv instead of assignment of values at each call, in order to save
+ !-cv computation time.
+ !***************************************************************************
+ !
+ !-----------------------------------------------------------------------------
+ ! *** On input: ***
+ !
+ !T: Array of absolute temperature (K) of dimension ND, with first
+ ! index corresponding to lowest model level. Note that this array
+ ! will be altered by the subroutine if dry convective adjustment
+ ! occurs and if IPBL is not equal to 0.
+ !
+ !Q: Array of specific humidity (gm/gm) of dimension ND, with first
+ ! index corresponding to lowest model level. Must be defined
+ ! at same grid levels as T. Note that this array will be altered
+ ! if dry convective adjustment occurs and if IPBL is not equal to 0.
+ !
+ !QS: Array of saturation specific humidity of dimension ND, with first
+ ! index corresponding to lowest model level. Must be defined
+ ! at same grid levels as T. Note that this array will be altered
+ ! if dry convective adjustment occurs and if IPBL is not equal to 0.
+ !
+ !U: Array of zonal wind velocity (m/s) of dimension ND, witth first
+ ! index corresponding with the lowest model level. Defined at
+ ! same levels as T. Note that this array will be altered if
+ ! dry convective adjustment occurs and if IPBL is not equal to 0.
+ !
+ !V: Same as U but for meridional velocity.
+ !
+ !TRA: Array of passive tracer mixing ratio, of dimensions (ND,NTRA),
+ ! where NTRA is the number of different tracers. If no
+ ! convective tracer transport is needed, define a dummy
+ ! input array of dimension (ND,1). Tracers are defined at
+ ! same vertical levels as T. Note that this array will be altered
+ ! if dry convective adjustment occurs and if IPBL is not equal to 0.
+ !
+ !P: Array of pressure (mb) of dimension ND, with first
+ ! index corresponding to lowest model level. Must be defined
+ ! at same grid levels as T.
+ !
+ !PH: Array of pressure (mb) of dimension ND+1, with first index
+ ! corresponding to lowest level. These pressures are defined at
+ ! levels intermediate between those of P, T, Q and QS. The first
+ ! value of PH should be greater than (i.e. at a lower level than)
+ ! the first value of the array P.
+ !
+ !ND: The dimension of the arrays T,Q,QS,P,PH,FT and FQ
+ !
+ !NL: The maximum number of levels to which convection can
+ ! penetrate, plus 1.
+ ! NL MUST be less than or equal to ND-1.
+ !
+ !NTRA:The number of different tracers. If no tracer transport
+ ! is needed, set this equal to 1. (On most compilers, setting
+ ! NTRA to 0 will bypass tracer calculation, saving some CPU.)
+ !
+ !DELT: The model time step (sec) between calls to CONVECT
+ !
+ !----------------------------------------------------------------------------
+ ! *** On Output: ***
+ !
+ !IFLAG: An output integer whose value denotes the following:
+ !
+ ! VALUE INTERPRETATION
+ ! ----- --------------
+ ! 0 No moist convection; atmosphere is not
+ ! unstable, or surface temperature is less
+ ! than 250 K or surface specific humidity
+ ! is non-positive.
+ !
+ ! 1 Moist convection occurs.
+ !
+ ! 2 No moist convection: lifted condensation
+ ! level is above the 200 mb level.
+ !
+ ! 3 No moist convection: cloud base is higher
+ ! then the level NL-1.
+ !
+ ! 4 Moist convection occurs, but a CFL condition
+ ! on the subsidence warming is violated. This
+ ! does not cause the scheme to terminate.
+ !
+ !FT: Array of temperature tendency (K/s) of dimension ND, defined at same
+ ! grid levels as T, Q, QS and P.
+ !
+ !FQ: Array of specific humidity tendencies ((gm/gm)/s) of dimension ND,
+ ! defined at same grid levels as T, Q, QS and P.
+ !
+ !FU: Array of forcing of zonal velocity (m/s^2) of dimension ND,
+ ! defined at same grid levels as T.
+ !
+ !FV: Same as FU, but for forcing of meridional velocity.
+ !
+ !FTRA: Array of forcing of tracer content, in tracer mixing ratio per
+ ! second, defined at same levels as T. Dimensioned (ND,NTRA).
+ !
+ !PRECIP: Scalar convective precipitation rate (mm/day).
+ !
+ !WD: A convective downdraft velocity scale. For use in surface
+ ! flux parameterizations. See convect.ps file for details.
+ !
+ !TPRIME: A convective downdraft temperature perturbation scale (K).
+ ! For use in surface flux parameterizations. See convect.ps
+ ! file for details.
+ !
+ !QPRIME: A convective downdraft specific humidity
+ ! perturbation scale (gm/gm).
+ ! For use in surface flux parameterizations. See convect.ps
+ ! file for details.
+ !
+ !CBMF: The cloud base mass flux ((kg/m**2)/s). THIS SCALAR VALUE MUST
+ ! BE STORED BY THE CALLING PROGRAM AND RETURNED TO CONVECT AT
+ ! ITS NEXT CALL. That is, the value of CBMF must be "remembered"
+ ! by the calling program between calls to CONVECT.
+ !
+ !-----------------------------------------------------------------------------
+ !
+ ! *** THE PARAMETER NA SHOULD IN GENERAL BE GREATER THAN ***
+ ! *** OR EQUAL TO ND + 1 ***
+ !
+ !
+ use par_mod
+
+ implicit none
+ !
+ !-cv====>Begin Module CONVECT File convect.f Undeclared variables
+ !
+ !Argument variables
+ !
+ integer :: iflag, nd, nl
+ !
+ real :: cbmf, delt, precip, qprime, tprime, wd
+ !
+ !Local variables
+ !
+ integer :: i, icb, ihmin, inb, inb1, j, jtt, k
+ integer :: nk
+ !
+ real :: ad, afac, ahmax, ahmin, alt, altem
+ real :: am, amp1, anum, asij, awat, b6, bf2, bsum, by
+ real :: byp, c6, cape, capem, cbmfold, chi, coeff
+ real :: cpinv, cwat, damps, dbo, dbosum
+ real :: defrac, dei, delm, delp, delt0, delti, denom, dhdp
+ real :: dpinv, dtma, dtmin, dtpbl, elacrit, ents
+ real :: epmax, fac, fqold, frac, ftold
+ real :: plcl, qp1, qsm, qstm, qti, rat
+ real :: rdcp, revap, rh, scrit, sigt, sjmax
+ real :: sjmin, smid, smin, stemp, tca
+ real :: tvaplcl, tvpplcl, tvx, tvy, wdtrain
+
+ !integer jc,jn
+ !real alvnew,a2,ahm,alv,rm,sum,qnew,dphinv,tc,thbar,tnew,x
+ !REAL TOLD(NA)
+
+ real :: FUP(NA),FDOWN(NA)
+ !
+ !-cv====>End Module CONVECT File convect.f
+
+ INTEGER :: NENT(NA)
+ REAL :: M(NA),MP(NA),MENT(NA,NA),QENT(NA,NA),ELIJ(NA,NA)
+ REAL :: SIJ(NA,NA),TVP(NA),TV(NA),WATER(NA)
+ REAL :: QP(NA),EP(NA),TH(NA),WT(NA),EVAP(NA),CLW(NA)
+ REAL :: SIGP(NA),TP(NA),CPN(NA)
+ REAL :: LV(NA),LVCP(NA),H(NA),HP(NA),GZ(NA),HM(NA)
+ !
+ ! -----------------------------------------------------------------------
+ !
+ ! *** Specify Switches ***
+ !
+ ! *** IPBL: Set to zero to bypass dry adiabatic adjustment ***
+ ! *** Any other value results in dry adiabatic adjustment ***
+ ! *** (Zero value recommended for use in models with ***
+ ! *** boundary layer schemes) ***
+ !
+ ! *** MINORIG: Lowest level from which convection may originate ***
+ ! *** (Should be first model level at which T is defined ***
+ ! *** for models using bulk PBL schemes; otherwise, it should ***
+ ! *** be the first model level at which T is defined above ***
+ ! *** the surface layer) ***
+ !
+ INTEGER,PARAMETER :: IPBL=0
+ INTEGER,PARAMETER :: MINORIG=1
+ !
+ !------------------------------------------------------------------------------
+ !
+ ! *** SPECIFY PARAMETERS ***
+ !
+ ! *** ELCRIT IS THE AUTOCONVERSION THERSHOLD WATER CONTENT (gm/gm) ***
+ ! *** TLCRIT IS CRITICAL TEMPERATURE BELOW WHICH THE AUTO- ***
+ ! *** CONVERSION THRESHOLD IS ASSUMED TO BE ZERO ***
+ ! *** (THE AUTOCONVERSION THRESHOLD VARIES LINEARLY ***
+ ! *** BETWEEN 0 C AND TLCRIT) ***
+ ! *** ENTP IS THE COEFFICIENT OF MIXING IN THE ENTRAINMENT ***
+ ! *** FORMULATION ***
+ ! *** SIGD IS THE FRACTIONAL AREA COVERED BY UNSATURATED DNDRAFT ***
+ ! *** SIGS IS THE FRACTION OF PRECIPITATION FALLING OUTSIDE ***
+ ! *** OF CLOUD ***
+ ! *** OMTRAIN IS THE ASSUMED FALL SPEED (P/s) OF RAIN ***
+ ! *** OMTSNOW IS THE ASSUMED FALL SPEED (P/s) OF SNOW ***
+ ! *** COEFFR IS A COEFFICIENT GOVERNING THE RATE OF EVAPORATION ***
+ ! *** OF RAIN ***
+ ! *** COEFFS IS A COEFFICIENT GOVERNING THE RATE OF EVAPORATION ***
+ ! *** OF SNOW ***
+ ! *** CU IS THE COEFFICIENT GOVERNING CONVECTIVE MOMENTUM ***
+ ! *** TRANSPORT ***
+ ! *** DTMAX IS THE MAXIMUM NEGATIVE TEMPERATURE PERTURBATION ***
+ ! *** A LIFTED PARCEL IS ALLOWED TO HAVE BELOW ITS LFC ***
+ ! *** ALPHA AND DAMP ARE PARAMETERS THAT CONTROL THE RATE OF ***
+ ! *** APPROACH TO QUASI-EQUILIBRIUM ***
+ ! *** (THEIR STANDARD VALUES ARE 0.20 AND 0.1, RESPECTIVELY) ***
+ ! *** (DAMP MUST BE LESS THAN 1) ***
+ !
+ REAL,PARAMETER :: ELCRIT=.0011
+ REAL,PARAMETER :: TLCRIT=-55.0
+ REAL,PARAMETER :: ENTP=1.5
+ REAL,PARAMETER :: SIGD=0.05
+ REAL,PARAMETER :: SIGS=0.12
+ REAL,PARAMETER :: OMTRAIN=50.0
+ REAL,PARAMETER :: OMTSNOW=5.5
+ REAL,PARAMETER :: COEFFR=1.0
+ REAL,PARAMETER :: COEFFS=0.8
+ REAL,PARAMETER :: CU=0.7
+ REAL,PARAMETER :: BETA=10.0
+ REAL,PARAMETER :: DTMAX=0.9
+ REAL,PARAMETER :: ALPHA=0.025 !original 0.2
+ REAL,PARAMETER :: DAMP=0.1
+ !
+ ! *** ASSIGN VALUES OF THERMODYNAMIC CONSTANTS, ***
+ ! *** GRAVITY, AND LIQUID WATER DENSITY. ***
+ ! *** THESE SHOULD BE CONSISTENT WITH ***
+ ! *** THOSE USED IN CALLING PROGRAM ***
+ ! *** NOTE: THESE ARE ALSO SPECIFIED IN SUBROUTINE TLIFT ***
+ !
+ REAL,PARAMETER :: CPD=1005.7
+ REAL,PARAMETER :: CPV=1870.0
+ REAL,PARAMETER :: CL=2500.0
+ REAL,PARAMETER :: RV=461.5
+ REAL,PARAMETER :: RD=287.04
+ REAL,PARAMETER :: LV0=2.501E6
+ REAL,PARAMETER :: G=9.81
+ REAL,PARAMETER :: ROWL=1000.0
+ !
+ REAL,PARAMETER :: CPVMCL=CL-CPV
+ REAL,PARAMETER :: EPS0=RD/RV
+ REAL,PARAMETER :: EPSI=1./EPS0
+ REAL,PARAMETER :: GINV=1.0/G
+ REAL,PARAMETER :: EPSILON=1.e-20
+
+ ! EPSILON IS A SMALL NUMBER USED TO EXCLUDE MASS FLUXES OF ZERO
+ !
+ DELTI=1.0/DELT
+ !
+ ! *** INITIALIZE OUTPUT ARRAYS AND PARAMETERS ***
+ !
+
+ FT(:NL+1)=0.0
+ FQ(:NL+1)=0.0
+ FDOWN(:NL+1)=0.0
+ SUB(:NL+1)=0.0
+ FUP(:NL+1)=0.0
+ M(:NL+1)=0.0
+ MP(:NL+1)=0.0
+ FMASS(:NL+1,:NL+1)=0.0
+ MENT(:NL+1,:NL+1)=0.0
+ ! DO I=1,NL+1
+ ! RDCP=(RD*(1.-QCONV(I))+QCONV(I)*RV)/ &
+ ! (CPD*(1.-QCONV(I))+QCONV(I)*CPV)
+ ! TH(I)=TCONV(I)*(1000.0/PCONV_HPA(I))**RDCP
+ ! END DO
+ ! LB 04.05.2021, below is not mentioned anywhere, so I commented it
+ ! TH(:NL+1)=TCONV(:NL+1)*(1000.0/PCONV_HPA(:NL+1))** &
+ ! (RD*(1.-QCONV(:NL+1))+QCONV(:NL+1)*RV)/ (CPD*(1.-QCONV(:NL+1))+QCONV(:NL+1)*CPV)
+ PRECIP=0.0
+ WD=0.0
+ TPRIME=0.0
+ QPRIME=0.0
+ IFLAG=0
+ !
+ ! IF(IPBL.NE.0)THEN
+ !
+ !*** PERFORM DRY ADIABATIC ADJUSTMENT ***
+ !
+ ! JC=0
+ ! DO 30 I=NL-1,1,-1
+ ! JN=0
+ ! SUM=TH(I)*(1.+QCONV(I)*EPSI-QCONV(I))
+ ! DO 10 J=I+1,NL
+ ! SUM=SUM+TH(J)*(1.+QCONV(J)*EPSI-QCONV(J))
+ ! THBAR=SUM/REAL(J+1-I)
+ ! IF((TH(J)*(1.+QCONV(J)*EPSI-QCONV(J))).LT.THBAR)JN=J
+ ! 10 CONTINUE
+ ! IF(I.EQ.1)JN=MAX(JN,2)
+ ! IF(JN.EQ.0)GOTO 30
+ ! 12 CONTINUE
+ ! AHM=0.0
+ ! RM=0.0
+ ! DO 15 J=I,JN
+ ! AHM=AHM+(CPD*(1.-QCONV(J))+QCONV(J)*CPV)*TCONV(J)*
+ ! + (PHCONV_HPA(J)-PHCONV_HPA(J+1))
+ ! RM=RM+QCONV(J)*(PHCONV_HPA(J)-PHCONV_HPA(J+1))
+ ! 15 CONTINUE
+ ! DPHINV=1./(PHCONV_HPA(I)-PHCONV_HPA(JN+1))
+ ! RM=RM*DPHINV
+ ! A2=0.0
+ ! DO 20 J=I,JN
+ ! QCONV(J)=RM
+ ! RDCP=(RD*(1.-QCONV(J))+QCONV(J)*RV)/
+ ! 1 (CPD*(1.-QCONV(J))+QCONV(J)*CPV)
+ ! X=(0.001*PCONV_HPA(J))**RDCP
+ ! TOLD(J)=TCONV(J)
+ ! TCONV(J)=X
+ ! A2=A2+(CPD*(1.-QCONV(J))+QCONV(J)*CPV)*X*
+ ! 1 (PHCONV_HPA(J)-PHCONV_HPA(J+1))
+ ! 20 CONTINUE
+ ! DO 25 J=I,JN
+ ! TH(J)=AHM/A2
+ ! TCONV(J)=TCONV(J)*TH(J)
+ ! TC=TOLD(J)-273.15
+ ! ALV=LV0-CPVMCL*TC
+ ! QSCONV(J)=QSCONV(J)+QSCONV(J)*(1.+QSCONV(J)*(EPSI-1.))*ALV*
+ ! 1 (TCONV(J)- TOLD(J))/(RV*TOLD(J)*TOLD(J))
+ ! if (qslev(j) .lt. 0.) then
+ ! write(*,*) 'qslev.lt.0 ',j,qslev
+ ! endif
+ ! 25 CONTINUE
+ ! IF((TH(JN+1)*(1.+QCONV(JN+1)*EPSI-QCONV(JN+1))).LT.
+ ! 1 (TH(JN)*(1.+QCONV(JN)*EPSI-QCONV(JN))))THEN
+ ! JN=JN+1
+ ! GOTO 12
+ ! END IF
+ ! IF(I.EQ.1)JC=JN
+ ! 30 CONTINUE
+ !
+ ! *** Remove any supersaturation that results from adjustment ***
+ !
+ !IF(JC.GT.1)THEN
+ ! DO 38 J=1,JC
+ ! IF(QSCONV(J).LT.QCONV(J))THEN
+ ! ALV=LV0-CPVMCL*(TCONV(J)-273.15)
+ ! TNEW=TCONV(J)+ALV*(QCONV(J)-QSCONV(J))/(CPD*(1.-QCONV(J))+
+ ! 1 CL*QCONV(J)+QSCONV(J)*(CPV-CL+ALV*ALV/(RV*TCONV(J)*TCONV(J))))
+ ! ALVNEW=LV0-CPVMCL*(TNEW-273.15)
+ ! QNEW=(ALV*QCONV(J)-(TNEW-TCONV(J))*(CPD*(1.-QCONV(J))
+ ! 1 +CL*QCONV(J)))/ALVNEW
+ ! PRECIP=PRECIP+24.*3600.*1.0E5*(PHCONV_HPA(J)-PHCONV_HPA(J+1))*
+ ! 1 (QCONV(J)-QNEW)/(G*DELT*ROWL)
+ ! TCONV(J)=TNEW
+ ! QCONV(J)=QNEW
+ ! QSCONV(J)=QNEW
+ ! END IF
+ ! 38 CONTINUE
+ !END IF
+ !
+ !END IF
+ !
+ ! *** CALCULATE ARRAYS OF GEOPOTENTIAL, HEAT CAPACITY AND STATIC ENERGY
+ !
+ GZ(1)=0.0
+ CPN(1)=CPD*(1.-QCONV(1))+QCONV(1)*CPV
+ H(1)=TCONV(1)*CPN(1)
+ LV(1)=LV0-CPVMCL*(TCONV(1)-273.15)
+ HM(1)=LV(1)*QCONV(1)
+ TV(1)=TCONV(1)*(1.+QCONV(1)*EPSI-QCONV(1))
+ AHMIN=1.0E12
+ IHMIN=NL
+
+ DO I=2,NL+1
+ TVX=TCONV(I)*(1.+QCONV(I)*EPSI-QCONV(I))
+ TVY=TCONV(I-1)*(1.+QCONV(I-1)*EPSI-QCONV(I-1))
+ GZ(I)=GZ(I-1)+0.5*RD*(TVX+TVY)*(PCONV_HPA(I-1)-PCONV_HPA(I))/ &
+ PHCONV_HPA(I)
+ CPN(I)=CPD*(1.-QCONV(I))+CPV*QCONV(I)
+ H(I)=TCONV(I)*CPN(I)+GZ(I)
+ LV(I)=LV0-CPVMCL*(TCONV(I)-273.15)
+ HM(I)=(CPD*(1.-QCONV(I))+CL*QCONV(I))*(TCONV(I)-TCONV(1))+ &
+ LV(I)*QCONV(I)+GZ(I)
+ TV(I)=TCONV(I)*(1.+QCONV(I)*EPSI-QCONV(I))
+!
+! *** Find level of minimum moist static energy ***
+!
+ IF(I.GE.MINORIG.AND.HM(I).LT.AHMIN.AND.HM(I).LT.HM(I-1))THEN
+ AHMIN=HM(I)
+ IHMIN=I
+ END IF
+ END DO
+ IHMIN=MIN(IHMIN, NL-1)
+ !
+ ! *** Find that model level below the level of minimum moist ***
+ ! *** static energy that has the maximum value of moist static energy ***
+ !
+ AHMAX=0.0
+ ! *** bug fixed: need to assign an initial value to NK
+ ! HSO, 05.08.2009
+ NK=MINORIG
+ DO I=MINORIG,IHMIN
+ IF(HM(I).GT.AHMAX)THEN
+ NK=I
+ AHMAX=HM(I)
+ END IF
+ END DO
+ ! LB 04.05.2021, replace above with array operations (maxloc not working)
+ ! NK=MINORIG+maxloc(HM(MINORIG:IHMIN))-1
+
+ !
+ ! *** CHECK WHETHER PARCEL LEVEL TEMPERATURE AND SPECIFIC HUMIDITY ***
+ ! *** ARE REASONABLE ***
+ ! *** Skip convection if HM increases monotonically upward ***
+ !
+ IF(TCONV(NK).LT.250.0.OR.QCONV(NK).LE.0.0.OR.IHMIN.EQ.(NL-1)) THEN
+ IFLAG=0
+ CBMF=0.0
+ RETURN
+ END IF
+ !
+ ! *** CALCULATE LIFTED CONDENSATION LEVEL OF AIR AT PARCEL ORIGIN LEVEL ***
+ ! *** (WITHIN 0.2% OF FORMULA OF BOLTON, MON. WEA. REV.,1980) ***
+ !
+ RH=QCONV(NK)/QSCONV(NK)
+ CHI=TCONV(NK)/(1669.0-122.0*RH-TCONV(NK))
+ PLCL=PCONV_HPA(NK)*(RH**CHI)
+ IF(PLCL.LT.200.0.OR.PLCL.GE.2000.0)THEN
+ IFLAG=2
+ CBMF=0.0
+ RETURN
+ END IF
+ !
+ ! *** CALCULATE FIRST LEVEL ABOVE LCL (=ICB) ***
+ !
+ ICB=NL-1
+ DO I=NK+1,NL
+ IF(PCONV_HPA(I).LT.PLCL)THEN
+ ICB=MIN(ICB,I)
+ END IF
+ END DO
+ IF(ICB.GE.(NL-1))THEN
+ IFLAG=3
+ CBMF=0.0
+ RETURN
+ END IF
+ !
+ ! *** FIND TEMPERATURE UP THROUGH ICB AND TEST FOR INSTABILITY ***
+ !
+ ! *** SUBROUTINE TLIFT CALCULATES PART OF THE LIFTED PARCEL VIRTUAL ***
+ ! *** TEMPERATURE, THE ACTUAL TEMPERATURE AND THE ADIABATIC ***
+ ! *** LIQUID WATER CONTENT ***
+ !
+ CALL TLIFT(GZ,ICB,NK,TVP,TP,CLW,ND,NL,1)
+ TVP(NK:ICB)=TVP(NK:ICB)-TP(NK:ICB)*QCONV(NK)
+ !
+ ! *** If there was no convection at last time step and parcel ***
+ ! *** is stable at ICB then skip rest of calculation ***
+ !
+ IF(CBMF.EQ.0.0.AND.TVP(ICB).LE.(TV(ICB)-DTMAX))THEN
+ IFLAG=0
+ RETURN
+ END IF
+ !
+ ! *** IF THIS POINT IS REACHED, MOIST CONVECTIVE ADJUSTMENT IS NECESSARY ***
+ !
+ IF(IFLAG.NE.4)IFLAG=1
+ !
+ ! *** FIND THE REST OF THE LIFTED PARCEL TEMPERATURES ***
+ !
+ CALL TLIFT(GZ,ICB,NK,TVP,TP,CLW,ND,NL,2)
+ !
+ ! *** SET THE PRECIPITATION EFFICIENCIES AND THE FRACTION OF ***
+ ! *** PRECIPITATION FALLING OUTSIDE OF CLOUD ***
+ ! *** THESE MAY BE FUNCTIONS OF TP(I), PCONV_HPA(I) AND CLW(I) ***
+ !
+ EP(1:NK)=0.0
+ SIGP(1:NL)=SIGS
+
+ DO I=NK+1,NL
+ TCA=TP(I)-273.15
+ IF(TCA.GE.0.0)THEN
+ ELACRIT=ELCRIT
+ ELSE
+ ELACRIT=ELCRIT*(1.0-TCA/TLCRIT)
+ END IF
+ ELACRIT=MAX(ELACRIT,0.0)
+ EPMAX=0.999
+ EP(I)=EPMAX*(1.0-ELACRIT/MAX(CLW(I),1.0E-8))
+ EP(I)=MAX(EP(I),0.0)
+ EP(I)=MIN(EP(I),EPMAX)
+ SIGP(I)=SIGS
+ END DO
+ ! LB 04.05.2021, replace above with array operations
+ ! (this makes it less readable, and not any faster)
+ ! PROBLEM 1 is within the statement below
+ ! EPMAX=0.999
+ ! where ((TP(NK+1:NL)-273.15).ge.0.0)
+ ! EP(NK+1:NL)=EPMAX*(1.0-max(ELCRIT, 0.0)/MAX(CLW(NK+1:NL),1.0E-8))
+ ! elsewhere
+ ! EP(NK+1:NL)=EPMAX*(1.0-max(ELCRIT*(1.0-TCA/TLCRIT), 0.0)/MAX(CLW(NK+1:NL),1.0E-8))
+ ! end where
+ ! where (EP(NK+1:NL).lt.0.0)
+ ! EP(NK+1:NL)=0.0
+ ! elsewhere (EP(NK+1:NL).gt.EPMAX)
+ ! EP(NK+1:NL)=EPMAX
+ ! end where
+
+ !
+ ! *** CALCULATE VIRTUAL TEMPERATURE AND LIFTED PARCEL ***
+ ! *** VIRTUAL TEMPERATURE ***
+ ! !
+ TVP(ICB+1:NL)=TVP(ICB+1:NL)-TP(ICB+1:NL)*QCONV(NK)
+ TVP(NL+1)=TVP(NL)-(GZ(NL+1)-GZ(NL))/CPD
+ !
+ ! *** NOW INITIALIZE VARIOUS ARRAYS USED IN THE COMPUTATIONS ***
+
+ HP(:NL+1)=H(:NL+1)
+ NENT(:NL+1)=0
+ WATER(:NL+1)=0.0
+ EVAP(:NL+1)=0.0
+ WT(:NL+1)=OMTSNOW
+ LVCP(:NL+1)=LV(:NL+1)/CPN(:NL+1)
+ ELIJ(:NL+1,:NL+1)=0.0
+ SIJ(:NL+1,:NL+1)=0.0
+ DO I=1,NL+1
+ QENT(I,:NL+1)=QCONV(:NL+1)
+ END DO
+ QP(1)=QCONV(1)
+ QP(2:NL+1)=QCONV(:NL)
+
+ !
+ ! *** FIND THE FIRST MODEL LEVEL (INB1) ABOVE THE PARCEL'S ***
+ ! *** HIGHEST LEVEL OF NEUTRAL BUOYANCY ***
+ ! *** AND THE HIGHEST LEVEL OF POSITIVE CAPE (INB) ***
+ !
+ CAPE=0.0
+ CAPEM=0.0
+ INB=ICB+1
+ INB1=INB
+ BYP=0.0
+ DO I=ICB+1,NL-1
+ BY=(TVP(I)-TV(I))*(PHCONV_HPA(I)-PHCONV_HPA(I+1))/PCONV_HPA(I)
+ CAPE=CAPE+BY
+ IF(BY.GE.0.0)INB1=I+1
+ IF(CAPE.GT.0.0)THEN
+ INB=I+1
+ BYP=(TVP(I+1)-TV(I+1))*(PHCONV_HPA(I+1)-PHCONV_HPA(I+2))/ &
+ PCONV_HPA(I+1)
+ CAPEM=CAPE
+ END IF
+ END DO
+ INB=MAX(INB,INB1)
+ CAPE=CAPEM+BYP
+ DEFRAC=CAPEM-CAPE
+ DEFRAC=MAX(DEFRAC,0.001)
+ FRAC=-CAPE/DEFRAC
+ FRAC=MIN(FRAC,1.0)
+ FRAC=MAX(FRAC,0.0)
+ !
+ ! *** CALCULATE LIQUID WATER STATIC ENERGY OF LIFTED PARCEL ***
+ !
+ HP(ICB:INB)=H(NK)+(LV(ICB:INB)+(CPD-CPV)*TCONV(ICB:INB))*EP(ICB:INB)*CLW(ICB:INB)
+ !
+ ! *** CALCULATE CLOUD BASE MASS FLUX AND RATES OF MIXING, M(I), ***
+ ! *** AT EACH MODEL LEVEL ***
+ !
+
+ !
+ ! *** INTERPOLATE DIFFERENCE BETWEEN LIFTED PARCEL AND ***
+ ! *** ENVIRONMENTAL TEMPERATURES TO LIFTED CONDENSATION LEVEL ***
+ !
+ TVPPLCL=TVP(ICB-1)-RD*TVP(ICB-1)*(PCONV_HPA(ICB-1)-PLCL)/ &
+ (CPN(ICB-1)*PCONV_HPA(ICB-1))
+ TVAPLCL=TV(ICB)+(TVP(ICB)-TVP(ICB+1))*(PLCL-PCONV_HPA(ICB))/ &
+ (PCONV_HPA(ICB)-PCONV_HPA(ICB+1))
+ DTPBL=0.0
+
+ DTPBL=sum((TVP(NK:ICB-1)-TV(NK:ICB-1))*(PHCONV_HPA(NK:ICB-1)-PHCONV_HPA(NK+1:ICB)))/ &
+ (PHCONV_HPA(NK)-PHCONV_HPA(ICB))
+ DTMIN=TVPPLCL-TVAPLCL+DTMAX+DTPBL
+ DTMA=DTMIN
+ !
+ ! *** ADJUST CLOUD BASE MASS FLUX ***
+ !
+ CBMFOLD=CBMF
+ ! *** C. Forster: adjustment of CBMF is not allowed to depend on FLEXPART timestep
+ DELT0=DELT/3.
+ DAMPS=DAMP*DELT/DELT0
+ CBMF=(1.-DAMPS)*CBMF+0.1*ALPHA*DTMA
+ CBMF=MAX(CBMF,0.0)
+ !
+ ! *** If cloud base mass flux is zero, skip rest of calculation ***
+ !
+ IF(CBMF.EQ.0.0.AND.CBMFOLD.EQ.0.0)THEN
+ RETURN
+ END IF
+
+ !
+ ! *** CALCULATE RATES OF MIXING, M(I) ***
+ M(ICB)=0.0
+ M(ICB+1:INB1)=ABS(TV(ICB+1:INB1)-TVP(ICB+1:INB1))+ &
+ ENTP*0.02*(PHCONV_HPA(ICB+1:INB1)-PHCONV_HPA(ICB+2:INB1+1))
+ M(INB1:INB)=ABS(TV(INB1)-TVP(INB1))+ &
+ ENTP*0.02*(PHCONV_HPA(INB1)-PHCONV_HPA(INB1+1))
+ M(ICB+1:INB)=CBMF*M(ICB+1:INB)/sum(M(ICB+1:INB))
+
+ !
+ ! *** CALCULATE ENTRAINED AIR MASS FLUX (MENT), TOTAL WATER MIXING ***
+ ! *** RATIO (QENT), TOTAL CONDENSED WATER (ELIJ), AND MIXING ***
+ ! *** FRACTION (SIJ) ***
+ !
+ DO I=ICB+1,INB
+ QTI=QCONV(NK)-EP(I)*CLW(I)
+ DO J=ICB,INB
+ BF2=1.+LV(J)*LV(J)*QSCONV(J)/(RV*TCONV(J)*TCONV(J)*CPD)
+ ANUM=H(J)-HP(I)+(CPV-CPD)*TCONV(J)*(QTI-QCONV(J))
+ DENOM=H(I)-HP(I)+(CPD-CPV)*(QCONV(I)-QTI)*TCONV(J)
+ DEI=DENOM
+ IF(ABS(DEI).LT.0.01)DEI=0.01
+ SIJ(I,J)=ANUM/DEI
+ SIJ(I,I)=1.0
+ ALTEM=SIJ(I,J)*QCONV(I)+(1.-SIJ(I,J))*QTI-QSCONV(J)
+ ALTEM=ALTEM/BF2
+ CWAT=CLW(J)*(1.-EP(J))
+ STEMP=SIJ(I,J)
+ IF((STEMP.LT.0.0.OR.STEMP.GT.1.0.OR. &
+ ALTEM.GT.CWAT).AND.J.GT.I)THEN
+ ANUM=ANUM-LV(J)*(QTI-QSCONV(J)-CWAT*BF2)
+ DENOM=DENOM+LV(J)*(QCONV(I)-QTI)
+ IF(ABS(DENOM).LT.0.01)DENOM=0.01
+ SIJ(I,J)=ANUM/DENOM
+ ALTEM=SIJ(I,J)*QCONV(I)+(1.-SIJ(I,J))*QTI-QSCONV(J)
+ ALTEM=ALTEM-(BF2-1.)*CWAT
+ END IF
+ IF(SIJ(I,J).GT.0.0.AND.SIJ(I,J).LT.0.9)THEN
+ QENT(I,J)=SIJ(I,J)*QCONV(I)+(1.-SIJ(I,J))*QTI
+ ELIJ(I,J)=ALTEM
+ ELIJ(I,J)=MAX(0.0,ELIJ(I,J))
+ MENT(I,J)=M(I)/(1.-SIJ(I,J))
+ NENT(I)=NENT(I)+1
+ END IF
+ SIJ(I,J)=MAX(0.0,SIJ(I,J))
+ SIJ(I,J)=MIN(1.0,SIJ(I,J))
+ END DO
+ !
+ ! *** IF NO AIR CAN ENTRAIN AT LEVEL I ASSUME THAT UPDRAFT DETRAINS ***
+ ! *** AT THAT LEVEL AND CALCULATE DETRAINED AIR FLUX AND PROPERTIES ***
+ !
+ IF(NENT(I).EQ.0)THEN
+ MENT(I,I)=M(I)
+ QENT(I,I)=QCONV(NK)-EP(I)*CLW(I)
+ ELIJ(I,I)=CLW(I)
+ SIJ(I,I)=1.0
+ END IF
+ END DO
+ SIJ(INB,INB)=1.0
+ ! LB 04.05.2021, Attempt to array the loop above: PROBLEM 2 is here
+ ! DO J=ICB,INB
+ ! BF2=1.+LV(J)*LV(J)*QSCONV(J)/(RV*TCONV(J)*TCONV(J)*CPD)
+ ! CWAT=CLW(J)*(1.-EP(J))
+ ! DO I=ICB+1,INB
+ ! QTI=QCONV(NK)-EP(I)*CLW(I)
+ ! ANUM=H(J)-HP(I)+(CPV-CPD)*TCONV(J)*(QTI-QCONV(J))
+ ! DENOM=H(I)-HP(I)+(CPD-CPV)*(QCONV(I)-QTI)*TCONV(J)
+ ! DEI=DENOM
+ ! IF(I.EQ.J)THEN
+ ! SIJ(I,I)=1.0
+ ! ELSE IF(ABS(DENOM).LT.0.01)THEN
+ ! SIJ(I,J)=ANUM/0.01
+ ! ELSE
+ ! SIJ(I,J)=ANUM/DENOM
+ ! END IF
+ ! ALTEM=(SIJ(I,J)*QCONV(I)+(1.-SIJ(I,J))*QTI-QSCONV(J))/BF2
+ ! IF((SIJ(I,J).LT.0.0.OR.SIJ(I,J).GT.1.0.OR. &
+ ! ALTEM.GT.CWAT).AND.J.GT.I)THEN
+ ! ANUM=ANUM-LV(J)*(QTI-QSCONV(J)-CWAT*BF2)
+ ! DENOM=DENOM+LV(J)*(QCONV(I)-QTI)
+ ! IF(ABS(DENOM).LT.0.01)DENOM=0.01
+ ! SIJ(I,J)=ANUM/DENOM
+ ! ALTEM=SIJ(I,J)*QCONV(I)+(1.-SIJ(I,J))*QTI-QSCONV(J)
+ ! ALTEM=ALTEM-(BF2-1.)*CWAT
+ ! END IF
+ ! IF(SIJ(I,J).GT.0.0.AND.SIJ(I,J).LT.0.9)THEN
+ ! QENT(I,J)=SIJ(I,J)*QCONV(I)+(1.-SIJ(I,J))*QTI
+ ! ELIJ(I,J)=ALTEM
+ ! ELIJ(I,J)=MAX(0.0,ELIJ(I,J))
+ ! MENT(I,J)=M(I)/(1.-SIJ(I,J))
+ ! NENT(I)=NENT(I)+1
+ ! END IF
+ ! SIJ(I,J)=MAX(0.0,SIJ(I,J))
+ ! SIJ(I,J)=MIN(1.0,SIJ(I,J))
+ ! END DO
+ ! END DO
+ ! !
+ ! ! *** IF NO AIR CAN ENTRAIN AT LEVEL I ASSUME THAT UPDRAFT DETRAINS ***
+ ! ! *** AT THAT LEVEL AND CALCULATE DETRAINED AIR FLUX AND PROPERTIES ***
+ ! !
+ ! do I=ICB+1,INB
+ ! IF(NENT(I).EQ.0)THEN
+ ! MENT(I,I)=M(I)
+ ! QENT(I,I)=QCONV(NK)-EP(I)*CLW(I)
+ ! ELIJ(I,I)=CLW(I)
+ ! SIJ(I,I)=1.0
+ ! END IF
+ ! END DO
+ ! SIJ(INB,INB)=1.0
+
+
+ !
+ ! *** NORMALIZE ENTRAINED AIR MASS FLUXES TO REPRESENT EQUAL ***
+ ! *** PROBABILITIES OF MIXING ***
+ !
+ ! LB 04.05.2021, depending on how often NENT.ne.0, reversing the loop could
+ ! speed it up...
+ DO I=ICB+1,INB
+ IF(NENT(I).NE.0)THEN
+ QP1=QCONV(NK)-EP(I)*CLW(I)
+ ANUM=H(I)-HP(I)-LV(I)*(QP1-QSCONV(I))
+ DENOM=H(I)-HP(I)+LV(I)*(QCONV(I)-QP1)
+ IF(ABS(DENOM).LT.0.01)DENOM=0.01
+ SCRIT=ANUM/DENOM
+ ALT=QP1-QSCONV(I)+SCRIT*(QCONV(I)-QP1)
+ IF(ALT.LT.0.0)SCRIT=1.0
+ SCRIT=MAX(SCRIT,0.0)
+ ASIJ=0.0
+ SMIN=1.0
+ DO J=ICB,INB
+ IF(SIJ(I,J).GT.0.0.AND.SIJ(I,J).LT.0.9)THEN
+ IF(J.GT.I)THEN
+ SMID=MIN(SIJ(I,J),SCRIT)
+ SJMAX=SMID
+ SJMIN=SMID
+ IF(SMID.LT.SMIN.AND.SIJ(I,J+1).LT.SMID)THEN
+ SMIN=SMID
+ SJMAX=MIN(SIJ(I,J+1),SIJ(I,J),SCRIT)
+ SJMIN=MAX(SIJ(I,J-1),SIJ(I,J))
+ SJMIN=MIN(SJMIN,SCRIT)
+ END IF
+ ELSE
+ SJMAX=MAX(SIJ(I,J+1),SCRIT)
+ SMID=MAX(SIJ(I,J),SCRIT)
+ SJMIN=0.0
+ IF(J.GT.1)SJMIN=SIJ(I,J-1)
+ SJMIN=MAX(SJMIN,SCRIT)
+ END IF
+ DELP=ABS(SJMAX-SMID)
+ DELM=ABS(SJMIN-SMID)
+ ASIJ=ASIJ+(DELP+DELM)*(PHCONV_HPA(J)-PHCONV_HPA(J+1))
+ MENT(I,J)=MENT(I,J)*(DELP+DELM)* &
+ (PHCONV_HPA(J)-PHCONV_HPA(J+1))
+ END IF
+ END DO
+ ASIJ=MAX(1.0E-21,ASIJ)
+ ASIJ=1.0/ASIJ
+ DO J=ICB,INB
+ MENT(I,J)=MENT(I,J)*ASIJ
+ END DO
+ BSUM=0.0
+ DO J=ICB,INB
+ BSUM=BSUM+MENT(I,J)
+ END DO
+ IF(BSUM.LT.1.0E-18)THEN
+ NENT(I)=0
+ MENT(I,I)=M(I)
+ QENT(I,I)=QCONV(NK)-EP(I)*CLW(I)
+ ELIJ(I,I)=CLW(I)
+ SIJ(I,I)=1.0
+ END IF
+ END IF
+ END DO
+
+ !
+ ! *** CHECK WHETHER EP(INB)=0, IF SO, SKIP PRECIPITATING ***
+ ! *** DOWNDRAFT CALCULATION ***
+ !
+ if (EP(INB).ge.0.0001) then
+ !
+ ! *** INTEGRATE LIQUID WATER EQUATION TO FIND CONDENSED WATER ***
+ ! *** AND CONDENSED WATER FLUX ***
+ !
+ JTT=2
+ !
+ ! *** BEGIN DOWNDRAFT LOOP ***
+ !
+ DO I=INB,1,-1
+ !
+ ! *** CALCULATE DETRAINED PRECIPITATION ***
+ !
+ WDTRAIN=G*EP(I)*M(I)*CLW(I)
+ IF(I.GT.1)THEN
+ DO J=1,I-1
+ AWAT=ELIJ(J,I)-(1.-EP(I))*CLW(I)
+ AWAT=MAX(0.0,AWAT)
+ WDTRAIN=WDTRAIN+G*AWAT*MENT(J,I)
+ END DO
+ END IF
+ !
+ ! *** FIND RAIN WATER AND EVAPORATION USING PROVISIONAL ***
+ ! *** ESTIMATES OF QP(I)AND QP(I-1) ***
+ !
+ !
+ ! *** Value of terminal velocity and coefficient of evaporation for snow ***
+ !
+ COEFF=COEFFS
+ WT(I)=OMTSNOW
+ !
+ ! *** Value of terminal velocity and coefficient of evaporation for rain ***
+ !
+ IF(TCONV(I).GT.273.0)THEN
+ COEFF=COEFFR
+ WT(I)=OMTRAIN
+ END IF
+ QSM=0.5*(QCONV(I)+QP(I+1))
+ AFAC=COEFF*PHCONV_HPA(I)*(QSCONV(I)-QSM)/ &
+ (1.0E4+2.0E3*PHCONV_HPA(I)*QSCONV(I))
+ AFAC=MAX(AFAC,0.0)
+ SIGT=SIGP(I)
+ SIGT=MAX(0.0,SIGT)
+ SIGT=MIN(1.0,SIGT)
+ B6=100.*(PHCONV_HPA(I)-PHCONV_HPA(I+1))*SIGT*AFAC/WT(I)
+ C6=(WATER(I+1)*WT(I+1)+WDTRAIN/SIGD)/WT(I)
+ REVAP=0.5*(-B6+SQRT(B6*B6+4.*C6))
+ EVAP(I)=SIGT*AFAC*REVAP
+ WATER(I)=REVAP*REVAP
+ !
+ ! *** CALCULATE PRECIPITATING DOWNDRAFT MASS FLUX UNDER ***
+ ! *** HYDROSTATIC APPROXIMATION ***
+ !
+ if (.not. I.eq.1) then
+ DHDP=(H(I)-H(I-1))/(PCONV_HPA(I-1)-PCONV_HPA(I))
+ DHDP=MAX(DHDP,10.0)
+ MP(I)=100.*GINV*LV(I)*SIGD*EVAP(I)/DHDP
+ MP(I)=MAX(MP(I),0.0)
+ !
+ ! *** ADD SMALL AMOUNT OF INERTIA TO DOWNDRAFT ***
+ !
+ FAC=20.0/(PHCONV_HPA(I-1)-PHCONV_HPA(I))
+ MP(I)=(FAC*MP(I+1)+MP(I))/(1.+FAC)
+ !
+ ! *** FORCE MP TO DECREASE LINEARLY TO ZERO ***
+ ! *** BETWEEN ABOUT 950 MB AND THE SURFACE ***
+ !
+ IF(PCONV_HPA(I).GT.(0.949*PCONV_HPA(1)))THEN
+ JTT=MAX(JTT,I)
+ MP(I)=MP(JTT)*(PCONV_HPA(1)-PCONV_HPA(I))/(PCONV_HPA(1)- &
+ PCONV_HPA(JTT))
+ END IF
+ endif
+ !
+ ! *** FIND MIXING RATIO OF PRECIPITATING DOWNDRAFT ***
+ !
+ if (.not. I.eq.INB) then
+ IF(I.EQ.1)THEN
+ QSTM=QSCONV(1)
+ ELSE
+ QSTM=QSCONV(I-1)
+ END IF
+ IF(MP(I).GT.MP(I+1))THEN
+ RAT=MP(I+1)/MP(I)
+ QP(I)=QP(I+1)*RAT+QCONV(I)*(1.0-RAT)+100.*GINV* &
+ SIGD*(PHCONV_HPA(I)-PHCONV_HPA(I+1))*(EVAP(I)/MP(I))
+ ELSE
+ IF(MP(I+1).GT.0.0)THEN
+ QP(I)=(GZ(I+1)-GZ(I)+QP(I+1)*(LV(I+1)+TCONV(I+1)*(CL-CPD))+ &
+ CPD*(TCONV(I+1)-TCONV(I)))/(LV(I)+TCONV(I)*(CL-CPD))
+ END IF
+ END IF
+ QP(I)=MIN(QP(I),QSTM)
+ QP(I)=MAX(QP(I),0.0)
+ endif
+ END DO
+ !
+ ! *** CALCULATE SURFACE PRECIPITATION IN MM/DAY ***
+ !
+ PRECIP=PRECIP+WT(1)*SIGD*WATER(1)*3600.*24000./(ROWL*G)
+ !
+ endif ! Downdraft calculation
+ !
+ ! *** CALCULATE DOWNDRAFT VELOCITY SCALE AND SURFACE TEMPERATURE AND ***
+ ! *** WATER VAPOR FLUCTUATIONS ***
+ !
+ WD=BETA*ABS(MP(ICB))*0.01*RD*TCONV(ICB)/(SIGD*PCONV_HPA(ICB))
+ QPRIME=0.5*(QP(1)-QCONV(1))
+ TPRIME=LV0*QPRIME/CPD
+ !
+ ! *** CALCULATE TENDENCIES OF LOWEST LEVEL POTENTIAL TEMPERATURE ***
+ ! *** AND MIXING RATIO ***
+ !
+
+ DPINV=0.01/(PHCONV_HPA(1)-PHCONV_HPA(2))
+ AM=0.0
+ IF(NK.EQ.1)THEN
+ AM = sum(M(2:INB))
+ END IF
+ ! save saturated upward mass flux for first level
+ FUP(1)=AM
+ IF((2.*G*DPINV*AM).GE.DELTI)IFLAG=4
+ FT(1)=FT(1)+G*DPINV*AM*(TCONV(2)-TCONV(1)+(GZ(2)-GZ(1))/CPN(1))
+ FT(1)=FT(1)-LVCP(1)*SIGD*EVAP(1)
+ FT(1)=FT(1)+SIGD*WT(2)*(CL-CPD)*WATER(2)*(TCONV(2)- &
+ TCONV(1))*DPINV/CPN(1)
+ FQ(1)=FQ(1)+G*MP(2)*(QP(2)-QCONV(1))* &
+ DPINV+SIGD*EVAP(1)
+ FQ(1)=FQ(1)+G*AM*(QCONV(2)-QCONV(1))*DPINV
+
+ FQ(1)=FQ(1)+G*DPINV*sum(MENT(2:INB,1)*(QENT(2:INB,1)-QCONV(1)))
+ !
+ ! *** CALCULATE TENDENCIES OF POTENTIAL TEMPERATURE AND MIXING RATIO ***
+ ! *** AT LEVELS ABOVE THE LOWEST LEVEL ***
+ !
+ ! *** FIRST FIND THE NET SATURATED UPDRAFT AND DOWNDRAFT MASS FLUXES ***
+ ! *** THROUGH EACH LEVEL ***
+ !
+ DO I=2,INB
+ DPINV=0.01/(PHCONV_HPA(I)-PHCONV_HPA(I+1))
+ CPINV=1.0/CPN(I)
+ AMP1=0.0
+ AD=0.0
+ IF(I.GE.NK)THEN
+ AMP1 = sum(M(I+1:INB+1))
+ END IF
+ AMP1 = AMP1 + sum(MENT(1:I,I+1:INB+1))
+ ! save saturated upward mass flux
+ FUP(I)=AMP1
+ IF((2.*G*DPINV*AMP1).GE.DELTI)IFLAG=4
+
+ AD = sum(MENT(I:INB,1:I-1))
+ ! save saturated downward mass flux
+ FDOWN(I)=AD
+ FT(I)=FT(I)+G*DPINV*(AMP1*(TCONV(I+1)-TCONV(I)+(GZ(I+1)-GZ(I))* &
+ CPINV)-AD*(TCONV(I)-TCONV(I-1)+(GZ(I)-GZ(I-1))*CPINV)) &
+ -SIGD*LVCP(I)*EVAP(I)
+ FT(I)=FT(I)+G*DPINV*MENT(I,I)*(HP(I)-H(I)+ &
+ TCONV(I)*(CPV-CPD)*(QCONV(I)-QENT(I,I)))*CPINV
+ FT(I)=FT(I)+SIGD*WT(I+1)*(CL-CPD)*WATER(I+1)* &
+ (TCONV(I+1)-TCONV(I))*DPINV*CPINV
+ FQ(I)=FQ(I)+G*DPINV*(AMP1*(QCONV(I+1)-QCONV(I))- &
+ AD*(QCONV(I)-QCONV(I-1)))
+ DO K=1,I-1
+ AWAT=ELIJ(K,I)-(1.-EP(I))*CLW(I)
+ AWAT=MAX(AWAT,0.0)
+ FQ(I)=FQ(I)+G*DPINV*MENT(K,I)*(QENT(K,I)-AWAT-QCONV(I))
+ END DO
+
+ FQ(I)=FQ(I)+G*DPINV*sum(MENT(I:INB,I)*(QENT(I:INB,I)-QCONV(I)))
+ FQ(I)=FQ(I)+SIGD*EVAP(I)+G*(MP(I+1)* &
+ (QP(I+1)-QCONV(I))-MP(I)*(QP(I)-QCONV(I-1)))*DPINV
+ END DO
+ !
+ ! *** Adjust tendencies at top of convection layer to reflect ***
+ ! *** actual position of the level zero CAPE ***
+ !
+ FQOLD=FQ(INB)
+ FQ(INB)=FQ(INB)*(1.-FRAC)
+ FQ(INB-1)=FQ(INB-1)+FRAC*FQOLD*((PHCONV_HPA(INB)- &
+ PHCONV_HPA(INB+1))/ &
+ (PHCONV_HPA(INB-1)-PHCONV_HPA(INB)))*LV(INB)/LV(INB-1)
+ FTOLD=FT(INB)
+ FT(INB)=FT(INB)*(1.-FRAC)
+ FT(INB-1)=FT(INB-1)+FRAC*FTOLD*((PHCONV_HPA(INB)- &
+ PHCONV_HPA(INB+1))/ &
+ (PHCONV_HPA(INB-1)-PHCONV_HPA(INB)))*CPN(INB)/CPN(INB-1)
+!
+! *** Very slightly adjust tendencies to force exact ***
+! *** enthalpy, momentum and tracer conservation ***
+!
+ ENTS=0.0
+
+ ENTS = sum((CPN(1:INB)*FT(1:INB)+LV(1:INB)*FQ(1:INB))* &
+ (PHCONV_HPA(1:INB)-PHCONV_HPA(2:INB+1)))
+
+ ENTS=ENTS/(PHCONV_HPA(1)-PHCONV_HPA(INB+1))
+
+ FT(1:INB)=FT(1:INB) - ENTS/CPN(1:INB)
+
+ ! ************************************************
+ ! **** DETERMINE MASS DISPLACEMENT MATRIX
+ ! ***** AND COMPENSATING SUBSIDENCE
+ ! ************************************************
+
+ ! mass displacement matrix due to saturated up-and downdrafts
+ ! inside the cloud and determine compensating subsidence
+ ! FUP(I) (saturated updrafts), FDOWN(I) (saturated downdrafts) are assumed to be
+ ! balanced by compensating subsidence (SUB(I))
+ ! FDOWN(I) and SUB(I) defined positive downwards
+
+ ! NCONVTOP IS THE TOP LEVEL AT WHICH CONVECTIVE MASS FLUXES ARE DIAGNOSED
+ ! EPSILON IS A SMALL NUMBER
+
+ FMASS(NK, :INB+1) = FMASS(NK,:INB+1)+M(:INB+1)
+ FMASS(:INB+1,:INB+1) = FMASS(:INB+1,:INB+1)+MENT(:INB+1,:INB+1)
+ SUB(1) = 0.
+ SUB(2:INB+1) = FUP(1:INB) - FDOWN(2:INB+1)
+ NCONVTOP=1
+ do i=1,INB+1
+ do j=1,INB+1
+ if (FMASS(j,i).gt.EPSILON) NCONVTOP=MAX(NCONVTOP,i,j)
+ end do
+ end do
+ NCONVTOP=NCONVTOP+1
+ RETURN
+ !
+END SUBROUTINE CONVECT
+!
+! ---------------------------------------------------------------------------
+!
+SUBROUTINE TLIFT(GZ,ICB,NK,TVP,TPK,CLW,ND,NL,KK)
+ !
+ !-cv
+ use par_mod
+
+ implicit none
+ !-cv
+ !====>Begin Module TLIFT File convect.f Undeclared variables
+ !
+ !Argument variables
+ !
+ integer :: icb, kk, nd, nk, nl
+ !
+ !Local variables
+ !
+ integer :: i, j, nsb, nst
+ !
+ real :: ah0, ahg, alv, cpinv, cpp, denom
+ real :: es, qg, rg, s, tc, tg
+ !
+ !====>End Module TLIFT File convect.f
+
+ REAL :: GZ(ND),TPK(ND),CLW(ND)
+ REAL :: TVP(ND)
+ !
+ ! *** ASSIGN VALUES OF THERMODYNAMIC CONSTANTS ***
+ !
+ REAL,PARAMETER :: CPD=1005.7
+ REAL,PARAMETER :: CPV=1870.0
+ REAL,PARAMETER :: CL=2500.0
+ REAL,PARAMETER :: RV=461.5
+ REAL,PARAMETER :: RD=287.04
+ REAL,PARAMETER :: LV0=2.501E6
+ !
+ REAL,PARAMETER :: CPVMCL=CL-CPV
+ REAL,PARAMETER :: EPS0=RD/RV
+ REAL,PARAMETER :: EPSI=1./EPS0
+ !
+ ! *** CALCULATE CERTAIN PARCEL QUANTITIES, INCLUDING STATIC ENERGY ***
+ !
+ AH0=(CPD*(1.-QCONV(NK))+CL*QCONV(NK))*TCONV(NK)+QCONV(NK)* &
+ (LV0-CPVMCL*( &
+ TCONV(NK)-273.15))+GZ(NK)
+ CPP=CPD*(1.-QCONV(NK))+QCONV(NK)*CPV
+ CPINV=1./CPP
+ !
+ IF(KK.EQ.1)THEN
+ !
+ ! *** CALCULATE LIFTED PARCEL QUANTITIES BELOW CLOUD BASE ***
+ !
+ CLW(1:ICB-1) = 0.0
+ TPK(NK:ICB-1)=TCONV(NK)-(GZ(NK:ICB-1)-GZ(NK))*CPINV
+ TVP(NK:ICB-1)=TPK(NK:ICB-1)*(1.+QCONV(NK)*EPSI)
+ END IF
+ !
+ ! *** FIND LIFTED PARCEL QUANTITIES ABOVE CLOUD BASE ***
+ !
+ NST=ICB
+ NSB=ICB
+ IF(KK.EQ.2)THEN
+ NST=NL
+ NSB=ICB+1
+ END IF
+ DO I=NSB,NST
+ TG=TCONV(I)
+ QG=QSCONV(I)
+ ALV=LV0-CPVMCL*(TCONV(I)-273.15)
+ DO J=1,2
+ S=CPD+ALV*ALV*QG/(RV*TCONV(I)*TCONV(I))
+ S=1./S
+ AHG=CPD*TG+(CL-CPD)*QCONV(NK)*TCONV(I)+ALV*QG+GZ(I)
+ TG=TG+S*(AH0-AHG)
+ TG=MAX(TG,35.0)
+ TC=TG-273.15
+ DENOM=243.5+TC
+ IF(TC.GE.0.0)THEN
+ ES=6.112*EXP(17.67*TC/DENOM)
+ ELSE
+ ES=EXP(23.33086-6111.72784/TG+0.15215*LOG(TG))
+ END IF
+ QG=EPS0*ES/(PCONV_HPA(I)-ES*(1.-EPS0))
+ END DO
+ ALV=LV0-CPVMCL*(TCONV(I)-273.15)
+ TPK(I)=(AH0-(CL-CPD)*QCONV(NK)*TCONV(I)-GZ(I)-ALV*QG)/CPD
+ CLW(I)=QCONV(NK)-QG
+ CLW(I)=MAX(0.0,CLW(I))
+ RG=QG/(1.-QCONV(NK))
+ TVP(I)=TPK(I)*(1.+RG*EPSI)
+ END DO
+ RETURN
+END SUBROUTINE TLIFT
+
+subroutine sort2(n,arr,brr)
+ ! From numerical recipes
+ ! Change by A. Stohl: Use of integer instead of real values
+ implicit none
+
+ integer, intent(in) :: n
+ integer, intent(inout) :: arr(n),brr(n)
+ integer,parameter :: m=7,nstack=50
+ integer :: i,ir,j,jstack,k,l,istack(nstack)
+ integer :: a,b,temp
+ jstack=0
+ l=1
+ ir=n
+ do
+ if(ir-l.lt.m)then
+ do j=l+1,ir
+ a=arr(j)
+ b=brr(j)
+ i=j-1
+ do while(i.gt.0)
+ if (arr(i).le.a) exit
+ arr(i+1)=arr(i)
+ brr(i+1)=brr(i)
+ i=i-1
+ end do
+ arr(i+1)=a
+ brr(i+1)=b
+ end do
+ if(jstack.eq.0)return
+ ir=istack(jstack)
+ l=istack(jstack-1)
+ jstack=jstack-2
+ else
+ k=(l+ir)/2
+ temp=arr(k)
+ arr(k)=arr(l+1)
+ arr(l+1)=temp
+ temp=brr(k)
+ brr(k)=brr(l+1)
+ brr(l+1)=temp
+ if(arr(l+1).gt.arr(ir))then
+ temp=arr(l+1)
+ arr(l+1)=arr(ir)
+ arr(ir)=temp
+ temp=brr(l+1)
+ brr(l+1)=brr(ir)
+ brr(ir)=temp
+ endif
+ if(arr(l).gt.arr(ir))then
+ temp=arr(l)
+ arr(l)=arr(ir)
+ arr(ir)=temp
+ temp=brr(l)
+ brr(l)=brr(ir)
+ brr(ir)=temp
+ endif
+ if(arr(l+1).gt.arr(l))then
+ temp=arr(l+1)
+ arr(l+1)=arr(l)
+ arr(l)=temp
+ temp=brr(l+1)
+ brr(l+1)=brr(l)
+ brr(l)=temp
+ endif
+ i=l+1
+ j=ir
+ a=arr(l)
+ b=brr(l)
+ do
+ do
+ i=i+1
+ if(arr(i).ge.a) exit
+ end do
+ do
+ j=j-1
+ if(arr(j).le.a) exit
+ end do
+ if(j.lt.i) exit
+ temp=arr(i)
+ arr(i)=arr(j)
+ arr(j)=temp
+ temp=brr(i)
+ brr(i)=brr(j)
+ brr(j)=temp
+ end do
+ arr(l)=arr(j)
+ arr(j)=a
+ brr(l)=brr(j)
+ brr(j)=b
+ jstack=jstack+2
+ if(jstack.gt.nstack) then
+ print*, 'nstack too small in sort2'
+ stop
+ end if
+ if(ir-i+1.ge.j-l)then
+ istack(jstack)=ir
+ istack(jstack-1)=i
+ ir=j-1
+ else
+ istack(jstack)=j-1
+ istack(jstack-1)=l
+ l=i
+ endif
+ endif
+ end do
+! (C) Copr. 1986-92 Numerical Recipes Software us.
+end subroutine sort2
end module conv_mod
diff --git a/src/coordinates_ecmwf_mod.f90 b/src/coordinates_ecmwf_mod.f90
new file mode 100644
index 00000000..bc7f0f37
--- /dev/null
+++ b/src/coordinates_ecmwf_mod.f90
@@ -0,0 +1,475 @@
+! SPDX-FileCopyrightText: FLEXPART 1998-2019, see flexpart_license.txt
+! SPDX-License-Identifier: GPL-3.0-or-later
+
+!*****************************************************************************
+! *
+! This module handles conversions between ECMWF eta coordinates and *
+! internal meter coordinates *
+! *
+! Author: L. Bakels *
+!*****************************************************************************
+
+module coordinates_ecmwf_mod
+
+ use par_mod
+ use com_mod
+ use windfields_mod
+
+contains
+
+subroutine update_zeta_to_z(itime, ipart)
+ use particle_mod
+ implicit none
+
+ integer, intent(in) :: &
+ itime, & ! time index
+ ipart ! particle index
+
+ if (.not. wind_coord_type.eq.'ETA') return
+ if (.not. part(ipart)%alive) return
+ if (part(ipart)%etaupdate) return
+
+ call zeta_to_z(itime,part(ipart)%xlon,part(ipart)%ylat, &
+ part(ipart)%zeta,part(ipart)%z)
+ part(ipart)%etaupdate = .true.
+ part(ipart)%meterupdate = .true.
+end subroutine update_zeta_to_z
+
+subroutine update_z_to_zeta(itime, ipart)
+ use particle_mod
+ implicit none
+
+ integer, intent(in) :: &
+ itime, & ! time index
+ ipart ! particle index
+
+ if (.not. wind_coord_type.eq.'ETA') return
+ if (.not. part(ipart)%alive) return
+ if (part(ipart)%meterupdate) return
+
+ call z_to_zeta(itime,part(ipart)%xlon,part(ipart)%ylat, &
+ part(ipart)%z,part(ipart)%zeta)
+ part(ipart)%etaupdate = .true.
+ part(ipart)%meterupdate = .true.
+end subroutine update_z_to_zeta
+
+subroutine z_to_zeta(itime,xt,yt,zold,zteta)
+ !*****************************************************************************
+ ! Converting z from meter coordinates to eta using logarithmic vertical *
+ ! interpolation *
+ !*****************************************************************************
+ ! *
+ ! Variables: *
+ ! itime [s] current temporal position *
+ ! xt,yt,zold,zold spatial positions of trajectory (meters) *
+ ! zteta vertical position in eta coordinates (output) *
+ ! *
+ ! etauvheight defined in windfields: half model heights for ETA coordinates *
+ ! Constants: *
+ ! *
+ !*****************************************************************************
+ use interpol_mod
+
+ implicit none
+ integer, intent(in) :: &
+ itime ! time index
+ integer :: &
+ i,m,k,n ! loop indices
+ real(kind=dp), intent(in) :: &
+ xt,yt ! particle position
+ real(kind=dp), intent(in) :: &
+ zold ! particle verticle position in eta coordinates
+ real(kind=dp), intent(inout) :: &
+ zteta ! converted output z in meters
+ real :: &
+ frac, & ! fraction between z levels
+ ztemp1,ztemp2, & ! z positions of the two encompassing levels
+ ttemp1(2), & ! storing virtual temperature
+ psint1(2),psint ! pressure of encompassing levels
+ real :: &
+ prx,pr1,pr2 ! pressure of encompassing levels
+
+ if (.not. logarithmic_interpolation) then
+ call z_to_zeta_lin(itime,xt,yt,zold,zteta)
+ return
+ endif
+
+ call find_ngrid(xt,yt)
+ call determine_grid_coordinates(real(xt),real(yt))
+ call find_grid_distances(real(xt),real(yt))
+ call find_time_variables(itime)
+
+ ! Integration method as used in the original verttransform_ecmwf.f90
+ !+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+ ! First estimate the level it is at, to reduce computation time
+ n=nz-3
+ if (ngrid.le.0) then
+ do i=2,nz-1
+ if ((etauvheight(ix,jy,i,memind(1)).gt.real(zold)) .or. &
+ (etauvheight(ixp,jy,i,memind(1)).gt.real(zold)) .or. &
+ (etauvheight(ix,jyp,i,memind(1)).gt.real(zold)) .or. &
+ (etauvheight(ixp,jyp,i,memind(1)).gt.real(zold))) then
+ n=i-2
+ exit
+ endif
+ end do
+ else
+ do i=2,nz-1
+ if ((etauvheightn(ix,jy,i,memind(1),ngrid).gt.real(zold)) .or. &
+ (etauvheightn(ixp,jy,i,memind(1),ngrid).gt.real(zold)) .or. &
+ (etauvheightn(ix,jyp,i,memind(1),ngrid).gt.real(zold)) .or. &
+ (etauvheightn(ixp,jyp,i,memind(1),ngrid).gt.real(zold))) then
+ n=i-2
+ exit
+ endif
+ end do
+ endif
+ n=max(n,2)
+
+ ztemp1 = 0.
+ do i=n,nz-1
+ k=i
+ if (ngrid.le.0) then
+ do m=1,2
+ call horizontal_interpolation(etauvheight,ttemp1(m),i,memind(m),nzmax)
+ end do
+ else
+ do m=1,2
+ call horizontal_interpolation_nests(etauvheightn,ttemp1(m),i,memind(m),nzmax)
+ end do
+ endif
+ call temporal_interpolation(ttemp1(1),ttemp1(2),ztemp2)
+
+ if (ztemp2.gt.real(zold)) then
+ !frac = (real(zold)-ztemp1)/(ztemp2-ztemp1)
+ exit
+ else if (i.eq.nz-1) then
+ frac = 1.
+ exit
+ endif
+ ztemp1=ztemp2
+ end do
+
+ if (k.lt.nz-1) then
+ if (ngrid.le.0) then
+ do m=1,2
+ call horizontal_interpolation(ps,psint1(m),1,memind(m),1)
+ end do
+ else
+ do m=1,2
+ call horizontal_interpolation_nests(psn,psint1(m),1,memind(m),1)
+ end do
+ endif
+ call temporal_interpolation(psint1(1),psint1(2),psint)
+ pr1=akz(k-1) + bkz(k-1)*psint
+ pr2=akz(k) + bkz(k)*psint
+
+ prx=pr1/exp(log(pr2/pr1)/(ztemp2-ztemp1)*ztemp1) * &
+ exp(log(pr2/pr1)/(ztemp2-ztemp1)*real(zold))
+ frac=(prx-pr1)/(pr2 - pr1)
+ endif
+
+ zteta=real(uvheight(k-1)*(1.-frac)+uvheight(k)*frac,kind=dp)
+end subroutine z_to_zeta
+
+subroutine zeta_to_z(itime,xt,yt,zteta,ztout)
+ !*****************************************************************************
+ ! Converting z from eta coordinates to meters using logarithmic *
+ ! vertical interpolation *
+ !*****************************************************************************
+ ! *
+ ! Variables: *
+ ! itime [s] current temporal position *
+ ! xt,yt,zteta spatial position of trajectory *
+ ! ztout vertical postion in meter (output) *
+ ! *
+ ! *
+ !*****************************************************************************
+ use interpol_mod
+
+ implicit none
+ integer, intent(in) :: &
+ itime ! time index
+ integer :: &
+ i,j,k,m,ii,indexh ! loop indices
+ real(kind=dp), intent(in) :: &
+ xt,yt ! particle position
+ real(kind=dp), intent(in) :: &
+ zteta ! particle verticle position in eta coordinates
+ real(kind=dp), intent(inout) :: &
+ ztout ! converted output z in meters
+ real(kind=dp) :: &
+ frac ! fraction between z levels
+ real :: &
+ ztemp1(2), & ! z positions of the two encompassing levels
+ ttemp1(2), & ! storing virtual temperature
+ psint1(2),psint,prx,pr1,pr2 ! pressure of encompassing levels
+
+ if (.not. logarithmic_interpolation) then
+ call zeta_to_z_lin(itime,xt,yt,zteta,ztout)
+ return
+ endif
+
+ ! Convert eta z coordinate to meters
+ !***********************************
+ call find_ngrid(xt,yt)
+ call determine_grid_coordinates(real(xt),real(yt))
+ call find_grid_distances(real(xt),real(yt))
+ call find_time_variables(itime)
+
+ k=nz-1
+ frac=1.
+ do i=2,nz-1
+ k=i
+ if (zteta.ge.real(uvheight(k),kind=dp)) then
+ frac=(zteta-real(uvheight(k-1),kind=dp))/(real(uvheight(k)-uvheight(k-1),kind=dp))
+ exit
+ endif
+ end do
+
+ if (ngrid.le.0) then
+ do m=1,2
+ call horizontal_interpolation(ps,psint1(m),1,memind(m),1)
+ end do
+ else
+ do m=1,2
+ call horizontal_interpolation_nests(psn,psint1(m),1,memind(m),1)
+ end do
+ endif
+
+ call temporal_interpolation(psint1(1),psint1(2),psint)
+ pr1=akz(k-1) + bkz(k-1)*psint
+ pr2=akz(k) + bkz(k)*psint
+ prx=pr1*(1.-frac) + pr2*frac
+
+ if (ngrid.le.0) then
+ do ii=1,2
+ do m=1,2
+ call horizontal_interpolation(etauvheight,ttemp1(m),k+ii-2,memind(m),nzmax)
+ end do
+ call temporal_interpolation(ttemp1(1),ttemp1(2),ztemp1(ii))
+ end do
+ else
+ do ii=1,2
+ do m=1,2
+ call horizontal_interpolation_nests(etauvheightn, &
+ ttemp1(m),k+ii-2,memind(m),nzmax)
+ end do
+ call temporal_interpolation(ttemp1(1),ttemp1(2),ztemp1(ii))
+ end do
+ endif
+
+ if ((pr2.eq.0).or.(pr1.eq.0)) then
+ ztout = real(ztemp1(1),kind=dp)*(1.-frac)+real(ztemp1(2),kind=dp)*frac
+ return
+ endif
+
+ ztout = ztemp1(1) + (ztemp1(2)-ztemp1(1))/log(pr2/pr1)*log(prx/pr1)
+end subroutine zeta_to_z
+
+subroutine w_to_weta(itime,dt,xt,yt,z_old,zeta_old,w_in,weta_out)
+ !*****************************************************************************
+ ! Converting z from meter coordinates to eta using logarithmic vertical *
+ ! interpolation *
+ !*****************************************************************************
+ ! *
+ ! Variables: *
+ ! itime [s] current temporal position *
+ ! xt,yt,zold,zold spatial positions of trajectory (meters) *
+ ! zteta vertical position in eta coordinates (output) *
+ ! *
+ ! etauvheight defined in windfields: half model heights for ETA coordinates *
+ ! Constants: *
+ ! *
+ !*****************************************************************************
+ use interpol_mod
+
+ implicit none
+ integer, intent(in) :: &
+ itime ! time index
+ integer :: &
+ i,m,k,n ! loop indices
+ real, intent(in) :: &
+ dt ! time step
+ real(kind=dp), intent(in) :: &
+ xt,yt,z_old,zeta_old ! particle position
+ real, intent(in) :: &
+ w_in ! w in meters/s
+ real, intent(inout) :: &
+ weta_out ! converted output w in meters to eta
+ real(kind=dp) :: &
+ znew
+
+ call z_to_zeta(itime,xt,yt,z_old+real(w_in*dt,kind=dp),znew)
+
+ weta_out=real(znew-zeta_old)/dt
+
+end subroutine w_to_weta
+
+subroutine z_to_zeta_lin(itime,xt,yt,zold,zteta)
+ !*****************************************************************************
+ ! Converting z from meter coordinates to eta using linear interpolation *
+ ! *
+ !*****************************************************************************
+ ! *
+ ! Variables: *
+ ! itime [s] current temporal position *
+ ! xt,yt,zold,zold spatial positions of trajectory (meters) *
+ ! zteta vertical position in eta coordinates (output) *
+ ! *
+ ! etauvheight defined in windfields: half model heights for ETA coordinates *
+ ! Constants: *
+ ! *
+ !*****************************************************************************
+ use interpol_mod
+
+ implicit none
+ integer, intent(in) :: &
+ itime ! time index
+ integer :: &
+ i,m,k,n ! loop indices
+ real(kind=dp), intent(in) :: &
+ xt,yt ! particle position
+ real(kind=dp), intent(in) :: &
+ zold ! particle verticle position in eta coordinates
+ real(kind=dp), intent(inout) :: &
+ zteta ! converted output z in meters
+ real :: &
+ frac, & ! fraction between z levels
+ ztemp1,ztemp2, & ! z positions of the two encompassing levels
+ ttemp1(2), & ! storing virtual temperature
+ psint1(2),psint ! pressure of encompassing levels
+ real :: &
+ prx,pr1,pr2 ! pressure of encompassing levels
+
+ call find_ngrid(xt,yt)
+ call determine_grid_coordinates(real(xt),real(yt))
+ call find_grid_distances(real(xt),real(yt))
+ call find_time_variables(itime)
+
+ ! Integration method as used in the original verttransform_ecmwf.f90
+ !+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+ ! First estimate the level it is at, to reduce computation time
+ n=nz-3
+ if (ngrid.le.0) then
+ do i=2,nz-1
+ if ((etauvheight(ix,jy,i,memind(1)).gt.real(zold)) .or. &
+ (etauvheight(ixp,jy,i,memind(1)).gt.real(zold)) .or. &
+ (etauvheight(ix,jyp,i,memind(1)).gt.real(zold)) .or. &
+ (etauvheight(ixp,jyp,i,memind(1)).gt.real(zold))) then
+ n=i-2
+ exit
+ endif
+ end do
+ else
+ do i=2,nz-1
+ if ((etauvheightn(ix,jy,i,memind(1),ngrid).gt.real(zold)) .or. &
+ (etauvheightn(ixp,jy,i,memind(1),ngrid).gt.real(zold)) .or. &
+ (etauvheightn(ix,jyp,i,memind(1),ngrid).gt.real(zold)) .or. &
+ (etauvheightn(ixp,jyp,i,memind(1),ngrid).gt.real(zold))) then
+ n=i-2
+ exit
+ endif
+ end do
+ endif
+ n=max(n,2)
+
+ ztemp1 = 0.
+ do i=n,nz-1
+ k=i
+ if (ngrid.le.0) then
+ do m=1,2
+ call horizontal_interpolation(etauvheight,ttemp1(m),i,memind(m),nzmax)
+ end do
+ else
+ do m=1,2
+ call horizontal_interpolation_nests(etauvheightn,ttemp1(m),i,memind(m),nzmax)
+ end do
+ endif
+ call temporal_interpolation(ttemp1(1),ttemp1(2),ztemp2)
+
+ if (ztemp2.gt.real(zold)) then
+ frac = (real(zold)-ztemp1)/(ztemp2-ztemp1)
+ exit
+ else if (i.eq.nz-1) then
+ frac = 1.
+ exit
+ endif
+ ztemp1=ztemp2
+ end do
+
+ zteta=real(uvheight(k-1)*(1.-frac)+uvheight(k)*frac,kind=dp)
+end subroutine z_to_zeta_lin
+
+subroutine zeta_to_z_lin(itime,xt,yt,zteta,ztout)
+
+ !*****************************************************************************
+ ! Converting z from eta coordinates to meters using linear interpolation *
+ ! *
+ !*****************************************************************************
+ ! *
+ ! Variables: *
+ ! itime [s] current temporal position *
+ ! xt,yt,zteta spatial position of trajectory *
+ ! ztout vertical postion in meter (output) *
+ ! *
+ ! *
+ !*****************************************************************************
+ use interpol_mod
+
+ implicit none
+ integer, intent(in) :: &
+ itime ! time index
+ integer :: &
+ i,j,k,m,ii,indexh ! loop indices
+ real(kind=dp), intent(in) :: &
+ xt,yt ! particle position
+ real(kind=dp), intent(in) :: &
+ zteta ! particle verticle position in eta coordinates
+ real(kind=dp), intent(inout) :: &
+ ztout ! converted output z in meters
+ real(kind=dp) :: &
+ frac ! fraction between z levels
+ real :: &
+ ztemp1(2), & ! z positions of the two encompassing levels
+ ttemp1(2), & ! storing virtual temperature
+ psint1(2),psint ! pressure of encompassing levels
+
+
+ ! Convert eta z coordinate to meters
+ !***********************************
+ call find_ngrid(xt,yt)
+ call determine_grid_coordinates(real(xt),real(yt))
+ call find_grid_distances(real(xt),real(yt))
+ call find_time_variables(itime)
+
+ k=nz-1
+ frac=1.
+ do i=2,nz-1
+ k=i
+ if (zteta.ge.real(uvheight(k),kind=dp)) then
+ frac=(zteta-real(uvheight(k-1),kind=dp))/(real(uvheight(k)-uvheight(k-1),kind=dp))
+ exit
+ endif
+ end do
+
+ if (ngrid.le.0) then
+ do ii=1,2
+ do m=1,2
+ call horizontal_interpolation(etauvheight,ttemp1(m),k+ii-2,memind(m),nzmax)
+ end do
+ call temporal_interpolation(ttemp1(1),ttemp1(2),ztemp1(ii))
+ end do
+ else
+ do ii=1,2
+ do m=1,2
+ call horizontal_interpolation_nests(etauvheightn,ttemp1(m),k+ii-2,memind(m),nzmax)
+ end do
+ call temporal_interpolation(ttemp1(1),ttemp1(2),ztemp1(ii))
+ end do
+ endif
+
+ ztout = real(ztemp1(1),kind=dp)*(1.-frac)+real(ztemp1(2),kind=dp)*frac
+end subroutine zeta_to_z_lin
+
+end module coordinates_ecmwf_mod
diff --git a/src/date_mod.f90 b/src/date_mod.f90
new file mode 100644
index 00000000..eadf4951
--- /dev/null
+++ b/src/date_mod.f90
@@ -0,0 +1,154 @@
+! SPDX-FileCopyrightText: FLEXPART 1998-2019, see flexpart_license.txt
+! SPDX-License-Identifier: GPL-3.0-or-later
+
+!*****************************************************************************
+! *
+! L. Bakels 2022: this module contains all subroutines related to *
+! calculations between dates: caldate and juldate *
+! *
+!*****************************************************************************
+
+module date_mod
+ use par_mod, only: dp
+
+ implicit none
+
+contains
+
+subroutine caldate(juliandate,yyyymmdd,hhmiss)
+ ! i o o
+ !*****************************************************************************
+ ! *
+ ! Calculates the Gregorian date from the Julian date *
+ ! *
+ ! AUTHOR: Andreas Stohl (21 January 1994), adapted from Numerical Recipes*
+ ! *
+ ! Variables: *
+ ! dd Day *
+ ! hh Hour *
+ ! hhmiss Hour, Minute, Second *
+ ! ja,jb,jc,jd,je help variables *
+ ! jalpha help variable *
+ ! juliandate Julian Date *
+ ! julday help variable *
+ ! mi Minute *
+ ! mm Month *
+ ! ss Seconds *
+ ! yyyy Year *
+ ! yyyymmdd Year, Month, Day *
+ ! *
+ ! Constants: *
+ ! igreg help constant *
+ ! *
+ !*****************************************************************************
+
+ implicit none
+
+ integer :: yyyymmdd,yyyy,mm,dd,hhmiss,hh,mi,ss
+ integer :: julday,ja,jb,jc,jd,je,jalpha
+ real(kind=dp) :: juliandate
+ integer,parameter :: igreg=2299161
+
+ julday=int(juliandate)
+ if ((juliandate-julday)*86400._dp .ge. 86399.5_dp) then
+ juliandate = juliandate + juliandate-julday-86399.5_dp/86400._dp
+ julday=int(juliandate)
+ endif
+ if(julday.ge.igreg)then
+ jalpha=int(((julday-1867216)-0.25)/36524.25)
+ ja=julday+1+jalpha-int(0.25*jalpha)
+ else
+ ja=julday
+ endif
+ jb=ja+1524
+ jc=int(6680.+((jb-2439870)-122.1)/365.25)
+ jd=365*jc+int(0.25*jc)
+ je=int((jb-jd)/30.6001)
+ dd=jb-jd-int(30.6001*je)
+ mm=je-1
+ if (mm.gt.12) mm=mm-12
+ yyyy=jc-4715
+ if (mm.gt.2) yyyy=yyyy-1
+ if (yyyy.le.0) yyyy=yyyy-1
+
+ yyyymmdd=10000*yyyy+100*mm+dd
+ hh=int(24._dp*(juliandate-real(julday,kind=dp)))
+ mi=int(1440._dp*(juliandate-real(julday,kind=dp))-60._dp*real(hh,kind=dp))
+ ss=nint(86400._dp*(juliandate-real(julday,kind=dp))-3600._dp*real(hh,kind=dp)- &
+ 60._dp*real(mi,kind=dp))
+ if (ss.eq.60) then ! 60 seconds = 1 minute
+ ss=0
+ mi=mi+1
+ endif
+ if (mi.eq.60) then
+ mi=0
+ hh=hh+1
+ endif
+ hhmiss=10000*hh+100*mi+ss
+
+end subroutine caldate
+
+real(kind=dp) function juldate(yyyymmdd,hhmiss)
+
+ !*****************************************************************************
+ ! *
+ ! Calculates the Julian date *
+ ! *
+ ! AUTHOR: Andreas Stohl (15 October 1993) *
+ ! *
+ ! Variables: *
+ ! dd Day *
+ ! hh Hour *
+ ! hhmiss Hour, minute + second *
+ ! ja,jm,jy help variables *
+ ! juldate Julian Date *
+ ! julday help variable *
+ ! mi Minute *
+ ! mm Month *
+ ! ss Second *
+ ! yyyy Year *
+ ! yyyymmddhh Date and Time *
+ ! *
+ ! Constants: *
+ ! igreg help constant *
+ ! *
+ !*****************************************************************************
+
+ implicit none
+
+ integer :: yyyymmdd,yyyy,mm,dd,hh,mi,ss,hhmiss
+ integer :: julday,jy,jm,ja
+ integer,parameter :: igreg=15+31*(10+12*1582)
+ !real(kind=dp) :: juldate
+
+ yyyy=yyyymmdd/10000
+ mm=(yyyymmdd-10000*yyyy)/100
+ dd=yyyymmdd-10000*yyyy-100*mm
+ hh=hhmiss/10000
+ mi=(hhmiss-10000*hh)/100
+ ss=hhmiss-10000*hh-100*mi
+
+ if (yyyy.eq.0) then
+ print*, 'there is no year zero.'
+ stop
+ end if
+ if (yyyy.lt.0) yyyy=yyyy+1
+ if (mm.gt.2) then
+ jy=yyyy
+ jm=mm+1
+ else
+ jy=yyyy-1
+ jm=mm+13
+ endif
+ julday=int(365.25*jy)+int(30.6001*jm)+dd+1720995
+ if (dd+31*(mm+12*yyyy).ge.igreg) then
+ ja=int(0.01*jy)
+ julday=julday+2-ja+int(0.25*ja)
+ endif
+
+ juldate=real(julday,kind=dp) + real(hh,kind=dp)/24._dp + &
+ real(mi,kind=dp)/1440._dp + real(ss,kind=dp)/86400._dp
+
+end function juldate
+
+end module date_mod
diff --git a/src/drydepo_mod.f90 b/src/drydepo_mod.f90
new file mode 100644
index 00000000..5d40f2cd
--- /dev/null
+++ b/src/drydepo_mod.f90
@@ -0,0 +1,1525 @@
+!*****************************************************************************
+! *
+! L. Bakels 2021: This module contains dry deposition related subroutines *
+! *
+! To do: dry deposition mass loss substraction of individual particles *
+! should be moved from to timemanager_mod.f90 to here *
+! *
+! *
+!*****************************************************************************
+
+module drydepo_mod
+ use par_mod
+ use com_mod
+ use unc_mod
+ use windfields_mod
+ use erf_mod
+
+ implicit none
+
+ real,allocatable,dimension(:,:,:) :: xlanduse
+ ! area fractions in percent [0-1]
+ real,allocatable,dimension(:,:,:,:) :: xlandusen
+ ! nested area fractions in percent [0-1]
+ real,allocatable,dimension(:,:,:,:) :: vdep ! deposition velocity [m/s]
+
+contains
+
+subroutine drydepo_allocate
+
+ implicit none
+
+ if (.not. drydep) return
+ write(*,*) 'allocate drydepo fields'
+ allocate(xlanduse(0:nxmax-1,0:nymax-1,numclass), &
+ xlandusen(0:nxmaxn-1,0:nymaxn-1,numclass,maxnests), &
+ vdep(0:nxmax-1,0:nymax-1,maxspec,numwfmem))
+
+end subroutine drydepo_allocate
+
+subroutine drydepo_deallocate
+
+ if (.not. drydep) return
+ deallocate(xlanduse,xlandusen,vdep)
+
+end subroutine drydepo_deallocate
+
+subroutine assignland
+
+ !*****************************************************************************
+ ! *
+ ! This routine assigns fractions of the 13 landuse classes to each ECMWF *
+ ! grid point. *
+ ! The landuse inventory of *
+ ! *
+ ! Belward, A.S., Estes, J.E., and Kline, K.D., 1999, *
+ ! The IGBP-DIS 1-Km Land-Cover Data Set DISCover: *
+ ! A Project Overview: Photogrammetric Engineering and Remote Sensing , *
+ ! v. 65, no. 9, p. 1013-1020 *
+ ! *
+ ! if there are no data in the inventory *
+ ! the ECMWF land/sea mask is used to distinguish *
+ ! between sea (-> ocean) and land (-> grasslands). *
+ ! *
+ ! Author: A. Stohl *
+ ! *
+ ! 5 December 1996 *
+ ! 8 February 1999 Additional use of nests, A. Stohl *
+ ! 29 December 2006 new landuse inventory, S. Eckhardt *
+ !*****************************************************************************
+ ! *
+ ! Variables: *
+ ! xlanduse fractions of numclass landuses for each model grid point *
+ ! landinvent landuse inventory (0.3 deg resolution) *
+ ! *
+ !*****************************************************************************
+
+ implicit none
+
+ integer :: ix,jy,k,l,li,nrefine,iix,jjy
+ integer,parameter :: lumaxx=1200,lumaxy=600
+ integer,parameter :: xlon0lu=-180,ylat0lu=-90
+ real,parameter :: dxlu=0.3
+ real :: xlon,ylat,sumperc,p,xi,yj
+ real :: xlandusep(lumaxx,lumaxy,numclass)
+ ! character*2 ck
+
+ if (.not.DRYDEP) return
+
+ do ix=1,lumaxx
+ do jy=1,lumaxy
+ do k=1,numclass
+ xlandusep(ix,jy,k)=0.
+ end do
+ sumperc=0.
+ do li=1,3
+ sumperc=sumperc+landinvent(ix,jy,li+3)
+ end do
+ do li=1,3
+ k=landinvent(ix,jy,li)
+ if (sumperc.gt.0) then
+ p=landinvent(ix,jy,li+3)/sumperc
+ else
+ p=0
+ endif
+! p has values between 0 and 1
+ xlandusep(ix,jy,k)=p
+ end do
+ end do
+ end do
+
+ ! do 13 k=1,11
+ ! write (ck,'(i2.2)') k
+ ! open(4,file='xlandusetest'//ck,form='formatted')
+ ! do 11 ix=1,lumaxx
+ !11 write (4,*) (xlandusep(ix,jy,k),jy=1,lumaxy)
+ !11 write (4,*) (landinvent(ix,jy,k),jy=1,lumaxy)
+ !13 close(4)
+
+ ! write (*,*) xlon0,ylat0,xlon0n(1),ylat0n(1),nxmin1,nymin1
+ ! write (*,*) dx, dy, dxout, dyout, ylat0, xlon0
+ nrefine=10
+ do ix=0,nxmin1
+ do jy=0,nymin1
+ do k=1,numclass
+ sumperc=0.
+ xlanduse(ix,jy,k)=0.
+ end do
+ do iix=1, nrefine
+ xlon=(ix+(iix-1)/real(nrefine))*dx+xlon0 ! longitude, should be between -180 and 179
+ if (xlon.ge.(xlon0lu+lumaxx*dxlu)) then
+ xlon=xlon-lumaxx*dxlu
+ endif
+ do jjy=1, nrefine
+ ylat=(jy+(jjy-1)/real(nrefine))*dy+ylat0 ! and lat. of each gridpoint
+ xi=int((xlon-xlon0lu)/dxlu)+1
+ yj=int((ylat-ylat0lu)/dxlu)+1
+ if (xi.gt.lumaxx) xi=xi-lumaxx
+ if (yj.gt.lumaxy) yj=yj-lumaxy
+ if (xi.lt.0) then
+ write (*,*) 'problem with landuseinv sampling: ', &
+ xlon,xlon0lu,ix,iix,xlon0,dx,nxmax
+ stop
+ endif
+ do k=1,numclass
+ xlanduse(ix,jy,k)= &
+ xlanduse(ix,jy,k)+xlandusep(int(xi),int(yj),k)
+ sumperc=sumperc+xlanduse(ix,jy,k) ! just for the check if landuseinv. is available
+ end do
+ end do
+ end do
+ if (sumperc.gt.0) then ! detailed landuse available
+ sumperc=0.
+ do k=1,numclass
+ xlanduse(ix,jy,k)= &
+ xlanduse(ix,jy,k)/real(nrefine*nrefine)
+ sumperc=sumperc+xlanduse(ix,jy,k)
+ end do
+ !cc the sum of all categories should be 1 ... 100 percent ... in order to get vdep right!
+ if (sumperc.lt.1-1E-5) then
+ do k=1,numclass
+ xlanduse(ix,jy,k)= &
+ xlanduse(ix,jy,k)/sumperc
+ end do
+ endif
+ else
+ if (lsm(ix,jy).lt.0.1) then ! over sea -> ocean
+ xlanduse(ix,jy,3)=1.
+ else ! over land -> rangeland
+ xlanduse(ix,jy,7)=1.
+ endif
+ endif
+
+
+ end do
+ end do
+
+ !***********************************
+ ! for test: write out xlanduse
+
+ ! open(4,file='landusetest',form='formatted')
+ ! do 56 k=1,13
+ ! do 55 ix=0,nxmin1
+ !55 write (4,*) (xlanduse(ix,jy,k),jy=0,nymin1)
+ !56 continue
+ ! close(4)
+ ! write (*,*) 'landuse written'
+ !stop
+ ! open(4,file='landseatest'//ck,form='formatted')
+ ! do 57 ix=0,nxmin1
+ !57 write (4,*) (lsm(ix,jy),jy=0,nymin1)
+ ! write (*,*) 'landseamask written'
+
+ !****************************************
+ ! Same as above, but for the nested grids
+ !****************************************
+
+ !************** TEST ********************
+ ! dyn(1)=dyn(1)/40
+ ! dxn(1)=dxn(1)/40
+ ! xlon0n(1)=1
+ ! ylat0n(1)=50
+ !************** TEST ********************
+
+ do l=1,numbnests
+ do ix=0,nxn(l)-1
+ do jy=0,nyn(l)-1
+ do k=1,numclass
+ sumperc=0.
+ xlandusen(ix,jy,k,l)=0.
+ end do
+ do iix=1, nrefine
+ xlon=(ix+(iix-1)/real(nrefine))*dxn(l)+xlon0n(l)
+ do jjy=1, nrefine
+ ylat=(jy+(jjy-1)/real(nrefine))*dyn(l)+ylat0n(l)
+ xi=int((xlon-xlon0lu)/dxlu)+1
+ yj=int((ylat-ylat0lu)/dxlu)+1
+ if (xi.gt.lumaxx) xi=xi-lumaxx
+ if (yj.gt.lumaxy) yj=yj-lumaxy
+ do k=1,numclass
+ xlandusen(ix,jy,k,l)=xlandusen(ix,jy,k,l)+ &
+ xlandusep(int(xi),int(yj),k)
+ sumperc=sumperc+xlandusen(ix,jy,k,l)
+ end do
+ end do
+ end do
+ if (sumperc.gt.0) then ! detailed landuse available
+ sumperc=0.
+ do k=1,numclass
+ xlandusen(ix,jy,k,l)= &
+ xlandusen(ix,jy,k,l)/real(nrefine*nrefine)
+ sumperc=sumperc+xlandusen(ix,jy,k,l)
+ end do
+ !cc the sum of all categories should be 1 ... 100 percent ... in order to get vdep right!
+ if (sumperc.lt.1-1E-5) then
+ do k=1,numclass
+ xlandusen(ix,jy,k,l)=xlandusen(ix,jy,k,l)/sumperc
+ end do
+ endif
+ else ! check land/sea mask
+ if (lsmn(ix,jy,l).lt.0.1) then ! over sea -> ocean
+ xlandusen(ix,jy,3,l)=1.
+ else ! over land -> grasslands
+ xlandusen(ix,jy,7,l)=1.
+ endif
+ endif
+ end do
+ end do
+ end do
+
+ !***********************************
+ ! for test: write out xlanduse
+
+ ! do 66 k=1,11
+ ! write (ck,'(i2.2)') k
+ ! open(4,file='nlandusetest'//ck,form='formatted')
+ ! do 65 ix=0,nxn(1)-1
+ !65 write (4,*) (xlandusen(ix,jy,k,1),jy=0,nyn(1)-1)
+ !66 close(4)
+
+ ! write (*,*) 'landuse nested written'
+end subroutine assignland
+
+real function raerod (l,ust,z0)
+ !*****************************************************************************
+ ! *
+ ! Calculation of the aerodynamical resistance ra from ground up to href *
+ ! *
+ ! AUTHOR: Matthias Langer, modified by Andreas Stohl (6 August 1993) *
+ ! *
+ ! Literature: *
+ ! [1] Hicks/Baldocchi/Meyers/Hosker/Matt (1987), A Preliminary *
+ ! Multiple Resistance Routine for Deriving Dry Deposition *
+ ! Velocities from Measured Quantities. *
+ ! Water, Air and Soil Pollution 36 (1987), pp.311-330. *
+ ! [2] Scire/Yamartino/Carmichael/Chang (1989), *
+ ! CALGRID: A Mesoscale Photochemical Grid Model. *
+ ! Vol II: User's Guide. (Report No.A049-1, June, 1989) *
+ ! *
+ ! Variable list: *
+ ! L = Monin-Obukhov-length [m] *
+ ! ust = friction velocity [m/sec] *
+ ! z0 = surface roughness length [m] *
+ ! href = reference height [m], for which deposition velocity is *
+ ! calculated *
+ ! *
+ ! Constants: *
+ ! karman = von Karman-constant (~0.4) *
+ ! ramin = minimum resistence of ra (1 s/m) *
+ ! *
+ ! Subprograms and functions: *
+ ! function psih (z/L) *
+ ! *
+ !*****************************************************************************
+
+ use pbl_profile_mod, only: psih
+
+ implicit none
+
+ real :: l,ust,z0
+
+ raerod=(alog(href/z0)-psih(href,l)+psih(z0,l))/(karman*ust)
+
+end function raerod
+
+subroutine drydepo_massloss(ipart,ks,ldeltat,drydepopart)
+ use particle_mod
+
+ implicit none
+
+ integer,intent(in) :: &
+ ipart, & ! particle index
+ ks, & ! species index
+ ldeltat ! radioactive decay time
+ real(dep_prec),intent(out) :: &
+ drydepopart ! drydeposit for particle ipart
+ real decfact ! radioactive decay factor
+
+ if (decay(ks).gt.0.) then ! radioactive decay
+ decfact=exp(-real(abs(lsynctime))*decay(ks))
+ else
+ decfact=1.
+ endif
+ drydepopart=part(ipart)%mass(ks)*part(ipart)%prob(ks)*decfact
+
+ part(ipart)%drydepo(ks)=part(ipart)%drydepo(ks)+ &
+ part(ipart)%mass(ks)*part(ipart)%prob(ks)*decfact
+
+ part(ipart)%mass(ks)=part(ipart)%mass(ks)*(1.-part(ipart)%prob(ks))*decfact
+
+ if (decay(ks).gt.0.) then ! correct for decay (see wetdepo)
+ drydepopart=drydepopart*exp(real(abs(ldeltat))*decay(ks))
+ endif
+
+end subroutine drydepo_massloss
+
+subroutine drydepokernel(nunc,deposit,x,y,nage,kp,thread)
+ ! i i i i i
+ !*****************************************************************************
+ ! *
+ ! Attribution of the deposition to the grid using a uniform kernel with *
+ ! bandwidths dx and dy. *
+ ! *
+ ! Author: A. Stohl *
+ ! *
+ ! 26 December 1996 *
+ ! *
+ !*****************************************************************************
+ ! *
+ ! Variables: *
+ ! *
+ ! nunc uncertainty class of the respective particle *
+ ! nage age class of the respective particle *
+ ! deposit amount (kg) to be deposited *
+ ! *
+ !*****************************************************************************
+ ! Changes:
+ ! eso 10/2016: Added option to disregard kernel
+ !
+ !*****************************************************************************
+
+ implicit none
+
+ integer,intent(in) :: thread
+ real(dep_prec), dimension(maxspec) :: deposit
+ real :: x,y,ddx,ddy,xl,yl,wx,wy,w
+ integer :: ix,jy,ixp,jyp,ks,nunc,nage,kp
+
+
+ xl=(x*dx+xoutshift)/dxout
+ yl=(y*dy+youtshift)/dyout
+ ix=int(xl)
+ jy=int(yl)
+ ddx=xl-real(ix) ! distance to left cell border
+ ddy=yl-real(jy) ! distance to lower cell border
+
+ if (ddx.gt.0.5) then
+ ixp=ix+1
+ wx=1.5-ddx
+ else
+ ixp=ix-1
+ wx=0.5+ddx
+ endif
+
+ if (ddy.gt.0.5) then
+ jyp=jy+1
+ wy=1.5-ddy
+ else
+ jyp=jy-1
+ wy=0.5+ddy
+ endif
+
+ ! If no kernel is used, direct attribution to grid cell
+ !******************************************************
+
+ if (.not.lusekerneloutput) then
+ do ks=1,nspec
+ if ((abs(deposit(ks)).gt.0).and.DRYDEPSPEC(ks)) then
+ if ((ix.ge.0).and.(jy.ge.0).and.(ix.le.numxgrid-1).and. &
+ (jy.le.numygrid-1)) then
+#ifdef _OPENMP
+ gridunc_omp(ix,jy,1,ks,kp,nunc,nage,thread)= &
+ gridunc_omp(ix,jy,1,ks,kp,nunc,nage,thread)+deposit(ks)
+#else
+ drygridunc(ix,jy,ks,kp,nunc,nage)= &
+ drygridunc(ix,jy,ks,kp,nunc,nage)+deposit(ks)
+#endif
+ end if
+ end if
+ end do
+ else ! use kernel
+
+
+ ! Determine mass fractions for four grid points
+ !**********************************************
+ do ks=1,nspec
+
+ if ((abs(deposit(ks)).gt.0).and.DRYDEPSPEC(ks)) then
+
+ if ((ix.ge.0).and.(jy.ge.0).and.(ix.le.numxgrid-1).and. &
+ (jy.le.numygrid-1)) then
+ w=wx*wy
+#ifdef _OPENMP
+ gridunc_omp(ix,jy,1,ks,kp,nunc,nage,thread)= &
+ gridunc_omp(ix,jy,1,ks,kp,nunc,nage,thread)+deposit(ks)*w
+#else
+ drygridunc(ix,jy,ks,kp,nunc,nage)= &
+ drygridunc(ix,jy,ks,kp,nunc,nage)+deposit(ks)*w
+#endif
+ endif
+
+ if ((ixp.ge.0).and.(jyp.ge.0).and.(ixp.le.numxgrid-1).and. &
+ (jyp.le.numygrid-1)) then
+ w=(1.-wx)*(1.-wy)
+#ifdef _OPENMP
+ gridunc_omp(ixp,jyp,1,ks,kp,nunc,nage,thread)= &
+ gridunc_omp(ixp,jyp,1,ks,kp,nunc,nage,thread)+deposit(ks)*w
+#else
+ drygridunc(ixp,jyp,ks,kp,nunc,nage)= &
+ drygridunc(ixp,jyp,ks,kp,nunc,nage)+deposit(ks)*w
+#endif
+ endif
+
+ if ((ixp.ge.0).and.(jy.ge.0).and.(ixp.le.numxgrid-1).and. &
+ (jy.le.numygrid-1)) then
+ w=(1.-wx)*wy
+#ifdef _OPENMP
+ gridunc_omp(ixp,jy,1,ks,kp,nunc,nage,thread)= &
+ gridunc_omp(ixp,jy,1,ks,kp,nunc,nage,thread)+deposit(ks)*w
+#else
+ drygridunc(ixp,jy,ks,kp,nunc,nage)= &
+ drygridunc(ixp,jy,ks,kp,nunc,nage)+deposit(ks)*w
+#endif
+ endif
+
+ if ((ix.ge.0).and.(jyp.ge.0).and.(ix.le.numxgrid-1).and. &
+ (jyp.le.numygrid-1)) then
+ w=wx*(1.-wy)
+#ifdef _OPENMP
+ gridunc_omp(ix,jyp,1,ks,kp,nunc,nage,thread)= &
+ gridunc_omp(ix,jyp,1,ks,kp,nunc,nage,thread)+deposit(ks)*w
+#else
+ drygridunc(ix,jyp,ks,kp,nunc,nage)= &
+ drygridunc(ix,jyp,ks,kp,nunc,nage)+deposit(ks)*w
+#endif
+ endif
+
+ endif ! deposit>0
+ end do
+ end if
+end subroutine drydepokernel
+
+subroutine drydepokernel_nest(nunc,deposit,x,y,nage,kp,thread)
+ ! i i i i i
+ !*****************************************************************************
+ ! *
+ ! Attribution of the deposition from an individual particle to the *
+ ! nested deposition fields using a uniform kernel with bandwidths *
+ ! dxoutn and dyoutn. *
+ ! *
+ ! Author: A. Stohl *
+ ! *
+ ! 26 December 1996 *
+ ! *
+ ! 2 September 2004: Adaptation from drydepokernel. *
+ ! *
+ !*****************************************************************************
+ ! *
+ ! Variables: *
+ ! *
+ ! nunc uncertainty class of the respective particle *
+ ! nage age class of the respective particle *
+ ! deposit amount (kg) to be deposited *
+ ! *
+ !*****************************************************************************
+
+ implicit none
+
+ integer,intent(in) :: thread
+ real(dep_prec), dimension(maxspec) :: deposit
+ real :: x,y,ddx,ddy,xl,yl,wx,wy,w
+ integer :: ix,jy,ixp,jyp,ks,kp,nunc,nage
+
+
+
+ xl=(x*dx+xoutshiftn)/dxoutn
+ yl=(y*dy+youtshiftn)/dyoutn
+ ix=int(xl)
+ jy=int(yl)
+ ddx=xl-real(ix) ! distance to left cell border
+ ddy=yl-real(jy) ! distance to lower cell border
+
+ if (ddx.gt.0.5) then
+ ixp=ix+1
+ wx=1.5-ddx
+ else
+ ixp=ix-1
+ wx=0.5+ddx
+ endif
+
+ if (ddy.gt.0.5) then
+ jyp=jy+1
+ wy=1.5-ddy
+ else
+ jyp=jy-1
+ wy=0.5+ddy
+ endif
+
+
+ ! Determine mass fractions for four grid points
+ !**********************************************
+ do ks=1,nspec
+
+ if (DRYDEPSPEC(ks).and.(abs(deposit(ks)).gt.0)) then
+
+ if ((ix.ge.0).and.(jy.ge.0).and.(ix.le.numxgridn-1).and. &
+ (jy.le.numygridn-1)) then
+ w=wx*wy
+#ifdef _OPENMP
+ griduncn_omp(ix,jy,1,ks,kp,nunc,nage,thread)= &
+ griduncn_omp(ix,jy,1,ks,kp,nunc,nage,thread)+deposit(ks)*w
+#else
+ drygriduncn(ix,jy,ks,kp,nunc,nage)= &
+ drygriduncn(ix,jy,ks,kp,nunc,nage)+deposit(ks)*w
+#endif
+ endif
+
+ if ((ixp.ge.0).and.(jyp.ge.0).and.(ixp.le.numxgridn-1).and. &
+ (jyp.le.numygridn-1)) then
+ w=(1.-wx)*(1.-wy)
+#ifdef _OPENMP
+ griduncn_omp(ixp,jyp,1,ks,kp,nunc,nage,thread)= &
+ griduncn_omp(ixp,jyp,1,ks,kp,nunc,nage,thread)+deposit(ks)*w
+#else
+ drygriduncn(ixp,jyp,ks,kp,nunc,nage)= &
+ drygriduncn(ixp,jyp,ks,kp,nunc,nage)+deposit(ks)*w
+#endif
+ endif
+
+ if ((ixp.ge.0).and.(jy.ge.0).and.(ixp.le.numxgridn-1).and. &
+ (jy.le.numygridn-1)) then
+ w=(1.-wx)*wy
+#ifdef _OPENMP
+ griduncn_omp(ixp,jy,1,ks,kp,nunc,nage,thread)= &
+ griduncn_omp(ixp,jy,1,ks,kp,nunc,nage,thread)+deposit(ks)*w
+#else
+ drygriduncn(ixp,jy,ks,kp,nunc,nage)= &
+ drygriduncn(ixp,jy,ks,kp,nunc,nage)+deposit(ks)*w
+#endif
+ endif
+
+ if ((ix.ge.0).and.(jyp.ge.0).and.(ix.le.numxgridn-1).and. &
+ (jyp.le.numygridn-1)) then
+ w=wx*(1.-wy)
+#ifdef _OPENMP
+ griduncn_omp(ix,jyp,1,ks,kp,nunc,nage,thread)= &
+ griduncn_omp(ix,jyp,1,ks,kp,nunc,nage,thread)+deposit(ks)*w
+#else
+ drygriduncn(ix,jyp,ks,kp,nunc,nage)= &
+ drygriduncn(ix,jyp,ks,kp,nunc,nage)+deposit(ks)*w
+#endif
+ endif
+
+ endif
+
+ end do
+end subroutine drydepokernel_nest
+
+subroutine part0(dquer,dsigma,density,ni,fract,schmi,cun,vsh)
+ ! i i i i o o o o
+ !*****************************************************************************
+ ! *
+ ! Calculation of time independent factors of the dry deposition of *
+ ! particles: *
+ ! Log-Normal-distribution of mass [dM/dlog(dp)], unimodal *
+ ! *
+ ! AUTHOR: Matthias Langer, adapted by Andreas Stohl, 13 November 1993 *
+ ! *
+ ! Literature: *
+ ! [1] Scire/Yamartino/Carmichael/Chang (1989), *
+ ! CALGRID: A Mesoscale Photochemical Grid Model. *
+ ! Vol II: User's Guide. (Report No.A049-1, June, 1989) *
+ ! *
+ !*****************************************************************************
+ ! *
+ ! Variables: *
+ ! alpha help variable *
+ ! cun 'slip-flow' correction after Cunningham *
+ ! d01 [um] upper diameter *
+ ! d02 [um] lower diameter *
+ ! dc [m2/s] coefficient of Brownian diffusion *
+ ! delta distance given in standard deviation units *
+ ! density [kg/m3] density of the particle *
+ ! dmean geometric mean diameter of interval *
+ ! dquer [um] geometric mass mean particle diameter *
+ ! dsigma e.g. dsigma=10 or dsigma=0.1 means that 68% of the mass *
+ ! are between 0.1*dquer and 10*dquer *
+ ! fract(ni) mass fraction of each diameter interval *
+ ! kn Knudsen number *
+ ! ni number of diameter intervals, for which deposition *
+ ! is calculated *
+ ! schmidt Schmidt number *
+ ! schmi schmidt**2/3 *
+ ! vsh [m/s] gravitational settling velocity of the particle *
+ ! x01 normalized upper diameter *
+ ! x02 normalized lower diameter *
+ ! *
+ ! Constants: *
+ ! g [m/s2] Acceleration of gravity *
+ ! kb [J/K] Stefan-Boltzmann constant *
+ ! lam [m] mean free path of air molecules *
+ ! myl [kg/m/s] dynamical viscosity of air *
+ ! nyl [m2/s] kinematic viscosity of air *
+ ! tr reference temperature *
+ ! *
+ ! Function: *
+ ! erf calculates the integral of the Gauss function *
+ ! *
+ !*****************************************************************************
+
+ implicit none
+
+ real,parameter :: tr=293.15
+
+ integer :: i,ni
+ real :: dquer,dsigma,density,xdummy,d01,d02,delta,x01,x02
+ real :: dmean,alpha,cun,dc,schmidt,kn,erf,fract_norm
+ real,dimension(ni),intent(inout) :: fract,schmi,vsh
+ real,parameter :: myl=1.81e-5,nyl=0.15e-4
+ real,parameter :: lam=6.53e-8,kb=1.38e-23,eps=1.2e-38
+
+ ! xdummy constant for all intervals
+ !**********************************
+
+ xdummy=sqrt(2.)*alog(dsigma)
+
+
+ ! particles diameters are split up to ni intervals between
+ ! dquer-3*dsigma and dquer+3*dsigma
+ !*********************************************************
+ ! Normalisation. Why was it not normalised?
+ !******************************************
+ x01=alog(dsigma**3)/xdummy
+ x02=alog(dsigma**(-3))/xdummy
+ fract_norm=0.5*(erf(x01)-erf(x02))
+
+ delta=6./real(ni)
+
+ d01=dquer*dsigma**(-3)
+ do i=1,ni
+ d02=d01
+ d01=dquer*dsigma**(-3.+delta*real(i))
+ x01=alog(d01/dquer)/xdummy
+ x02=alog(d02/dquer)/xdummy
+ !print*,'part0:: d02=' , d02 , 'd01=', d01
+
+ ! Area under Gauss-function is calculated and gives mass fraction of interval
+ !****************************************************************************
+
+ fract(i)=0.5*(erf(x01)-erf(x02))/fract_norm
+ !print*,'part0:: fract(',i,')', fract(i)
+ !print*,'part0:: fract', fract(i), x01, x02, erf(x01), erf(x02)
+
+ ! Geometric mean diameter of interval in [m]
+ !*******************************************
+
+ dmean=1.E-6*exp(0.5*alog(d01*d02))
+ !print*,'part0:: dmean=', dmean
+
+ ! Calculation of time independent parameters of each interval
+ !************************************************************
+
+ kn=2.*lam/dmean
+ if ((-1.1/kn).le.log10(eps)*log(10.)) then
+ alpha=1.257
+ else
+ alpha=1.257+0.4*exp(-1.1/kn)
+ endif
+ cun=1.+alpha*kn
+ dc=kb*tr*cun/(3.*pi*myl*dmean)
+ schmidt=nyl/dc
+ schmi(i)=schmidt**(-2./3.)
+ vsh(i)=ga*density*dmean*dmean*cun/(18.*myl)
+
+ !print*,'part0:: vsh(',i,')', vsh(i)
+
+ end do
+
+ !stop 'part0'
+end subroutine part0
+
+subroutine get_vdep_prob(itime,xt,yt,zt,prob)
+ ! i i i i o
+ !*****************************************************************************
+ ! *
+ ! Calculation of the probability for dry deposition *
+ ! *
+ ! Particle positions are read in - prob returned *
+ ! *
+ !*****************************************************************************
+ ! *
+ ! Variables: *
+ ! itime [s] time at which this subroutine is entered *
+ ! itimec [s] actual time, which is incremented in this subroutine *
+ ! href [m] height for which dry deposition velocity is calculated *
+ ! ldirect 1 forward, -1 backward *
+ ! ldt [s] Time step for the next integration *
+ ! lsynctime [s] Synchronisation interval of FLEXPART *
+ ! ngrid index which grid is to be used *
+ ! prob probability of absorption due to dry deposition *
+ ! vdepo Deposition velocities for all species *
+ ! xt,yt,zt Particle position *
+ ! *
+ !*****************************************************************************
+
+ use point_mod
+ use par_mod
+ use com_mod
+ use interpol_mod
+
+ implicit none
+
+ real :: xt,yt,zt
+ integer :: itime,i,j,k,memindnext
+ integer :: ks,m!nix,njy,
+ real :: prob(maxspec),vdepo(maxspec),vdeptemp(2)
+ real :: eps
+
+ eps=nxmax/3.e5
+
+ if (DRYDEP) then ! reset probability for deposition
+ do ks=1,nspec
+ depoindicator(ks)=.true.
+ prob(ks)=0.
+ end do
+ endif
+
+
+ ! Determine whether lat/long grid or polarstereographic projection
+ ! is to be used
+ ! Furthermore, determine which nesting level to be used
+ !*****************************************************************
+ call find_ngrid(xt,yt)
+
+ !***************************
+ ! Interpolate necessary data
+ !***************************
+
+ if (abs(itime-memtime(1)).lt.abs(itime-memtime(2))) then
+ memindnext=1
+ else
+ memindnext=2
+ endif
+
+ ! Determine nested grid coordinates
+ !**********************************
+ call determine_grid_coordinates(xt,yt)
+
+ ! Determine probability of deposition
+ !************************************
+
+ if ((DRYDEP).and.(real(zt).lt.2.*href)) then
+ do ks=1,nspec
+ if (DRYDEPSPEC(ks)) then
+ if (depoindicator(ks)) then
+ if (ngrid.le.0) then
+ do m=1,2
+ call horizontal_interpolation(vdep,vdeptemp(m),ks,memind(m),maxspec)
+ end do
+ else
+ do m=1,2
+ call horizontal_interpolation_nests(vdepn,vdeptemp(m),ks,memind(m),maxspec)
+ end do
+ endif
+ call temporal_interpolation(vdeptemp(1),vdeptemp(2),vdepo(ks))
+ endif
+ ! correction by Petra Seibert, 10 April 2001
+ ! this formulation means that prob(n) = 1 - f(0)*...*f(n)
+ ! where f(n) is the exponential term
+ prob(ks)=vdepo(ks)
+ ! prob(ks)=vdepo(ks)/2./href
+ ! instead of prob - return vdepo -> result kg/m2/s
+ endif
+ end do
+ endif
+end subroutine get_vdep_prob
+
+subroutine drydepo_probability(prob,dt,zts,vdepo)
+ use par_mod
+ use com_mod
+ use interpol_mod
+
+ implicit none
+
+ real,intent(inout) :: prob(maxspec)
+ real,intent(inout) :: vdepo(maxspec) ! deposition velocities for all species
+ real,intent(in) :: dt,zts ! real(ldt), real(zt)
+ integer :: ns,m ! loop variable over species
+ real :: vdeptemp(2)
+
+ if ((DRYDEP).and.(zts.lt.2.*href)) then
+ do ns=1,nspec
+ if (DRYDEPSPEC(ns)) then
+ if (depoindicator(ns)) then
+ if (ngrid.le.0) then
+ do m=1,2
+ call horizontal_interpolation(vdep,vdeptemp(m),ns,memind(m),maxspec)
+ end do
+ else
+ do m=1,2
+ call horizontal_interpolation_nests(vdepn,vdeptemp(m),ns,memind(m),maxspec)
+ end do
+ endif
+ call temporal_interpolation(vdeptemp(1),vdeptemp(2),vdepo(ns))
+ endif
+ ! correction by Petra Seibert, 10 April 2001
+ ! this formulation means that prob(n) = 1 - f(0)*...*f(n)
+ ! where f(n) is the exponential term
+ prob(ns)=1.+(prob(ns)-1.)*exp(-vdepo(ns)*abs(dt)/(2.*href))
+ !if (pp.eq.535) write(*,*) 'advance1', ks,dtt,p1,vdep(ix,jy,ks,1)
+ endif
+ end do
+ endif
+end subroutine drydepo_probability
+
+subroutine getvdep(n,ix,jy,ust,temp,pa,L,gr,rh,rr,snow,vdepo)
+ ! i i i i i i i i i i i o
+ !*****************************************************************************
+ ! *
+ ! This routine calculates the dry deposition velocities. *
+ ! *
+ ! Author: A. Stohl *
+ ! *
+ ! 20 December 1996 *
+ ! Sabine Eckhardt, Jan 07 *
+ ! if the latitude is negative: add half a year to the julian day *
+ ! *
+ !*****************************************************************************
+ ! *
+ ! Variables: *
+ ! gr [W/m2] global radiation *
+ ! L [m] Obukhov length *
+ ! nyl kinematic viscosity *
+ ! pa [Pa] surface air pressure *
+ ! ra [s/m] aerodynamic resistance *
+ ! raquer [s/m] average aerodynamic resistance *
+ ! rh [0-1] relative humidity *
+ ! rhoa density of the air *
+ ! rr [mm/h] precipitation rate *
+ ! temp [K] 2m temperature *
+ ! tc [C] 2m temperature *
+ ! ust [m/s] friction velocity *
+ ! snow [m of water equivalent] snow depth *
+ ! xlanduse fractions of numclasS landuses for each model grid point *
+ ! *
+ !*****************************************************************************
+ use date_mod
+
+ implicit none
+
+ integer :: yyyymmdd,hhmmss,yyyy,mmdd,n,lseason,i,j,ix,jy
+ real :: vdepo(maxspec),vd,rb(maxspec),rc(maxspec),raquer,ylat
+ real :: ra,ust,temp,tc,pa,L,gr,rh,rr,myl,nyl,rhoa,diffh2o,snow
+ real :: slanduse(numclass)
+ real,parameter :: eps=1.e-5
+ real(kind=dp) :: jul
+
+ ! Calculate month and determine the seasonal category
+ !****************************************************
+
+ jul=bdate+real(wftime(n),kind=dp)/86400._dp
+
+ ylat=jy*dy+ylat0
+ if (ylat.lt.0) then
+ jul=jul+365/2
+ endif
+
+
+ call caldate(jul,yyyymmdd,hhmmss)
+ yyyy=yyyymmdd/10000
+ mmdd=yyyymmdd-10000*yyyy
+
+ if ((ylat.gt.-20).and.(ylat.lt.20)) then
+ mmdd=600 ! summer
+ endif
+
+ if ((mmdd.ge.1201).or.(mmdd.le.301)) then
+ lseason=4
+ else if ((mmdd.ge.1101).or.(mmdd.le.331)) then
+ lseason=3
+ else if ((mmdd.ge.401).and.(mmdd.le.515)) then
+ lseason=5
+ else if ((mmdd.ge.516).and.(mmdd.le.915)) then
+ lseason=1
+ else
+ lseason=2
+ endif
+
+ ! Calculate diffusivity of water vapor
+ !************************************
+ diffh2o=2.11e-5*(temp/273.15)**1.94*(101325/pa)
+
+ ! Conversion of temperature from K to C
+ !**************************************
+
+ tc=temp-273.15
+
+ ! Calculate dynamic viscosity
+ !****************************
+
+ ! Why is this different from the viscosity funtion???
+
+ if (tc.lt.0) then
+ myl=(1.718+0.0049*tc-1.2e-05*tc**2)*1.e-05
+ else
+ myl=(1.718+0.0049*tc)*1.e-05
+ endif
+
+ ! Calculate kinematic viscosity
+ !******************************
+
+ rhoa=pa/(287.*temp)
+ nyl=myl/rhoa
+
+
+ ! 0. Set all deposition velocities zero
+ !**************************************
+
+ do i=1,nspec
+ vdepo(i)=0.
+ end do
+
+
+ ! 1. Compute surface layer resistances rb
+ !****************************************
+
+ call getrb(nspec,ust,nyl,diffh2o,reldiff,rb)
+
+ ! change for snow
+ do j=1,numclass
+ if (snow.gt.0.001) then ! 10 mm
+ if (j.eq.12) then
+ slanduse(j)=1.
+ else
+ slanduse(j)=0.
+ endif
+ else
+ slanduse(j)=xlanduse(ix,jy,j)
+ endif
+ end do
+
+ raquer=0.
+ do j=1,numclass ! loop over all landuse classes
+
+ if (slanduse(j).gt.eps) then
+
+ ! 2. Calculate aerodynamic resistance ra
+ !***************************************
+
+ ra=raerod(L,ust,z0(j))
+ raquer=raquer+ra*slanduse(j)
+
+ ! 3. Calculate surface resistance for gases
+ !******************************************
+
+ call getrc(nspec,lseason,j,tc,gr,rh,rr,rc)
+
+ ! 4. Calculate deposition velocities for gases and ...
+ ! 5. ... sum deposition velocities for all landuse classes
+ !*********************************************************
+
+ do i=1,nspec
+ if (reldiff(i).gt.0.) then
+ if ((ra+rb(i)+rc(i)).gt.0.) then
+ vd=1./(ra+rb(i)+rc(i))
+ else
+ vd=9.999
+ endif
+ vdepo(i)=vdepo(i)+vd*slanduse(j)
+ endif
+ end do
+ endif
+ end do
+
+
+ ! 6. Calculate deposition velocities for particles
+ !*************************************************
+
+ call partdep(nspec,density,fract,schmi,vset,raquer,ust,nyl, &
+ rhoa,vdepo)
+
+ !if (debug_mode) then
+ ! print*,'getvdep:188: vdepo=', vdepo
+ !stop
+ !endif
+
+ ! 7. If no detailed parameterization available, take constant deposition
+ ! velocity if that is available
+ !***********************************************************************
+
+ do i=1,nspec
+ if ((reldiff(i).lt.0.).and.(density(i).lt.0.).and. &
+ (dryvel(i).gt.0.)) then
+ vdepo(i)=dryvel(i)
+ endif
+ end do
+end subroutine getvdep
+
+subroutine getvdep_nests(n,ix,jy,ust,temp,pa, &
+ L,gr,rh,rr,snow,vdepo,lnest)
+ ! i i i i i i i i i i i o i
+ !*****************************************************************************
+ ! *
+ ! This routine calculates the dry deposition velocities. *
+ ! *
+ ! Author: A. Stohl *
+ ! *
+ ! 20 December 1996 *
+ ! Sabine Eckhardt, Jan 07 *
+ ! if the latitude is negative: add half a year to the julian day *
+ ! *
+ !*****************************************************************************
+ ! *
+ ! Variables: *
+ ! gr [W/m2] global radiation *
+ ! L [m] Obukhov length *
+ ! nyl kinematic viscosity *
+ ! pa [Pa] surface air pressure *
+ ! ra [s/m] aerodynamic resistance *
+ ! raquer [s/m] average aerodynamic resistance *
+ ! rh [0-1] relative humidity *
+ ! rhoa density of the air *
+ ! rr [mm/h] precipitation rate *
+ ! temp [K] 2m temperature *
+ ! tc [C] 2m temperature *
+ ! ust [m/s] friction velocity *
+ ! snow [m of water equivalent] snow depth *
+ ! xlanduse fractions of numclasS landuses for each model grid point *
+ ! *
+ !*****************************************************************************
+ use date_mod
+
+ implicit none
+
+ integer :: yyyymmdd,hhmmss,yyyy,mmdd,n,lseason,i,j,ix,jy,lnest
+ real :: vdepo(maxspec),vd,rb(maxspec),rc(maxspec),raquer,ylat
+ real :: ra,ust,temp,tc,pa,L,gr,rh,rr,myl,nyl,rhoa,diffh2o,snow
+ real :: slanduse(numclass)
+ real,parameter :: eps=1.e-5
+ real(kind=dp) :: jul
+
+ ! Calculate month and determine the seasonal category
+ !****************************************************
+
+ jul=bdate+real(wftime(n),kind=dp)/86400._dp
+
+ ylat=jy*dy+ylat0
+ if (ylat.lt.0) then
+ jul=jul+365/2
+ endif
+
+
+ call caldate(jul,yyyymmdd,hhmmss)
+ yyyy=yyyymmdd/10000
+ mmdd=yyyymmdd-10000*yyyy
+
+ if ((ylat.gt.-20).and.(ylat.lt.20)) then
+ mmdd=600 ! summer
+ endif
+
+ if ((mmdd.ge.1201).or.(mmdd.le.301)) then
+ lseason=4
+ else if ((mmdd.ge.1101).or.(mmdd.le.331)) then
+ lseason=3
+ else if ((mmdd.ge.401).and.(mmdd.le.515)) then
+ lseason=5
+ else if ((mmdd.ge.516).and.(mmdd.le.915)) then
+ lseason=1
+ else
+ lseason=2
+ endif
+
+ ! Calculate diffusivity of water vapor
+ !************************************
+ diffh2o=2.11e-5*(temp/273.15)**1.94*(101325/pa)
+
+ ! Conversion of temperature from K to C
+ !**************************************
+
+ tc=temp-273.15
+
+ ! Calculate dynamic viscosity
+ !****************************
+
+ if (tc.lt.0) then
+ myl=(1.718+0.0049*tc-1.2e-05*tc**2)*1.e-05
+ else
+ myl=(1.718+0.0049*tc)*1.e-05
+ endif
+
+ ! Calculate kinematic viscosity
+ !******************************
+
+ rhoa=pa/(287.*temp)
+ nyl=myl/rhoa
+
+
+ ! 0. Set all deposition velocities zero
+ !**************************************
+
+ do i=1,nspec
+ vdepo(i)=0.
+ end do
+
+
+ ! 1. Compute surface layer resistances rb
+ !****************************************
+
+ call getrb(nspec,ust,nyl,diffh2o,reldiff,rb)
+
+ ! change for snow
+ do j=1,numclass
+ if (snow.gt.0.001) then ! 10 mm
+ if (j.eq.12) then
+ slanduse(j)=1.
+ else
+ slanduse(j)=0.
+ endif
+ else
+ slanduse(j)=xlandusen(ix,jy,j,lnest)
+ endif
+ end do
+
+ raquer=0.
+ do j=1,numclass ! loop over all landuse classes
+
+ if (slanduse(j).gt.eps) then
+
+ ! 2. Calculate aerodynamic resistance ra
+ !***************************************
+
+ ra=raerod(L,ust,z0(j))
+ raquer=raquer+ra*slanduse(j)
+
+ ! 3. Calculate surface resistance for gases
+ !******************************************
+
+ call getrc(nspec,lseason,j,tc,gr,rh,rr,rc)
+
+ ! 4. Calculate deposition velocities for gases and ...
+ ! 5. ... sum deposition velocities for all landuse classes
+ !*********************************************************
+
+ do i=1,nspec
+ if (reldiff(i).gt.0.) then
+ if ((ra+rb(i)+rc(i)).gt.0.) then
+ vd=1./(ra+rb(i)+rc(i))
+ ! XXXXXXXXXXXXXXXXXXXXXXXXXX TEST
+ ! vd=1./rc(i)
+ ! XXXXXXXXXXXXXXXXXXXXXXXXXX TEST
+ else
+ vd=9.999
+ endif
+ vdepo(i)=vdepo(i)+vd*slanduse(j)
+ endif
+ end do
+ endif
+ end do
+
+
+ ! 6. Calculate deposition velocities for particles
+ !*************************************************
+
+ call partdep(nspec,density,fract,schmi,vset,raquer,ust,nyl, &
+ rhoa,vdepo)
+
+ ! 7. If no detailed parameterization available, take constant deposition
+ ! velocity if that is available
+ !***********************************************************************
+
+ do i=1,nspec
+ if ((reldiff(i).lt.0.).and.(density(i).lt.0.).and. &
+ (dryvel(i).gt.0.)) then
+ vdepo(i)=dryvel(i)
+ endif
+ end do
+end subroutine getvdep_nests
+
+subroutine partdep(nc,density,fract,schmi,vset,ra,ustar,nyl,rhoa,vdep)
+ ! i i i i i i i i i, i, i/o
+ !*****************************************************************************
+ ! *
+ ! Calculation of the dry deposition velocities of particles. *
+ ! This routine is based on Stokes' law for considering settling and *
+ ! assumes constant dynamic viscosity of the air. *
+ ! *
+ ! AUTHOR: Andreas Stohl, 12 November 1993 *
+ ! Update: 20 December 1996 *
+ ! *
+ ! Literature: *
+ ! [1] Hicks/Baldocchi/Meyers/Hosker/Matt (1987), A Preliminary *
+ ! Multiple Resistance Routine for Deriving Dry Deposition *
+ ! Velocities from Measured Quantities. *
+ ! Water, Air and Soil Pollution 36 (1987), pp.311-330. *
+ ! [2] Slinn (1982), Predictions for Particle Deposition to *
+ ! Vegetative Canopies. Atm.Env.16-7 (1982), pp.1785-1794. *
+ ! [3] Slinn/Slinn (1980), Predictions for Particle Deposition on *
+ ! Natural Waters. Atm.Env.14 (1980), pp.1013-1016. *
+ ! [4] Scire/Yamartino/Carmichael/Chang (1989), *
+ ! CALGRID: A Mesoscale Photochemical Grid Model. *
+ ! Vol II: User's Guide. (Report No.A049-1, June, 1989) *
+ ! [5] Langer M. (1992): Ein einfaches Modell zur Abschaetzung der *
+ ! Depositionsgeschwindigkeit von Teilchen und Gasen. *
+ ! Internal report. *
+ ! *
+ !*****************************************************************************
+ ! *
+ ! Variables: *
+ ! alpha help variable *
+ ! fract(nc,ni) mass fraction of each diameter interval *
+ ! lpdep(nc) 1 for particle deposition, 0 else *
+ ! nc actual number of chemical components *
+ ! ni number of diameter intervals, for which vdepj is calc.*
+ ! rdp [s/m] deposition layer resistance *
+ ! ra [s/m] aerodynamical resistance *
+ ! schmi(nc,ni) Schmidt number**2/3 of each diameter interval *
+ ! stokes Stokes number *
+ ! ustar [m/s] friction velocity *
+ ! vdep(nc) [m/s] deposition velocities of all components *
+ ! vdepj [m/s] help, deposition velocity of 1 interval *
+ ! vset(nc,ni) gravitational settling velocity of each interval *
+ ! *
+ ! Constants: *
+ ! nc number of chemical species *
+ ! ni number of diameter intervals, for which deposition *
+ ! is calculated *
+ ! *
+ !*****************************************************************************
+
+ implicit none
+
+ real, intent(in) :: &
+ nyl, & ! kinematic viscosity
+ rhoa, & ! air density
+ ustar, & ! friction velocity
+ ra, & ! aerodynamical resistance
+ vset(maxspec,maxndia), & ! gravitational settling velocity of each interval
+ density(maxspec), & ! density of the particle
+ fract(maxspec,maxndia) ! mass fraction of each diameter interval
+ real, intent(inout) :: &
+ vdep(maxspec)
+ real :: schmi(maxspec,maxndia)
+ real :: stokes,vdepj,rdp,alpha
+ real :: & ! Variables related to shape
+ dfdr, alpha1, alpha2, beta1, beta2, ks, kn, c_d, &
+ settling, settling_old, reynolds, ks1, ks2, kn1, kn2
+
+ real,parameter :: eps=1.e-5
+ integer :: ic,j,nc,i
+
+
+ do ic=1,nc ! loop over all species
+ if (density(ic).gt.0.) then
+ do j=1,ndia(ic) ! loop over all diameter intervals
+ if (ustar.gt.eps) then
+ if (shape(ic).eq.0) then
+
+ ! Stokes number for each diameter interval
+ !*****************************************
+ ! Use this stokes number for different shapes
+ stokes=vset(ic,j)/ga*ustar*ustar/nyl
+ alpha=-3./stokes
+
+ ! Deposition layer resistance
+ !****************************
+
+ if (alpha.le.log10(eps)) then
+ rdp=1./(schmi(ic,j)*ustar)
+ else
+ rdp=1./((schmi(ic,j)+10.**alpha)*ustar)
+ endif
+
+ vdepj=vset(ic,j)+1./(ra+rdp+ra*rdp*vset(ic,j))
+
+ else ! Daria Tatsii: Drag coefficient scheme by Bagheri & Bonadonna 2016
+ ! Settling velocities of other shapes
+ dfdr=density(ic)/rhoa
+
+ reynolds=dquer(ic)/1.e6*vset(ic,j)/nyl
+ settling_old=-1.0*vset(ic,j)
+
+ ! Orientation of particles
+ !*************************
+ if (orient(ic).eq.0) then
+ ! Horizontal orientation
+ alpha2=0.77 ! B&B: eq. 32
+ beta2=0.63
+ ks=0.5*((Fs(ic)**0.05)+(Fs(ic)**(-0.36))) ! B&B Figure 12 k_(s,max)
+ kn=10.**(alpha2*(-log10(Fn(ic)))**beta2)
+ else if (orient(ic).eq.1) then
+ ! Random orientation
+ alpha1=0.45+10.0/(exp(2.5*log10(dfdr))+30.0)
+ beta1=1.-37.0/(exp(3.0*log10(dfdr))+100.0)
+ ks=(Fs(ic)**(1./3.) + Fs(ic)**(-1./3))/2.
+ kn=10.**(alpha1*(-log10(Fn(ic)))**beta1)
+ else
+ ! The average of random and horizontal orientation
+ alpha1=0.45+10.0/(exp(2.5*log10(dfdr))+30.0)
+ beta1=1.-37.0/(exp(3.0*log10(dfdr))+100.0)
+ alpha2=0.77 ! B&B: eq. 32
+ beta2=0.63
+ ks1=(Fs(ic)**(1./3.) + Fs(ic)**(-1./3))/2.
+ kn1=10.**(alpha1*(-log10(Fn(ic)))**beta1)
+ ks2=0.5*((Fs(ic)**0.05)+(Fs(ic)**(-0.36))) ! B&B Figure 12 k_(s,max)
+ kn2=10.**(alpha2*(-log10(Fn(ic)))**beta2)
+ ks=(ks1+ks2)/2.
+ kn=(kn1+kn2)/2.
+ endif
+
+ do i=1,20
+ c_d=(24.*ks/reynolds)*(1.+0.125*((reynolds*kn/ks)**(2./3.)))+ &
+ (0.46*kn/(1.+5330./(reynolds*kn/ks)))
+
+ ! Settling velocity of a particle is defined by the Newton's impact law:
+ settling=-1.* &
+ sqrt(4.*ga*dquer(ic)/1.e6*density(ic)*cunningham(ic)/ &
+ (3.*c_d*rhoa))
+
+ if (abs((settling-settling_old)/settling).lt.0.01) exit
+
+ reynolds=dquer(ic)/1.e6*abs(settling)/nyl
+ settling_old=settling
+ end do
+ ! We assume aerodynamic resistance ra and quasi-laminar sub-layer resistance rdp
+ ! Stokes number for each diameter interval
+ !*****************************************
+ ! Use this stokes number for different shapes
+ stokes=abs(settling)/ga*ustar*ustar/nyl
+ alpha=-3./stokes
+
+ ! Deposition layer resistance
+ !****************************
+
+ if (alpha.le.log10(eps)) then
+ rdp=1./(schmi(ic,j)*ustar)
+ else
+ rdp=1./((schmi(ic,j)+10.**alpha)*ustar)
+ endif
+
+
+ vdepj=abs(settling)+1./(ra+rdp+ra*rdp*abs(settling))
+
+ endif
+
+ else
+ vdepj=vset(ic,j)
+ endif
+
+ ! deposition velocities of each interval are weighted with mass fraction
+ !***********************************************************************
+
+ vdep(ic)=vdep(ic)+vdepj*fract(ic,j)
+
+ end do
+ endif
+ end do
+
+end subroutine partdep
+
+subroutine getrb(nc,ustar,nyl,diffh2o,reldiff,rb)
+ ! i i i i i o
+ !*****************************************************************************
+ ! *
+ ! Calculation of the quasilaminar sublayer resistance to dry deposition. *
+ ! *
+ ! AUTHOR: Andreas Stohl, 20 May 1995 *
+ ! *
+ !*****************************************************************************
+ ! *
+ ! Variables: *
+ ! rb(ncmax) sublayer resistance *
+ ! schmidt Schmidt number *
+ ! ustar [m/s] friction velocity *
+ ! diffh20 [m2/s] diffusivity of water vapor in air *
+ ! reldiff diffusivity relative to H2O *
+ ! *
+ ! Constants: *
+ ! karman von Karman constant *
+ ! pr Prandtl number *
+ ! *
+ !*****************************************************************************
+
+ implicit none
+
+ real :: ustar,diffh2o,rb(maxspec),schmidt,nyl
+ real :: reldiff(maxspec)
+ integer :: ic,nc
+ real,parameter :: pr=0.72
+
+ do ic=1,nc
+ if (reldiff(ic).gt.0.) then
+ schmidt=nyl/diffh2o*reldiff(ic)
+ rb(ic)=2.0*(schmidt/pr)**0.67/(karman*ustar)
+ endif
+ end do
+end subroutine getrb
+
+subroutine getrc(nc,i,j,t,gr,rh,rr,rc)
+ ! i i i i i i i o
+ !*****************************************************************************
+ ! *
+ ! Calculation of the surface resistance according to the procedure given *
+ ! in: *
+ ! Wesely (1989): Parameterization of surface resistances to gaseous *
+ ! dry deposition in regional-scale numerical models. *
+ ! Atmos. Environ. 23, 1293-1304. *
+ ! *
+ ! *
+ ! AUTHOR: Andreas Stohl, 19 May 1995 *
+ ! *
+ !*****************************************************************************
+ ! *
+ ! Variables: *
+ ! *
+ ! reldiff(maxspec) diffusivity of H2O/diffusivity of component i *
+ ! gr [W/m2] global radiation *
+ ! i index of seasonal category *
+ ! j index of landuse class *
+ ! ldep(maxspec) 1, if deposition shall be calculated for species i *
+ ! nc actual number of chemical components *
+ ! rcl(maxspec,5,8) [s/m] Lower canopy resistance *
+ ! rgs(maxspec,5,8) [s/m] Ground resistance *
+ ! rlu(maxspec,5,8) [s/m] Leaf cuticular resistance *
+ ! rm(maxspec) [s/m] Mesophyll resistance *
+ ! t [C] temperature *
+ ! *
+ !*****************************************************************************
+
+ implicit none
+
+ integer :: i,j,ic,nc
+ real :: gr,rh,rr,t,rs,rsm,corr,rluc,rclc,rgsc,rdc,rluo
+ real :: rc(maxspec)
+
+
+ ! Compute stomatal resistance
+ !****************************
+ ! Sabine Eckhardt, Dec 06: use 1E25 instead of 99999. for infinite res.
+
+ if ((t.gt.0.).and.(t.lt.40.)) then
+ rs=ri(i,j)*(1.+(200./(gr+0.1))**2)*(400./(t*(40.-t)))
+ else
+ rs=1.E25
+ ! rs=99999.
+ endif
+
+
+ ! Correct stomatal resistance for effect of dew and rain
+ !*******************************************************
+
+ if ((rh.gt.0.9).or.(rr.gt.0.)) rs=rs*3.
+
+ ! Compute the lower canopy resistance
+ !************************************
+
+ rdc=100.*(1.+1000./(gr+10.))
+
+
+ corr=1000.*exp(-1.*t-4.)
+ do ic=1,nc
+ if (reldiff(ic).gt.0.) then
+
+ ! Compute combined stomatal and mesophyll resistance
+ !***************************************************
+
+ rsm=rs*reldiff(ic)+rm(ic)
+
+ ! Correct leaf cuticular, lower canopy and ground resistance
+ !***********************************************************
+
+ rluc=rlu(ic,i,j)+corr
+ rclc=rcl(ic,i,j)+corr
+ rgsc=rgs(ic,i,j)+corr
+
+ ! Correct leaf cuticular resistance for effect of dew and rain
+ !*************************************************************
+
+ if (rr.gt.0.) then
+ rluo=1./(1./1000.+1./(3.*rluc))
+ rluc=1./(1./(3.*rluc)+1.e-7*henry(ic)+f0(ic)/rluo)
+ else if (rh.gt.0.9) then
+ rluo=1./(1./3000.+1./(3.*rluc))
+ rluc=1./(1./(3.*rluc)+1.e-7*henry(ic)+f0(ic)/rluo)
+ endif
+
+ ! Combine resistances to give total resistance
+ !*********************************************
+
+ rc(ic)=1./(1./rsm+1./rluc+1./(rdc+rclc)+1./(rac(i,j)+rgsc))
+ ! Sabine Eckhardt, Dec 06: avoid possible excessively high vdep
+ if (rc(ic).lt.10.) rc(ic)=10.
+ endif
+ end do
+end subroutine getrc
+
+end module drydepo_mod
diff --git a/src/erf.f90 b/src/erf_mod.f90
similarity index 93%
rename from src/erf.f90
rename to src/erf_mod.f90
index 1e0eff6c..9fc13a44 100644
--- a/src/erf.f90
+++ b/src/erf_mod.f90
@@ -1,6 +1,16 @@
! SPDX-FileCopyrightText: FLEXPART 1998-2019, see flexpart_license.txt
! SPDX-License-Identifier: GPL-3.0-or-later
+module erf_mod
+
+ implicit none
+
+ private :: gammln,gammp,gammq,gser,gcf
+ public :: erf,erfc,erfcc
+
+contains
+
+
! To be used, if the non-standard Fortran function erf does not exist on
! your machine
!
@@ -85,7 +95,7 @@ subroutine gser(gamser,a,x,gln)
integer :: n
real :: gamser, a, x, gln, ap, summ, del
- real, external :: gammln
+ !real, external :: gammln
integer,parameter :: itmax=100
real,parameter :: eps=3.e-7
@@ -119,7 +129,7 @@ subroutine gcf(gammcf,a,x,gln)
integer :: n
real :: gammcf, a, x, gln, gold, a0, a1, b0, b1, fac, an, anf, ana, g
- real, external :: gammln
+ !real, external :: gammln
integer,parameter :: itmax=100
real,parameter :: eps=3.e-7
@@ -156,7 +166,7 @@ function erf(x)
implicit none
real :: x, erf
- real, external :: gammp
+ !real, external :: gammp
if(x.lt.0.)then
erf=-gammp(.5,x**2)
@@ -170,7 +180,7 @@ function erfc(x)
implicit none
real :: x, erfc
- real, external :: gammp, gammq
+ !real, external :: gammp, gammq
if(x.lt.0.)then
erfc=1.+gammp(.5,x**2)
@@ -192,3 +202,5 @@ function erfcc(x)
t*(1.48851587+t*(-.82215223+t*.17087277)))))))))
if (x.lt.0.) erfcc=2.-erfcc
end function erfcc
+
+end module erf_mod
diff --git a/src/ew.f90 b/src/ew.f90
deleted file mode 100644
index 38c0b0f3..00000000
--- a/src/ew.f90
+++ /dev/null
@@ -1,29 +0,0 @@
-! SPDX-FileCopyrightText: FLEXPART 1998-2019, see flexpart_license.txt
-! SPDX-License-Identifier: GPL-3.0-or-later
-
-real function ew(x)
-
- !****************************************************************
- !SAETTIGUNGSDAMPFDRUCK UEBER WASSER IN PA. X IN KELVIN.
- !NACH DER GOFF-GRATCH-FORMEL.
- !****************************************************************
-
- implicit none
-
- real :: x, y, a, c, d
-
- ew=0.
- if(x.le.0.) stop 'sorry: t not in [k]'
- y=373.16/x
- a=-7.90298*(y-1.)
- a=a+(5.02808*0.43429*alog(y))
- c=(1.-(1./y))*11.344
- c=-1.+(10.**c)
- c=-1.3816*c/(10.**7)
- d=(1.-y)*3.49149
- d=-1.+(10.**d)
- d=8.1328*d/(10.**3)
- y=a+c+d
- ew=101324.6*(10.**y) ! Saettigungsdampfdruck in Pa
-
-end function ew
diff --git a/src/flux_mod.f90 b/src/flux_mod.f90
index c1f44130..57606034 100644
--- a/src/flux_mod.f90
+++ b/src/flux_mod.f90
@@ -6,10 +6,15 @@ module flux_mod
! flux eastward, westward, northward, southward, upward and downward
! fluxes of all species and all ageclasses
! areaeast,areanorth [m2] side areas of each grid cell
+ use outg_mod
+ use par_mod
+ use com_mod
+ use windfields_mod
implicit none
- real,allocatable, dimension (:,:,:,:,:,:,:) :: flux
+ !Moved to outg_mod, because of dependencies
+ ! real,allocatable, dimension (:,:,:,:,:,:,:) :: flux
!1 fluxw west - east
!2 fluxe east - west
@@ -20,4 +25,521 @@ module flux_mod
!real,allocatable, dimension (:,:,:) :: areanorth
!real,allocatable, dimension (:,:,:) :: areaeast
+contains
+
+subroutine calcfluxes(itime,nage,jpart,xold,yold,zold,thread)
+ ! i i i i i
+ !*****************************************************************************
+ ! *
+ ! Calculation of the gross fluxes across horizontal, eastward and *
+ ! northward facing surfaces. The routine calculates the mass flux *
+ ! due to the motion of only one particle. The fluxes of subsequent calls *
+ ! to this subroutine are accumulated until the next output is due. *
+ ! Upon output, flux fields are re-set to zero in subroutine fluxoutput.f.*
+ ! *
+ ! Author: A. Stohl *
+ ! *
+ ! 04 April 2000 *
+ ! *
+ ! Changes *
+ ! 2021 L. Bakels: OpenMP parallelisation *
+ ! *
+ !*****************************************************************************
+ ! *
+ ! Variables: *
+ ! *
+ ! nage Age class of the particle considered *
+ ! jpart Index of the particle considered *
+ ! xold,yold,zold "Memorized" old positions of the particle *
+ ! *
+ !*****************************************************************************
+
+ use particle_mod
+ use coordinates_ecmwf_mod
+
+ implicit none
+ integer, intent(in) :: thread ! for OMP, number of thread
+ integer :: itime,jpart,nage,ixave,jyave,kz,kzave,kp
+ integer :: k,k1,k2,ix,ix1,ix2,ixs,jy,jy1,jy2
+ real :: xold,yold,zold,xmean,ymean
+
+
+ ! Determine average positions
+ !****************************
+
+ if ((ioutputforeachrelease.eq.1).and.(mdomainfill.eq.0)) then
+ kp=part(jpart)%npoint
+ else
+ kp=1
+ endif
+ call update_zeta_to_z(itime,jpart)
+ xmean=(xold+part(jpart)%xlon)/2.
+ ymean=(yold+part(jpart)%ylat)/2.
+
+ ixave=int((xmean*dx+xoutshift)/dxout)
+ jyave=int((ymean*dy+youtshift)/dyout)
+ do kz=1,numzgrid ! determine height of cell
+ if (outheight(kz).gt.part(jpart)%z) exit
+ end do
+ kzave=kz
+
+
+ ! Determine vertical fluxes
+ !**************************
+
+ if ((ixave.ge.0).and.(jyave.ge.0).and.(ixave.le.numxgrid-1).and. &
+ (jyave.le.numygrid-1)) then
+ do kz=1,numzgrid ! determine height of cell
+ if (outheighthalf(kz).gt.zold) exit
+ end do
+ k1=min(numzgrid,kz)
+ do kz=1,numzgrid ! determine height of cell
+ if (outheighthalf(kz).gt.part(jpart)%z) exit
+ end do
+ k2=min(numzgrid,kz)
+
+ do k=1,nspec
+ do kz=k1,k2-1
+#ifdef _OPENMP
+ flux_omp(5,ixave,jyave,kz,k,kp,nage,thread)= &
+ flux_omp(5,ixave,jyave,kz,k,kp,nage,thread)+ &
+ part(jpart)%mass(k)
+#else
+ flux(5,ixave,jyave,kz,k,kp,nage)= &
+ flux(5,ixave,jyave,kz,k,kp,nage)+ &
+ part(jpart)%mass(k)
+#endif
+ end do
+ do kz=k2,k1-1
+#ifdef _OPENMP
+ flux_omp(6,ixave,jyave,kz,k,kp,nage,thread)= &
+ flux_omp(6,ixave,jyave,kz,k,kp,nage,thread)+ &
+ part(jpart)%mass(k)
+#else
+ flux(6,ixave,jyave,kz,k,kp,nage)= &
+ flux(6,ixave,jyave,kz,k,kp,nage)+ &
+ part(jpart)%mass(k)
+#endif
+ end do
+ end do
+ endif
+
+
+ ! Determine west-east fluxes (fluxw) and east-west fluxes (fluxe)
+ !****************************************************************
+
+ if ((kzave.le.numzgrid).and.(jyave.ge.0).and. &
+ (jyave.le.numygrid-1)) then
+
+ ! 1) Particle does not cross domain boundary
+
+ if (abs(xold-part(jpart)%xlon).lt.real(nx)/2.) then
+ ix1=int((xold*dx+xoutshift)/dxout+0.5)
+ ix2=int((part(jpart)%xlon*dx+xoutshift)/dxout+0.5)
+ do k=1,nspec
+ do ix=ix1,ix2-1
+ if ((ix.ge.0).and.(ix.le.numxgrid-1)) then
+#ifdef _OPENMP
+ flux_omp(1,ix,jyave,kzave,k,kp,nage,thread)= &
+ flux_omp(1,ix,jyave,kzave,k,kp,nage,thread) &
+ +part(jpart)%mass(k)
+#else
+ flux(1,ix,jyave,kzave,k,kp,nage)= &
+ flux(1,ix,jyave,kzave,k,kp,nage) &
+ +part(jpart)%mass(k)
+#endif
+ endif
+ end do
+ do ix=ix2,ix1-1
+ if ((ix.ge.0).and.(ix.le.numxgrid-1)) then
+#ifdef _OPENMP
+ flux_omp(2,ix,jyave,kzave,k,kp,nage,thread)= &
+ flux_omp(2,ix,jyave,kzave,k,kp,nage,thread) &
+ +part(jpart)%mass(k)
+#else
+ flux(2,ix,jyave,kzave,k,kp,nage)= &
+ flux(2,ix,jyave,kzave,k,kp,nage) &
+ +part(jpart)%mass(k)
+#endif
+ endif
+ end do
+ end do
+
+ ! 2) Particle crosses domain boundary: use cyclic boundary condition
+ ! and attribute flux to easternmost grid row only (approximation valid
+ ! for relatively slow motions compared to output grid cell size)
+
+ else
+ ixs=int(((real(nxmin1)-1.e5)*dx+xoutshift)/dxout)
+ if ((ixs.ge.0).and.(ixs.le.numxgrid-1)) then
+ if (xold.gt.part(jpart)%xlon) then ! west-east flux
+ do k=1,nspec
+#ifdef _OPENMP
+ flux_omp(1,ixs,jyave,kzave,k,kp,nage,thread)= &
+ flux_omp(1,ixs,jyave,kzave,k,kp,nage,thread) &
+ +part(jpart)%mass(k)
+#else
+ flux(1,ixs,jyave,kzave,k,kp,nage)= &
+ flux(1,ixs,jyave,kzave,k,kp,nage) &
+ +part(jpart)%mass(k)
+#endif
+ end do
+ else ! east-west flux
+ do k=1,nspec
+#ifdef _OPENMP
+ flux_omp(2,ixs,jyave,kzave,k,kp,nage,thread)= &
+ flux_omp(2,ixs,jyave,kzave,k,kp,nage,thread) &
+ +part(jpart)%mass(k)
+#else
+ flux(2,ixs,jyave,kzave,k,kp,nage)= &
+ flux(2,ixs,jyave,kzave,k,kp,nage) &
+ +part(jpart)%mass(k)
+#endif
+ end do
+ endif
+ endif
+ endif
+ endif
+
+
+ ! Determine south-north fluxes (fluxs) and north-south fluxes (fluxn)
+ !********************************************************************
+
+ if ((kzave.le.numzgrid).and.(ixave.ge.0).and. &
+ (ixave.le.numxgrid-1)) then
+ jy1=int((yold*dy+youtshift)/dyout+0.5)
+ jy2=int((part(jpart)%ylat*dy+youtshift)/dyout+0.5)
+
+ do k=1,nspec
+ do jy=jy1,jy2-1
+ if ((jy.ge.0).and.(jy.le.numygrid-1)) then
+#ifdef _OPENMP
+ flux_omp(3,ixave,jy,kzave,k,kp,nage,thread)= &
+ flux_omp(3,ixave,jy,kzave,k,kp,nage,thread) &
+ +part(jpart)%mass(k)
+#else
+ flux(3,ixave,jy,kzave,k,kp,nage)= &
+ flux(3,ixave,jy,kzave,k,kp,nage) &
+ +part(jpart)%mass(k)
+#endif
+ endif
+ end do
+ do jy=jy2,jy1-1
+ if ((jy.ge.0).and.(jy.le.numygrid-1)) then
+#ifdef _OPENMP
+ flux_omp(4,ixave,jy,kzave,k,kp,nage,thread)= &
+ flux_omp(4,ixave,jy,kzave,k,kp,nage,thread) &
+ +part(jpart)%mass(k)
+#else
+ flux(4,ixave,jy,kzave,k,kp,nage)= &
+ flux(4,ixave,jy,kzave,k,kp,nage) &
+ +part(jpart)%mass(k)
+#endif
+ endif
+ end do
+ end do
+ endif
+end subroutine calcfluxes
+
+subroutine fluxoutput(itime)
+ ! i
+ !*****************************************************************************
+ ! *
+ ! Output of the gridded fluxes. *
+ ! Eastward, westward, northward, southward, upward and downward gross *
+ ! fluxes are written to output file in either sparse matrix or grid dump *
+ ! format, whichever is more efficient. *
+ ! *
+ ! Author: A. Stohl *
+ ! *
+ ! 04 April 2000 *
+ ! *
+ !*****************************************************************************
+ ! *
+ ! Variables: *
+ ! ncellse number of cells with non-zero values for eastward fluxes *
+ ! sparsee .true. if in sparse matrix format, else .false. *
+ ! *
+ !*****************************************************************************
+ use date_mod
+
+ implicit none
+
+ real(kind=dp) :: jul
+ integer :: itime,ix,jy,kz,k,nage,jjjjmmdd,ihmmss,kp,i
+ integer :: ncellse(maxspec,maxageclass),ncellsw(maxspec,maxageclass)
+ integer :: ncellss(maxspec,maxageclass),ncellsn(maxspec,maxageclass)
+ integer :: ncellsu(maxspec,maxageclass),ncellsd(maxspec,maxageclass)
+ logical :: sparsee(maxspec,maxageclass),sparsew(maxspec,maxageclass)
+ logical :: sparses(maxspec,maxageclass),sparsen(maxspec,maxageclass)
+ logical :: sparseu(maxspec,maxageclass),sparsed(maxspec,maxageclass)
+ character :: adate*8,atime*6
+
+
+ ! Determine current calendar date, needed for the file name
+ !**********************************************************
+
+ jul=bdate+real(itime,kind=dp)/86400._dp
+ call caldate(jul,jjjjmmdd,ihmmss)
+ write(adate,'(i8.8)') jjjjmmdd
+ write(atime,'(i6.6)') ihmmss
+
+
+ open(unitflux,file=path(2)(1:length(2))//'grid_flux_'//adate// &
+ atime,form='unformatted')
+
+ !**************************************************************
+ ! Check, whether output of full grid or sparse matrix format is
+ ! more efficient in terms of storage space. This is checked for
+ ! every species and for every age class
+ !**************************************************************
+
+ do k=1,nspec
+ do nage=1,nageclass
+ ncellse(k,nage)=0
+ ncellsw(k,nage)=0
+ ncellsn(k,nage)=0
+ ncellss(k,nage)=0
+ ncellsu(k,nage)=0
+ ncellsd(k,nage)=0
+ end do
+ end do
+
+ do k=1,nspec
+ do kp=1,maxpointspec_act
+ do nage=1,nageclass
+ do jy=0,numygrid-1
+ do ix=0,numxgrid-1
+ do kz=1,numzgrid
+ if (flux(2,ix,jy,kz,k,kp,nage).gt.0) ncellse(k,nage)= &
+ ncellse(k,nage)+1
+ if (flux(1,ix,jy,kz,k,kp,nage).gt.0) ncellsw(k,nage)= &
+ ncellsw(k,nage)+1
+ if (flux(4,ix,jy,kz,k,kp,nage).gt.0) ncellsn(k,nage)= &
+ ncellsn(k,nage)+1
+ if (flux(3,ix,jy,kz,k,kp,nage).gt.0) ncellss(k,nage)= &
+ ncellss(k,nage)+1
+ if (flux(5,ix,jy,kz,k,kp,nage).gt.0) ncellsu(k,nage)= &
+ ncellsu(k,nage)+1
+ if (flux(6,ix,jy,kz,k,kp,nage).gt.0) ncellsd(k,nage)= &
+ ncellsd(k,nage)+1
+ end do
+ end do
+ end do
+ end do
+ end do
+ end do
+
+ ! Output in sparse matrix format more efficient, if less than
+ ! 2/5 of all cells contains concentrations>0
+ !************************************************************
+
+ do k=1,nspec
+ do nage=1,nageclass
+ if (4*ncellse(k,nage).lt.numxgrid*numygrid*numzgrid) then
+ sparsee(k,nage)=.true.
+ else
+ sparsee(k,nage)=.false.
+ endif
+ if (4*ncellsw(k,nage).lt.numxgrid*numygrid*numzgrid) then
+ sparsew(k,nage)=.true.
+ else
+ sparsew(k,nage)=.false.
+ endif
+ if (4*ncellsn(k,nage).lt.numxgrid*numygrid*numzgrid) then
+ sparsen(k,nage)=.true.
+ else
+ sparsen(k,nage)=.false.
+ endif
+ if (4*ncellss(k,nage).lt.numxgrid*numygrid*numzgrid) then
+ sparses(k,nage)=.true.
+ else
+ sparses(k,nage)=.false.
+ endif
+ if (4*ncellsu(k,nage).lt.numxgrid*numygrid*numzgrid) then
+ sparseu(k,nage)=.true.
+ else
+ sparseu(k,nage)=.false.
+ endif
+ if (4*ncellsd(k,nage).lt.numxgrid*numygrid*numzgrid) then
+ sparsed(k,nage)=.true.
+ else
+ sparsed(k,nage)=.false.
+ endif
+ end do
+ end do
+
+
+
+ ! Flux output: divide by area and time to get flux in ng/m2/s
+ !************************************************************
+
+ write(unitflux) itime
+ do k=1,nspec
+ do kp=1,maxpointspec_act
+ do nage=1,nageclass
+
+ if (sparsee(k,nage)) then
+ write(unitflux) 1
+ do kz=1,numzgrid
+ do jy=0,numygrid-1
+ do ix=0,numxgrid-1
+ if (flux(2,ix,jy,kz,k,kp,nage).gt.0.) write(unitflux) &
+ ix+jy*numxgrid+kz*numxgrid*numygrid,1.e12* &
+ flux(2,ix,jy,kz,k,kp,nage)/areaeast(ix,jy,kz)/outstep
+ end do
+ end do
+ end do
+ write(unitflux) -999,999.
+ else
+ write(unitflux) 2
+ do kz=1,numzgrid
+ do ix=0,numxgrid-1
+ write(unitflux) (1.e12*flux(2,ix,jy,kz,k,kp,nage)/ &
+ areaeast(ix,jy,kz)/outstep,jy=0,numygrid-1)
+ end do
+ end do
+ endif
+
+ if (sparsew(k,nage)) then
+ write(unitflux) 1
+ do kz=1,numzgrid
+ do jy=0,numygrid-1
+ do ix=0,numxgrid-1
+ if (flux(1,ix,jy,kz,k,kp,nage).gt.0.) write(unitflux) &
+ ix+jy*numxgrid+kz*numxgrid*numygrid,1.e12* &
+ flux(1,ix,jy,kz,k,kp,nage)/areaeast(ix,jy,kz)/outstep
+ end do
+ end do
+ end do
+ write(unitflux) -999,999.
+ else
+ write(unitflux) 2
+ do kz=1,numzgrid
+ do ix=0,numxgrid-1
+ write(unitflux) (1.e12*flux(1,ix,jy,kz,k,kp,nage)/ &
+ areaeast(ix,jy,kz)/outstep,jy=0,numygrid-1)
+ end do
+ end do
+ endif
+
+ if (sparses(k,nage)) then
+ write(unitflux) 1
+ do kz=1,numzgrid
+ do jy=0,numygrid-1
+ do ix=0,numxgrid-1
+ if (flux(3,ix,jy,kz,k,kp,nage).gt.0.) write(unitflux) &
+ ix+jy*numxgrid+kz*numxgrid*numygrid,1.e12* &
+ flux(3,ix,jy,kz,k,kp,nage)/areanorth(ix,jy,kz)/outstep
+ end do
+ end do
+ end do
+ write(unitflux) -999,999.
+ else
+ write(unitflux) 2
+ do kz=1,numzgrid
+ do ix=0,numxgrid-1
+ write(unitflux) (1.e12*flux(3,ix,jy,kz,k,kp,nage)/ &
+ areanorth(ix,jy,kz)/outstep,jy=0,numygrid-1)
+ end do
+ end do
+ endif
+
+ if (sparsen(k,nage)) then
+ write(unitflux) 1
+ do kz=1,numzgrid
+ do jy=0,numygrid-1
+ do ix=0,numxgrid-1 ! north
+ if (flux(4,ix,jy,kz,k,kp,nage).gt.0.) write(unitflux) &
+ ix+jy*numxgrid+kz*numxgrid*numygrid,1.e12* &
+ flux(4,ix,jy,kz,k,kp,nage)/areanorth(ix,jy,kz)/outstep
+ end do
+ end do
+ end do
+ write(unitflux) -999,999.
+ else
+ write(unitflux) 2
+ do kz=1,numzgrid
+ do ix=0,numxgrid-1
+ write(unitflux) (1.e12*flux(4,ix,jy,kz,k,kp,nage)/ &
+ areanorth(ix,jy,kz)/outstep,jy=0,numygrid-1)
+ end do
+ end do
+ endif
+
+ if (sparseu(k,nage)) then
+ write(unitflux) 1
+ do kz=1,numzgrid
+ do jy=0,numygrid-1
+ do ix=0,numxgrid-1
+ if (flux(5,ix,jy,kz,k,kp,nage).gt.0.) write(unitflux) &
+ ix+jy*numxgrid+kz*numxgrid*numygrid,1.e12* &
+ flux(5,ix,jy,kz,k,kp,nage)/area(ix,jy)/outstep
+ end do
+ end do
+ end do
+ write(unitflux) -999,999.
+ else
+ write(unitflux) 2
+ do kz=1,numzgrid
+ do ix=0,numxgrid-1
+ write(unitflux) (1.e12*flux(5,ix,jy,kz,k,kp,nage)/ &
+ area(ix,jy)/outstep,jy=0,numygrid-1)
+ end do
+ end do
+ endif
+
+ if (sparsed(k,nage)) then
+ write(unitflux) 1
+ do kz=1,numzgrid
+ do jy=0,numygrid-1
+ do ix=0,numxgrid-1
+ if (flux(6,ix,jy,kz,k,kp,nage).gt.0.) write(unitflux) &
+ ix+jy*numxgrid+kz*numxgrid*numygrid,1.e12* &
+ flux(6,ix,jy,kz,k,kp,nage)/area(ix,jy)/outstep
+ end do
+ end do
+ end do
+ write(unitflux) -999,999.
+ else
+ write(unitflux) 2
+ do kz=1,numzgrid
+ do ix=0,numxgrid-1
+ write(unitflux) (1.e12*flux(6,ix,jy,kz,k,kp,nage)/ &
+ area(ix,jy)/outstep,jy=0,numygrid-1)
+ end do
+ end do
+ endif
+
+ end do
+ end do
+ end do
+
+
+ close(unitflux)
+
+ write(*,*) 'Flux:', itime, flux(:,1,1,1,1,1,1)
+ ! Reinitialization of grid
+ !*************************
+
+ do k=1,nspec
+ do kp=1,maxpointspec_act
+ do jy=0,numygrid-1
+ do ix=0,numxgrid-1
+ do kz=1,numzgrid
+ do nage=1,nageclass
+ do i=1,6
+ flux(i,ix,jy,kz,k,kp,nage)=0.
+#ifdef _OPENMP
+ flux_omp(i,ix,jy,kz,k,kp,nage,:)=0.
+#endif
+ end do
+ end do
+ end do
+ end do
+ end do
+ end do
+ end do
+end subroutine fluxoutput
+
end module flux_mod
diff --git a/src/get_settling.f90 b/src/get_settling.f90
deleted file mode 100644
index f508700e..00000000
--- a/src/get_settling.f90
+++ /dev/null
@@ -1,129 +0,0 @@
-! SPDX-FileCopyrightText: FLEXPART 1998-2019, see flexpart_license.txt
-! SPDX-License-Identifier: GPL-3.0-or-later
-
-subroutine get_settling(itime,xt,yt,zt,nsp,settling)
- ! i i i i i o
- !*****************************************************************************
- ! *
- ! This subroutine calculates particle settling velocity. *
- ! *
- ! Author: A. Stohl *
- ! *
- ! May 2010 *
- ! *
- ! Improvement over traditional settling calculation in FLEXPART: *
- ! generalize to higher Reynolds numbers and also take into account the *
- ! temperature dependence of dynamic viscosity. *
- ! *
- ! Based on: *
- ! Naeslund E., and Thaning, L. (1991): On the settling velocity in a *
- ! nonstationary atmosphere, Aerosol Science and Technology 14, 247-256. *
- ! *
- !*****************************************************************************
- ! *
- ! Variables: *
- ! itime [s] current temporal position *
- ! xt,yt,zt coordinates position for which wind data shall be cal- *
- ! culated *
- ! *
- ! Constants: *
- ! *
- !*****************************************************************************
-
- use par_mod
- use com_mod
-
- implicit none
-
- integer :: itime,indz
- real :: xt,yt,zt
-
- ! Auxiliary variables needed for interpolation
- real :: dz1,dz2,dz
- real :: rho1(2),tt1(2),temperature,airdens,vis_dyn,vis_kin,viscosity
- real :: settling,settling_old,reynolds,c_d
- integer :: i,n,nix,njy,indzh,nsp
-
-
- !*****************************************************************************
- ! 1. Interpolate temperature and density: nearest neighbor interpolation sufficient
- !*****************************************************************************
-
- nix=int(xt)
- njy=int(yt)
-
- ! Determine the level below the current position for u,v
- !*******************************************************
-
- do i=2,nz
- if (height(i).gt.zt) then
- indz=i-1
- goto 6
- endif
- end do
-6 continue
-
-
- ! Vertical distance to the level below and above current position
- !****************************************************************
-
- dz=1./(height(indz+1)-height(indz))
- dz1=(zt-height(indz))*dz
- dz2=(height(indz+1)-zt)*dz
-
-
- ! Bilinear horizontal interpolation
- !**********************************
-
- ! Loop over 2 levels
- !*******************
-
- do n=1,2
- indzh=indz+n-1
- rho1(n)=rho(nix,njy,indzh,1)
- tt1(n)=tt(nix,njy,indzh,1)
- end do
-
-
- ! Linear vertical interpolation
- !******************************
-
- temperature=dz2*tt1(1)+dz1*tt1(2)
- airdens=dz2*rho1(1)+dz1*rho1(2)
-
-
- vis_dyn=viscosity(temperature)
- vis_kin=vis_dyn/airdens
-
- reynolds=dquer(nsp)/1.e6*abs(vsetaver(nsp))/vis_kin
-
-
-
- ! Iteration to determine both Reynolds number and settling velocity
- !******************************************************************
-
- settling_old=vsetaver(nsp) ! initialize iteration with Stokes' law, constant viscosity estimate
-
- do i=1,20 ! do a few iterations
-
- if (reynolds.lt.1.917) then
- c_d=24./reynolds
- else if (reynolds.lt.500.) then
- c_d=18.5/(reynolds**0.6)
- else
- c_d=0.44
- endif
-
- settling=-1.* &
- sqrt(4*ga*dquer(nsp)/1.e6*density(nsp)*cunningham(nsp)/ &
- (3.*c_d*airdens))
-
- if (abs((settling-settling_old)/settling).lt.0.01) goto 11 ! stop iteration
-
- reynolds=dquer(nsp)/1.e6*abs(settling)/vis_kin
- settling_old=settling
- end do
-
-11 continue
-
-end subroutine get_settling
diff --git a/src/getfields_mod.f90 b/src/getfields_mod.f90
new file mode 100644
index 00000000..956f1287
--- /dev/null
+++ b/src/getfields_mod.f90
@@ -0,0 +1,1685 @@
+! SPDX-FileCopyrightText: FLEXPART 1998-2019, see flexpart_license.txt
+! SPDX-License-Identifier: GPL-3.0-or-later
+
+ !*****************************************************************************
+ ! *
+ ! L. Bakels 2022: - This module contains all subroutines handling the *
+ ! internal storage and processing of the meteorological *
+ ! data, including computation of PV and boundary *
+ ! layer parameters *
+ ! - The reading of the meteo data happens in windfields_mod *
+ ! - The vertical coordinate transformation is done in *
+ ! verttransform_mod *
+ ! *
+ !*****************************************************************************
+
+module getfields_mod
+
+ use par_mod
+ use com_mod
+ use windfields_mod
+ use verttransform_mod
+
+ implicit none
+
+ real,allocatable,dimension(:,:,:) :: &
+ uuh, & ! wind components in x-direction [m/s]
+ vvh, & ! wind components in y-direction [m/s]
+ pvh, & ! potential vorticity
+ wwh ! wind components in y-direction [m/s]
+ real,allocatable,dimension(:,:,:,:) :: & ! Same for nexted grids
+ uuhn, & !
+ vvhn, & !
+ pvhn, & !
+ wwhn, & !
+ pwater ! RLT added partial pressure water vapor
+ real,allocatable,dimension(:,:,:) :: & ! For calcpv
+ ppml, & !
+ ppmk !
+ real,allocatable,dimension(:) :: & ! For calcpar
+ ttlev, & !
+ qvlev, & !
+ ulev, & !
+ vlev, & !
+ zlev !
+
+ private :: obukhov,richardson,scalev,calcpar,calcpar_nests,calcpv,calcpv_nests
+
+ public :: getfields
+contains
+
+subroutine getfields_allocate
+ implicit none
+ allocate(uuh(0:nxmax-1,0:nymax-1,nuvzmax), &
+ vvh(0:nxmax-1,0:nymax-1,nuvzmax), &
+ pvh(0:nxmax-1,0:nymax-1,nuvzmax), &
+ wwh(0:nxmax-1,0:nymax-1,nwzmax), &
+ uuhn(0:nxmaxn-1,0:nymaxn-1,nuvzmax,maxnests), &
+ vvhn(0:nxmaxn-1,0:nymaxn-1,nuvzmax,maxnests), &
+ pvhn(0:nxmaxn-1,0:nymaxn-1,nuvzmax,maxnests), &
+ wwhn(0:nxmaxn-1,0:nymaxn-1,nwzmax,maxnests), &
+ pwater(0:nxmax-1,0:nymax-1,nzmax,numwfmem))
+
+ allocate(ppml(0:nxmax-1,0:nymax-1,nuvzmax),ppmk(0:nxmax-1,0:nymax-1,nuvzmax))
+ allocate(ttlev(nuvzmax),qvlev(nuvzmax),ulev(nuvzmax),vlev(nuvzmax),zlev(nuvzmax))
+end subroutine getfields_allocate
+
+subroutine getfields_deallocate
+ implicit none
+ deallocate(uuh,vvh,pvh,wwh,uuhn,vvhn,pvhn,wwhn,pwater)
+ deallocate(ppml,ppmk)
+ deallocate(ttlev,qvlev,ulev,vlev,zlev)
+end subroutine getfields_deallocate
+
+subroutine getfields(itime,nstop)
+ ! i o
+ !*****************************************************************************
+ ! *
+ ! This subroutine manages the 3 data fields to be kept in memory. *
+ ! During the first time step of petterssen it has to be fulfilled that the *
+ ! first data field must have |wftime|<itime, i.e. the absolute value of *
+ ! wftime must be smaller than the absolute value of the current time in [s].*
+ ! The other 2 fields are the next in time after the first one. *
+ ! Pointers (memind) are used, because otherwise one would have to resort the*
+ ! wind fields, which costs a lot of computing time. Here only the pointers *
+ ! are resorted. *
+ ! *
+ ! Author: A. Stohl *
+ ! *
+ ! 29 April 1994 *
+ ! *
+ !*****************************************************************************
+ ! Changes, Bernd C. Krueger, Feb. 2001: *
+ ! Variables tth,qvh,tthn,qvhn (on eta coordinates) in common block. *
+ ! Function of nstop extended. *
+ ! *
+ ! Unified ECMWF and GFS builds *
+ ! Marian Harustak, 12.5.2017 *
+ ! - Added passing of metdata_format as it was needed by called routines *
+ !*****************************************************************************
+ ! *
+ ! Variables: *
+ ! lwindinterval [s] time difference between the two wind fields read in *
+ ! indj indicates the number of the wind field to be read in *
+ ! indmin remembers the number of wind fields already treated *
+ ! memind(2) pointer, on which place the wind fields are stored *
+ ! memtime(2) [s] times of the wind fields, which are kept in memory *
+ ! itime [s] current time since start date of trajectory calcu- *
+ ! lation *
+ ! nstop > 0, if trajectory has to be terminated *
+ ! nx,ny,nuvz,nwz field dimensions in x,y and z direction *
+ ! uu(0:nxmax,0:nymax,nuvzmax,2) wind components in x-direction [m/s] *
+ ! vv(0:nxmax,0:nymax,nuvzmax,2) wind components in y-direction [m/s] *
+ ! ww(0:nxmax,0:nymax,nwzmax,2) wind components in z-direction [deltaeta/s]*
+ ! tt(0:nxmax,0:nymax,nuvzmax,2) temperature [K] *
+ ! ps(0:nxmax,0:nymax,2) surface pressure [Pa] *
+ ! metdata_format format of metdata (ecmwf/gfs) *
+ ! *
+ ! Constants: *
+ ! idiffmax maximum allowable time difference between 2 wind *
+ ! fields *
+ ! *
+ !*****************************************************************************
+
+ use class_gribfile
+ use wetdepo_mod
+
+ implicit none
+
+ integer :: indj,itime,nstop,memaux
+ integer :: kz, ix
+ character(len=100) :: rowfmt
+
+ integer :: indmin = 1
+
+ ! Check, if wind fields are available for the current time step
+ !**************************************************************
+
+ nstop=0
+ if ((ldirect*wftime(1).gt.ldirect*itime).or. &
+ (ldirect*wftime(numbwf).lt.ldirect*itime)) then
+ write(*,*) 'FLEXPART WARNING: NO WIND FIELDS ARE AVAILABLE.'
+ write(*,*) 'A TRAJECTORY HAS TO BE TERMINATED.'
+ nstop=4
+ return
+ endif
+
+ if ((ldirect*memtime(1).le.ldirect*itime).and. &
+ (ldirect*memtime(2).gt.ldirect*itime)) then
+
+ ! The right wind fields are already in memory -> don't do anything
+ !*****************************************************************
+
+ continue
+
+ else if ((ldirect*memtime(2).le.ldirect*itime).and. &
+ (memtime(2).ne.999999999)) then
+
+
+ ! Current time is after 2nd wind field
+ ! -> Resort wind field pointers, so that current time is between 1st and 2nd
+ !***************************************************************************
+
+ memaux=memind(1)
+ memind(1)=memind(2)
+ memind(2)=memaux
+ memtime(1)=memtime(2)
+
+
+ ! Read a new wind field and store it on place memind(2)
+ !******************************************************
+
+ do indj=indmin,numbwf-1
+ if (ldirect*wftime(indj+1).gt.ldirect*itime) then
+ if (metdata_format.eq.GRIBFILE_CENTRE_ECMWF) then
+ call SYSTEM_CLOCK(count_clock, count_rate, count_max)
+ s_temp = (count_clock - count_clock0)/real(count_rate)
+ call readwind_ecmwf(indj+1,memind(2),uuh,vvh,wwh)
+ call SYSTEM_CLOCK(count_clock, count_rate, count_max)
+ s_readwind = s_readwind + ((count_clock - count_clock0)/real(count_rate)-s_temp)
+ else
+ call readwind_gfs(indj+1,memind(2),uuh,vvh,wwh)
+ end if
+ call readwind_nests(indj+1,memind(2),uuhn,vvhn,wwhn)
+ call calcpar(memind(2))
+ call calcpar_nests(memind(2))
+ if (metdata_format.eq.GRIBFILE_CENTRE_ECMWF) then
+ call verttransform_ecmwf(memind(2),uuh,vvh,wwh,pvh)
+ else
+ call verttransform_gfs(memind(2),uuh,vvh,wwh,pvh)
+ end if
+ call verttransform_nests(memind(2),uuhn,vvhn,wwhn,pvhn)
+ memtime(2)=wftime(indj+1)
+ nstop = 1
+ exit
+ endif
+ end do
+ indmin=indj
+
+ if ((WETBKDEP).and.(ipin.ne.3).and.(ipin.ne.4)) then
+ call writeprecip(itime,memind(1))
+ endif
+
+ else
+
+ ! No wind fields, which can be used, are currently in memory
+ ! -> read both wind fields
+ !***********************************************************
+
+ do indj=indmin,numbwf-1
+ if ((ldirect*wftime(indj).le.ldirect*itime).and. &
+ (ldirect*wftime(indj+1).gt.ldirect*itime)) then
+ memind(1)=1
+ if (metdata_format.eq.GRIBFILE_CENTRE_ECMWF) then
+ call SYSTEM_CLOCK(count_clock, count_rate, count_max)
+ s_temp = (count_clock - count_clock0)/real(count_rate)
+ call readwind_ecmwf(indj,memind(1),uuh,vvh,wwh)
+ call SYSTEM_CLOCK(count_clock, count_rate, count_max)
+ s_readwind = s_readwind + ((count_clock - count_clock0)/real(count_rate)-s_temp)
+ else
+ call readwind_gfs(indj,memind(1),uuh,vvh,wwh)
+ end if
+ call readwind_nests(indj,memind(1),uuhn,vvhn,wwhn)
+ call calcpar(memind(1))
+ call calcpar_nests(memind(1))
+ if (metdata_format.eq.GRIBFILE_CENTRE_ECMWF) then
+ call verttransform_ecmwf(memind(1),uuh,vvh,wwh,pvh)
+ else
+ call verttransform_gfs(memind(1),uuh,vvh,wwh,pvh)
+ end if
+ call verttransform_nests(memind(1),uuhn,vvhn,wwhn,pvhn)
+ memtime(1)=wftime(indj)
+ memind(2)=2
+ if (metdata_format.eq.GRIBFILE_CENTRE_ECMWF) then
+ call SYSTEM_CLOCK(count_clock, count_rate, count_max)
+ s_temp = (count_clock - count_clock0)/real(count_rate)
+ call readwind_ecmwf(indj+1,memind(2),uuh,vvh,wwh)
+ call SYSTEM_CLOCK(count_clock, count_rate, count_max)
+ s_readwind = s_readwind + ((count_clock - count_clock0)/real(count_rate)-s_temp)
+ else
+ call readwind_gfs(indj+1,memind(2),uuh,vvh,wwh)
+ end if
+ call readwind_nests(indj+1,memind(2),uuhn,vvhn,wwhn)
+ call calcpar(memind(2))
+ call calcpar_nests(memind(2))
+ if (metdata_format.eq.GRIBFILE_CENTRE_ECMWF) then
+ call verttransform_ecmwf(memind(2),uuh,vvh,wwh,pvh)
+ else
+ call verttransform_gfs(memind(2),uuh,vvh,wwh,pvh)
+ end if
+ call verttransform_nests(memind(2),uuhn,vvhn,wwhn,pvhn)
+ memtime(2)=wftime(indj+1)
+ nstop = 1
+ exit
+ endif
+ end do
+ indmin=indj
+
+ if ((WETBKDEP).and.(ipin.ne.3).and.(ipin.ne.4)) then
+ call writeprecip(itime,memind(1))
+ endif
+
+ end if
+
+ ! RLT calculate dry air density
+ if (DRYDEP) then
+ pwater=qv*prs/((r_air/r_water)*(1.-qv)+qv)
+ rho_dry=(prs-pwater)/(r_air*tt)
+ endif
+#ifndef USE_NCF
+ pwater=qv*prs/((r_air/r_water)*(1.-qv)+qv)
+ rho_dry=(prs-pwater)/(r_air*tt)
+#endif
+
+ lwindinterv=abs(memtime(2)-memtime(1))
+
+ if (lwindinterv.gt.idiffmax) nstop=3
+end subroutine getfields
+
+subroutine calcpv(n)
+ ! i i i o
+ !*****************************************************************************
+ ! *
+ ! Calculation of potential vorticity on 3-d grid. *
+ ! *
+ ! Author: P. James *
+ ! 3 February 2000 *
+ ! *
+ ! Adaptation to FLEXPART, A. Stohl, 1 May 2000 *
+ ! *
+ !*****************************************************************************
+ ! *
+ ! Variables: *
+ ! n temporal index for meteorological fields (1 to 2) *
+ ! *
+ ! Constants: *
+ ! *
+ !*****************************************************************************
+
+ implicit none
+
+ integer :: n,ix,jy,i,j,k,kl,ii,jj,klvrp,klvrm,klpt,kup,kdn,kch
+ integer :: jyvp,jyvm,ixvp,ixvm,jumpx,jumpy,jux,juy,ivrm,ivrp,ivr
+ integer :: nlck
+ real :: vx(2),uy(2),phi,tanphi,cosphi,dvdx,dudy,f
+ real :: theta,thetap,thetam,dthetadp,dt1,dt2,dt
+ real :: pvavr
+ real :: thup,thdn
+ real,parameter :: eps=1.e-5, p0=101325
+
+ ! Set number of levels to check for adjacent theta
+ nlck=nuvz/3
+ !
+ ! Loop over entire grid
+ !**********************
+ do kl=1,nuvz
+ do jy=0,nymin1
+ do ix=0,nxmin1
+ ppml(ix,jy,kl)=akz(kl)+bkz(kl)*ps(ix,jy,1,n)
+ enddo
+ enddo
+ enddo
+
+! ppmk(:,:,1:nuvz)=(100000./ppml(:,:,1:nuvz))**kappa
+ ppmk(0:nxmin1,0:nymin1,1:nuvz)=(100000./ppml(0:nxmin1,0:nymin1,1:nuvz))**kappa
+!$OMP PARALLEL PRIVATE(jy,ix,kl,phi,f,tanphi,cosphi,jyvp,jyvm,jumpy,juy, &
+!$OMP ixvp,ixvm,jumpx,ivrp,ivrm,jux,theta,klvrp,klvrm,klpt,thetap,thetam,dthetadp, &
+!$OMP ii,i,ivr,kdn,kch,kup,thdn,thup,dt1,dt2,dt,vx,k,dvdx, &
+!$OMP jj,j,uy,dudy)
+!$OMP DO
+ do jy=0,nymin1
+ if (sglobal.and.jy.eq.0) cycle
+ if (nglobal.and.jy.eq.nymin1) cycle
+ phi = (ylat0 + jy * dy) * pi / 180.
+ f = 0.00014585 * sin(phi)
+ tanphi = tan(phi)
+ cosphi = cos(phi)
+ ! Provide a virtual jy+1 and jy-1 in case we are on domain edge (Lat)
+ jyvp=jy+1
+ jyvm=jy-1
+ if (jy.eq.0) jyvm=0
+ if (jy.eq.nymin1) jyvp=nymin1
+ ! Define absolute gap length
+ jumpy=2
+ if (jy.eq.0.or.jy.eq.nymin1) jumpy=1
+ if (sglobal.and.jy.eq.1) then
+ jyvm=1
+ jumpy=1
+ end if
+ if (nglobal.and.jy.eq.ny-2) then
+ jyvp=ny-2
+ jumpy=1
+ end if
+ juy=jumpy
+ !
+ do ix=0,nxmin1
+ ! Provide a virtual ix+1 and ix-1 in case we are on domain edge (Long)
+ ixvp=ix+1
+ ixvm=ix-1
+ jumpx=2
+ if (xglobal) then
+ ivrp=ixvp
+ ivrm=ixvm
+ if (ixvm.lt.0) ivrm=ixvm+nxmin1
+ if (ixvp.ge.nx) ivrp=ixvp-nx+1
+ else
+ if (ix.eq.0) ixvm=0
+ if (ix.eq.nxmin1) ixvp=nxmin1
+ ivrp=ixvp
+ ivrm=ixvm
+ ! Define absolute gap length
+ if (ix.eq.0.or.ix.eq.nxmin1) jumpx=1
+ end if
+ jux=jumpx
+ !
+ ! Loop over the vertical
+ !***********************
+
+ do kl=1,nuvz
+ theta=tth(ix,jy,kl,n)*ppmk(ix,jy,kl)
+ klvrp=kl+1
+ klvrm=kl-1
+ klpt=kl
+ ! If top or bottom level, dthetadp is evaluated between the current
+ ! level and the level inside, otherwise between level+1 and level-1
+ !
+ if (klvrp.gt.nuvz) klvrp=nuvz
+ if (klvrm.lt.1) klvrm=1
+ thetap=tth(ix,jy,klvrp,n)*ppmk(ix,jy,klvrp)
+ thetam=tth(ix,jy,klvrm,n)*ppmk(ix,jy,klvrm)
+ dthetadp=(thetap-thetam)/(ppml(ix,jy,klvrp)-ppml(ix,jy,klvrm))
+
+ ! Compute vertical position at pot. temperature surface on subgrid
+ ! and the wind at that position
+ !*****************************************************************
+ ! a) in x direction
+ ii=0
+ x_loop: do i=ixvm,ixvp,jumpx
+ ivr=i
+ if (xglobal) then
+ if (i.lt.0) ivr=ivr+nxmin1
+ if (i.ge.nx) ivr=ivr-nx+1
+ end if
+ ii=ii+1
+ ! Search adjacent levels for current theta value
+ ! Spiral out from current level for efficiency
+ kup=klpt-1
+ kdn=klpt
+ kch=0
+ x_lev_loop: do while (kch.lt.nlck)
+ ! Upward branch
+ kup=kup+1
+ if (kup.lt.nuvz) then
+ kch=kch+1
+ k=kup
+ thdn=tth(ivr,jy,k,n)*ppmk(ivr,jy,k)
+ thup=tth(ivr,jy,k+1,n)*ppmk(ivr,jy,k+1)
+
+
+ if (((thdn.ge.theta).and.(thup.le.theta)).or. &
+ ((thdn.le.theta).and.(thup.ge.theta))) then
+ dt1=abs(theta-thdn)
+ dt2=abs(theta-thup)
+ dt=dt1+dt2
+ if (dt.lt.eps) then ! Avoid division by zero error
+ dt1=0.5 ! G.W., 10.4.1996
+ dt2=0.5
+ dt=1.0
+ endif
+ vx(ii)=(vvh(ivr,jy,k)*dt2+vvh(ivr,jy,k+1)*dt1)/dt
+ cycle x_loop
+ endif
+ endif
+ ! Downward branch
+ kdn=kdn-1
+ if (kdn.ge.1) then
+ kch=kch+1
+ k=kdn
+ thdn=tth(ivr,jy,k,n)*ppmk(ivr,jy,k)
+ thup=tth(ivr,jy,k+1,n)*ppmk(ivr,jy,k+1)
+
+ if (((thdn.ge.theta).and.(thup.le.theta)).or. &
+ ((thdn.le.theta).and.(thup.ge.theta))) then
+ dt1=abs(theta-thdn)
+ dt2=abs(theta-thup)
+ dt=dt1+dt2
+ if (dt.lt.eps) then ! Avoid division by zero error
+ dt1=0.5 ! G.W., 10.4.1996
+ dt2=0.5
+ dt=1.0
+ endif
+ vx(ii)=(vvh(ivr,jy,k)*dt2+vvh(ivr,jy,k+1)*dt1)/dt
+ cycle x_loop
+ endif
+ endif
+ end do x_lev_loop
+ ! This section used when no values were found
+ ! Must use vv at current level and long. jux becomes smaller by 1
+ vx(ii)=vvh(ix,jy,kl)
+ jux=jux-1
+ ! Otherwise OK
+ end do x_loop
+ if (jux.gt.0) then
+ dvdx=(vx(2)-vx(1))/real(jux)/(dx*pi/180.)
+ else
+ dvdx=vvh(ivrp,jy,kl)-vvh(ivrm,jy,kl)
+ dvdx=dvdx/real(jumpx)/(dx*pi/180.)
+ ! Only happens if no equivalent theta value
+ ! can be found on either side, hence must use values
+ ! from either side, same pressure level.
+ end if
+
+ ! b) in y direction
+
+ jj=0
+ y_loop: do j=jyvm,jyvp,jumpy
+ jj=jj+1
+ ! Search adjacent levels for current theta value
+ ! Spiral out from current level for efficiency
+ kup=klpt-1
+ kdn=klpt
+ kch=0
+ y_lev_loop: do while (kch.lt.nlck)
+ ! Upward branch
+ kup=kup+1
+ if (kup.lt.nuvz) then
+ kch=kch+1
+ k=kup
+ thdn=tth(ix,j,k,n)*ppmk(ix,j,k)
+ thup=tth(ix,j,k+1,n)*ppmk(ix,j,k+1)
+ if (((thdn.ge.theta).and.(thup.le.theta)).or. &
+ ((thdn.le.theta).and.(thup.ge.theta))) then
+ dt1=abs(theta-thdn)
+ dt2=abs(theta-thup)
+ dt=dt1+dt2
+ if (dt.lt.eps) then ! Avoid division by zero error
+ dt1=0.5 ! G.W., 10.4.1996
+ dt2=0.5
+ dt=1.0
+ endif
+ uy(jj)=(uuh(ix,j,k)*dt2+uuh(ix,j,k+1)*dt1)/dt
+ cycle y_loop
+ endif
+ endif
+ ! Downward branch
+ kdn=kdn-1
+ if (kdn.ge.1) then
+ kch=kch+1
+ k=kdn
+ thdn=tth(ix,j,k,n)*ppmk(ix,j,k)
+ thup=tth(ix,j,k+1,n)*ppmk(ix,j,k+1)
+ if (((thdn.ge.theta).and.(thup.le.theta)).or. &
+ ((thdn.le.theta).and.(thup.ge.theta))) then
+ dt1=abs(theta-thdn)
+ dt2=abs(theta-thup)
+ dt=dt1+dt2
+ if (dt.lt.eps) then ! Avoid division by zero error
+ dt1=0.5 ! G.W., 10.4.1996
+ dt2=0.5
+ dt=1.0
+ endif
+ uy(jj)=(uuh(ix,j,k)*dt2+uuh(ix,j,k+1)*dt1)/dt
+ cycle y_loop
+ endif
+ endif
+ end do y_lev_loop
+ ! This section used when no values were found
+ ! Must use uu at current level and lat. juy becomes smaller by 1
+ uy(jj)=uuh(ix,jy,kl)
+ juy=juy-1
+ ! Otherwise OK
+ end do y_loop
+ if (juy.gt.0) then
+ dudy=(uy(2)-uy(1))/real(juy)/(dy*pi/180.)
+ else
+ dudy=uuh(ix,jyvp,kl)-uuh(ix,jyvm,kl)
+ dudy=dudy/real(jumpy)/(dy*pi/180.)
+ end if
+ !
+ pvh(ix,jy,kl)=dthetadp*(f+(dvdx/cosphi-dudy &
+ +uuh(ix,jy,kl)*tanphi)/r_earth)*(-1.e6)*9.81
+ !
+ ! Resest jux and juy
+ jux=jumpx
+ juy=jumpy
+ end do
+ end do
+ end do
+!$OMP END DO
+!$OMP END PARALLEL
+ !
+ ! Fill in missing PV values on poles, if present
+ ! Use mean PV of surrounding latitude ring
+ !
+ if (sglobal) then
+ do kl=1,nuvz
+ pvavr=0.
+ do ix=0,nxmin1
+ pvavr=pvavr+pvh(ix,1,kl)
+ end do
+ pvavr=pvavr/real(nx)
+ jy=0
+ do ix=0,nxmin1
+ pvh(ix,jy,kl)=pvavr
+ end do
+ end do
+ end if
+ if (nglobal) then
+ do kl=1,nuvz
+ pvavr=0.
+ do ix=0,nxmin1
+ pvavr=pvavr+pvh(ix,ny-2,kl)
+ end do
+ pvavr=pvavr/real(nx)
+ jy=nymin1
+ do ix=0,nxmin1
+ pvh(ix,jy,kl)=pvavr
+ end do
+ end do
+ end if
+end subroutine calcpv
+
+subroutine calcpv_nests(l,n)
+ ! i i i i o
+ !*****************************************************************************
+ ! *
+ ! Calculation of potential vorticity on 3-d nested grid *
+ ! *
+ ! Author: P. James *
+ ! 22 February 2000 *
+ ! *
+ !*****************************************************************************
+ ! *
+ ! Variables: *
+ ! n temporal index for meteorological fields (1 to 2) *
+ ! l index of current nest *
+ ! *
+ ! Constants: *
+ ! *
+ !*****************************************************************************
+
+ implicit none
+
+ integer :: n,ix,jy,i,j,k,kl,ii,jj,klvrp,klvrm,klpt,kup,kdn,kch
+ integer :: jyvp,jyvm,ixvp,ixvm,jumpx,jumpy,jux,juy,ivrm,ivrp,ivr
+ integer :: nlck,l
+ real :: vx(2),uy(2),phi,tanphi,cosphi,dvdx,dudy,f
+ real :: theta,thetap,thetam,dthetadp,dt1,dt2,dt
+ real :: thup,thdn
+ real,parameter :: eps=1.e-5,p0=101325
+
+ ! Set number of levels to check for adjacent theta
+ nlck=nuvz/3
+ !
+ ! Loop over entire grid
+ !**********************
+ do kl=1,nuvz
+ do jy=0,nyn(l)-1
+ do ix=0,nxn(l)-1
+ ppml(ix,jy,kl)=akz(kl)+bkz(kl)*psn(ix,jy,1,n,l)
+ enddo
+ enddo
+ enddo
+ ! ppmk=(100000./ppml)**kappa
+ ppmk(0:nxn(l)-1,0:nyn(l)-1,1:nuvz)=(100000./ppml(0:nxn(l)-1,0:nyn(l)-1,1:nuvz))**kappa
+
+ do jy=0,nyn(l)-1
+ phi = (ylat0n(l) + jy * dyn(l)) * pi / 180.
+ f = 0.00014585 * sin(phi)
+ tanphi = tan(phi)
+ cosphi = cos(phi)
+ ! Provide a virtual jy+1 and jy-1 in case we are on domain edge (Lat)
+ jyvp=jy+1
+ jyvm=jy-1
+ if (jy.eq.0) jyvm=0
+ if (jy.eq.nyn(l)-1) jyvp=nyn(l)-1
+ ! Define absolute gap length
+ jumpy=2
+ if (jy.eq.0.or.jy.eq.nyn(l)-1) jumpy=1
+ juy=jumpy
+ !
+ do ix=0,nxn(l)-1
+ ! Provide a virtual ix+1 and ix-1 in case we are on domain edge (Long)
+ ixvp=ix+1
+ ixvm=ix-1
+ jumpx=2
+ if (ix.eq.0) ixvm=0
+ if (ix.eq.nxn(l)-1) ixvp=nxn(l)-1
+ ivrp=ixvp
+ ivrm=ixvm
+ ! Define absolute gap length
+ if (ix.eq.0.or.ix.eq.nxn(l)-1) jumpx=1
+ jux=jumpx
+ !
+ ! Loop over the vertical
+ !***********************
+
+ do kl=1,nuvz
+ theta=tthn(ix,jy,kl,n,l)*ppmk(ix,jy,kl)
+ klvrp=kl+1
+ klvrm=kl-1
+ klpt=kl
+ ! If top or bottom level, dthetadp is evaluated between the current
+ ! level and the level inside, otherwise between level+1 and level-1
+ !
+ if (klvrp.gt.nuvz) klvrp=nuvz
+ if (klvrm.lt.1) klvrm=1
+ thetap=tthn(ix,jy,klvrp,n,l)*ppmk(ix,jy,klvrp)
+ thetam=tthn(ix,jy,klvrm,n,l)*ppmk(ix,jy,klvrm)
+ dthetadp=(thetap-thetam)/(ppml(ix,jy,klvrp)-ppml(ix,jy,klvrm))
+
+ ! Compute vertical position at pot. temperature surface on subgrid
+ ! and the wind at that position
+ !*****************************************************************
+ ! a) in x direction
+ ii=0
+ x_loop: do i=ixvm,ixvp,jumpx
+ ivr=i
+ ii=ii+1
+ ! Search adjacent levels for current theta value
+ ! Spiral out from current level for efficiency
+ kup=klpt-1
+ kdn=klpt
+ kch=0
+ x_lev_loop: do while (kch.lt.nlck)
+ ! Upward branch
+ kup=kup+1
+ if (kup.lt.nuvz) then
+ kch=kch+1
+ k=kup
+ thdn=tthn(ivr,jy,k,n,l)*ppmk(ivr,jy,k)
+ thup=tthn(ivr,jy,k+1,n,l)*ppmk(ivr,jy,k+1)
+
+ if (((thdn.ge.theta).and.(thup.le.theta)).or. &
+ ((thdn.le.theta).and.(thup.ge.theta))) then
+ dt1=abs(theta-thdn)
+ dt2=abs(theta-thup)
+ dt=dt1+dt2
+ if (dt.lt.eps) then ! Avoid division by zero error
+ dt1=0.5 ! G.W., 10.4.1996
+ dt2=0.5
+ dt=1.0
+ endif
+ vx(ii)=(vvhn(ivr,jy,k,l)*dt2+vvhn(ivr,jy,k+1,l)*dt1)/dt
+ cycle x_loop
+ endif
+ endif
+ ! Downward branch
+ kdn=kdn-1
+ if (kdn.ge.1) then
+ kch=kch+1
+ k=kdn
+ thdn=tthn(ivr,jy,k,n,l)*ppmk(ivr,jy,k)
+ thup=tthn(ivr,jy,k+1,n,l)*ppmk(ivr,jy,k+1)
+
+ if (((thdn.ge.theta).and.(thup.le.theta)).or. &
+ ((thdn.le.theta).and.(thup.ge.theta))) then
+ dt1=abs(theta-thdn)
+ dt2=abs(theta-thup)
+ dt=dt1+dt2
+ if (dt.lt.eps) then ! Avoid division by zero error
+ dt1=0.5 ! G.W., 10.4.1996
+ dt2=0.5
+ dt=1.0
+ endif
+ vx(ii)=(vvhn(ivr,jy,k,l)*dt2+vvhn(ivr,jy,k+1,l)*dt1)/dt
+ cycle x_loop
+ endif
+ endif
+ end do x_lev_loop
+ ! This section used when no values were found
+ ! Must use vv at current level and long. jux becomes smaller by 1
+ vx(ii)=vvhn(ix,jy,kl,l)
+ jux=jux-1
+ ! Otherwise OK
+ end do x_loop
+ if (jux.gt.0) then
+ dvdx=(vx(2)-vx(1))/real(jux)/(dxn(l)*pi/180.)
+ else
+ dvdx=vvhn(ivrp,jy,kl,l)-vvhn(ivrm,jy,kl,l)
+ dvdx=dvdx/real(jumpx)/(dxn(l)*pi/180.)
+ ! Only happens if no equivalent theta value
+ ! can be found on either side, hence must use values
+ ! from either side, same pressure level.
+ end if
+
+ ! b) in y direction
+
+ jj=0
+ y_loop: do j=jyvm,jyvp,jumpy
+ jj=jj+1
+ ! Search adjacent levels for current theta value
+ ! Spiral out from current level for efficiency
+ kup=klpt-1
+ kdn=klpt
+ kch=0
+ y_lev_loop: do while (kch.lt.nlck)
+ ! Upward branch
+ kup=kup+1
+ if (kup.lt.nuvz) then
+ kch=kch+1
+ k=kup
+ thdn=tthn(ix,j,k,n,l)*ppmk(ix,j,k)
+ thup=tthn(ix,j,k+1,n,l)*ppmk(ix,j,k+1)
+ if (((thdn.ge.theta).and.(thup.le.theta)).or. &
+ ((thdn.le.theta).and.(thup.ge.theta))) then
+ dt1=abs(theta-thdn)
+ dt2=abs(theta-thup)
+ dt=dt1+dt2
+ if (dt.lt.eps) then ! Avoid division by zero error
+ dt1=0.5 ! G.W., 10.4.1996
+ dt2=0.5
+ dt=1.0
+ endif
+ uy(jj)=(uuhn(ix,j,k,l)*dt2+uuhn(ix,j,k+1,l)*dt1)/dt
+ cycle y_loop
+ endif
+ endif
+ ! Downward branch
+ kdn=kdn-1
+ if (kdn.ge.1) then
+ kch=kch+1
+ k=kdn
+ thdn=tthn(ix,j,k,n,l)*ppmk(ix,j,k)
+ thup=tthn(ix,j,k+1,n,l)*ppmk(ix,j,k+1)
+ if (((thdn.ge.theta).and.(thup.le.theta)).or. &
+ ((thdn.le.theta).and.(thup.ge.theta))) then
+ dt1=abs(theta-thdn)
+ dt2=abs(theta-thup)
+ dt=dt1+dt2
+ if (dt.lt.eps) then ! Avoid division by zero error
+ dt1=0.5 ! G.W., 10.4.1996
+ dt2=0.5
+ dt=1.0
+ endif
+ uy(jj)=(uuhn(ix,j,k,l)*dt2+uuhn(ix,j,k+1,l)*dt1)/dt
+ cycle y_loop
+ endif
+ endif
+ end do y_lev_loop
+ ! This section used when no values were found
+ ! Must use uu at current level and lat. juy becomes smaller by 1
+ uy(jj)=uuhn(ix,jy,kl,l)
+ juy=juy-1
+ ! Otherwise OK
+ end do y_loop
+ if (juy.gt.0) then
+ dudy=(uy(2)-uy(1))/real(juy)/(dyn(l)*pi/180.)
+ else
+ dudy=uuhn(ix,jyvp,kl,l)-uuhn(ix,jyvm,kl,l)
+ dudy=dudy/real(jumpy)/(dyn(l)*pi/180.)
+ end if
+
+ pvhn(ix,jy,kl,l)=dthetadp*(f+(dvdx/cosphi-dudy &
+ +uuhn(ix,jy,kl,l)*tanphi)/r_earth)*(-1.e6)*9.81
+
+ ! Resest jux and juy
+ jux=jumpx
+ juy=jumpy
+ end do
+ end do
+ end do
+end subroutine calcpv_nests
+
+subroutine calcpar(n)
+ ! i i i o
+ !*****************************************************************************
+ ! *
+ ! Computation of several boundary layer parameters needed for the *
+ ! dispersion calculation and calculation of dry deposition velocities. *
+ ! All parameters are calculated over the entire grid. *
+ ! *
+ ! Author: A. Stohl *
+ ! *
+ ! 21 May 1995 *
+ ! *
+ ! ------------------------------------------------------------------ *
+ ! Petra Seibert, Feb 2000: *
+ ! convection scheme: *
+ ! new variables in call to richardson *
+ ! *
+ ! CHANGE 17/11/2005 Caroline Forster NCEP GFS version *
+ ! *
+ ! Changes, Bernd C. Krueger, Feb. 2001: *
+ ! Variables tth and qvh (on eta coordinates) in common block *
+ ! *
+ ! Unified ECMWF and GFS builds *
+ ! Marian Harustak, 12.5.2017 *
+ ! - Merged calcpar and calcpar_gfs into one routine using if-then *
+ ! for meteo-type dependent code *
+ !*****************************************************************************
+
+ !*****************************************************************************
+ ! *
+ ! Variables: *
+ ! n temporal index for meteorological fields (1 to 3) *
+ ! metdata_format format of metdata (ecmwf/gfs) *
+ ! *
+ ! Constants: *
+ ! *
+ ! *
+ ! Functions: *
+ ! scalev computation of ustar *
+ ! obukhov computatio of Obukhov length *
+ ! *
+ !*****************************************************************************
+
+ use class_gribfile
+ use drydepo_mod
+ use qvsat_mod
+
+ implicit none
+
+ integer :: n,ix,jy,i,kz,lz,kzmin,llev,loop_start,ierr
+ real :: ol,hmixplus
+ real :: rh,subsceff,ylat
+ real :: altmin,tvold,pold,zold,pint,tv,hmixdummy,akzdummy
+ real :: vd(maxspec)
+ real :: z0_tmp(numclass) ! temporary variable for z0 (shared between OMP threads)
+ real,parameter :: const=r_air/ga
+
+ !write(*,*) 'in calcpar writting snowheight'
+ !***********************************
+ ! for test: write out snow depths
+
+ ! open(4,file='slandusetest',form='formatted')
+ ! do 5 ix=0,nxmin1
+ !5 write (4,*) (sd(ix,jy,1,n),jy=0,nymin1)
+ ! close(4)
+
+
+ ! Loop over entire grid
+ !**********************
+
+ ! openmp change
+ z0_tmp = z0
+ !$OMP PARALLEL PRIVATE(jy,ix,ulev,vlev,ttlev,qvlev,llev,ylat,ol,i,hmixplus, &
+ !$OMP subsceff,vd,kz,lz,zlev,rh,kzmin,pold,zold,tvold,pint,tv,loop_start,ierr, &
+ !$OMP altmin)
+ z0 = z0_tmp
+
+ !$OMP DO
+ do jy=0,nymin1
+
+ ! Set minimum height for tropopause
+ !**********************************
+
+ ylat=ylat0+real(jy)*dy
+ if ((ylat.ge.-20.).and.(ylat.le.20.)) then
+ altmin = 5000.
+ else
+ if ((ylat.gt.20.).and.(ylat.lt.40.)) then
+ altmin=2500.+(40.-ylat)*125.
+ else if ((ylat.gt.-40.).and.(ylat.lt.-20.)) then
+ altmin=2500.+(40.+ylat)*125.
+ else
+ altmin=2500.
+ endif
+ endif
+
+ do ix=0,nxmin1
+
+ ! 1) Calculation of friction velocity
+ !************************************
+
+ ustar(ix,jy,1,n)=scalev(ps(ix,jy,1,n),tt2(ix,jy,1,n), &
+ td2(ix,jy,1,n),surfstr(ix,jy,1,n))
+ if (ustar(ix,jy,1,n).le.1.e-8) ustar(ix,jy,1,n)=1.e-8
+
+ ! 2) Calculation of inverse Obukhov length scale
+ !***********************************************
+
+ if (metdata_format.eq.GRIBFILE_CENTRE_NCEP) then
+ ! NCEP version: find first level above ground
+ llev = 0
+ do i=1,nuvz
+ if (ps(ix,jy,1,n).lt.akz(i)) llev=i
+ end do
+ llev = llev+1
+ if (llev.gt.nuvz) llev = nuvz-1
+ ! NCEP version
+
+ ! calculate inverse Obukhov length scale with tth(llev)
+ ol=obukhov(ps(ix,jy,1,n),tt2(ix,jy,1,n),td2(ix,jy,1,n), &
+ tth(ix,jy,llev,n),ustar(ix,jy,1,n),sshf(ix,jy,1,n), &
+ akm,bkm,akz(llev))
+ else
+ llev=0
+ ol=obukhov(ps(ix,jy,1,n),tt2(ix,jy,1,n),td2(ix,jy,1,n), &
+ tth(ix,jy,2,n),ustar(ix,jy,1,n),sshf(ix,jy,1,n),akm,bkm,akzdummy)
+ end if
+
+ if (ol.ne.0.) then
+ oli(ix,jy,1,n)=1./ol
+ else
+ oli(ix,jy,1,n)=99999.
+ endif
+
+
+ ! 3) Calculation of convective velocity scale and mixing height
+ !**************************************************************
+
+ do i=1,nuvz
+ ulev(i)=uuh(ix,jy,i)
+ vlev(i)=vvh(ix,jy,i)
+ ttlev(i)=tth(ix,jy,i,n)
+ qvlev(i)=qvh(ix,jy,i,n)
+ end do
+
+ if (metdata_format.eq.GRIBFILE_CENTRE_NCEP) then
+ ! NCEP version hmix has been read in in readwind.f, is therefore not calculated here
+ call richardson(ps(ix,jy,1,n),ustar(ix,jy,1,n),ttlev,qvlev, &
+ ulev,vlev,nuvz,akz,bkz,sshf(ix,jy,1,n),tt2(ix,jy,1,n), &
+ td2(ix,jy,1,n),hmixdummy,wstar(ix,jy,1,n),hmixplus,ierr)
+ else
+ call richardson(ps(ix,jy,1,n),ustar(ix,jy,1,n),ttlev,qvlev, &
+ ulev,vlev,nuvz,akz,bkz,sshf(ix,jy,1,n),tt2(ix,jy,1,n), &
+ td2(ix,jy,1,n),hmix(ix,jy,1,n),wstar(ix,jy,1,n),hmixplus,ierr)
+ end if
+
+ if (ierr.lt.0) then
+ write(*,9500) 'failure', ix, jy
+ stop
+ endif
+9500 format( 'calcpar - richardson ', a, ' - ix,jy=', 2i5 )
+
+ if(lsubgrid.eq.1) then
+ subsceff=min(excessoro(ix,jy),hmixplus)
+ else
+ subsceff=0.0
+ endif
+ !
+ ! CALCULATE HMIX EXCESS ACCORDING TO SUBGRIDSCALE VARIABILITY AND STABILITY
+ !
+ hmix(ix,jy,1,n)=hmix(ix,jy,1,n)+subsceff
+ hmix(ix,jy,1,n)=max(hmixmin,hmix(ix,jy,1,n)) ! set minimum PBL height
+ hmix(ix,jy,1,n)=min(hmixmax,hmix(ix,jy,1,n)) ! set maximum PBL height
+
+ ! 4) Calculation of dry deposition velocities
+ !********************************************
+
+ if (DRYDEP) then
+ ! Sabine Eckhardt, Dec 06: use new index for z0 for water depending on
+ ! windspeed
+ z0(7)=0.016*ustar(ix,jy,1,n)*ustar(ix,jy,1,n)/ga
+
+ ! Calculate relative humidity at surface
+ !***************************************
+ rh=ew(td2(ix,jy,1,n),ps(ix,jy,1,n))/ew(tt2(ix,jy,1,n),ps(ix,jy,1,n))
+
+ call getvdep(n,ix,jy,ustar(ix,jy,1,n), &
+ tt2(ix,jy,1,n),ps(ix,jy,1,n),1./oli(ix,jy,1,n), &
+ ssr(ix,jy,1,n),rh,lsprec(ix,jy,1,n)+convprec(ix,jy,1,n), &
+ sd(ix,jy,1,n),vd)
+
+ do i=1,nspec
+ vdep(ix,jy,i,n)=vd(i)
+ end do
+
+ endif
+
+ !******************************************************
+ ! Calculate height of thermal tropopause (Hoinka, 1997)
+ !******************************************************
+
+ ! 1) Calculate altitudes of model levels
+ !***************************************
+
+ tvold=tt2(ix,jy,1,n)*(1.+0.378*ew(td2(ix,jy,1,n),ps(ix,jy,1,n))/ &
+ ps(ix,jy,1,n))
+ pold=ps(ix,jy,1,n)
+ zold=0.
+ if (metdata_format.eq.GRIBFILE_CENTRE_ECMWF) then
+ loop_start=2
+ else
+ loop_start=llev
+ end if
+ do kz=loop_start,nuvz
+ pint=akz(kz)+bkz(kz)*ps(ix,jy,1,n) ! pressure on model layers
+ tv=tth(ix,jy,kz,n)*(1.+0.608*qvh(ix,jy,kz,n))
+
+ if (abs(tv-tvold).gt.0.2) then
+ zlev(kz)=zold+const*log(pold/pint)*(tv-tvold)/log(tv/tvold)
+ else
+ zlev(kz)=zold+const*log(pold/pint)*tv
+ endif
+ tvold=tv
+ pold=pint
+ zold=zlev(kz)
+ end do
+
+ ! 2) Define a minimum level kzmin, from which upward the tropopause is
+ ! searched for. This is to avoid inversions in the lower troposphere
+ ! to be identified as the tropopause
+ !************************************************************************
+
+ if (metdata_format.eq.GRIBFILE_CENTRE_ECMWF) then
+ !LB, The CTM version has 2 (as bugfix), so I changed it 2 from 1 to try out
+ loop_start=2
+ else
+ loop_start=llev
+ end if
+
+ do kz=loop_start,nuvz
+ if (zlev(kz).ge.altmin) then
+ kzmin=kz
+ exit
+ endif
+ end do
+
+ ! 3) Search for first stable layer above minimum height that fulfills the
+ ! thermal tropopause criterion
+ !************************************************************************
+
+ outer: do kz=kzmin,nuvz
+ inner: do lz=kz+1,nuvz
+ if ((zlev(lz)-zlev(kz)).gt.2000.) then
+ if (((tth(ix,jy,kz,n)-tth(ix,jy,lz,n))/ &
+ (zlev(lz)-zlev(kz))).lt.0.002) then
+ tropopause(ix,jy,1,n)=zlev(kz)
+ exit outer
+ endif
+ exit inner
+ endif
+ end do inner
+ end do outer
+
+ end do
+ end do
+ !$OMP END DO
+ !$OMP END PARALLEL
+ ! openmp change end
+
+ ! Calculation of potential vorticity on 3-d grid
+ !***********************************************
+
+ call calcpv(n)
+end subroutine calcpar
+
+subroutine calcpar_nests(n)
+ ! i i i o
+ !*****************************************************************************
+ ! *
+ ! Computation of several boundary layer parameters needed for the *
+ ! dispersion calculation and calculation of dry deposition velocities. *
+ ! All parameters are calculated over the entire grid. *
+ ! This routine is similar to calcpar, but is used for the nested grids. *
+ ! *
+ ! Author: A. Stohl *
+ ! *
+ ! 8 February 1999 *
+ ! *
+ ! ------------------------------------------------------------------ *
+ ! Petra Seibert, Feb 2000: *
+ ! convection scheme: *
+ ! new variables in call to richardson *
+ ! *
+ !*****************************************************************************
+ ! Changes, Bernd C. Krueger, Feb. 2001: *
+ ! Variables tth and qvh (on eta coordinates) in common block *
+ ! *
+ ! Unified ECMWF and GFS builds *
+ ! Marian Harustak, 12.5.2017 *
+ !*****************************************************************************
+ ! *
+ ! Variables: *
+ ! n temporal index for meteorological fields (1 to 3) *
+ ! metdata_format format of metdata (ecmwf/gfs) *
+ ! *
+ ! Constants: *
+ ! *
+ ! *
+ ! Functions: *
+ ! scalev computation of ustar *
+ ! obukhov computatio of Obukhov length *
+ ! *
+ !*****************************************************************************
+
+ use drydepo_mod
+ use qvsat_mod
+
+ implicit none
+
+ integer :: n,ix,jy,i,l,kz,lz,kzmin,ierr
+ real :: ol,hmixplus,dummyakzllev
+ real :: rh,subsceff,ylat
+ real :: altmin,tvold,pold,zold,pint,tv
+ real :: vd(maxspec)
+ real :: z0_tmp(numclass) ! temporary variable for z0 (shared between OMP threads)
+ real,parameter :: const=r_air/ga
+
+
+ ! Loop over all nests
+ !********************
+
+ do l=1,numbnests
+
+ ! Loop over entire grid
+ !**********************
+ z0_tmp = z0
+!$OMP PARALLEL DEFAULT(SHARED) &
+!$OMP PRIVATE(i,ix,jy,kz,lz,kzmin,tvold,pold,zold,zlev,tv,pint, &
+!$OMP rh,ierr,subsceff,ulev,vlev,ttlev,qvlev,ol,altmin,ylat,hmixplus, &
+!$OMP dummyakzllev,vd )
+ z0 = z0_tmp
+
+!$OMP DO
+ do jy=0,nyn(l)-1
+
+ ! Set minimum height for tropopause
+ !**********************************
+
+ ylat=ylat0n(l)+real(jy)*dyn(l)
+ if ((ylat.ge.-20.).and.(ylat.le.20.)) then
+ altmin = 5000.
+ else
+ if ((ylat.gt.20.).and.(ylat.lt.40.)) then
+ altmin=2500.+(40.-ylat)*125.
+ else if ((ylat.gt.-40.).and.(ylat.lt.-20.)) then
+ altmin=2500.+(40.+ylat)*125.
+ else
+ altmin=2500.
+ endif
+ endif
+
+ do ix=0,nxn(l)-1
+
+ ! 1) Calculation of friction velocity
+ !************************************
+
+ ustarn(ix,jy,1,n,l)=scalev(psn(ix,jy,1,n,l),tt2n(ix,jy,1,n,l), &
+ td2n(ix,jy,1,n,l),surfstrn(ix,jy,1,n,l))
+ if (ustarn(ix,jy,1,n,l).le.1.e-8) ustarn(ix,jy,1,n,l)=1.e-8
+
+ ! 2) Calculation of inverse Obukhov length scale
+ !***********************************************
+
+ ol=obukhov(psn(ix,jy,1,n,l),tt2n(ix,jy,1,n,l), &
+ td2n(ix,jy,1,n,l),tthn(ix,jy,2,n,l),ustarn(ix,jy,1,n,l), &
+ sshfn(ix,jy,1,n,l),akm,bkm,dummyakzllev)
+ if (ol.ne.0.) then
+ olin(ix,jy,1,n,l)=1./ol
+ else
+ olin(ix,jy,1,n,l)=99999.
+ endif
+
+
+ ! 3) Calculation of convective velocity scale and mixing height
+ !**************************************************************
+
+ do i=1,nuvz
+ ulev(i)=uuhn(ix,jy,i,l)
+ vlev(i)=vvhn(ix,jy,i,l)
+ ttlev(i)=tthn(ix,jy,i,n,l)
+ qvlev(i)=qvhn(ix,jy,i,n,l)
+ end do
+
+ call richardson(psn(ix,jy,1,n,l),ustarn(ix,jy,1,n,l),ttlev, &
+ qvlev,ulev,vlev,nuvz,akz,bkz,sshfn(ix,jy,1,n,l), &
+ tt2n(ix,jy,1,n,l),td2n(ix,jy,1,n,l),hmixn(ix,jy,1,n,l), &
+ wstarn(ix,jy,1,n,l),hmixplus,ierr)
+ if (ierr.lt.0) then
+ write(*,9500) 'failure', ix, jy, l
+ stop
+ endif
+9500 format( 'calcparn - richardson ', a, ' - ix,jy=', 2i5 )
+
+ if(lsubgrid.eq.1) then
+ subsceff=min(excessoron(ix,jy,l),hmixplus)
+ else
+ subsceff=0.0
+ endif
+ !
+ ! CALCULATE HMIX EXCESS ACCORDING TO SUBGRIDSCALE VARIABILITY AND STABILITY
+ !
+ hmixn(ix,jy,1,n,l)=hmixn(ix,jy,1,n,l)+subsceff
+ hmixn(ix,jy,1,n,l)=max(hmixmin,hmixn(ix,jy,1,n,l)) ! minim PBL height
+ hmixn(ix,jy,1,n,l)=min(hmixmax,hmixn(ix,jy,1,n,l)) ! maxim PBL height
+
+
+ ! 4) Calculation of dry deposition velocities
+ !********************************************
+
+ if (DRYDEP) then
+ ! z0(4)=0.016*ustarn(ix,jy,1,n,l)*ustarn(ix,jy,1,n,l)/ga
+ ! z0(9)=0.016*ustarn(ix,jy,1,n,l)*ustarn(ix,jy,1,n,l)/ga
+ z0(7)=0.016*ustarn(ix,jy,1,n,l)*ustarn(ix,jy,1,n,l)/ga
+
+ ! Calculate relative humidity at surface
+ !***************************************
+ rh=ew(td2n(ix,jy,1,n,l),psn(ix,jy,1,n,l))/ew(tt2n(ix,jy,1,n,l),psn(ix,jy,1,n,l))
+
+ call getvdep_nests(n,ix,jy,ustarn(ix,jy,1,n,l), &
+ tt2n(ix,jy,1,n,l),psn(ix,jy,1,n,l),1./olin(ix,jy,1,n,l), &
+ ssrn(ix,jy,1,n,l),rh,lsprecn(ix,jy,1,n,l)+ &
+ convprecn(ix,jy,1,n,l),sdn(ix,jy,1,n,l),vd,l)
+
+ do i=1,nspec
+ vdepn(ix,jy,i,n,l)=vd(i)
+ end do
+
+ endif
+
+ !******************************************************
+ ! Calculate height of thermal tropopause (Hoinka, 1997)
+ !******************************************************
+
+ ! 1) Calculate altitudes of ECMWF model levels
+ !*********************************************
+
+ tvold=tt2n(ix,jy,1,n,l)*(1.+0.378*ew(td2n(ix,jy,1,n,l),psn(ix,jy,1,n,l))/ &
+ psn(ix,jy,1,n,l))
+ pold=psn(ix,jy,1,n,l)
+ zold=0.
+ do kz=2,nuvz
+ pint=akz(kz)+bkz(kz)*psn(ix,jy,1,n,l) ! pressure on model layers
+ tv=tthn(ix,jy,kz,n,l)*(1.+0.608*qvhn(ix,jy,kz,n,l))
+
+ if (abs(tv-tvold).gt.0.2) then
+ zlev(kz)=zold+const*log(pold/pint)*(tv-tvold)/log(tv/tvold)
+ else
+ zlev(kz)=zold+const*log(pold/pint)*tv
+ endif
+ tvold=tv
+ pold=pint
+ zold=zlev(kz)
+ end do
+
+ ! 2) Define a minimum level kzmin, from which upward the tropopause is
+ ! searched for. This is to avoid inversions in the lower troposphere
+ ! to be identified as the tropopause
+ !************************************************************************
+
+ do kz=1,nuvz
+ if (zlev(kz).ge.altmin) then
+ kzmin=kz
+ exit
+ endif
+ end do
+
+ ! 3) Search for first stable layer above minimum height that fulfills the
+ ! thermal tropopause criterion
+ !************************************************************************
+
+ kzloop : do kz=kzmin,nuvz
+ lzloop : do lz=kz+1,nuvz
+ if ((zlev(lz)-zlev(kz)).gt.2000.) then
+ if (((tthn(ix,jy,kz,n,l)-tthn(ix,jy,lz,n,l))/ &
+ (zlev(lz)-zlev(kz))).lt.0.002) then
+ tropopausen(ix,jy,1,n,l)=zlev(kz)
+ exit kzloop
+ endif
+ exit lzloop
+ endif
+ end do lzloop
+ end do kzloop
+
+ end do
+ end do
+
+!$OMP END DO
+!$OMP END PARALLEL
+
+ ! Calculation of potential vorticity on 3-d grid
+ !***********************************************
+
+ call calcpv_nests(l,n)
+
+ end do
+end subroutine calcpar_nests
+
+real function obukhov(ps,tsurf,tdsurf,tlev,ustar,hf,akm,bkm,plev)
+
+ !********************************************************************
+ ! *
+ ! Author: G. WOTAWA *
+ ! Date: 1994-06-27 *
+ ! *
+ ! This program calculates Obukhov scale height from surface *
+ ! meteorological data and sensible heat flux. *
+ ! *
+ !********************************************************************
+ ! *
+ ! Update: A. Stohl, 2000-09-25, avoid division by zero by *
+ ! setting ustar to minimum value *
+ ! CHANGE: 17/11/2005 Caroline Forster NCEP GFS version *
+ ! *
+ ! Unified ECMWF and GFS builds *
+ ! Marian Harustak, 12.5.2017 *
+ ! - Merged obukhov and obukhov_gfs into one routine using *
+ ! if-then for meteo-type dependent code *
+ ! *
+ !********************************************************************
+ ! *
+ ! INPUT: *
+ ! *
+ ! ps surface pressure [Pa] *
+ ! tsurf surface temperature [K] *
+ ! tdsurf surface dew point [K] *
+ ! tlev temperature first model level [K] *
+ ! ustar scale velocity [m/s] *
+ ! hf surface sensible heat flux [W/m2] *
+ ! akm ECMWF vertical discretization parameter *
+ ! bkm ECMWF vertical discretization parameter *
+ ! plev *
+ ! metdata_format format of metdata (ecmwf/gfs) *
+ ! *
+ !********************************************************************
+
+ use class_gribfile
+ use qvsat_mod
+
+ implicit none
+
+ real,dimension(:) :: akm,bkm
+ real :: ps,tsurf,tdsurf,tlev,ustar,hf,e,tv,rhoa,plev
+ real :: ak1,bk1,theta,thetastar
+
+
+ e=ew(tdsurf,ps) ! vapor pressure
+ tv=tsurf*(1.+0.378*e/ps) ! virtual temperature
+ rhoa=ps/(r_air*tv) ! air density
+ if (metdata_format.eq.GRIBFILE_CENTRE_ECMWF) then
+ ak1=(akm(1)+akm(2))/2.
+ bk1=(bkm(1)+bkm(2))/2.
+ plev=ak1+bk1*ps ! Pressure level 1
+ end if
+ theta=tlev*(100000./plev)**(r_air/cpa) ! potential temperature
+ if (ustar.le.0.) ustar=1.e-8
+ thetastar=hf/(rhoa*cpa*ustar) ! scale temperature
+ if(abs(thetastar).gt.1.e-10) then
+ obukhov=theta*ustar**2/(karman*ga*thetastar)
+ else
+ obukhov=9999 ! zero heat flux
+ endif
+ if (obukhov.gt. 9999.) obukhov= 9999.
+ if (obukhov.lt.-9999.) obukhov=-9999.
+end function obukhov
+
+subroutine richardson(psurf,ust,ttlev,qvlev,ulev,vlev,nuvz, &
+ akz,bkz,hf,tt2,td2,h,wst,hmixplus,ierr)
+ ! i i i i i i i
+ ! i i i i i o o o
+ !****************************************************************************
+ ! *
+ ! Calculation of mixing height based on the critical Richardson number. *
+ ! Calculation of convective time scale. *
+ ! For unstable conditions, one iteration is performed. An excess *
+ ! temperature (dependent on hf and wst) is calculated, added to the *
+ ! temperature at the lowest model level. Then the procedure is repeated.*
+ ! *
+ ! Author: A. Stohl *
+ ! *
+ ! 22 August 1996 *
+ ! *
+ ! Literature: *
+ ! Vogelezang DHP and Holtslag AAM (1996): Evaluation and model impacts *
+ ! of alternative boundary-layer height formulations. Boundary-Layer *
+ ! Meteor. 81, 245-269. *
+ ! *
+ !****************************************************************************
+ ! *
+ ! Update: 1999-02-01 by G. Wotawa *
+ ! *
+ ! Two meter level (temperature, humidity) is taken as reference level *
+ ! instead of first model level. *
+ ! New input variables tt2, td2 introduced. *
+ ! *
+ ! CHANGE: 17/11/2005 Caroline Forster NCEP GFS version *
+ ! *
+ ! Unified ECMWF and GFS builds *
+ ! Marian Harustak, 12.5.2017 *
+ ! - Merged richardson and richardson_gfs into one routine using *
+ ! if-then for meteo-type dependent code *
+ ! *
+ !****************************************************************************
+ ! *
+ ! Variables: *
+ ! h mixing height [m] *
+ ! hf sensible heat flux *
+ ! psurf surface pressure at point (xt,yt) [Pa] *
+ ! tv virtual temperature *
+ ! wst convective velocity scale *
+ ! metdata_format format of metdata (ecmwf/gfs) *
+ ! *
+ ! Constants: *
+ ! ric critical Richardson number *
+ ! *
+ !****************************************************************************
+
+ use class_gribfile
+ use qvsat_mod
+
+ implicit none
+
+ integer,intent(out) :: &
+ ierr ! Returns error when no richardson number can be found
+ real, intent(out) :: &
+ h, & ! mixing height [m]
+ wst, & ! convective velocity scale
+ hmixplus !
+ integer,intent(in) :: &
+ nuvz ! Upper vertical level
+ real,intent(in) :: &
+ psurf, & ! surface pressure at point (xt,yt) [Pa]
+ ust, & ! Scale velocity
+ hf, & ! Surface sensible heat flux
+ tt2,td2 ! Temperature
+ real,intent(in),dimension(:) :: &
+ ttlev, &
+ qvlev, &
+ ulev, &
+ vlev, &
+ akz,bkz
+ integer :: &
+ i,k,iter,llev,loop_start ! Loop variables
+ real :: &
+ tv,tvold, & ! Virtual temperature
+ zref,z,zold,zl,zl1,zl2, & ! Heights
+ pint,pold, & ! Pressures
+ theta,thetaold,thetaref,thetal, & ! Potential temperature
+ theta1,theta2,thetam, &
+ ri, & ! Richardson number per level
+ ril, & ! Richardson number sub level
+ excess, & !
+ ul,vl, & ! Velocities sub level
+ wspeed, & ! Wind speed at z=hmix
+ bvfsq, & ! Brunt-Vaisala frequency
+ bvf, & ! square root of bvfsq
+ rh,rhold,rhl
+ real,parameter :: const=r_air/ga, ric=0.25, b=100., bs=8.5
+ integer,parameter :: itmax=3
+
+ excess=0.0
+
+ if (metdata_format.eq.GRIBFILE_CENTRE_NCEP) then
+ ! NCEP version: find first model level above ground
+ !**************************************************
+
+ llev = 0
+ do i=1,nuvz
+ if (psurf.lt.akz(i)) llev=i
+ end do
+ llev = llev+1
+ ! sec llev should not be 1!
+ if (llev.eq.1) llev = 2
+ if (llev.gt.nuvz) llev = nuvz-1
+ ! NCEP version
+ end if
+
+
+ ! Compute virtual temperature and virtual potential temperature at
+ ! reference level (2 m)
+ !*****************************************************************
+
+ do iter=1,itmax,1
+
+ pold=psurf
+ tvold=tt2*(1.+0.378*ew(td2,psurf)/psurf)
+ zold=2.0
+ zref=zold
+ rhold=ew(td2,psurf)/ew(tt2,psurf)
+
+ thetaref=tvold*(100000./pold)**(r_air/cpa)+excess
+ thetaold=thetaref
+
+
+ ! Integrate z up to one level above zt
+ !*************************************
+ if (metdata_format.eq.GRIBFILE_CENTRE_ECMWF) then
+ loop_start=2
+ else
+ loop_start=llev
+ end if
+ do k=loop_start,nuvz
+ pint=akz(k)+bkz(k)*psurf ! pressure on model layers
+ tv=ttlev(k)*(1.+0.608*qvlev(k))
+
+ if (abs(tv-tvold).gt.0.2) then
+ z=zold+const*log(pold/pint)*(tv-tvold)/log(tv/tvold)
+ else
+ z=zold+const*log(pold/pint)*tv
+ endif
+
+ theta=tv*(100000./pint)**(r_air/cpa)
+ ! Petra
+ rh = qvlev(k) / f_qvsat( pint, ttlev(k) )
+
+
+ ! Calculate Richardson number at each level
+ !****************************************
+
+ ri=ga/thetaref*(theta-thetaref)*(z-zref)/ &
+ max(((ulev(k)-ulev(2))**2+(vlev(k)-vlev(2))**2+b*ust**2),0.1)
+
+ ! addition of second condition: MH should not be placed in an
+ ! unstable layer (PS / Feb 2000)
+ if (ri.gt.ric .and. thetaold.lt.theta) exit
+
+ tvold=tv
+ pold=pint
+ rhold=rh
+ thetaold=theta
+ zold=z
+ end do
+ ! Check opied from FLEXPART-WRF, 2022 LB
+ if (k.ge.nuvz) then
+ write(*,*) 'richardson not working -- k = nuvz'
+ ierr = -10
+ goto 7000
+ endif
+ !k=min(k,nuvz) ! ESO: make sure k <= nuvz (ticket #139) !MD change to work without goto
+
+ ! Determine Richardson number between the critical levels
+ !********************************************************
+
+ zl1=zold
+ theta1=thetaold
+ do i=1,20
+ zl=zold+real(i)/20.*(z-zold)
+ ul=ulev(k-1)+real(i)/20.*(ulev(k)-ulev(k-1))
+ vl=vlev(k-1)+real(i)/20.*(vlev(k)-vlev(k-1))
+ thetal=thetaold+real(i)/20.*(theta-thetaold)
+ rhl=rhold+real(i)/20.*(rh-rhold)
+ ril=ga/thetaref*(thetal-thetaref)*(zl-zref)/ &
+ max(((ul-ulev(2))**2+(vl-vlev(2))**2+b*ust**2),0.1)
+ zl2=zl
+ theta2=thetal
+ if (ril.gt.ric) exit
+ if (i.eq.20) then
+ write(*,*) 'WARNING: NO RICHARDSON NUMBER GREATER THAN 0.25 FOUND', k,ril,ri
+ exit
+ endif
+ zl1=zl
+ theta1=thetal
+ !if (i.eq.20) stop 'RICHARDSON: NO RICHARDSON NUMBER GREATER THAN 0.25 FOUND'
+ end do
+
+ h=zl
+ thetam=0.5*(theta1+theta2)
+ wspeed=sqrt(ul**2+vl**2) ! Wind speed at z=hmix
+ bvfsq=(ga/thetam)*(theta2-theta1)/(zl2-zl1) ! Brunt-Vaisala frequency
+ ! at z=hmix
+
+ ! Under stable conditions, limit the maximum effect of the subgrid-scale topography
+ ! by the maximum lifting possible from the available kinetic energy
+ !*****************************************************************************
+
+ if(bvfsq.le.0.) then
+ hmixplus=9999.
+ else
+ bvf=sqrt(bvfsq)
+ hmixplus=wspeed/bvf*convke
+ endif
+
+
+ ! Calculate convective velocity scale
+ !************************************
+
+ if (hf.lt.0.) then
+ wst=(-h*ga/thetaref*hf/cpa)**0.333
+ excess=-bs*hf/cpa/wst
+ else
+ wst=0.
+ exit
+ endif
+ end do
+
+ ierr = 0
+ return
+
+! Fatal error -- print the inputs
+7000 continue
+ write(*,'(a )') 'nuvz'
+ write(*,'(i5 )') nuvz
+ write(*,'(a )') 'psurf,ust,hf,tt2,td2,h,wst,hmixplus'
+ write(*,'(1p,4e18.10)') psurf,ust,hf,tt2,td2,h,wst,hmixplus
+ write(*,'(a )') 'ttlev'
+ write(*,'(1p,4e18.10)') ttlev
+ write(*,'(a )') 'qvlev'
+ write(*,'(1p,4e18.10)') qvlev
+ write(*,'(a )') 'ulev'
+ write(*,'(1p,4e18.10)') ulev
+ write(*,'(a )') 'vlev'
+ write(*,'(1p,4e18.10)') vlev
+ write(*,'(a )') 'pplev'
+ write(*,'(1p,4e18.10)') pplev
+ return
+end subroutine richardson
+
+real function scalev(ps,t,td,stress)
+
+ !********************************************************************
+ ! *
+ ! Author: G. WOTAWA *
+ ! Date: 1994-06-27 *
+ ! Update: 1996-05-21 A. Stohl *
+ ! *
+ !********************************************************************
+ ! *
+ ! This Programm calculates scale velocity ustar from surface *
+ ! stress and air density. *
+ ! *
+ !********************************************************************
+ ! *
+ ! INPUT: *
+ ! *
+ ! ps surface pressure [Pa] *
+ ! t surface temperature [K] *
+ ! td surface dew point [K] *
+ ! stress surface stress [N/m2] *
+ ! *
+ !********************************************************************
+ use qvsat_mod
+
+ implicit none
+
+ real :: ps,t,td,e,tv,rhoa,stress
+
+ e=ew(td,ps) ! vapor pressure
+ tv=t*(1.+0.378*e/ps) ! virtual temperature
+ rhoa=ps/(r_air*tv) ! air density
+ scalev=sqrt(abs(stress)/rhoa)
+end function scalev
+
+end module getfields_mod
diff --git a/src/initialise_mod.f90 b/src/initialise_mod.f90
new file mode 100644
index 00000000..b156b781
--- /dev/null
+++ b/src/initialise_mod.f90
@@ -0,0 +1,1853 @@
+! SPDX-FileCopyrightText: FLEXPART 1998-2019, see flexpart_license.txt
+! SPDX-License-Identifier: GPL-3.0-or-later
+
+ !*****************************************************************************
+ ! *
+ ! L. Bakels 2021: This module contains subroutines related to the *
+ ! initialisation of the particles *
+ ! *
+ !*****************************************************************************
+
+module initialise_mod
+
+ use com_mod
+ use par_mod
+ use date_mod
+ use particle_mod
+ use windfields_mod
+ use random_mod
+ use coordinates_ecmwf_mod
+
+ implicit none
+
+ !**********************************************************
+ ! Variables used for domain-filling trajectory calculations
+ !**********************************************************
+
+ integer :: &
+ nx_we(2), & ! x indices of western and eastern boundary of domain-filling.
+ ny_sn(2), & ! y indices of southern and northern boundary of domain-filling.
+ numcolumn ! Maximum number of particles to be released within a single column.
+ integer,allocatable,dimension(:,:) :: &
+ numcolumn_we, & ! Number of particles to be released within one column
+ ! at the western and eastern boundary surfaces.
+ numcolumn_sn ! Same as numcolumn_we, but for southern and northern domain boundary.
+ real,allocatable,dimension(:,:,:) :: &
+ zcolumn_we, & ! Altitudes where particles are to be released
+ ! at the western and eastern boundary surfaces.
+ zcolumn_sn, & ! Same as zcolumn_we, but for southern and northern domain boundary.
+ acc_mass_we, & ! Mass that has accumulated at the western and eastern boundary;
+ ! if it exceeds xmassperparticle, a particle is released and
+ ! acc_mass_we is reduced accordingly.
+ acc_mass_sn ! Same as acc_mass_we, but for southern and northern domain boundary
+ real :: &
+ xmassperparticle ! Air mass per particle in the domain-filling traj. option.
+
+contains
+
+subroutine domainfill_allocate
+ implicit none
+ allocate(numcolumn_we(2,0:nymax-1),numcolumn_sn(2,0:nxmax-1))
+ allocate(zcolumn_we(2,0:nymax-1,maxcolumn),zcolumn_sn(2,0:nxmax-1,maxcolumn), &
+ acc_mass_we(2,0:nymax-1,maxcolumn),acc_mass_sn(2,0:nxmax-1,maxcolumn))
+end subroutine domainfill_allocate
+
+subroutine domainfill_deallocate
+ if (mdomainfill.lt.1) return
+ deallocate(numcolumn_we,numcolumn_sn,zcolumn_sn,zcolumn_we,acc_mass_sn,acc_mass_we)
+end subroutine domainfill_deallocate
+
+subroutine releaseparticles(itime)
+ ! o
+ !*****************************************************************************
+ ! *
+ ! This subroutine releases particles from the release locations. *
+ ! *
+ ! It searches for a "vacant" storage space and assigns all particle *
+ ! information to that space. A space is vacant either when no particle *
+ ! is yet assigned to it, or when it's particle is expired and, thus, *
+ ! the storage space is made available to a new particle. *
+ ! *
+ ! Author: A. Stohl *
+ ! *
+ ! 29 June 2002 *
+ ! *
+ !*****************************************************************************
+ ! *
+ ! Variables: *
+ ! itime [s] current time *
+ ! ireleasestart, ireleaseend start and end times of all releases *
+ ! npart(maxpoint) number of particles to be released in total *
+ ! numrel number of particles to be released during this time *
+ ! step *
+ ! *
+ !*****************************************************************************
+
+ use point_mod
+ use xmass_mod
+#ifdef USE_NCF
+ use netcdf_output_mod
+#endif
+ use output_mod
+
+ implicit none
+
+ !real xaux,yaux,zaux,ran1,rfraction,xmasssave(maxpoint)
+ real :: xaux,yaux,zaux,rfraction
+ real :: topo,rhoaux(2),r,t,rhoout
+ real :: dz1,dz2,dz,xlonav,timecorrect(maxspec),press,pressold
+ real :: presspart,average_timecorrect
+ integer :: itime,numrel,i,j,k,n,ipart,minpart,ii
+ integer :: kz,istart,iend,totpart
+ integer :: nweeks,ndayofweek,nhour,jjjjmmdd,ihmmss,mm
+ real(kind=dp) :: julmonday,jul,jullocal,juldiff
+ real,parameter :: eps2=1.e-6
+
+ integer :: ngrid,ix,jy,ixp,jyp,indz,indzp
+ real :: ddx,ddy,rddx,rddy,p1,p2,p3,p4,xtn,ytn
+
+ integer :: idummy = -7
+ !save idummy,xmasssave
+ !data idummy/-7/,xmasssave/maxpoint*0./
+
+ real :: frac,psint,zzlev,zzlev2,ttemp
+
+ real :: eps
+ eps=nxmax/3.e5
+
+
+ ! Determine the actual date and time in Greenwich (i.e., UTC + correction for daylight savings time)
+ !*****************************************************************************
+
+ julmonday=juldate(19000101,0) ! this is a Monday
+ jul=bdate+real(itime,kind=dp)/86400._dp ! this is the current day
+ call caldate(jul,jjjjmmdd,ihmmss)
+ mm=(jjjjmmdd-10000*(jjjjmmdd/10000))/100
+ if ((mm.ge.4).and.(mm.le.9)) jul=jul+1._dp/24._dp ! daylight savings time in summer
+
+
+ ! For every release point, check whether we are in the release time interval
+ !***************************************************************************
+ ! First allocate all particles that are going to be in the simulation
+
+ if (itime.eq.0) then
+ totpart=0
+ do i=1,numpoint
+ totpart = totpart+npart(i)
+ end do
+ call allocate_particles(totpart)
+ else if (itime.eq.itime_init) then !From restart point only allocate particles that are yet to be born
+ totpart=0
+ do i=1,numpoint
+ totpart = totpart+npart(i)
+ end do
+ if (totpart.gt.count%allocated) call allocate_particles(totpart-count%allocated)
+ end if
+
+ call get_total_part_num(istart)
+ minpart=1
+ do i=1,numpoint
+ if ((itime.ge.ireleasestart(i)).and. &! are we within release interval?
+ (itime.le.ireleaseend(i))) then
+
+ ! Determine the local day and time
+ !*********************************
+
+ xlonav=xlon0+(xpoint2(i)+xpoint1(i))/2.*dx ! longitude needed to determine local time
+ if (xlonav.lt.-180.) xlonav=xlonav+360.
+ if (xlonav.gt.180.) xlonav=xlonav-360.
+ jullocal=jul+real(xlonav,kind=dp)/360._dp ! correct approximately for time zone to obtain local time
+
+ juldiff=jullocal-julmonday
+ nweeks=int(juldiff/7._dp)
+ juldiff=juldiff-real(nweeks,kind=dp)*7._dp
+ ndayofweek=int(juldiff)+1 ! this is the current day of week, starting with Monday
+ nhour=nint((juldiff-real(ndayofweek-1,kind=dp))*24._dp) ! this is the current hour
+ if (nhour.eq.0) then
+ nhour=24
+ ndayofweek=ndayofweek-1
+ if (ndayofweek.eq.0) ndayofweek=7
+ endif
+
+ ! Calculate a species- and time-dependent correction factor, distinguishing between
+ ! area (those with release starting at surface) and point (release starting above surface) sources
+ ! Also, calculate an average time correction factor (species independent)
+ !*****************************************************************************
+ average_timecorrect=0.
+ do k=1,nspec
+ if(abs(xpoint2(i)-xpoint1(i)).lt.1.E-4.and.abs(ypoint2(i)-ypoint1(i)).lt.1.E-4) then
+ ! if (zpoint1(i).gt.0.5) then ! point source
+ timecorrect(k)=point_hour(k,nhour)*point_dow(k,ndayofweek)
+ else ! area source
+ timecorrect(k)=area_hour(k,nhour)*area_dow(k,ndayofweek)
+ endif
+ average_timecorrect=average_timecorrect+timecorrect(k)
+ end do
+ average_timecorrect=average_timecorrect/real(nspec)
+
+ ! Determine number of particles to be released this time; at start and at end of release,
+ ! only half the particles are released
+ !*****************************************************************************
+
+ if (ireleasestart(i).ne.ireleaseend(i)) then
+ rfraction=abs(real(npart(i))*real(lsynctime)/ &
+ real(ireleaseend(i)-ireleasestart(i)))
+ if ((itime.eq.ireleasestart(i)).or. &
+ (itime.eq.ireleaseend(i))) rfraction=rfraction/2.
+
+ ! Take the species-average time correction factor in order to scale the
+ ! number of particles released this time
+ !**********************************************************************
+ rfraction=rfraction*average_timecorrect
+
+ rfraction=rfraction+xmasssave(i) ! number to be released at this time
+ numrel=int(rfraction)
+ xmasssave(i)=rfraction-real(numrel)
+ else
+ numrel=npart(i)
+ endif
+
+ xaux=xpoint2(i)-xpoint1(i)
+ yaux=ypoint2(i)-ypoint1(i)
+ zaux=zpoint2(i)-zpoint1(i)
+
+ do j=1,numrel ! loop over particles to be released this time
+ call get_new_part_index(ipart)
+ call spawn_particle(itime, ipart)
+
+ ! Particle coordinates are determined by using a random position within the release volume
+ !*****************************************************************************
+
+ ! Determine horizontal particle position
+ !***************************************
+ call set_xlon(ipart,real(xpoint1(i)+ran1(idummy,0)*xaux,kind=dp))
+ if (xglobal) then
+ if (part(ipart)%xlon.gt.real(nxmin1,kind=dp)) &
+ call set_xlon(ipart,-real(nxmin1,kind=dp))
+ if (part(ipart)%xlon.lt.0.) &
+ call set_xlon(ipart,real(nxmin1,kind=dp))
+ endif
+ call set_ylat(ipart,real(ypoint1(i)+ran1(idummy,0)*yaux,kind=dp))
+
+ ! Assign mass to particle: Total mass divided by total number of particles.
+ ! Time variation has partly been taken into account already by a species-average
+ ! correction factor, by which the number of particles released this time has been
+ ! scaled. Adjust the mass per particle by the species-dependent time correction factor
+ ! divided by the species-average one
+ ! for the scavenging calculation the mass needs to be multiplied with rho of the particle layer and
+ ! divided by the sum of rho of all particles.
+ !*****************************************************************************
+ do k=1,nspec
+ part(ipart)%mass(k)=xmass(i,k)/real(npart(i)) &
+ *timecorrect(k)/average_timecorrect
+ part(ipart)%mass_init(k)=part(ipart)%mass(k)
+ if (DRYBKDEP.or.WETBKDEP) then ! if there is no scavenging in wetdepo it will be set to 0
+ ! if ( henry(k).gt.0 .or. &
+ ! crain_aero(k).gt.0. .or. csnow_aero(k).gt.0. .or. &
+ ! ccn_aero(k).gt.0. .or. in_aero(k).gt.0. ) then
+ xscav_frac1(ipart,k)=-1.
+ endif
+ ! Assign certain properties to particle
+ !**************************************
+ end do
+ part(ipart)%nclass=min(int(ran1(idummy,0)*real(nclassunc))+1, &
+ nclassunc)
+ numparticlecount=numparticlecount+1
+ if (mquasilag.eq.0) then
+ part(ipart)%npoint=i
+ else
+ part(ipart)%npoint=numparticlecount
+ endif
+ part(ipart)%idt=mintime ! first time step
+
+ ! Determine vertical particle position
+ !*************************************
+ call set_z(ipart,zpoint1(i)+ran1(idummy,0)*zaux)
+ ! Interpolation of topography and density
+ !****************************************
+
+ ! Determine the nest we are in
+ !*****************************
+ ! Temporary fix for nested layer edges: replaced eps with dxn and dyn (LB)
+ ngrid=0
+ do k=numbnests,1,-1
+ if ((real(part(ipart)%xlon).gt.xln(k)+dxn(k)).and. &
+ (real(part(ipart)%xlon).lt.xrn(k)-dxn(k)).and. &
+ (real(part(ipart)%xlon).gt.yln(k)+dyn(k)).and. &
+ (real(part(ipart)%xlon).lt.yrn(k)-dyn(k))) then
+ ngrid=k
+ exit
+ endif
+ end do
+
+ ! Determine (nested) grid coordinates and auxiliary parameters used for interpolation
+ !*****************************************************************************
+
+ if (ngrid.gt.0) then
+ xtn=(real(part(ipart)%xlon)-xln(ngrid))*xresoln(ngrid)
+ ytn=(real(part(ipart)%ylat)-yln(ngrid))*yresoln(ngrid)
+ ! ix=int(xtn)
+ ! jy=int(ytn)
+ ix=max(min(nint(xtn),nxn(ngrid)-1),0)
+ jy=max(min(nint(ytn),nyn(ngrid)-1),0)
+ ddy=ytn-real(jy)
+ ddx=xtn-real(ix)
+ else
+ ix=int(part(ipart)%xlon)
+ jy=int(part(ipart)%ylat)
+ ddy=part(ipart)%ylat-real(jy)
+ ddx=part(ipart)%xlon-real(ix)
+ endif
+ ixp=ix+1
+ jyp=jy+1
+ rddx=1.-ddx
+ rddy=1.-ddy
+ p1=rddx*rddy
+ p2=ddx*rddy
+ p3=rddx*ddy
+ p4=ddx*ddy
+
+ if (ngrid.gt.0) then
+ topo=p1*oron(ix ,jy ,ngrid) &
+ + p2*oron(ixp,jy ,ngrid) &
+ + p3*oron(ix ,jyp,ngrid) &
+ + p4*oron(ixp,jyp,ngrid)
+ else
+ topo=p1*oro(ix ,jy) &
+ + p2*oro(ixp,jy) &
+ + p3*oro(ix ,jyp) &
+ + p4*oro(ixp,jyp)
+ endif
+
+ ! If starting height is in pressure coordinates, retrieve pressure profile and convert zpart1 to meters
+ !*****************************************************************************
+ if (kindz(i).eq.3) then
+ presspart=part(ipart)%z
+ do kz=1,nz
+ if (ngrid.gt.0) then
+ r=p1*rhon(ix ,jy ,kz,2,ngrid) &
+ +p2*rhon(ixp,jy ,kz,2,ngrid) &
+ +p3*rhon(ix ,jyp,kz,2,ngrid) &
+ +p4*rhon(ixp,jyp,kz,2,ngrid)
+ t=p1*ttn(ix ,jy ,kz,2,ngrid) &
+ +p2*ttn(ixp,jy ,kz,2,ngrid) &
+ +p3*ttn(ix ,jyp,kz,2,ngrid) &
+ +p4*ttn(ixp,jyp,kz,2,ngrid)
+ else
+ r=p1*rho(ix ,jy ,kz,2) &
+ +p2*rho(ixp,jy ,kz,2) &
+ +p3*rho(ix ,jyp,kz,2) &
+ +p4*rho(ixp,jyp,kz,2)
+ t=p1*tt(ix ,jy ,kz,2) &
+ +p2*tt(ixp,jy ,kz,2) &
+ +p3*tt(ix ,jyp,kz,2) &
+ +p4*tt(ixp,jyp,kz,2)
+ endif
+ press=r*r_air*t/100.
+ if (kz.eq.1) pressold=press
+
+ if (press.lt.presspart) then
+ if (kz.eq.1) then
+ call set_z(ipart,height(1)/2.)
+ else
+ dz1=pressold-presspart
+ dz2=presspart-press
+ call set_z(ipart,(height(kz-1)*dz2+height(kz)*dz1) &
+ /(dz1+dz2))
+ endif
+ exit
+ endif
+ pressold=press
+ end do
+ endif
+
+
+ ! If release positions are given in meters above sea level, subtract the
+ ! topography from the starting height
+ !***********************************************************************
+
+ if (kindz(i).eq.2) call update_z(ipart,-topo)
+ if (part(ipart)%z.lt.eps2) call set_z(ipart,eps2) ! Minimum starting height is eps2
+ if (part(ipart)%z.gt.height(nz)-0.5) &
+ call set_z(ipart,height(nz)-0.5) ! Maximum starting height is uppermost level - 0.5 meters
+
+ if (wind_coord_type.eq.'ETA') then
+ call z_to_zeta(itime,part(ipart)%xlon,part(ipart)%ylat,part(ipart)%z,part(ipart)%zeta)
+ part(ipart)%etaupdate = .true. ! The z(meter) coordinate is up to date
+ end if
+
+ ! For special simulations, multiply particle concentration air density;
+ ! Simply take the 2nd field in memory to do this (accurate enough)
+ !***********************************************************************
+ !AF IND_SOURCE switches between different units for concentrations at the source
+ !Af NOTE that in backward simulations the release of particles takes place at the
+ !Af receptor and the sampling at the source.
+ !Af 1="mass"
+ !Af 2="mass mixing ratio"
+ !Af IND_RECEPTOR switches between different units for concentrations at the receptor
+ ! 0= no receptors
+ !Af 1="mass"
+ !Af 2="mass mixing ratio"
+ ! 3 = wet deposition in outputfield
+ ! 4 = dry deposition in outputfield
+
+ !Af switches for the releasefile:
+ !Af IND_REL = 1 : xmass * rho
+ !Af IND_REL = 0 : xmass * 1
+
+ !Af ind_rel is defined in readcommand.f
+
+ if ((ind_rel .eq. 1).or.(ind_rel .eq. 3).or.(ind_rel .eq. 4)) then
+
+ ! Interpolate the air density
+ !****************************
+
+ do ii=2,nz
+ if (height(ii).gt.part(ipart)%z) then
+ indz=ii-1
+ indzp=ii
+ exit
+ endif
+ end do
+
+ dz1=part(ipart)%z-height(indz)
+ dz2=height(indzp)-part(ipart)%z
+ dz=1./(dz1+dz2)
+
+ if (ngrid.gt.0) then
+ do n=1,2
+ rhoaux(n)=p1*rhon(ix ,jy ,indz+n-1,2,ngrid) &
+ +p2*rhon(ixp,jy ,indz+n-1,2,ngrid) &
+ +p3*rhon(ix ,jyp,indz+n-1,2,ngrid) &
+ +p4*rhon(ixp,jyp,indz+n-1,2,ngrid)
+ end do
+ else
+ do n=1,2
+ rhoaux(n)=p1*rho(ix ,jy ,indz+n-1,2) &
+ +p2*rho(ixp,jy ,indz+n-1,2) &
+ +p3*rho(ix ,jyp,indz+n-1,2) &
+ +p4*rho(ixp,jyp,indz+n-1,2)
+ end do
+ endif
+ rhoout=(dz2*rhoaux(1)+dz1*rhoaux(2))*dz
+ rho_rel(i)=rhoout
+
+
+ ! Multiply "mass" (i.e., mass mixing ratio in forward runs) with density
+ !********************************************************************
+
+ do k=1,nspec
+ part(ipart)%mass(k)=part(ipart)%mass(k)*rhoout
+ part(ipart)%mass_init(k)=part(ipart)%mass(k)
+ end do
+ endif
+
+ call get_total_part_num(numpart)
+
+ end do ! numrel
+ endif ! releasepoint
+ end do ! numpoint
+
+ call get_total_part_num(iend)
+
+ ! NetCDF only: write initial positions of new particles
+#ifdef USE_NCF
+ if ((iend-istart.gt.0).and.(ipout.ge.1)) then
+ call write_particles_initialoutput(itime,istart,iend)
+ call output_particles(itime,.true.)
+ endif
+#endif
+ return
+
+996 continue
+ write(*,*) '#####################################################'
+ write(*,*) '#### FLEXPART MODEL SUBROUTINE RELEASEPARTICLES: ####'
+ write(*,*) '#### ####'
+ write(*,*) '#### ERROR - TOTAL NUMBER OF PARTICLES REQUIRED ####'
+ write(*,*) '#### EXCEEDS THE MAXIMUM ALLOWED NUMBER. REDUCE ####'
+ write(*,*) '#### EITHER NUMBER OF PARTICLES PER RELEASE POINT####'
+ write(*,*) '#### OR REDUCE NUMBER OF RELEASE POINTS. ####'
+ write(*,*) '#####################################################'
+ stop
+
+end subroutine releaseparticles
+
+subroutine readpartpositions
+
+ !*****************************************************************************
+ ! *
+ ! This routine opens the particle dump file and reads all the particle *
+ ! positions from a previous run to initialize the current run. *
+ ! *
+ ! *
+ ! Author: A. Stohl *
+ ! *
+ ! 24 March 2000 *
+ ! *
+ ! Changes *
+ ! 2022, L. Bakels: NetCDF option for reading particle information *
+ ! *
+ !*****************************************************************************
+ ! *
+ ! Variables: *
+ ! *
+ !*****************************************************************************
+
+ use netcdf_output_mod
+
+ implicit none
+
+ integer :: ibdatein,ibtimein,nspecin,itimein,numpointin,i,j,lix,ios
+ integer :: id1,id2,it1,it2
+ real :: xlonin,ylatin,topo,hmixi,pvi,qvi,rhoi,tri,tti
+ character :: specin*7
+ real(kind=dp) :: julin,julpartin
+
+ integer :: idummy = -8
+
+ numparticlecount=0
+
+ ! Open header file of dumped particle data
+ !*****************************************
+ if (lnetcdfout.eq.1) then
+#ifdef USE_NCF
+ call readpartpositions_netcdf(ibtime,ibdate)
+ call get_total_part_num(numpart)
+ numparticlecount=numpart
+ return
+#endif
+ endif
+
+ open(unitpartin,file=path(2)(1:length(2))//'header', &
+ form='unformatted',err=998)
+
+ read(unitpartin) ibdatein,ibtimein
+ read(unitpartin)
+ read(unitpartin)
+
+ read(unitpartin)
+ read(unitpartin)
+ read(unitpartin) nspecin
+ nspecin=nspecin/3
+ if ((ldirect.eq.1).and.(nspec.ne.nspecin)) then
+ write(*,*) ' #### FLEXPART MODEL ERROR IN READPARTPOSITIONS#### '
+ write(*,*) ' #### THE NUMBER OF SPECIES TO BE READ IN DOES #### '
+ write(*,*) ' #### NOT AGREE WITH CURRENT SETTINGS! #### '
+ stop
+ end if
+
+ do i=1,nspecin
+ read(unitpartin)
+ read(unitpartin)
+ read(unitpartin) j,specin
+ if ((ldirect.eq.1).and.(species(i)(1:7).ne.specin)) then
+ write(*,*) ' #### FLEXPART MODEL ERROR IN READPARTPOSITIONS#### '
+ write(*,*) ' #### SPECIES NAMES TO BE READ IN DO NOT #### '
+ write(*,*) ' #### AGREE WITH CURRENT SETTINGS! #### '
+ stop
+ end if
+ end do
+
+ read(unitpartin) numpointin
+ if (numpointin.ne.numpoint) then
+ write(*,*) ' #### FLEXPART MODEL WARNING IN READPARTPOSITIONS#### '
+ write(*,*) ' #### NUMBER OF RELEASE LOCATIONS DOES NOT #### '
+ write(*,*) ' #### AGREE WITH CURRENT SETTINGS! #### '
+ end if
+ do i=1,numpointin
+ read(unitpartin)
+ read(unitpartin)
+ read(unitpartin)
+ read(unitpartin)
+ do j=1,nspec
+ read(unitpartin)
+ read(unitpartin)
+ read(unitpartin)
+ end do
+ end do
+ read(unitpartin)
+ read(unitpartin)
+
+ do lix=0,numxgrid-1
+ read(unitpartin)
+ end do
+
+
+ ! Open data file of dumped particle data
+ !***************************************
+
+ close(unitpartin)
+ open(unitpartin,file=path(2)(1:length(2))//'partposit_end', &
+ form='unformatted',err=998)
+
+
+ do
+ read(unitpartin,iostat=ios) itimein
+ if (ios.lt.0) exit
+ i=0
+ do
+ i=i+1
+ read(unitpartin) part(i)%npoint,xlonin,ylatin,part(i)%z,part(i)%tstart, &
+ topo,pvi,qvi,rhoi,hmixi,tri,tti,(part(i)%mass(j),j=1,nspec)
+ ! For switching coordinates: this happens in timemanager.f90 after the first fields are read
+ if (xlonin.eq.-9999.9) exit
+ call set_xlon(i,real((xlonin-xlon0)/dx,kind=dp))
+ call set_ylat(i,real((ylatin-ylat0)/dy,kind=dp))
+ numparticlecount=max(numparticlecount,part(i)%npoint)
+ end do
+ end do
+
+ numpart=i-1
+
+ close(unitpartin)
+
+ julin=juldate(ibdatein,ibtimein)+real(itimein,kind=dp)/86400._dp
+ if (abs(julin-bdate).gt.1.e-5) then
+ write(*,*) ' #### FLEXPART MODEL ERROR IN READPARTPOSITIONS#### '
+ write(*,*) ' #### ENDING TIME OF PREVIOUS MODEL RUN DOES #### '
+ write(*,*) ' #### NOT AGREE WITH STARTING TIME OF THIS RUN.#### '
+ call caldate(julin,id1,it1)
+ call caldate(bdate,id2,it2)
+ write(*,*) 'julin: ',julin,id1,it1
+ write(*,*) 'bdate: ',bdate,id2,it2
+ stop
+ end if
+ do i=1,numpart
+ julpartin=juldate(ibdatein,ibtimein)+ &
+ real(part(i)%tstart,kind=dp)/86400._dp
+ part(i)%nclass=min(int(ran1(idummy,0)*real(nclassunc))+1, &
+ nclassunc)
+ part(i)%idt=mintime
+ part(i)%tstart=nint((julpartin-bdate)*86400.)
+ end do
+
+ return
+
+998 write(*,*) ' #### FLEXPART MODEL ERROR! THE FILE #### '
+ write(*,*) ' #### '//path(2)(1:length(2))//'partposit'//' #### '
+ write(*,*) ' #### CANNOT BE OPENED. IF A FILE WITH THIS #### '
+ write(*,*) ' #### NAME ALREADY EXISTS, DELETE IT AND START #### '
+ write(*,*) ' #### THE PROGRAM AGAIN. #### '
+ stop
+
+end subroutine readpartpositions
+
+subroutine initialize_particle(itime,ipart)
+ ! i i o o o
+ ! o o o i i i o
+ !*****************************************************************************
+ ! *
+ ! Calculation of trajectories utilizing a zero-acceleration scheme. The time*
+ ! step is determined by the Courant-Friedrichs-Lewy (CFL) criterion. This *
+ ! means that the time step must be so small that the displacement within *
+ ! this time step is smaller than 1 grid distance. Additionally, a temporal *
+ ! CFL criterion is introduced: the time step must be smaller than the time *
+ ! interval of the wind fields used for interpolation. *
+ ! For random walk simulations, these are the only time step criteria. *
+ ! For the other options, the time step is also limited by the Lagrangian *
+ ! time scale. *
+ ! *
+ ! Author: A. Stohl *
+ ! *
+ ! 16 December 1997 *
+ ! *
+ ! Literature: *
+ ! *
+ !*****************************************************************************
+ ! *
+ ! Variables: *
+ ! h [m] Mixing height *
+ ! lwindinterv [s] time interval between two wind fields *
+ ! itime [s] current temporal position *
+ ! ldt [s] Suggested time step for next integration *
+ ! ladvance [s] Total integration time period *
+ ! rannumb(maxrand) normally distributed random variables *
+ ! usig,vsig,wsig uncertainties of wind velocities due to interpolation *
+ ! xt,yt,zt Next time step's spatial position of trajectory *
+ ! *
+ ! *
+ ! Constants: *
+ ! cfl factor, by which the time step has to be smaller than *
+ ! the spatial CFL-criterion *
+ ! cflt factor, by which the time step has to be smaller than *
+ ! the temporal CFL-criterion *
+ ! *
+ !*****************************************************************************
+
+ use turbulence_mod
+ use random_mod, only: ran3
+ use omp_lib
+ use interpol_mod
+ use cbl_mod
+
+ implicit none
+
+ integer,intent(in) :: &
+ itime, &
+ ipart
+ integer :: i,j,k,m,indexh
+ integer :: nrand
+ real :: dz,dz1,dz2,wp
+ real :: ttemp,dummy1,dummy2
+ real :: xt,yt,zt,zteta
+ integer :: thread
+
+#ifdef _OPENMP
+ thread = OMP_GET_THREAD_NUM()
+#else
+ thread = 0
+#endif
+
+ part(ipart)%icbt=1 ! initialize particle to no "reflection"
+
+ nrand=int(ran3(iseed1(thread),thread)*real(maxrand-1))+1
+
+ xt = real(part(ipart)%xlon)
+ yt = real(part(ipart)%ylat)
+ zt = real(part(ipart)%z)
+ zteta = real(part(ipart)%zeta)
+
+ !******************************
+ ! 2. Interpolate necessary data
+ !******************************
+
+ ! Where in the grid? Stereographic (ngrid<0) or nested (ngrid>0)
+ !***************************************************************
+ call find_ngrid(xt,yt)
+ ! Compute maximum mixing height around particle position
+ !*******************************************************
+ call determine_grid_coordinates(xt,yt)
+
+ h=max(hmix(ix ,jy,1,memind(1)), &
+ hmix(ixp,jy ,1,memind(1)), &
+ hmix(ix ,jyp,1,memind(1)), &
+ hmix(ixp,jyp,1,memind(1)), &
+ hmix(ix ,jy ,1,memind(2)), &
+ hmix(ixp,jy ,1,memind(2)), &
+ hmix(ix ,jyp,1,memind(2)), &
+ hmix(ixp,jyp,1,memind(2)))
+
+ zeta=zt/h
+
+
+ !*************************************************************
+ ! If particle is in the PBL, interpolate once and then make a
+ ! time loop until end of interval is reached
+ !*************************************************************
+
+ if (zeta.le.1.) then
+
+ call interpol_PBL(itime,xt,yt,zt,zteta)
+
+ ! Vertical interpolation of u,v,w,rho and drhodz
+ !***********************************************
+
+ ! Vertical distance to the level below and above current position
+ ! both in terms of (u,v) and (w) fields
+ !****************************************************************
+ call interpol_PBL_short(zt,dummy1,dummy2)
+
+ ! Compute the turbulent disturbances
+
+ ! Determine the sigmas and the timescales
+ !****************************************
+
+ if (turbswitch) then
+ call hanna(zt)
+ else
+ call hanna1(zt)
+ endif
+
+
+ ! Determine the new diffusivity velocities
+ !*****************************************
+
+ if (nrand+2.gt.maxrand) nrand=1
+ part(ipart)%turbvel%u=rannumb(nrand)*sigu
+ part(ipart)%turbvel%v=rannumb(nrand+1)*sigv
+ part(ipart)%turbvel%w=rannumb(nrand+2)
+ if (.not.turbswitch) then ! modified by mc
+ part(ipart)%turbvel%w=part(ipart)%turbvel%w*sigw
+ else if (cblflag.eq.1) then ! modified by mc
+ if(-h/ol.gt.5) then
+ !if (ol.lt.0.) then
+ !if (ol.gt.0.) then !by mc : only for test correct is lt.0
+ call initialize_cbl_vel(iseed1(thread),zt,ust,wst,h,sigw,part(ipart)%turbvel%w,ol,thread)
+ else
+ part(ipart)%turbvel%w=part(ipart)%turbvel%w*sigw
+ end if
+ end if
+
+
+ ! Determine time step for next integration
+ !*****************************************
+
+ if (turbswitch) then
+ part(ipart)%idt=int(min(tlw,h/max(2.*abs(part(ipart)%turbvel%w*sigw),1.e-5), &
+ 0.5/abs(dsigwdz),600.)*ctl)
+ else
+ part(ipart)%idt=int(min(tlw,h/max(2.*abs(part(ipart)%turbvel%w),1.e-5),600.)*ctl)
+ endif
+ part(ipart)%idt=max(part(ipart)%idt,mintime)
+
+ ! call interpol_average()
+ ! usig=(usigprof(indzp)+usigprof(indz))/2.
+ ! vsig=(vsigprof(indzp)+vsigprof(indz))/2.
+ ! wsig=(wsigprof(indzp)+wsigprof(indz))/2.
+
+ ! wsigeta=(wsigprofeta(indzpeta)+wsigprofeta(indzeta))/2.
+
+ else
+
+
+
+ !**********************************************************
+ ! For all particles that are outside the PBL, make a single
+ ! time step. Only horizontal turbulent disturbances are
+ ! calculated. Vertical disturbances are reset.
+ !**********************************************************
+
+
+ ! Interpolate the wind
+ !*********************
+
+ call interpol_wind(itime,xt,yt,zt,zteta,10)
+
+
+ ! Compute everything for above the PBL
+
+ ! Assume constant turbulent perturbations
+ !****************************************
+
+ part(ipart)%idt=abs(lsynctime)
+
+ if (nrand+1.gt.maxrand) nrand=1
+ part(ipart)%turbvel%u=rannumb(nrand)*0.3
+ part(ipart)%turbvel%v=rannumb(nrand+1)*0.3
+ nrand=nrand+2
+ part(ipart)%turbvel%w=0.
+ sigw=0.
+
+ endif
+
+ !****************************************************************
+ ! Add mesoscale random disturbances
+ ! This is done only once for the whole lsynctime interval to save
+ ! computation time
+ !****************************************************************
+
+
+ ! It is assumed that the average interpolation error is 1/2 sigma
+ ! of the surrounding points, autocorrelation time constant is
+ ! 1/2 of time interval between wind fields
+ !****************************************************************
+ if (mesoscale_turbulence) then
+ call interpol_mesoscale(itime,xt,yt,zt,zteta)
+ if (nrand+2.gt.maxrand) nrand=1
+ part(ipart)%mesovel%u=rannumb(nrand)*usig
+ part(ipart)%mesovel%v=rannumb(nrand+1)*vsig
+ select case (wind_coord_type)
+ case ('ETA')
+ part(ipart)%mesovel%w=rannumb(nrand+2)*wsigeta
+ case ('METER')
+ part(ipart)%mesovel%w=rannumb(nrand+2)*wsig
+ case default
+ part(ipart)%mesovel%w=rannumb(nrand+2)*wsig
+ end select
+ endif
+end subroutine initialize_particle
+
+subroutine init_domainfill
+ !
+ !*****************************************************************************
+ ! *
+ ! Initializes particles equally distributed over the first release location *
+ ! specified in file RELEASES. This box is assumed to be the domain for doing *
+ ! domain-filling trajectory calculations. *
+ ! All particles carry the same amount of mass which alltogether comprises the*
+ ! mass of air within the box. *
+ ! *
+ ! Author: A. Stohl *
+ ! *
+ ! 15 October 2002 *
+ ! *
+ ! Changes *
+ ! 2022, L. Bakels: OpenMP parallelisation *
+ ! *
+ !*****************************************************************************
+ ! *
+ ! Variables: *
+ ! *
+ ! numparticlecount consecutively counts the number of particles released *
+ ! nx_we(2) grid indices for western and eastern boundary of domain- *
+ ! filling trajectory calculations *
+ ! ny_sn(2) grid indices for southern and northern boundary of domain- *
+ ! filling trajectory calculations *
+ ! *
+ !*****************************************************************************
+
+ use point_mod
+ use particle_mod
+
+ implicit none
+
+ integer :: j,kz,lix,ljy,ncolumn,numparttot
+ real :: pp(nzmax),ylat,ylatp,ylatm,hzone
+ real :: cosfactm,cosfactp,deltacol,dz1,dz2,dz,pnew,pnew_temp,fractus
+ real,parameter :: pih=pi/180.
+ real :: colmasstotal,zposition
+
+ integer :: ixm,ixp,jym,jyp,indzm,indzh,indzp,i,jj,ii
+ integer :: alive_tmp,allocated_tmp,spawned_tmp,terminated_tmp
+ real :: pvpart,ddx,ddy,rddx,rddy,p1,p2,p3,p4,y1(2)
+ integer :: idummy = -11
+
+ real :: frac,psint,zzlev,zzlev2,ttemp,height_tmp
+
+ logical :: deall
+
+ real,allocatable,dimension(:) :: gridarea !
+ real,allocatable,dimension(:,:) :: colmass !
+
+ ! Determine the release region (only full grid cells), over which particles
+ ! shall be initialized
+ ! Use 2 fields for west/east and south/north boundary
+ !**************************************************************************
+ call domainfill_allocate
+
+ nx_we(1)=max(int(xpoint1(1)),0)
+ nx_we(2)=min((int(xpoint2(1))+1),nxmin1)
+ ny_sn(1)=max(int(ypoint1(1)),0)
+ ny_sn(2)=min((int(ypoint2(1))+1),nymin1)
+
+ ! For global simulations (both global wind data and global domain-filling),
+ ! set a switch, such that no boundary conditions are used
+ !**************************************************************************
+ if (xglobal.and.sglobal.and.nglobal) then
+ if ((nx_we(1).eq.0).and.(nx_we(2).eq.nxmin1).and. &
+ (ny_sn(1).eq.0).and.(ny_sn(2).eq.nymin1)) then
+ gdomainfill=.true.
+ else
+ gdomainfill=.false.
+ endif
+ endif
+ write(*,*) 'Global domain: ', gdomainfill
+
+ ! Exit here if resuming a run from particle dump
+ !***********************************************
+ if (gdomainfill.and.ipin.ne.0) return
+
+ ! Allocate grid and column mass
+ !*******************************
+ allocate(gridarea(0:nymax-1),colmass(0:nxmax-1,0:nymax-1))
+
+ ! Do not release particles twice (i.e., not at both in the leftmost and rightmost
+ ! grid cell) for a global domain
+ !*****************************************************************************
+ if (xglobal) nx_we(2)=min(nx_we(2),nx-2)
+
+
+ ! Calculate area of grid cell with formula M=2*pi*R*h*dx/360,
+ ! see Netz, Formeln der Mathematik, 5. Auflage (1983), p.90
+ !************************************************************
+ ! First for the south pole
+
+ if (sglobal) then
+ ylat=ylat0
+ ylatp=ylat+0.5*dy
+ ylatm=ylat
+ cosfactm=0.
+ cosfactp=cos(ylatp*pih)*r_earth
+ hzone=sqrt(r_earth**2-cosfactm**2)- &
+ sqrt(r_earth**2-cosfactp**2)
+ gridarea(0)=2.*pi*r_earth*hzone*dx/360.
+ endif
+
+ ! Do the same for the north pole
+
+ if (nglobal) then
+ ylat=ylat0+real(nymin1)*dy
+ ylatp=ylat
+ ylatm=ylat-0.5*dy
+ cosfactp=0.
+ cosfactm=cos(ylatm*pih)*r_earth
+ hzone=sqrt(r_earth**2-cosfactp**2)- &
+ sqrt(r_earth**2-cosfactm**2)
+ gridarea(nymin1)=2.*pi*r_earth*hzone*dx/360.
+ endif
+
+
+
+ ! Allocate memory for storing the particles
+ !******************************************
+ call allocate_particles(npart(1))
+
+ ! Initialise total particle number
+ numparttot=0
+ ! Initialise max column number
+ numcolumn=0
+
+ ! Initialise the sum over the total mass of the atmosphere
+ colmasstotal=0.
+
+!$OMP PARALLEL PRIVATE(ljy,ylat,ylatp,ylatm,hzone,cosfactp,cosfactm,pp,lix) &
+!$OMP REDUCTION(+:colmasstotal)
+!$OMP DO
+ do ljy=ny_sn(1),ny_sn(2) ! loop about latitudes
+ ylat=ylat0+real(ljy)*dy
+ ylatp=ylat+0.5*dy
+ ylatm=ylat-0.5*dy
+ if ((ylatm.lt.0).and.(ylatp.gt.0.)) then
+ hzone=1./dyconst
+ else
+ cosfactp=cos(ylatp*pih)*r_earth
+ cosfactm=cos(ylatm*pih)*r_earth
+ if (cosfactp.lt.cosfactm) then
+ hzone=sqrt(r_earth**2-cosfactp**2)- &
+ sqrt(r_earth**2-cosfactm**2)
+ else
+ hzone=sqrt(r_earth**2-cosfactm**2)- &
+ sqrt(r_earth**2-cosfactp**2)
+ endif
+ endif
+ gridarea(ljy)=2.*pi*r_earth*hzone*dx/360.
+ end do
+!$OMP END DO
+!$OMP BARRIER
+
+ ! Calculate total mass of each grid column and of the whole atmosphere
+ !*********************************************************************
+!$OMP DO
+ do ljy=ny_sn(1),ny_sn(2) ! loop about latitudes
+ do lix=nx_we(1),nx_we(2) ! loop about longitudes
+ pp(1)=prs(lix,ljy,1,1) !rho(lix,ljy,1,1)*r_air*tt(lix,ljy,1,1)
+ pp(nz)=prs(lix,ljy,nz,1) !rho(lix,ljy,nz,1)*r_air*tt(lix,ljy,nz,1)
+ colmass(lix,ljy)=(pp(1)-pp(nz))/ga*gridarea(ljy)
+ colmasstotal=colmasstotal+colmass(lix,ljy)
+ end do
+ end do
+!$OMP END DO
+!$OMP END PARALLEL
+
+ write(*,*) 'Atm. mass: ',colmasstotal
+
+ if (ipin.eq.0) numpart=0
+
+ ! Determine the particle positions
+ !*********************************
+ do ljy=ny_sn(1),ny_sn(2) ! loop about latitudes
+ ylat=ylat0+real(ljy)*dy
+ do lix=nx_we(1),nx_we(2) ! loop about longitudes
+ ncolumn=nint(0.999*real(npart(1))*colmass(lix,ljy)/ &
+ colmasstotal)
+ if (ncolumn.eq.0) cycle
+ if (ncolumn.gt.numcolumn) numcolumn=ncolumn
+
+ ! Calculate pressure at the altitudes of model surfaces, using the air density
+ ! information, which is stored as a 3-d field
+ !*****************************************************************************
+
+ do kz=1,nz
+ pp(kz)=prs(lix,ljy,kz,1)!rho(lix,ljy,kz,1)*r_air*tt(lix,ljy,kz,1)
+ end do
+
+
+ deltacol=(pp(1)-pp(nz))/real(ncolumn)
+ pnew=pp(1)+deltacol/2.
+ jj=0
+ do j=1,ncolumn ! looping over the number of particles within the column
+
+ ! For columns with many particles (i.e. around the equator), distribute
+ ! the particles equally (1 on a random position within the deltacol range),
+ ! for columns with few particles (i.e. around the poles),
+ ! distribute the particles randomly
+ !***********************************************************************
+
+ if ((ncolumn.gt.20).and.(ncolumn-j.gt.20)) then
+ pnew_temp=pnew-ran1(idummy,0)*deltacol
+ pnew=pnew-deltacol
+ else if ((ncolumn.gt.20).and.(ncolumn-j.le.20)) then
+ ! When only few particles are left, distribute them randomly above pnew
+ pnew_temp=pnew-ran1(idummy,0)*(pnew-pp(nz))
+ else
+ pnew_temp=pp(1)-ran1(idummy,0)*(pp(1)-pp(nz))
+ endif
+
+ do kz=1,nz-1
+ if ((pp(kz).ge.pnew_temp).and.(pp(kz+1).lt.pnew_temp)) then
+ dz1=log(pnew_temp)-log(pp(kz))
+ dz=1./log(pp(kz+1)/pp(kz))
+
+ ! Assign particle position
+ !*************************
+ ! Do the following steps only if particles are not read in from previous model run
+ !*****************************************************************************
+ if (ipin.eq.0) then
+ ! First spawn the particle into existence
+ !****************************************
+ jj=jj+1
+ !THIS WILL CAUSE PROBLEMS WITH OMP! because of dynamical allocation
+ call spawn_particle(0,numpart+jj)
+ if (allocated_tmp.lt.numpart+jj) allocated_tmp=numpart+jj
+ call set_xlon(numpart+jj,real(real(lix)-0.5+ran1(idummy,0),kind=dp))
+ if (lix.eq.0) call set_xlon(numpart+jj,real(ran1(idummy,0),kind=dp))
+ if (lix.eq.nxmin1) &
+ call set_xlon(numpart+jj,real(real(nxmin1)-ran1(idummy,0),kind=dp))
+ call set_ylat(numpart+jj,real(real(ljy)-0.5+ran1(idummy,0),kind=dp))
+ ! Logarithmic distribution of particles along pressure levels:
+ ! hx=h1+(h2-h1)/log(p2/p1)*log(px/p1)
+ height_tmp=height(kz)+(height(kz+1)-height(kz))*dz*dz1
+ call set_z(numpart+jj,height_tmp)
+ if (real(part(numpart+jj)%z).gt.height(nz)-0.5) &
+ call set_z(numpart+jj,height(nz)-0.5)
+
+ call update_z_to_zeta(0, numpart+jj)
+
+ ! Interpolate PV to the particle position
+ !****************************************
+ ixm=int(part(numpart+jj)%xlon)
+ jym=int(part(numpart+jj)%ylat)
+ ixp=ixm+1
+ jyp=jym+1
+ ddx=part(numpart+jj)%xlon-real(ixm)
+ ddy=part(numpart+jj)%ylat-real(jym)
+ rddx=1.-ddx
+ rddy=1.-ddy
+ p1=rddx*rddy
+ p2=ddx*rddy
+ p3=rddx*ddy
+ p4=ddx*ddy
+
+ !***************************************************************************
+ indzm=nz-1
+ indzp=nz
+ do i=2,nz
+ if (real(height(i),kind=dp).gt.part(numpart+jj)%z) then
+ indzm=i-1
+ indzp=i
+ exit
+ endif
+ end do
+ dz1=real(part(numpart+jj)%z)-height(indzm)
+ dz2=height(indzp)-real(part(numpart+jj)%z)
+ dz=1./(dz1+dz2)
+ do ii=1,2
+ indzh=indzm+ii-1
+ y1(ii)=p1*pv(ixm,jym,indzh,1) &
+ +p2*pv(ixp,jym,indzh,1) &
+ +p3*pv(ixm,jyp,indzh,1) &
+ +p4*pv(ixp,jyp,indzh,1)
+ end do
+ pvpart=(dz2*y1(1)+dz1*y1(2))*dz
+ if (ylat.lt.0.) pvpart=-1.*pvpart
+
+
+ ! For domain-filling option 2 (stratospheric O3), do the rest only in the stratosphere
+ !*****************************************************************************
+
+ if (((part(numpart+jj)%z.gt.3000.).and. &
+ (pvpart.gt.pvcrit)).or.(mdomainfill.eq.1)) then
+
+ ! Assign certain properties to the particle
+ !******************************************
+ part(numpart+jj)%nclass=min(int(ran1(idummy,0)* &
+ real(nclassunc))+1,nclassunc)
+ numparticlecount=numparticlecount+1
+ part(numpart+jj)%npoint=numparticlecount
+ part(numpart+jj)%idt=mintime
+ part(numpart+jj)%mass(1)=colmass(lix,ljy)/real(ncolumn)
+ if (mdomainfill.eq.2) part(numpart+jj)%mass(1)= &
+ part(numpart+jj)%mass(1)*pvpart*48./29.*ozonescale/10.**9
+ part(numpart+jj)%mass_init(1)=part(numpart+jj)%mass(1)
+ else
+ call terminate_particle(numpart+jj, 0)
+ jj=jj-1
+ endif
+ endif
+ endif
+ end do
+ end do
+ numparttot=numparttot+ncolumn
+ if (ipin.eq.0) numpart=numpart+jj
+ end do
+ end do
+
+
+ alive_tmp=count%alive
+ spawned_tmp=count%spawned
+ allocated_tmp=count%allocated
+ terminated_tmp=count%terminated
+
+!$OMP PARALLEL PRIVATE(j) REDUCTION(+:alive_tmp,spawned_tmp,allocated_tmp,terminated_tmp)
+
+ ! Make sure that all particles are within domain
+ !***********************************************
+!$OMP DO
+ do j=1,numpart
+ if ((part(j)%xlon.lt.0.).or.(part(j)%xlon.ge.real(nxmin1,kind=dp)).or. &
+ (part(j)%ylat.lt.0.).or.(part(j)%ylat.ge.real(nymin1,kind=dp))) then
+ call terminate_particle(j,0)
+ alive_tmp=alive_tmp-1
+ terminated_tmp=terminated_tmp+1
+ endif
+ end do
+!$OMP END DO
+!$OMP END PARALLEL
+
+ count%alive=alive_tmp
+ count%spawned=spawned_tmp
+ count%allocated=allocated_tmp
+ count%terminated=terminated_tmp
+ ! Check whether numpart is really smaller than maxpart
+ !*****************************************************
+
+ ! ! ESO :TODO: this warning need to be moved further up, else out-of-bounds error earlier
+ ! if (numpart.gt.maxpart) then
+ ! write(*,*) 'numpart too large: change source in init_atm_mass.f'
+ ! write(*,*) 'numpart: ',numpart,' maxpart: ',maxpart
+ ! endif
+
+
+ xmassperparticle=colmasstotal/real(numparttot)
+
+
+ ! For boundary conditions, we need fewer particle release heights per column,
+ ! because otherwise it takes too long until enough mass has accumulated to
+ ! release a particle at the boundary (would take dx/u seconds), leading to
+ ! relatively large position errors of the order of one grid distance.
+ ! It's better to release fewer particles per column, but to do so more often.
+ ! Thus, use on the order of nz starting heights per column.
+ ! We thus repeat the above to determine fewer starting heights, that are
+ ! used furtheron in subroutine boundcond_domainfill.f.
+ !****************************************************************************
+
+ fractus=real(numcolumn)/real(nz)
+ write(*,*) 'Total number of particles at model start: ',numpart
+ write(*,*) 'Maximum number of particles per column: ',numcolumn
+ write(*,*) 'If ',fractus,' <1, better use more particles'
+ fractus=sqrt(max(fractus,1.))/2.
+
+ do ljy=ny_sn(1),ny_sn(2) ! loop about latitudes
+ do lix=nx_we(1),nx_we(2) ! loop about longitudes
+ ncolumn=nint(0.999/fractus*real(npart(1))*colmass(lix,ljy) &
+ /colmasstotal)
+ if (ncolumn.gt.maxcolumn) stop 'maxcolumn too small'
+ if (ncolumn.eq.0) cycle
+
+
+ ! Memorize how many particles per column shall be used for all boundaries
+ ! This is further used in subroutine boundcond_domainfill.f
+ ! Use 2 fields for west/east and south/north boundary
+ !************************************************************************
+
+ if (lix.eq.nx_we(1)) numcolumn_we(1,ljy)=ncolumn
+ if (lix.eq.nx_we(2)) numcolumn_we(2,ljy)=ncolumn
+ if (ljy.eq.ny_sn(1)) numcolumn_sn(1,lix)=ncolumn
+ if (ljy.eq.ny_sn(2)) numcolumn_sn(2,lix)=ncolumn
+
+ ! Calculate pressure at the altitudes of model surfaces, using the air density
+ ! information, which is stored as a 3-d field
+ !*****************************************************************************
+
+ do kz=1,nz
+ pp(kz)=prs(lix,ljy,kz,1) !rho(lix,ljy,kz,1)*r_air*tt(lix,ljy,kz,1)
+ end do
+
+ ! Determine the reference starting altitudes
+ !*******************************************
+
+ deltacol=(pp(1)-pp(nz))/real(ncolumn)
+ pnew=pp(1)+deltacol/2.
+ do j=1,ncolumn
+ pnew=pnew-deltacol
+ do kz=1,nz-1
+ if ((pp(kz).ge.pnew).and.(pp(kz+1).lt.pnew)) then
+ dz1=pp(kz)-pnew
+ dz2=pnew-pp(kz+1)
+ dz=1./(dz1+dz2)
+ zposition=(height(kz)*dz2+height(kz+1)*dz1)*dz
+ if (zposition.gt.height(nz)-0.5) zposition=height(nz)-0.5
+
+ ! Memorize vertical positions where particles are introduced
+ ! This is further used in subroutine boundcond_domainfill.f
+ !***********************************************************
+
+ if (lix.eq.nx_we(1)) zcolumn_we(1,ljy,j)=zposition
+ if (lix.eq.nx_we(2)) zcolumn_we(2,ljy,j)=zposition
+ if (ljy.eq.ny_sn(1)) zcolumn_sn(1,lix,j)=zposition
+ if (ljy.eq.ny_sn(2)) zcolumn_sn(2,lix,j)=zposition
+
+ ! Initialize mass that has accumulated at boundary to zero
+ !*********************************************************
+
+ acc_mass_we(1,ljy,j)=0.
+ acc_mass_we(2,ljy,j)=0.
+ acc_mass_sn(1,ljy,j)=0.
+ acc_mass_sn(2,ljy,j)=0.
+ endif
+ end do
+ end do
+ end do
+ end do
+
+ ! If there were more particles allocated than used,
+ ! Deallocate unused memory and update numpart
+ !**************************************************
+ deall=.false.
+ do i=numpart, 1, -1
+ if (.not. part(i)%alive) then
+ deall=.true.
+ numpart = numpart - 1
+ else
+ exit
+ endif
+ end do
+
+ if (deall) call deallocate_particle(numpart) !Deallocates everything above numpart (F2008)
+
+
+ ! If particles shall be read in to continue an existing run,
+ ! then the accumulated masses at the domain boundaries must be read in, too.
+ ! This overrides any previous calculations.
+ !***************************************************************************
+
+ if ((ipin.eq.1).and.(.not.gdomainfill)) then
+ open(unitboundcond,file=path(2)(1:length(2))//'boundcond.bin', &
+ form='unformatted')
+ read(unitboundcond) numcolumn_we,numcolumn_sn, &
+ zcolumn_we,zcolumn_sn,acc_mass_we,acc_mass_sn
+ close(unitboundcond)
+ endif
+
+ deallocate(gridarea,colmass)
+end subroutine init_domainfill
+
+subroutine boundcond_domainfill(itime,loutend)
+ ! i i
+ !*****************************************************************************
+ ! *
+ ! Particles are created by this subroutine continuously throughout the *
+ ! simulation at the boundaries of the domain-filling box. *
+ ! All particles carry the same amount of mass which alltogether comprises the*
+ ! mass of air within the box, which remains (more or less) constant. *
+ ! *
+ ! Author: A. Stohl *
+ ! *
+ ! 16 October 2002 *
+ ! *
+ ! Changes *
+ ! 2022, L. Bakels: OpenMP parallelisation *
+ ! *
+ !*****************************************************************************
+ ! *
+ ! Variables: *
+ ! *
+ ! nx_we(2) grid indices for western and eastern boundary of domain- *
+ ! filling trajectory calculations *
+ ! ny_sn(2) grid indices for southern and northern boundary of domain- *
+ ! filling trajectory calculations *
+ ! *
+ !*****************************************************************************
+
+ use point_mod
+#ifdef _OPENMP
+ use omp_lib
+#endif
+ implicit none
+
+ real :: dz,dz1,dz2,dt1,dt2,dtt,ylat,xm,cosfact,accmasst
+ integer :: itime,in,indz,indzp,i,loutend,numparticlecount_tmp
+ integer :: j,k,ix,jy,m,indzh,indexh,minpart,ipart,mmass,ithread
+ integer :: numactiveparticles
+
+ real :: windl(2),rhol(2)
+ real :: windhl(2),rhohl(2)
+ real :: windx,rhox
+ real :: deltaz,boundarea,fluxofmass
+
+ integer :: ixm,ixp,jym,jyp,indzm,mm
+ real :: pvpart,ddx,ddy,rddx,rddy,p1,p2,p3,p4,y1(2),yh1(2)
+
+ integer :: idummy = -11
+
+
+ ! If domain-filling is global, no boundary conditions are needed
+ !***************************************************************
+
+ if (gdomainfill) return
+
+ ! Determine auxiliary variables for time interpolation
+ !*****************************************************
+
+ dt1=real(itime-memtime(1))
+ dt2=real(memtime(2)-itime)
+ dtt=1./(dt1+dt2)
+
+ numactiveparticles=0
+ numparticlecount_tmp=numparticlecount
+ accmasst=0.
+ ! Terminate trajectories that have left the domain, if domain-filling
+ ! trajectory calculation domain is not global
+ !********************************************************************
+
+ do i=1,numpart
+ if (.not. part(i)%alive) cycle
+
+ if ((part(i)%ylat.gt.real(ny_sn(2))).or. &
+ (part(i)%ylat.lt.real(ny_sn(1)))) call terminate_particle(i,itime)
+ if (((.not.xglobal).or.(nx_we(2).ne.(nx-2))).and. &
+ ((part(i)%xlon.lt.real(nx_we(1))).or. &
+ (part(i)%xlon.gt.real(nx_we(2))))) call terminate_particle(i,itime)
+ if (part(i)%alive) numactiveparticles = numactiveparticles+1
+ end do
+
+ !***************************************
+ ! Western and eastern boundary condition
+ !***************************************
+
+ ! Loop from south to north
+ !*************************
+!$OMP PARALLEL PRIVATE(i,jy,k,j,deltaz,boundarea,indz,indzp,indexh,windl,rhol, &
+!$OMP windhl,rhohl,windx,rhox,fluxofmass,mmass,ixm,jym,ixp,jyp,ddx,ddy,rddx, &
+!$OMP rddy,p1,p2,p3,p4,indzm,mm,indzh,pvpart,ylat,ix,cosfact,ipart) &
+!$OMP REDUCTION(+:numactiveparticles,numparticlecount_tmp,accmasst)
+
+#ifdef _OPENMP
+ ithread = OMP_GET_THREAD_NUM()
+#else
+ ithread = 0
+#endif
+
+!$OMP DO
+ do jy=ny_sn(1),ny_sn(2)
+
+ ! Loop over western (index 1) and eastern (index 2) boundary
+ !***********************************************************
+
+ do k=1,2
+
+ ! Loop over all release locations in a column
+ !********************************************
+
+ do j=1,numcolumn_we(k,jy)
+
+ ! Determine, for each release location, the area of the corresponding boundary
+ !*****************************************************************************
+
+ if (j.eq.1) then
+ deltaz=(zcolumn_we(k,jy,2)+zcolumn_we(k,jy,1))/2.
+ else if (j.eq.numcolumn_we(k,jy)) then
+ ! In order to avoid taking a very high column for very many particles,
+ ! use the deltaz from one particle below instead
+ deltaz=(zcolumn_we(k,jy,j)-zcolumn_we(k,jy,j-2))/2.
+ else
+ deltaz=(zcolumn_we(k,jy,j+1)-zcolumn_we(k,jy,j-1))/2.
+ endif
+ if ((jy.eq.ny_sn(1)).or.(jy.eq.ny_sn(2))) then
+ boundarea=deltaz*111198.5/2.*dy
+ else
+ boundarea=deltaz*111198.5*dy
+ endif
+
+
+ ! Interpolate the wind velocity and density to the release location
+ !******************************************************************
+
+ ! Determine the model level below the release position
+ !*****************************************************
+ indz=nz-1
+ indzp=nz
+ do i=2,nz
+ if (height(i).gt.zcolumn_we(k,jy,j)) then
+ indz=i-1
+ indzp=i
+ exit
+ endif
+ end do
+
+ ! Vertical distance to the level below and above current position
+ !****************************************************************
+
+ dz1=zcolumn_we(k,jy,j)-height(indz)
+ dz2=height(indzp)-zcolumn_we(k,jy,j)
+ dz=1./(dz1+dz2)
+
+ ! Vertical and temporal interpolation
+ !************************************
+
+ do m=1,2
+ indexh=memind(m)
+ do in=1,2
+ indzh=indz+in-1
+ windl(in)=uu(nx_we(k),jy,indzh,indexh)
+ rhol(in)=rho(nx_we(k),jy,indzh,indexh)
+ end do
+
+ windhl(m)=(dz2*windl(1)+dz1*windl(2))*dz
+ rhohl(m)=(dz2*rhol(1)+dz1*rhol(2))*dz
+ end do
+
+ windx=(windhl(1)*dt2+windhl(2)*dt1)*dtt
+ rhox=(rhohl(1)*dt2+rhohl(2)*dt1)*dtt
+
+ ! Calculate mass flux
+ !********************
+
+ fluxofmass=windx*rhox*boundarea*real(lsynctime)
+
+
+ ! If the mass flux is directed into the domain, add it to previous mass fluxes;
+ ! if it is out of the domain, set accumulated mass flux to zero
+ !******************************************************************************
+
+ if (k.eq.1) then
+ if (fluxofmass.ge.0.) then
+ acc_mass_we(k,jy,j)=acc_mass_we(k,jy,j)+fluxofmass
+ else
+ acc_mass_we(k,jy,j)=0.
+ endif
+ else
+ if (fluxofmass.le.0.) then
+ acc_mass_we(k,jy,j)=acc_mass_we(k,jy,j)+abs(fluxofmass)
+ else
+ acc_mass_we(k,jy,j)=0.
+ endif
+ endif
+ accmasst=accmasst+acc_mass_we(k,jy,j)
+
+ ! If the accumulated mass exceeds half the mass that each particle shall carry,
+ ! one (or more) particle(s) is (are) released and the accumulated mass is
+ ! reduced by the mass of this (these) particle(s)
+ !******************************************************************************
+
+ if (acc_mass_we(k,jy,j).ge.xmassperparticle/2.) then
+ mmass=int((acc_mass_we(k,jy,j)+xmassperparticle/2.)/ &
+ xmassperparticle)
+ acc_mass_we(k,jy,j)=acc_mass_we(k,jy,j)- &
+ real(mmass)*xmassperparticle
+ else
+ mmass=0
+ endif
+
+ do m=1,mmass
+ call get_new_part_index(ipart)
+ call spawn_particle(itime, ipart)
+
+ ! Assign particle positions
+ !**************************
+
+ call set_xlon(ipart,real(nx_we(k),kind=dp))
+ if (jy.eq.ny_sn(1)) then
+ call set_ylat(ipart,real(real(jy)+0.5*ran1(idummy,ithread),kind=dp))
+ else if (jy.eq.ny_sn(2)) then
+ call set_ylat(ipart,real(real(jy)-0.5*ran1(idummy,ithread),kind=dp))
+ else
+ call set_ylat(ipart,real(real(jy)+(ran1(idummy,ithread)-.5),kind=dp))
+ endif
+ if (j.eq.1) then
+ call set_z(ipart,zcolumn_we(k,jy,1)+(zcolumn_we(k,jy,2)- &
+ zcolumn_we(k,jy,1))/4.)
+ else if (j.eq.numcolumn_we(k,jy)) then
+ call set_z(ipart,(2.*zcolumn_we(k,jy,j)+ &
+ zcolumn_we(k,jy,j-1)+height(nz))/4.)
+ else
+ call set_z(ipart,zcolumn_we(k,jy,j-1)+ran1(idummy,ithread)* &
+ (zcolumn_we(k,jy,j+1)-zcolumn_we(k,jy,j-1)))
+ endif
+
+ call update_z_to_zeta(itime, ipart)
+
+ ! Interpolate PV to the particle position
+ !****************************************
+ ixm=int(part(ipart)%xlon)
+ jym=int(part(ipart)%ylat)
+ ixp=ixm+1
+ jyp=jym+1
+ ddx=part(ipart)%xlon-real(ixm)
+ ddy=part(ipart)%ylat-real(jym)
+ rddx=1.-ddx
+ rddy=1.-ddy
+ p1=rddx*rddy
+ p2=ddx*rddy
+ p3=rddx*ddy
+ p4=ddx*ddy
+ indzm=nz-1
+ indzp=nz
+ do i=2,nz
+ if (real(height(i),kind=dp).gt.part(ipart)%z) then
+ indzm=i-1
+ indzp=i
+ exit
+ endif
+ end do
+ dz1=real(part(ipart)%z)-height(indzm)
+ dz2=height(indzp)-real(part(ipart)%z)
+ dz=1./(dz1+dz2)
+ do mm=1,2
+ indexh=memind(mm)
+ do in=1,2
+ indzh=indzm+in-1
+ y1(in)=p1*pv(ixm,jym,indzh,indexh) &
+ +p2*pv(ixp,jym,indzh,indexh) &
+ +p3*pv(ixm,jyp,indzh,indexh) &
+ +p4*pv(ixp,jyp,indzh,indexh)
+ end do
+ yh1(mm)=(dz2*y1(1)+dz1*y1(2))*dz
+ end do
+ pvpart=(yh1(1)*dt2+yh1(2)*dt1)*dtt
+ ylat=ylat0+part(ipart)%ylat*dy
+ if (ylat.lt.0.) pvpart=-1.*pvpart
+
+
+ ! For domain-filling option 2 (stratospheric O3), do the rest only in the stratosphere
+ !*****************************************************************************
+
+ if (((part(ipart)%z.gt.3000.).and. &
+ (pvpart.gt.pvcrit)).or.(mdomainfill.eq.1)) then
+ part(ipart)%nclass=min(int(ran1(idummy,ithread)* &
+ real(nclassunc))+1,nclassunc)
+ numactiveparticles=numactiveparticles+1
+ numparticlecount_tmp=numparticlecount_tmp+1
+ part(ipart)%npoint=numparticlecount_tmp
+ part(ipart)%idt=mintime
+ part(ipart)%tstart=itime
+ part(ipart)%mass(1)=xmassperparticle
+ if (mdomainfill.eq.2) part(ipart)%mass(1)= &
+ part(ipart)%mass(1)*pvpart*48./29.*ozonescale/10.**9
+ part(ipart)%mass_init(1)=part(ipart)%mass(1)
+ else
+ stop 'boundcond_domainfill error: look into original to understand what should happen here'
+ endif
+ end do ! particles
+ end do ! release locations in column
+ end do ! western and eastern boundary
+ end do ! south to north
+!$OMP END DO
+
+ !*****************************************
+ ! Southern and northern boundary condition
+ !*****************************************
+
+ ! Loop from west to east
+ !***********************
+!$OMP DO
+ do ix=nx_we(1),nx_we(2)
+
+ ! Loop over southern (index 1) and northern (index 2) boundary
+ !*************************************************************
+
+ do k=1,2
+ ylat=ylat0+real(ny_sn(k))*dy
+ cosfact=cos(ylat*pi180)
+
+ ! Loop over all release locations in a column
+ !********************************************
+
+ do j=1,numcolumn_sn(k,ix)
+
+ ! Determine, for each release location, the area of the corresponding boundary
+ !*****************************************************************************
+
+ if (j.eq.1) then
+ deltaz=(zcolumn_sn(k,ix,2)+zcolumn_sn(k,ix,1))/2.
+ else if (j.eq.numcolumn_sn(k,ix)) then
+ ! deltaz=height(nz)-(zcolumn_sn(k,ix,j-1)+
+ ! + zcolumn_sn(k,ix,j))/2.
+ ! In order to avoid taking a very high column for very many particles,
+ ! use the deltaz from one particle below instead
+ deltaz=(zcolumn_sn(k,ix,j)-zcolumn_sn(k,ix,j-2))/2.
+ else
+ deltaz=(zcolumn_sn(k,ix,j+1)-zcolumn_sn(k,ix,j-1))/2.
+ endif
+ if ((ix.eq.nx_we(1)).or.(ix.eq.nx_we(2))) then
+ boundarea=deltaz*111198.5/2.*cosfact*dx
+ else
+ boundarea=deltaz*111198.5*cosfact*dx
+ endif
+
+
+ ! Interpolate the wind velocity and density to the release location
+ !******************************************************************
+
+ ! Determine the model level below the release position
+ !*****************************************************
+ indz=nz-1
+ indzp=nz
+ do i=2,nz
+ if (height(i).gt.zcolumn_sn(k,ix,j)) then
+ indz=i-1
+ indzp=i
+ exit
+ endif
+ end do
+
+ ! Vertical distance to the level below and above current position
+ !****************************************************************
+
+ dz1=zcolumn_sn(k,ix,j)-height(indz)
+ dz2=height(indzp)-zcolumn_sn(k,ix,j)
+ dz=1./(dz1+dz2)
+
+ ! Vertical and temporal interpolation
+ !************************************
+
+ do m=1,2
+ indexh=memind(m)
+ do in=1,2
+ indzh=indz+in-1
+ windl(in)=vv(ix,ny_sn(k),indzh,indexh)
+ rhol(in)=rho(ix,ny_sn(k),indzh,indexh)
+ end do
+
+ windhl(m)=(dz2*windl(1)+dz1*windl(2))*dz
+ rhohl(m)=(dz2*rhol(1)+dz1*rhol(2))*dz
+ end do
+
+ windx=(windhl(1)*dt2+windhl(2)*dt1)*dtt
+ rhox=(rhohl(1)*dt2+rhohl(2)*dt1)*dtt
+
+ ! Calculate mass flux
+ !********************
+
+ fluxofmass=windx*rhox*boundarea*real(lsynctime)
+
+ ! If the mass flux is directed into the domain, add it to previous mass fluxes;
+ ! if it is out of the domain, set accumulated mass flux to zero
+ !******************************************************************************
+
+ if (k.eq.1) then
+ if (fluxofmass.ge.0.) then
+ acc_mass_sn(k,ix,j)=acc_mass_sn(k,ix,j)+fluxofmass
+ else
+ acc_mass_sn(k,ix,j)=0.
+ endif
+ else
+ if (fluxofmass.le.0.) then
+ acc_mass_sn(k,ix,j)=acc_mass_sn(k,ix,j)+abs(fluxofmass)
+ else
+ acc_mass_sn(k,ix,j)=0.
+ endif
+ endif
+ accmasst=accmasst+acc_mass_sn(k,ix,j)
+
+ ! If the accumulated mass exceeds half the mass that each particle shall carry,
+ ! one (or more) particle(s) is (are) released and the accumulated mass is
+ ! reduced by the mass of this (these) particle(s)
+ !******************************************************************************
+
+ if (acc_mass_sn(k,ix,j).ge.xmassperparticle/2.) then
+ mmass=int((acc_mass_sn(k,ix,j)+xmassperparticle/2.)/ &
+ xmassperparticle)
+ acc_mass_sn(k,ix,j)=acc_mass_sn(k,ix,j)- &
+ real(mmass)*xmassperparticle
+ else
+ mmass=0
+ endif
+
+ do m=1,mmass
+ call get_new_part_index(ipart)
+ call spawn_particle(itime, ipart)
+
+ ! Assign particle positions
+ !**************************
+ call set_ylat(ipart,real(ny_sn(k),kind=dp))
+ if (ix.eq.nx_we(1)) then
+ call set_xlon(ipart,real(real(ix)+0.5*ran1(idummy,ithread),kind=dp))
+ else if (ix.eq.nx_we(2)) then
+ call set_xlon(ipart,real(real(ix)-0.5*ran1(idummy,ithread),kind=dp))
+ else
+ call set_xlon(ipart,real(real(ix)+(ran1(idummy,ithread)-.5),kind=dp))
+ endif
+ if (j.eq.1) then
+ call set_z(ipart,zcolumn_sn(k,ix,1)+(zcolumn_sn(k,ix,2)- &
+ zcolumn_sn(k,ix,1))/4.)
+ else if (j.eq.numcolumn_sn(k,ix)) then
+ call set_z(ipart,(2.*zcolumn_sn(k,ix,j)+ &
+ zcolumn_sn(k,ix,j-1)+height(nz))/4.)
+ else
+ call set_z(ipart,zcolumn_sn(k,ix,j-1)+ran1(idummy,ithread)* &
+ (zcolumn_sn(k,ix,j+1)-zcolumn_sn(k,ix,j-1)))
+ endif
+
+ call update_z_to_zeta(itime, ipart)
+
+ ! Interpolate PV to the particle position
+ !****************************************
+ ixm=int(part(ipart)%xlon)
+ jym=int(part(ipart)%ylat)
+ ixp=ixm+1
+ jyp=jym+1
+ ddx=part(ipart)%xlon-real(ixm)
+ ddy=part(ipart)%ylat-real(jym)
+ rddx=1.-ddx
+ rddy=1.-ddy
+ p1=rddx*rddy
+ p2=ddx*rddy
+ p3=rddx*ddy
+ p4=ddx*ddy
+ indzm=nz-1
+ indzp=nz
+ do i=2,nz
+ if (real(height(i),kind=dp).gt.part(ipart)%z) then
+ indzm=i-1
+ indzp=i
+ exit
+ endif
+ end do
+ dz1=real(part(ipart)%z)-height(indzm)
+ dz2=height(indzp)-real(part(ipart)%z)
+ dz=1./(dz1+dz2)
+ do mm=1,2
+ indexh=memind(mm)
+ do in=1,2
+ indzh=indzm+in-1
+ y1(in)=p1*pv(ixm,jym,indzh,indexh) &
+ +p2*pv(ixp,jym,indzh,indexh) &
+ +p3*pv(ixm,jyp,indzh,indexh) &
+ +p4*pv(ixp,jyp,indzh,indexh)
+ end do
+ yh1(mm)=(dz2*y1(1)+dz1*y1(2))*dz
+ end do
+ pvpart=(yh1(1)*dt2+yh1(2)*dt1)*dtt
+ if (ylat.lt.0.) pvpart=-1.*pvpart
+
+
+ ! For domain-filling option 2 (stratospheric O3), do the rest only in the stratosphere
+ !*****************************************************************************
+
+ if (((part(ipart)%z.gt.3000.).and. &
+ (pvpart.gt.pvcrit)).or.(mdomainfill.eq.1)) then
+ part(ipart)%nclass=min(int(ran1(idummy,ithread)* &
+ real(nclassunc))+1,nclassunc)
+ numactiveparticles=numactiveparticles+1
+ numparticlecount_tmp=numparticlecount_tmp+1
+ part(ipart)%npoint=numparticlecount_tmp
+ part(ipart)%idt=mintime
+ part(ipart)%mass(1)=xmassperparticle
+ if (mdomainfill.eq.2) part(ipart)%mass(1)= &
+ part(ipart)%mass(1)*pvpart*48./29.*ozonescale/10.**9
+ part(ipart)%mass_init(1)=part(ipart)%mass(1)
+ else
+ stop 'boundcond_domainfill error: look into original to understand what should happen here'
+ endif
+ end do ! particles
+ end do ! releases per column
+ end do ! east west
+ end do ! north south
+!$OMP END DO
+!$OMP END PARALLEL
+ numparticlecount = numparticlecount_tmp
+ ! If particles shall be dumped, then accumulated masses at the domain boundaries
+ ! must be dumped, too, to be used for later runs
+ !*****************************************************************************
+
+ if ((ipout.gt.0).and.(itime.eq.loutend)) then
+ open(unitboundcond,file=path(2)(1:length(2))//'boundcond.bin', &
+ form='unformatted')
+ write(unitboundcond) numcolumn_we,numcolumn_sn, &
+ zcolumn_we,zcolumn_sn,acc_mass_we,acc_mass_sn
+ close(unitboundcond)
+ endif
+end subroutine boundcond_domainfill
+
+end module initialise_mod
diff --git a/src/interpol_mod.f90 b/src/interpol_mod.f90
index 0a9c3291..dfdf15fa 100644
--- a/src/interpol_mod.f90
+++ b/src/interpol_mod.f90
@@ -1,20 +1,1557 @@
-module interpol_mod
+ !*****************************************************************************
+ ! *
+ ! L. Bakels 2022: This module contains all interpolation subroutines *
+ ! Code has been organised into subroutines *
+ ! Vertical logarithmic interpolation is optional (par_mod) *
+ ! *
+ !*****************************************************************************
- use par_mod, only: nzmax, maxspec
+module interpol_mod
+ use par_mod
+ use com_mod
+ use windfields_mod
+ use particle_mod
implicit none
- real :: uprof(nzmax),vprof(nzmax),wprof(nzmax)
- real :: usigprof(nzmax),vsigprof(nzmax),wsigprof(nzmax)
- real :: rhoprof(nzmax),rhogradprof(nzmax)
+ real,dimension(nzmax) :: &
+ uprof,vprof,wprof,wprofeta, &
+ usigprof,vsigprof,wsigprof,wsigprofeta, &
+ rhoprof,rhogradprof
+ logical,dimension(nzmax) :: &
+ indzindicator
- real :: u,v,w,usig,vsig,wsig,pvi
+ real :: u,v,w,usig,vsig,wsig,ueta,veta,weta,wsigeta
real :: p1,p2,p3,p4,ddx,ddy,rddx,rddy,dtt,dt1,dt2
- integer :: ix,jy,ixp,jyp,ngrid,indz,indzp
+ real :: xtn,ytn
+ real :: dz1out,dz2out
+ integer :: nix,njy
+ integer :: ix,jy,ixp,jyp,ngrid,indz,indzp,indzeta,indzpeta
+ integer :: induv,indpuv
logical :: depoindicator(maxspec)
- logical :: indzindicator(nzmax)
+ logical :: lbounds(2),lbounds_w(2),lbounds_uv(2) ! marking particles below or above bounds
+
+ private :: interpol_wind_meter,interpol_wind_eta
+ private :: standard_deviation_meter,standard_deviation_eta
+ private :: interpol_partoutput_value_eta,interpol_partoutput_value_meter
+
+ interface horizontal_interpolation
+ procedure horizontal_interpolation_4d,horizontal_interpolation_2d
+ end interface horizontal_interpolation
+
+ interface horizontal_interpolation_nests
+ procedure horizontal_interpolation_4d_nests,horizontal_interpolation_2d_nests
+ end interface horizontal_interpolation_nests
+
+
+ interface find_ngrid
+ procedure find_ngrid_dp, find_ngrid_float
+ end interface find_ngrid
+!$OMP THREADPRIVATE(uprof,vprof,wprof,usigprof,vsigprof,wsigprof, &
+!$OMP rhoprof,rhogradprof,u,v,w,usig,vsig,wsig, &
+!$OMP p1,p2,p3,p4,ddx,ddy,rddx,rddy,dtt,dt1,dt2,ix,jy,ixp,jyp, &
+!$OMP ngrid,indz,indzp,depoindicator,indzindicator, &
+!$OMP wprofeta,wsigprofeta,induv,indpuv,lbounds,lbounds_w,lbounds_uv, &
+!$OMP indzeta,indzpeta,ueta,veta,weta,wsigeta, &
+!$OMP xtn,ytn,nix,njy,dz1out,dz2out)
+
+contains
+
+subroutine interpol_allocate
+ ! allocate(uprof(nzmax),vprof(nzmax),wprof(nzmax),wprofeta(nzmax), &
+ ! usigprof(nzmax),vsigprof(nzmax),wsigprof(nzmax),wsigprofeta(nzmax), &
+ ! rhoprof(nzmax),rhogradprof(nzmax),indzindicator(nzmax))
+end subroutine interpol_allocate
+
+subroutine interpol_deallocate
+ ! deallocate(uprof,vprof,wprof,wprofeta, &
+ ! usigprof,vsigprof,wsigprof,wsigprofeta, &
+ ! rhoprof,rhogradprof,indzindicator)
+end subroutine interpol_deallocate
+
+subroutine initialise_interpol_mod(itime,xt,yt,zt,zteta)
+ ! This routine initialises all important values used in the interpol module
+ ! This includes:
+ ! - The current grid number in which the particle is positioned
+ ! - The interpolation fractions of the grid (x,y,z) and of time
+
+ implicit none
+
+ integer, intent(in) :: itime ! time step
+ real, intent(in) :: xt,yt ! particle positions
+ real, intent(in) :: zt ! height in meters
+ real, intent(in) :: zteta ! height in eta coordinates
+
+ call find_ngrid(xt,yt)
+ call determine_grid_coordinates(xt,yt)
+ call find_grid_distances(xt,yt)
+ call find_time_variables(itime)
+ call find_z_level(zt,zteta)
+end subroutine initialise_interpol_mod
+
+subroutine determine_grid_coordinates(xt,yt)
+ implicit none
+
+ real, intent(in) :: xt,yt ! particle positions
+
+ if (ngrid.gt.0) then
+ xtn=(xt-xln(ngrid))*xresoln(ngrid)
+ ytn=(yt-yln(ngrid))*yresoln(ngrid)
+ ! ix=int(xtn)
+ ! jy=int(ytn)
+ ! nix=nint(xtn)
+ ! njy=nint(ytn)
+ nix=max(min(nint(xtn),nxn(ngrid)-1),0)
+ njy=max(min(nint(ytn),nyn(ngrid)-1),0)
+ ix=nix
+ jy=njy
+ ixp=ix+1
+ jyp=jy+1
+ return
+ else
+ ix=int(xt)
+ jy=int(yt)
+ nix=nint(xt)
+ njy=nint(yt)
+ ixp=ix+1
+ jyp=jy+1
+ endif
+
+ ! eso: Temporary fix for particle exactly at north pole
+ if (jyp.ge.nymax) then
+ write(*,*) 'WARNING: interpol_mod.f90 jyp >= nymax. xt,yt:',xt,yt
+ jyp=jyp-1
+ end if
+
+ if (ixp.ge.nxmax) then
+ write(*,*) 'WARNING: interpol_mod.f90 ixp >= nxmax. xt,yt:',xt,yt
+ ixp=ixp-nxmax
+ end if
+end subroutine determine_grid_coordinates
+
+subroutine find_grid_distances(xt,yt)
+
+ implicit none
+
+ real, intent(in) :: xt,yt ! particle positions
+
+ if (ngrid.le.0) then
+ ddx=xt-real(ix)
+ ddy=yt-real(jy)
+ else
+ ddx=xtn-real(ix)
+ ddy=ytn-real(jy)
+ endif
+ rddx=1.-ddx
+ rddy=1.-ddy
+ p1=rddx*rddy
+ p2=ddx*rddy
+ p3=rddx*ddy
+ p4=ddx*ddy
+end subroutine find_grid_distances
+
+subroutine find_time_variables(itime)
+
+ implicit none
+
+ integer, intent(in) :: itime ! time step
+
+ dt1=real(itime-memtime(1))
+ dt2=real(memtime(2)-itime)
+ dtt=1./(dt1+dt2)
+end subroutine find_time_variables
+
+subroutine find_z_level(zt,zteta)
+ implicit none
+ real, intent(in) :: &
+ zt, & ! height in meters
+ zteta ! height in eta
+
+ select case (wind_coord_type)
+ case('ETA')
+ call find_z_level_meters(zt)
+ call find_z_level_eta(zteta)
+ case('METER')
+ call find_z_level_meters(zt)
+ case default
+ call find_z_level_meters(zt)
+ end select
+end subroutine find_z_level
+
+subroutine find_z_level_meters(zt)
+ implicit none
+ real, intent(in) :: zt ! height in meters
+ integer :: i
+
+ indz=nz-1
+ indzp=nz
+ if (zt.le.height(1)) then
+ lbounds(1)=.true.
+ lbounds(2)=.false.
+ indz=1
+ indzp=2
+ else if (zt.ge.height(nz)) then
+ lbounds(1)=.false.
+ lbounds(2)=.true.
+ else
+ lbounds(1)=.false.
+ lbounds(2)=.false.
+ do i=2,nz
+ if (height(i).gt.zt) then
+ indz=i-1
+ indzp=i
+ exit
+ endif
+ end do
+ endif
+end subroutine find_z_level_meters
+
+subroutine find_z_level_eta(zteta)
+ implicit none
+ real, intent(in) :: zteta ! height in eta coordinates
+ integer :: i ! loop variable
+
+ call find_z_level_eta_w(zteta)
+
+ call find_z_level_eta_uv(zteta)
+end subroutine find_z_level_eta
+
+subroutine find_z_level_eta_w(zteta)
+ implicit none
+ real, intent(in) :: zteta ! height in eta coordinates
+ integer :: i ! loop variable
+
+ indzeta=nz-1
+ indzpeta=nz
+ ! Flag particles that are above or below bounds
+ if (zteta.ge.wheight(1)) then
+ lbounds_w(1)=.true.
+ lbounds_w(2)=.false.
+ indzeta=1
+ indzpeta=2
+ else if (zteta.le.wheight(nz)) then
+ lbounds_w(1)=.false.
+ lbounds_w(2)=.true.
+ else
+ lbounds_w(1)=.false.
+ lbounds_w(2)=.false.
+ do i=2,nz
+ if (wheight(i).lt.zteta) then
+ indzeta=i-1
+ indzpeta=i
+ exit
+ endif
+ end do
+ endif
+end subroutine find_z_level_eta_w
+
+subroutine find_z_level_eta_uv(zteta)
+ implicit none
+ real, intent(in) :: zteta ! height in eta coordinates
+ integer :: i ! loop variable
+
+ induv=nz-1
+ indpuv=nz
+ if (zteta.gt.uvheight(1)) then
+ lbounds_uv(1)=.true.
+ lbounds_uv(2)=.false.
+ induv=1
+ indpuv=2
+ else if (zteta.lt.uvheight(nz)) then
+ lbounds_uv(1)=.false.
+ lbounds_uv(2)=.true.
+ else
+ lbounds_uv(1)=.false.
+ lbounds_uv(2)=.false.
+ do i=2,nz
+ if (uvheight(i).lt.zteta) then
+ induv=i-1
+ indpuv=i
+ exit
+ endif
+ end do
+ endif
+end subroutine find_z_level_eta_uv
+
+subroutine find_vertical_variables(vertlevels,zpos,zlevel,dz1,dz2,bounds,wlevel)
+ !*****************************************************************************
+ ! *
+ ! This subroutine computes the vertical interpolation variables *
+ ! logarithmically, unless logarithmic_interpolation=.false. in the par_mod *
+ ! *
+ ! Author: L. Bakels *
+ !*****************************************************************************
+
+ implicit none
+ real, intent(in) :: vertlevels(:) ! vertical levels in coordinate system
+ real, intent(in) :: zpos ! verticle particle position
+ integer, intent(in) :: zlevel ! vertical level of interest
+ logical, intent(in) :: bounds(2),wlevel ! flag marking if particles are outside bounds
+ real, intent(inout) :: dz1,dz2 ! fractional distance to point 1 (closer to ground) and 2
+ real :: dz,dh1,dh,pfact
+ real :: psint1(2),psint,pr1,pr2,pr_test ! pressure of encompassing levels
+ integer :: m
+
+ ! Only do logarithmic interpolation when using ETA coordinates, since the
+ ! levels are following pressure, while METER levels are linear.
+ !##############################################################
+ if (.not. logarithmic_interpolation) then
+ call find_vertical_variables_lin(vertlevels,zpos,zlevel,dz1,dz2,bounds,wlevel)
+ return
+ endif
+
+ ! To check if taking the logarithm is safe
+ if (wlevel) then
+ pr_test=akm(zlevel+1)+bkm(zlevel+1)
+ else
+ pr_test=akz(zlevel+1)+bkz(zlevel+1)
+ endif
+
+ ! If the particle is below bounds (bounds(1)==.true.):
+ if (bounds(1)) then
+ dz1=0.
+ dz2=1.
+ ! If above bounds (bounds(2)==.true.):
+ else if (bounds(2)) then
+ dz1=1.
+ dz2=0.
+
+ ! Instead of the linear z variables, we need the ones that correspond to
+ ! the pressure of the height of the particle in relation to the model levels
+ !***************************************************************************
+ else if (pr_test.eq.0) then
+ dz=1./(vertlevels(zlevel+1)-vertlevels(zlevel))
+ dz1=(zpos-vertlevels(zlevel))*dz
+ dz2=(vertlevels(zlevel+1)-zpos)*dz
+ else
+ if (ngrid.le.0) then
+ do m=1,2
+ call horizontal_interpolation(ps,psint1(m),1,memind(m),1)
+ end do
+ else
+ do m=1,2
+ call horizontal_interpolation_nests(psn,psint1(m),1,memind(m),1)
+ end do
+ endif
+ call temporal_interpolation(psint1(1),psint1(2),psint)
+ dh = vertlevels(zlevel+1)-vertlevels(zlevel)
+ dh1 = zpos - vertlevels(zlevel)
+ if (wlevel) then
+ pr1=akm(zlevel) + bkm(zlevel)*psint
+ pr2=akm(zlevel+1) + bkm(zlevel+1)*psint
+ else
+ pr1=akz(zlevel) + bkz(zlevel)*psint
+ pr2=akz(zlevel+1) + bkz(zlevel+1)*psint
+ endif
+ pfact = log(pr2/pr1)*dh1/dh
+ dz = 1./(pr2-pr1)
+ dz1 = pr1*(exp(pfact)-1.)*dz
+ dz2 = 1.-dz1
+ endif
+ ! else if ((vertlevels(zlevel).eq.0).or.(vertlevels(zlevel+1).eq.0)) then
+ ! ! Linear interpolation for bottom or top layer is zero
+ ! dz=1./(vertlevels(zlevel+1)-vertlevels(zlevel))
+ ! dz1=(zpos-vertlevels(zlevel))*dz
+ ! dz2=(vertlevels(zlevel+1)-zpos)*dz
+ ! else
+ ! ! Logaritmic interpolation
+ ! dz=1./(log(vertlevels(zlevel+1))-log(vertlevels(zlevel)))
+ ! dz1=(log(zpos)-log(vertlevels(zlevel)))*dz
+ ! dz2=(log(vertlevels(zlevel+1))-log(zpos))*dz
+ ! endif
+end subroutine find_vertical_variables
+
+subroutine find_vertical_variables_lin(vertlevels,zpos,zlevel,dz1,dz2,bounds,wlevel)
+ implicit none
+ real, intent(in) :: vertlevels(:) ! vertical levels in coordinate system
+ real, intent(in) :: zpos ! verticle particle position
+ integer, intent(in) :: zlevel ! vertical level of interest
+ logical, intent(in) :: bounds(2),wlevel ! flag marking if particles are outside bounds
+ real, intent(inout) :: dz1,dz2 ! fractional distance to point 1 (closer to ground) and 2
+ real :: dz,dh1,dh,pfact
+ real :: psint1(2),psint,pr1,pr2,temp ! pressure of encompassing levels
+
+ ! If the particle is below bounds (bounds(1)==.true.):
+ if (bounds(1)) then
+ dz1=0.
+ dz2=1.
+ ! If above bounds (bounds(2)==.true.):
+ else if (bounds(2)) then
+ dz1=1.
+ dz2=0.
+ else
+ dz=1./(vertlevels(zlevel+1)-vertlevels(zlevel))
+ dz1=(zpos-vertlevels(zlevel))*dz
+ dz2=(vertlevels(zlevel+1)-zpos)*dz
+ endif
+end subroutine find_vertical_variables_lin
+
+subroutine find_ngrid_dp(xt,yt)
+
+ implicit none
+ real :: &
+ eps
+ real(kind=dp), intent(in) :: &
+ xt,yt ! particle positions on grid
+ integer :: &
+ j
+
+ eps=nxmax/3.e5
+ if (nglobal.and.(real(yt).gt.switchnorthg)) then
+ ngrid=-1
+ else if (sglobal.and.(real(yt).lt.switchsouthg)) then
+ ngrid=-2
+ else
+ ngrid=0
+ ! Temporary fix for nested layer edges: replaced eps with dxn and dyn (LB)
+ do j=numbnests,1,-1
+ if ((real(xt).gt.xln(j)+dxn(j)).and.(real(xt).lt.xrn(j)-dxn(j)).and. &
+ (real(yt).gt.yln(j)+dyn(j)).and.(real(yt).lt.yrn(j)-dyn(j))) then
+ ngrid=j
+ exit
+ endif
+ end do
+ endif
+end subroutine find_ngrid_dp
+
+subroutine find_ngrid_float(xt,yt)
+
+ implicit none
+ real :: &
+ eps
+ real, intent(in) :: &
+ xt,yt ! particle positions on grid
+ integer :: &
+ j
+
+ eps=nxmax/3.e5
+ if (nglobal.and.(yt.gt.switchnorthg)) then
+ ngrid=-1
+ else if (sglobal.and.(yt.lt.switchsouthg)) then
+ ngrid=-2
+ else
+ ngrid=0
+ ! Temporary fix for nested layer edges: replaced eps with dxn and dyn (LB)
+ do j=numbnests,1,-1
+ if ((xt.gt.xln(j)+dxn(j)).and.(xt.lt.xrn(j)-dxn(j)).and. &
+ (yt.gt.yln(j)+dyn(j)).and.(yt.lt.yrn(j)-dyn(j))) then
+ ngrid=j
+ exit
+ endif
+ end do
+ endif
+end subroutine find_ngrid_float
+
+subroutine horizontal_interpolation_4d(field,output,zlevel,indexh,ztot)
+
+ implicit none
+
+ integer, intent(in) :: zlevel,ztot,indexh ! interpolation z level, z
+ real, intent(in) :: field(0:nxmax-1,0:nymax-1,ztot,numwfmem) ! input field to interpolate over
+ real, intent(inout) :: output ! interpolated values
+
+ output=p1*field(ix ,jy ,zlevel,indexh) &
+ + p2*field(ixp,jy ,zlevel,indexh) &
+ + p3*field(ix ,jyp,zlevel,indexh) &
+ + p4*field(ixp,jyp,zlevel,indexh)
+end subroutine horizontal_interpolation_4d
+
+subroutine horizontal_interpolation_2d(field,output)
+ implicit none
+ real, intent(in) :: field(0:nxmax-1,0:nymax-1) ! 2D imput field
+ real, intent(inout) :: output ! Interpolated value
+
+ output=p1*field(ix ,jy) &
+ + p2*field(ixp,jy) &
+ + p3*field(ix ,jyp) &
+ + p4*field(ixp,jyp)
+end subroutine horizontal_interpolation_2d
+
+subroutine horizontal_interpolation_4d_nests(field,output,zlevel,indexh,ztot)
+
+ implicit none
+
+ integer, intent(in) :: zlevel,ztot,indexh ! interpolation z level, z
+ real, intent(in) :: field(0:nxmaxn-1,0:nymaxn-1,ztot,numwfmem,numbnests) ! input field to interpolate over
+ real, intent(inout) :: output ! interpolated values
+
+ output=p1*field(ix ,jy ,zlevel,indexh,ngrid) &
+ + p2*field(ixp,jy ,zlevel,indexh,ngrid) &
+ + p3*field(ix ,jyp,zlevel,indexh,ngrid) &
+ + p4*field(ixp,jyp,zlevel,indexh,ngrid)
+end subroutine horizontal_interpolation_4d_nests
+
+subroutine horizontal_interpolation_2d_nests(field,output)
+
+ implicit none
+
+ real, intent(in) :: field(0:nxmaxn-1,0:nymaxn-1,numbnests) ! input field to interpolate over
+ real, intent(inout) :: output ! interpolated values
+
+ output=p1*field(ix ,jy ,ngrid) &
+ + p2*field(ixp,jy ,ngrid) &
+ + p3*field(ix ,jyp,ngrid) &
+ + p4*field(ixp,jyp,ngrid)
+end subroutine horizontal_interpolation_2d_nests
+
+subroutine temporal_interpolation(time1,time2,output)
+
+ implicit none
+
+ real, intent(in) :: time1,time2 ! input data at two timesteps
+ real, intent(inout) :: output ! interpolated data
+
+ output=(time1*dt2+time2*dt1)*dtt
+end subroutine temporal_interpolation
+
+subroutine vertical_interpolation(input1,input2,dz1,dz2,output)
+
+ implicit none
+
+ real, intent(in) :: input1,input2 ! input data at two vertical levels, 1 being closer to ground
+ real, intent(in) :: dz1,dz2 ! logarithmic interpolation values
+ real, intent(inout) :: output ! interpolated data
+
+ output = input1*dz2 + input2*dz1!input1**dz2 * input2**dz1
+end subroutine vertical_interpolation
+
+subroutine bilinear_spatial_interpolation(field,output,zlevel,dz1,dz2,ztot)
+ implicit none
+ integer, intent(in) :: zlevel,ztot ! interpolation z level
+ real, intent(in) :: field(0:nxmax-1,0:nymax-1,ztot,numwfmem) ! input field to interpolate over
+ real, intent(in) :: dz1,dz2
+ real, intent(inout) :: output(2) ! interpolated values
+ integer :: m,n,indzh
+ real :: output1(2)
+
+ do m=1,2
+ do n=1,2
+ indzh=zlevel+n-1
+ call horizontal_interpolation_4d(field,output1(n),indzh,memind(m),ztot)
+ end do
+ !**********************************
+ ! 2.) Linear vertical interpolation on logarithmic scale
+ !**********************************
+ call vertical_interpolation(output1(1),output1(2),dz1,dz2,output(m))
+ end do
+end subroutine bilinear_spatial_interpolation
+
+subroutine bilinear_spatial_interpolation_nests(field,output,zlevel,dz1,dz2,ztot)
+ implicit none
+ integer, intent(in) :: zlevel,ztot ! interpolation z level
+ real, intent(in) :: field(0:nxmaxn-1,0:nymaxn-1,ztot,numwfmem,numbnests) ! input field to interpolate over
+ real, intent(in) :: dz1,dz2
+ real, intent(inout) :: output(2) ! interpolated values
+ integer :: m,n,indzh
+ real :: output1(2)
+
+ do m=1,2
+ do n=1,2
+ indzh=zlevel+n-1
+ call horizontal_interpolation_4d_nests(field,output1(n),indzh,memind(m),ztot)
+ end do
+ !**********************************
+ ! 2.) Linear vertical interpolation on logarithmic scale
+ !**********************************
+ call vertical_interpolation(output1(1),output1(2),dz1,dz2,output(m))
+ end do
+end subroutine bilinear_spatial_interpolation_nests
+
+subroutine compute_sl_sq(field,sl,sq,zlevel,indexh,ztot)
+ implicit none
+
+ integer, intent(in) :: zlevel,ztot,indexh ! interpolation z levels
+ real, intent(in) :: field(0:nxmax-1,0:nymax-1,ztot,numwfmem) ! input field to interpolate over
+ real, intent(inout) :: sl,sq ! standard deviation
+
+
+ sl=sl+field(ix ,jy ,zlevel,indexh)+field(ixp,jy ,zlevel,indexh) &
+ +field(ix ,jyp,zlevel,indexh)+field(ixp,jyp,zlevel,indexh)
+ sq=sq+field(ix ,jy ,zlevel,indexh)*field(ix ,jy ,zlevel,indexh)+ &
+ field(ixp,jy ,zlevel,indexh)*field(ixp,jy ,zlevel,indexh)+ &
+ field(ix ,jyp,zlevel,indexh)*field(ix ,jyp,zlevel,indexh)+ &
+ field(ixp,jyp,zlevel,indexh)*field(ixp,jyp,zlevel,indexh)
+end subroutine compute_sl_sq
+
+subroutine compute_sl_sq_nests(field,sl,sq,zlevel,indexh,ztot)
+ implicit none
+
+ integer, intent(in) :: zlevel,ztot,indexh ! interpolation z levels
+ real, intent(in) :: field(0:nxmaxn-1,0:nymaxn-1,ztot,numwfmem,numbnests) ! input field to interpolate over
+ real, intent(inout) :: sl,sq ! standard deviation
+
+
+ sl=sl+field(ix ,jy ,zlevel,indexh,ngrid)+field(ixp,jy ,zlevel,indexh,ngrid) &
+ +field(ix ,jyp,zlevel,indexh,ngrid)+field(ixp,jyp,zlevel,indexh,ngrid)
+ sq=sq+field(ix ,jy ,zlevel,indexh,ngrid)*field(ix ,jy ,zlevel,indexh,ngrid)+ &
+ field(ixp,jy ,zlevel,indexh,ngrid)*field(ixp,jy ,zlevel,indexh,ngrid)+ &
+ field(ix ,jyp,zlevel,indexh,ngrid)*field(ix ,jyp,zlevel,indexh,ngrid)+ &
+ field(ixp,jyp,zlevel,indexh,ngrid)*field(ixp,jyp,zlevel,indexh,ngrid)
+end subroutine compute_sl_sq_nests
+
+subroutine standard_deviation(sl,sq,ndivide,output)
+ implicit none
+
+ real, intent(in) :: sl,sq,ndivide
+ real, intent(out) :: output
+ real :: xaux
+ real,parameter :: eps=1.0e-30
+
+ xaux=sq-sl*sl/ndivide
+
+ if (xaux.lt.eps) then
+ output=0.
+ else
+ output=sqrt(xaux/(ndivide-1.))
+ endif
+end subroutine standard_deviation
+
+! Interpolation functions
+!************************
+subroutine interpol_PBL(itime,xt,yt,zt,zteta)
+ ! i i i i
+ !*****************************************************************************
+ ! *
+ ! This subroutine interpolates everything that is needed for calculating the*
+ ! dispersion. *
+ ! *
+ ! Author: A. Stohl *
+ ! *
+ ! 16 December 1997 *
+ ! *
+ ! Revision March 2005 by AST : all output variables in common block cal- *
+ ! culation of standard deviation done in this *
+ ! routine rather than subroutine call in order *
+ ! to save computation time *
+ ! *
+ !*****************************************************************************
+ ! *
+ ! Variables: *
+ ! itime [s] current temporal position *
+ ! memtime(3) [s] times of the wind fields in memory *
+ ! xt,yt,zt coordinates position for which wind data shall be *
+ ! culated *
+ ! *
+ ! Constants: *
+ ! *
+ !*****************************************************************************
+
+ use turbulence_mod
+
+ implicit none
+
+ integer, intent(in) :: itime
+ real, intent(in) :: xt,yt,zt,zteta
+ integer :: m,n,indexh
+ integer :: iw(2),iweta(2)
+ real :: uh1(2),vh1(2),wh1(2),wetah1(2),rho1(2),rhograd1(2)
+ real :: dz1weta,dz2weta
+ real,parameter :: eps=1.0e-30
+
+ ! Auxiliary variables needed for interpolation
+ real :: ust1(2),wst1(2),oli1(2),oliaux
+ !********************************************
+ ! Multilinear interpolation in time and space
+ !********************************************
+
+ ! ngrid and grid coordinates have already been definded, and are included
+ ! in the input (for nested: xtn,ytn; for not nested: xts,yts)
+ !************************************************************************
+
+ ! Determine the lower left corner and its distance to the current position
+ !*************************************************************************
+ call find_grid_distances(xt,yt)
+
+ ! Calculate variables for time interpolation
+ !*******************************************
+ call find_time_variables(itime)
+
+ !********************************************************
+ ! 1. Interpolate u*, w* and Obukhov length for turbulence
+ !********************************************************
+
+ ! a) Bilinear horizontal interpolation
+ if (ngrid.le.0) then ! No nest
+ do m=1,2
+ indexh=memind(m)
+ call horizontal_interpolation(ustar,ust1(m),1,memind(m),1)
+ call horizontal_interpolation(wstar,wst1(m),1,memind(m),1)
+ call horizontal_interpolation(oli,oli1(m),1,memind(m),1)
+ end do
+ else ! Nest
+ do m=1,2
+ indexh=memind(m)
+ call horizontal_interpolation_nests(ustarn,ust1(m),1,memind(m),1)
+ call horizontal_interpolation_nests(wstarn,wst1(m),1,memind(m),1)
+ call horizontal_interpolation_nests(olin,oli1(m),1,memind(m),1)
+ end do
+ endif
+ ! b) Temporal interpolation
+ call temporal_interpolation(ust1(1),ust1(2),ust)
+ call temporal_interpolation(wst1(1),wst1(2),wst)
+ call temporal_interpolation(oli1(1),oli1(2),oliaux)
+
+ if (oliaux.ne.0.) then
+ ol=1./oliaux
+ else
+ ol=99999.
+ endif
+
+ ! Within the PBL, only METER coordinates are used
+ ! with the exception of mesoscale turbulence,
+ ! which uses wsigeta computed in interpol_mesoscale
+ !**************************************************
+
+ ! Determine the level below the current position
+ !***********************************************
+ call find_z_level_meters(zt)
+
+ iw(:)=(/ indz, indzp /)
+
+ ! w(eta) velocities are necessary for the Petterssen correction
+ !**************************************************************
+ if (wind_coord_type.eq.'ETA') then
+ call find_z_level_eta(zteta)
+ iweta(:)=(/ indzeta, indzpeta /)
+ endif
+
+ !**************************************
+ ! 1.) Bilinear horizontal interpolation
+ ! 2.) Temporal interpolation (linear)
+ !**************************************
+
+ ! Loop over 2 time steps and indz levels
+ !***************************************
+ if (ngrid.le.0) then ! No nest
+ do n=1,2
+ do m=1,2
+ call horizontal_interpolation(ww,wh1(m),iw(n),memind(m),nzmax)
+ if (wind_coord_type.eq.'ETA') &
+ call horizontal_interpolation(wweta,wetah1(m),iweta(n),memind(m),nzmax)
+ call horizontal_interpolation(rho,rho1(m),iw(n),memind(m),nzmax)
+ call horizontal_interpolation(drhodz,rhograd1(m),iw(n),memind(m),nzmax)
+ if (ngrid.lt.0) then
+ call horizontal_interpolation(uupol,uh1(m),iw(n),memind(m),nzmax)
+ call horizontal_interpolation(vvpol,vh1(m),iw(n),memind(m),nzmax)
+ else
+ call horizontal_interpolation(uu,uh1(m),iw(n),memind(m),nzmax)
+ call horizontal_interpolation(vv,vh1(m),iw(n),memind(m),nzmax)
+ endif
+ end do
+ call temporal_interpolation(wh1(1),wh1(2),wprof(iw(n)))
+ if (wind_coord_type.eq.'ETA') &
+ call temporal_interpolation(wetah1(1),wetah1(2),wprofeta(iweta(n)))
+ call temporal_interpolation(uh1(1),uh1(2),uprof(iw(n)))
+ call temporal_interpolation(vh1(1),vh1(2),vprof(iw(n)))
+ call temporal_interpolation(rho1(1),rho1(2),rhoprof(iw(n)))
+ call temporal_interpolation(rhograd1(1),rhograd1(2),rhogradprof(iw(n)))
+ end do
+ else ! Nest
+ do n=1,2
+ do m=1,2
+ call horizontal_interpolation_nests(wwn,wh1(m),iw(n),memind(m),nzmax)
+ if (wind_coord_type.eq.'ETA') &
+ call horizontal_interpolation_nests(wwetan,wetah1(m),iweta(n),memind(m),nzmax)
+ call horizontal_interpolation_nests(uun,uh1(m),iw(n),memind(m),nzmax)
+ call horizontal_interpolation_nests(vvn,vh1(m),iw(n),memind(m),nzmax)
+ call horizontal_interpolation_nests(rhon,rho1(m),iw(n),memind(m),nzmax)
+ call horizontal_interpolation_nests(drhodzn,rhograd1(m),iw(n),memind(m),nzmax)
+ end do
+ call temporal_interpolation(wh1(1),wh1(2),wprof(iw(n)))
+ if (wind_coord_type.eq.'ETA') &
+ call temporal_interpolation(wetah1(1),wetah1(2),wprofeta(iweta(n)))
+ call temporal_interpolation(uh1(1),uh1(2),uprof(iw(n)))
+ call temporal_interpolation(vh1(1),vh1(2),vprof(iw(n)))
+ call temporal_interpolation(rho1(1),rho1(2),rhoprof(iw(n)))
+ call temporal_interpolation(rhograd1(1),rhograd1(2),rhogradprof(iw(n)))
+
+ indzindicator(iw(n))=.false.
+ end do
+ endif
+
+ ! Only necessary for the Petterssen correction
+ if (wind_coord_type.eq.'ETA') then
+ call find_vertical_variables(wheight,zteta,indzeta,dz1weta,dz2weta,lbounds_w,.true.)
+ call vertical_interpolation(wprofeta(indzeta),wprofeta(indzpeta),dz1weta,dz2weta,weta)
+ endif
+end subroutine interpol_PBL
+
+subroutine interpol_PBL_misslev()
+ !
+ !*****************************************************************************
+ ! *
+ ! This subroutine interpolates u,v,w, density and density gradients. *
+ ! *
+ ! Author: A. Stohl *
+ ! *
+ ! 16 December 1997 *
+ ! Update: 2 March 1999 *
+ ! *
+ ! Revision March 2005 by AST : all output variables in common block cal- *
+ ! culation of standard deviation done in this *
+ ! routine rather than subroutine call in order *
+ ! to save computation time *
+ ! *
+ !*****************************************************************************
+ ! *
+ ! Variables: *
+ ! n level *
+ ! *
+ ! Constants: *
+ ! *
+ !*****************************************************************************
+ implicit none
+
+ integer :: n,iw(2)
+ real :: uh1(2),vh1(2),wh1(2),rho1(2),rhograd1(2)
+ integer :: m
+
+
+ ! Within the PBL, only METER coordinates are used
+ ! with the exception of mesoscale turbulence,
+ ! which uses wsigeta computed in interpol_mesoscale
+ !**************************************************
+
+ !********************************************
+ ! Multilinear interpolation in time and space
+ !********************************************
+ iw(:)=(/ indz, indzp /)
+ do n=1,2
+ if (indzindicator(iw(n))) then
+ if (ngrid.le.0) then ! No nest
+ do m=1,2
+ call horizontal_interpolation(ww,wh1(m),iw(n),memind(m),nzmax)
+ call horizontal_interpolation(rho,rho1(m),iw(n),memind(m),nzmax)
+ call horizontal_interpolation(drhodz,rhograd1(m),iw(n),memind(m),nzmax)
+ if (ngrid.lt.0) then
+ call horizontal_interpolation(uupol,uh1(m),iw(n),memind(m),nzmax)
+ call horizontal_interpolation(vvpol,vh1(m),iw(n),memind(m),nzmax)
+ else
+ call horizontal_interpolation(uu,uh1(m),iw(n),memind(m),nzmax)
+ call horizontal_interpolation(vv,vh1(m),iw(n),memind(m),nzmax)
+ endif
+ end do
+ else ! Nest
+ do m=1,2
+ call horizontal_interpolation_nests(wwn,wh1(m),iw(n),memind(m),nzmax)
+ call horizontal_interpolation_nests(uun,uh1(m),iw(n),memind(m),nzmax)
+ call horizontal_interpolation_nests(vvn,vh1(m),iw(n),memind(m),nzmax)
+ call horizontal_interpolation_nests(rhon,rho1(m),iw(n),memind(m),nzmax)
+ call horizontal_interpolation_nests(drhodzn,rhograd1(m),iw(n),memind(m),nzmax)
+ end do
+ endif
+ call temporal_interpolation(wh1(1),wh1(2),wprof(iw(n)))
+ call temporal_interpolation(uh1(1),uh1(2),uprof(iw(n)))
+ call temporal_interpolation(vh1(1),vh1(2),vprof(iw(n)))
+ call temporal_interpolation(rho1(1),rho1(2),rhoprof(iw(n)))
+ call temporal_interpolation(rhograd1(1),rhograd1(2),rhogradprof(iw(n)))
+
+ indzindicator(iw(n))=.false.
+ endif
+ end do
+end subroutine interpol_PBL_misslev
+
+subroutine interpol_PBL_short(zt,rhoa,rhograd)
+ implicit none
+ real, intent(in) :: zt
+ real, intent(inout) :: rhoa,rhograd
+ real :: dz1,dz2
+
+ call find_vertical_variables(height,zt,indz,dz1,dz2,lbounds,.false.)
+
+ call vertical_interpolation(wprof(indz),wprof(indzp),dz1,dz2,w)
+ call vertical_interpolation(uprof(indz),uprof(indzp),dz1,dz2,u)
+ call vertical_interpolation(vprof(indz),vprof(indzp),dz1,dz2,v)
+ call vertical_interpolation(rhoprof(indz),rhoprof(indzp),dz1,dz2,rhoa)
+ call vertical_interpolation(rhogradprof(indz),rhogradprof(indzp),dz1,dz2,rhograd)
+end subroutine interpol_PBL_short
+
+subroutine interpol_mesoscale(itime,xt,yt,zt,zteta)
+ use turbulence_mod
+
+ implicit none
+
+ integer, intent(in) :: itime
+ real, intent(in) :: xt,yt,zt,zteta
+ integer :: m,indexh
+ integer :: iw(2),iuv(2),iweta(2)
+
+ ! Where in the grid? Stereographic (ngrid<0) or nested (ngrid>0)
+ !***************************************************************
+ call find_ngrid(xt,yt)
+
+ call determine_grid_coordinates(xt,yt)
+
+ ! Determine the level below the current position
+ !***********************************************
+ call find_z_level_meters(zt)
+ iw(:)=(/ indz, indzp /)
+
+ select case (wind_coord_type)
+ case ('ETA')
+ call find_z_level_eta(zteta)
+ iuv(:)=(/ induv, indpuv /)
+ iweta(:)=(/ indzeta, indzpeta /)
+ call standard_deviation_eta(iw,iuv,iweta)
+ case ('METER')
+ iw(:)=(/ indz, indzp /)
+ call standard_deviation_meter(iw)
+ case default
+ write(*,*) 'ERROR: wind_coord_type is not allowed ', wind_coord_type
+ write(*,*) 'Choose ETA or METER.'
+ stop
+ end select
+end subroutine interpol_mesoscale
+
+subroutine interpol_wind(itime,xt,yt,zt,zteta,pp)
+ ! i i i i
+ !*****************************************************************************
+ ! *
+ ! This subroutine interpolates the wind data to current trajectory position.*
+ ! *
+ ! Author: A. Stohl *
+ ! *
+ ! 16 December 1997 *
+ ! *
+ ! Revision March 2005 by AST : all output variables in common block cal- *
+ ! culation of standard deviation done in this *
+ ! routine rather than subroutine call in order *
+ ! to save computation time *
+ ! *
+ !*****************************************************************************
+ ! *
+ ! Variables: *
+ ! u,v,w wind components *
+ ! itime [s] current temporal position *
+ ! memtime(3) [s] times of the wind fields in memory *
+ ! xt,yt,zt coordinates position for which wind data shall be *
+ ! calculated *
+ ! *
+ ! Constants: *
+ ! *
+ !*****************************************************************************
+
+
+ implicit none
+
+ integer, intent(in) :: itime,pp
+ real, intent(in) :: xt,yt,zt
+ real, intent(in) :: zteta
+ integer :: iw(2),iuv(2),iweta(2)
+
+
+ ! Where in the grid? Stereographic (ngrid<0) or nested (ngrid>0)
+ !***************************************************************
+ call find_ngrid(xt,yt)
+
+ call determine_grid_coordinates(xt,yt)
+ ! ! Multilinear interpolation in time and space
+ ! !********************************************
+
+ ! Determine the lower left corner and its distance to the current position
+ !*************************************************************************
+ call find_grid_distances(xt,yt)
+
+ ! Calculate variables for time interpolation
+ !*******************************************
+ call find_time_variables(itime)
+
+ ! Interpolate over the windfields depending on the prefered
+ ! coordinate system
+ !**********************************************************
+ select case (wind_coord_type)
+ case ('ETA')
+ ! Same for eta coordinates
+ !*************************
+ call find_z_level_eta(zteta)
+
+ iuv(:) = (/ induv, indpuv /)
+ iweta(:)= (/ indzeta, indzpeta /)
+ call interpol_wind_eta(zteta,iuv,iweta)
+ !call standard_deviation_wind_eta(iw,iuv,iweta)
+ case ('METER')
+ ! Determine the level below the current position for u,v
+ !*******************************************************
+ call find_z_level_meters(zt)
+
+ iw(:)=(/ indz, indzp /)
+ call interpol_wind_meter(zt,iw)
+ !call standard_deviation_wind_meter(iw)
+
+ case default
+ write(*,*) 'ERROR: wind_coord_type is not allowed ', wind_coord_type
+ write(*,*) 'Choose ETA or METER.'
+ stop
+ end select
+end subroutine interpol_wind
+
+subroutine interpol_wind_short(itime,xt,yt,zt,zteta)
+ ! i i i i
+ !*****************************************************************************
+ ! *
+ ! This subroutine interpolates the wind data to current trajectory position.*
+ ! *
+ ! Author: A. Stohl *
+ ! *
+ ! 16 December 1997 *
+ ! *
+ ! Revision March 2005 by AST : all output variables in common block *
+ ! *
+ !*****************************************************************************
+ ! *
+ ! Variables: *
+ ! u,v,w wind components *
+ ! itime [s] current temporal position *
+ ! memtime(3) [s] times of the wind fields in memory *
+ ! xt,yt,zt coordinates position for which wind data shall be *
+ ! calculated *
+ ! *
+ ! Constants: *
+ ! *
+ !*****************************************************************************
+
+
+ implicit none
+
+ integer, intent(in) :: itime
+ real, intent(in) :: xt,yt,zt
+ real, intent(in) :: zteta
+ integer :: iw(2),iuv(2),iweta(2)
+
+ !********************************************
+ ! Multilinear interpolation in time and space
+ !********************************************
+
+ ! Where in the grid? Stereographic (ngrid<0) or nested (ngrid>0)
+ !***************************************************************
+ call find_ngrid(xt,yt)
+ call determine_grid_coordinates(xt,yt)
+ call find_grid_distances(xt,yt)
+
+ ! Calculate variables for time interpolation
+ !*******************************************
+ call find_time_variables(itime)
+
+ ! Interpolate over the windfields depending on the prefered
+ ! coordinate system
+ !**********************************************************
+ select case (wind_coord_type)
+ case ('ETA')
+ ! Determine the level below the current position for eta coordinates
+ !*******************************************************************
+ call find_z_level_eta(zteta)
+
+ iuv(:)=(/ induv, indpuv /)
+ iweta(:)=(/ indzeta, indzpeta /)
+ ! Interpolate the u, v, weta windfields
+ !**************************************
+ call interpol_wind_eta(zteta,iuv,iweta)
+ case ('METER')
+
+ ! Determine the level below the current position for u,v
+ !*******************************************************
+ call find_z_level_meters(zt)
+
+ iw(:)=(/ indz, indzp /)
+ call interpol_wind_meter(zt,iw)
+ case default
+ write(*,*) 'ERROR: wind_coord_type is not allowed ', wind_coord_type
+ write(*,*) 'Choose ETA or METER.'
+ stop
+ end select
+end subroutine interpol_wind_short
+
+subroutine interpol_partoutput_value(fieldname,output,j)
+ implicit none
+ integer, intent(in) :: j ! particle number
+ character(2), intent(in) :: fieldname ! input field to interpolate over
+ real, intent(inout) :: output
+ ! Interpolate over the windfields depending on the prefered
+ ! coordinate system
+ !**********************************************************
+ select case (wind_coord_type)
+ case ('ETA')
+ call interpol_partoutput_value_eta(fieldname,output,j)
+ case ('METER')
+ call interpol_partoutput_value_meter(fieldname,output,j)
+ case default
+ call interpol_partoutput_value_meter(fieldname,output,j)
+ end select
+end subroutine interpol_partoutput_value
+
+subroutine interpol_htropo_hmix(tropop,h)
+ implicit none
+ real, intent(inout) :: &
+ tropop, & ! height of troposphere
+ h ! mixing height
+ real :: &
+ h1(2) ! mixing height of 2 timesteps
+ integer :: &
+ mind, & ! windfield index
+ i,j,k,m ! loop variables
+
+ h=0.
+ if (ngrid.le.0) then
+ if (interpolhmix) then
+ do m=1,2
+ call horizontal_interpolation(hmix,h1(m),1,memind(m),1)
+ end do
+ else
+ do k=1,2
+ mind=memind(k) ! eso: compatibility with 3-field version
+ do j=jy,jyp
+ do i=ix,ixp
+ if (hmix(i,j,1,mind).gt.h) h=hmix(i,j,1,mind)
+ end do
+ end do
+ end do
+ endif
+ tropop=tropopause(nix,njy,1,memind(1))
+ else
+ do k=1,2
+ mind=memind(k)
+ do j=jy,jyp
+ do i=ix,ixp
+ if (hmixn(i,j,1,mind,ngrid).gt.h) h=hmixn(i,j,1,mind,ngrid)
+ end do
+ end do
+ end do
+ tropop=tropopausen(nix,njy,1,memind(1),ngrid)
+ endif
+
+ if (interpolhmix) h=(h1(1)*dt2+h1(2)*dt1)*dtt
+end subroutine interpol_htropo_hmix
+
+subroutine interpol_density(itime,ipart,output)
+
+ implicit none
+
+ integer, intent(in) :: itime,ipart ! time and particle index
+ real, intent(inout) :: output ! output density (rhoi)
+ integer :: ind
+ real :: dz1,dz2
+ real :: rhoprof(2)
+
+ ! Where in the grid? Stereographic (ngrid<0) or nested (ngrid>0)
+ !***************************************************************
+ call find_ngrid(part(ipart)%xlon,part(ipart)%ylat)
+ call determine_grid_coordinates(real(part(ipart)%xlon),real(part(ipart)%ylat))
+ call find_grid_distances(real(part(ipart)%xlon),real(part(ipart)%ylat))
+ call find_time_variables(itime)
+
+ ! Take density from 2nd wind field in memory (accurate enough, no time interpolation needed)
+ !*****************************************************************************
+ select case (wind_coord_type)
+ case ('ETA')
+ call find_z_level_eta(real(part(ipart)%zeta))
+ call find_vertical_variables(uvheight,real(part(ipart)%zeta),induv,dz1,dz2,lbounds_uv,.false.)
+ if (ngrid.le.0) then
+ do ind=induv,indpuv
+ call horizontal_interpolation(rhoeta,rhoprof(ind-induv+1),ind,memind(2),nzmax)
+ end do
+ else
+ do ind=induv,indpuv
+ call horizontal_interpolation_nests(rhoetan,rhoprof(ind-induv+1),ind,memind(2),nzmax)
+ end do
+ endif
+ case ('METER')
+ call find_z_level_meters(real(part(ipart)%z))
+ call find_vertical_variables(height,real(part(ipart)%z),indz,dz1,dz2,lbounds,.false.)
+ if (ngrid.le.0) then
+ do ind=indz,indzp
+ call horizontal_interpolation(rho,rhoprof(ind-indz+1),ind,memind(2),nzmax)
+ end do
+ else
+ do ind=indz,indzp
+ call horizontal_interpolation_nests(rhon,rhoprof(ind-indz+1),ind,memind(2),nzmax)
+ end do
+ endif
+ case default
+ stop 'wind_coord_type not defined in conccalc.f90'
+ end select
+ call vertical_interpolation(rhoprof(1),rhoprof(2),dz1,dz2,output)
+end subroutine interpol_density
+
+!*********************
+!* PRIVATE FUNCTIONS *
+!*********************
+! Interpolation of wind fields
+!*****************************
+subroutine interpol_wind_eta(zteta,iuv,iweta)
+ implicit none
+
+ real, intent(in) :: zteta
+ integer,intent(in) :: iuv(2),iweta(2)
+ integer :: n,m
+ real :: uh(2),vh(2),wetah(2),uh1(2),vh1(2),wetah1(2)
+ real :: dz1uv,dz2uv,dz1weta,dz2weta
+ !**********************************************************************
+ ! 1.) Bilinear horizontal interpolation
+ ! This has to be done separately for 6 fields (Temporal(2)*Vertical(3))
+ !**********************************************************************
+
+ ! Vertical distance to the level below and above current position
+ !****************************************************************
+ call find_vertical_variables(uvheight,zteta,induv,dz1uv,dz2uv,lbounds_uv,.false.)
+ call find_vertical_variables(wheight,zteta,indzeta,dz1weta,dz2weta,lbounds_w,.true.)
+
+ ! Loop over 2 time steps and 2 levels
+ !************************************
+ if (ngrid.le.0) then ! No nest
+ do m=1,2
+ do n=1,2
+ call horizontal_interpolation(wweta,wetah1(n),iweta(n),memind(m),nzmax)
+ if (ngrid.lt.0) then
+ call horizontal_interpolation(uupoleta,uh1(n),iuv(n),memind(m),nzmax)
+ call horizontal_interpolation(vvpoleta,vh1(n),iuv(n),memind(m),nzmax)
+ else
+ call horizontal_interpolation(uueta,uh1(n),iuv(n),memind(m),nzmax)
+ call horizontal_interpolation(vveta,vh1(n),iuv(n),memind(m),nzmax)
+ endif
+ end do
+ call vertical_interpolation(uh1(1),uh1(2),dz1uv,dz2uv,uh(m))
+ call vertical_interpolation(vh1(1),vh1(2),dz1uv,dz2uv,vh(m))
+ call vertical_interpolation(wetah1(1),wetah1(2),dz1weta,dz2weta,wetah(m))
+ end do
+ else ! Nest
+ do m=1,2
+ do n=1,2
+
+ ! wetah1(n) = p1*wwetan(ix ,jy ,iweta(n),memind(m),ngrid) &
+ ! + p2*wwetan(ixp,jy ,iweta(n),memind(m),ngrid) &
+ ! + p3*wwetan(ix ,jyp,iweta(n),memind(m),ngrid) &
+ ! + p4*wwetan(ixp,jyp,iweta(n),memind(m),ngrid)
+ call horizontal_interpolation_nests(wwetan,wetah1(n),iweta(n),memind(m),nzmax)
+ call horizontal_interpolation_nests(uuetan,uh1(n),iuv(n),memind(m),nzmax)
+ call horizontal_interpolation_nests(vvetan,vh1(n),iuv(n),memind(m),nzmax)
+ end do
+ call vertical_interpolation(uh1(1),uh1(2),dz1uv,dz2uv,uh(m))
+ call vertical_interpolation(vh1(1),vh1(2),dz1uv,dz2uv,vh(m))
+ call vertical_interpolation(wetah1(1),wetah1(2),dz1weta,dz2weta,wetah(m))
+ end do
+ endif
+ call temporal_interpolation(uh(1),uh(2),u)
+ call temporal_interpolation(vh(1),vh(2),v)
+ call temporal_interpolation(wetah(1),wetah(2),weta)
+end subroutine interpol_wind_eta
+
+subroutine interpol_wind_meter(zt,iw)
+ implicit none
+
+ real, intent(in) :: zt
+ integer,intent(in) :: iw(2)
+ integer :: n,m
+ real :: uh(2),vh(2),wh(2),uh1(2),vh1(2),wh1(2)
+ real :: dz1w,dz2w
+
+ !**********************************************************************
+ ! 1.) Bilinear horizontal interpolation
+ ! This has to be done separately for 6 fields (Temporal(2)*Vertical(3))
+ !**********************************************************************
+
+ ! Vertical distance to the level below and above current position
+ !****************************************************************
+ call find_vertical_variables(height,zt,indz,dz1w,dz2w,lbounds,.false.)
+
+ ! Loop over 2 time steps and 2 levels
+ !************************************
+ if (ngrid.le.0) then ! No nest
+ do m=1,2
+ do n=1,2
+ call horizontal_interpolation(ww,wh1(n),iw(n),memind(m),nzmax)
+ if (ngrid.lt.0) then
+ call horizontal_interpolation(uupol,uh1(n),iw(n),memind(m),nzmax)
+ call horizontal_interpolation(vvpol,vh1(n),iw(n),memind(m),nzmax)
+ else
+ call horizontal_interpolation(uu,uh1(n),iw(n),memind(m),nzmax)
+ call horizontal_interpolation(vv,vh1(n),iw(n),memind(m),nzmax)
+ endif
+ end do
+ call vertical_interpolation(wh1(1),wh1(2),dz1w,dz2w,wh(m))
+ call vertical_interpolation(uh1(1),uh1(2),dz1w,dz2w,uh(m))
+ call vertical_interpolation(vh1(1),vh1(2),dz1w,dz2w,vh(m))
+ end do
+ else ! Nest
+ do m=1,2
+ do n=1,2
+ call horizontal_interpolation_nests(wwn,wh1(n),iw(n),memind(m),nzmax)
+ call horizontal_interpolation_nests(uun,uh1(n),iw(n),memind(m),nzmax)
+ call horizontal_interpolation_nests(vvn,vh1(n),iw(n),memind(m),nzmax)
+ end do
+ call vertical_interpolation(wh1(1),wh1(2),dz1w,dz2w,wh(m))
+ call vertical_interpolation(uh1(1),uh1(2),dz1w,dz2w,uh(m))
+ call vertical_interpolation(vh1(1),vh1(2),dz1w,dz2w,vh(m))
+ end do
+ endif
+ call temporal_interpolation(wh(1),wh(2),w)
+ call temporal_interpolation(uh(1),uh(2),u)
+ call temporal_interpolation(vh(1),vh(2),v)
+end subroutine interpol_wind_meter
+
+subroutine interpol_partoutput_value_eta(fieldname,output,j)
+ implicit none
+ integer, intent(in) :: j ! particle number
+ character(2), intent(in) :: fieldname ! input field to interpolate over
+ real, intent(inout) :: output
+ real :: field1(2)
+
+ if (int(dz1out).eq.-1) then
+ call find_z_level_eta(real(part(j)%zeta))
+ call find_vertical_variables(uvheight,real(part(j)%zeta),induv,dz1out,dz2out,lbounds_uv,.false.)
+ endif
+
+ select case(fieldname)
+ case('PR','pr')
+ if (ngrid.le.0) then
+ call bilinear_spatial_interpolation(prseta,field1,induv,dz1out,dz2out,nzmax)
+ else
+ call bilinear_spatial_interpolation_nests(prsetan,field1,induv,dz1out,dz2out,nzmax)
+ endif
+ call temporal_interpolation(field1(1),field1(2),output)
+ case('PV','pv')
+ if (ngrid.le.0) then
+ call bilinear_spatial_interpolation(pveta,field1,induv,dz1out,dz2out,nzmax)
+ else
+ call bilinear_spatial_interpolation_nests(pvetan,field1,induv,dz1out,dz2out,nzmax)
+ endif
+ call temporal_interpolation(field1(1),field1(2),output)
+ case('QV','qv')
+ if (ngrid.le.0) then
+ call bilinear_spatial_interpolation(qv,field1,induv,dz1out,dz2out,nzmax)
+ else
+ call bilinear_spatial_interpolation_nests(qvn,field1,induv,dz1out,dz2out,nzmax)
+ endif
+ call temporal_interpolation(field1(1),field1(2),output)
+ case('TT','tt')
+ if (ngrid.le.0) then
+ call bilinear_spatial_interpolation(tteta,field1,induv,dz1out,dz2out,nzmax)
+ else
+ call bilinear_spatial_interpolation_nests(ttetan,field1,induv,dz1out,dz2out,nzmax)
+ endif
+ call temporal_interpolation(field1(1),field1(2),output)
+ case('UU','uu')
+ if (ngrid.le.0) then
+ call bilinear_spatial_interpolation(uueta,field1,induv,dz1out,dz2out,nzmax)
+ else
+ call bilinear_spatial_interpolation_nests(uuetan,field1,induv,dz1out,dz2out,nzmax)
+ endif
+ call temporal_interpolation(field1(1),field1(2),output)
+ case('VV','vv')
+ if (ngrid.le.0) then
+ call bilinear_spatial_interpolation(vveta,field1,induv,dz1out,dz2out,nzmax)
+ else
+ call bilinear_spatial_interpolation_nests(vvetan,field1,induv,dz1out,dz2out,nzmax)
+ endif
+ call temporal_interpolation(field1(1),field1(2),output)
+ case('WW','ww')
+ call find_z_level_meters(real(part(j)%z))
+ call find_vertical_variables(height,real(part(j)%z),indz,dz1out,dz2out,lbounds,.false.)
+ if (ngrid.le.0) then
+ call bilinear_spatial_interpolation(ww,field1,induv,dz1out,dz2out,nzmax)
+ else
+ call bilinear_spatial_interpolation_nests(wwn,field1,induv,dz1out,dz2out,nzmax)
+ endif
+ call temporal_interpolation(field1(1),field1(2),output)
+ dz1out = -1
+ case('RH','rh')
+ if (ngrid.le.0) then
+ call bilinear_spatial_interpolation(rhoeta,field1,induv,dz1out,dz2out,nzmax)
+ else
+ call bilinear_spatial_interpolation_nests(rhoetan,field1,induv,dz1out,dz2out,nzmax)
+ endif
+ call temporal_interpolation(field1(1),field1(2),output)
+ end select
+end subroutine interpol_partoutput_value_eta
+
+subroutine interpol_partoutput_value_meter(fieldname,output,j)
+ implicit none
+ integer, intent(in) :: j ! particle number
+ character(2), intent(in) :: fieldname ! input field to interpolate over
+ real, intent(inout) :: output
+ real :: field1(2)
+
+ if (int(dz1out).eq.-1) then
+ call find_z_level_meters(real(part(j)%z))
+ call find_vertical_variables(height,real(part(j)%z),indz,dz1out,dz2out,lbounds,.false.)
+ endif
+
+ select case(fieldname)
+ case('PR','pr')
+ if (ngrid.le.0) then
+ call bilinear_spatial_interpolation(prs,field1,indz,dz1out,dz2out,nzmax)
+ else
+ call bilinear_spatial_interpolation_nests(prsn,field1,indz,dz1out,dz2out,nzmax)
+ endif
+ call temporal_interpolation(field1(1),field1(2),output)
+ case('PV','pv')
+ if (ngrid.le.0) then
+ call bilinear_spatial_interpolation(pv,field1,indz,dz1out,dz2out,nzmax)
+ else
+ call bilinear_spatial_interpolation_nests(pvn,field1,indz,dz1out,dz2out,nzmax)
+ endif
+ call temporal_interpolation(field1(1),field1(2),output)
+ case('QV','qv')
+ if (ngrid.le.0) then
+ call bilinear_spatial_interpolation(qv,field1,indz,dz1out,dz2out,nzmax)
+ else
+ call bilinear_spatial_interpolation_nests(qvn,field1,indz,dz1out,dz2out,nzmax)
+ endif
+ call temporal_interpolation(field1(1),field1(2),output)
+ case('TT','tt')
+ if (ngrid.le.0) then
+ call bilinear_spatial_interpolation(tt,field1,indz,dz1out,dz2out,nzmax)
+ else
+ call bilinear_spatial_interpolation_nests(ttn,field1,indz,dz1out,dz2out,nzmax)
+ endif
+ call temporal_interpolation(field1(1),field1(2),output)
+ case('UU','uu')
+ if (ngrid.le.0) then
+ call bilinear_spatial_interpolation(uu,field1,indz,dz1out,dz2out,nzmax)
+ else
+ call bilinear_spatial_interpolation_nests(uun,field1,indz,dz1out,dz2out,nzmax)
+ endif
+ call temporal_interpolation(field1(1),field1(2),output)
+ case('VV','vv')
+ if (ngrid.le.0) then
+ call bilinear_spatial_interpolation(vv,field1,indz,dz1out,dz2out,nzmax)
+ else
+ call bilinear_spatial_interpolation_nests(vvn,field1,indz,dz1out,dz2out,nzmax)
+ endif
+ call temporal_interpolation(field1(1),field1(2),output)
+ case('WW','ww')
+ if (ngrid.le.0) then
+ call bilinear_spatial_interpolation(ww,field1,indz,dz1out,dz2out,nzmax)
+ else
+ call bilinear_spatial_interpolation_nests(wwn,field1,indz,dz1out,dz2out,nzmax)
+ endif
+ call temporal_interpolation(field1(1),field1(2),output)
+ case('RH','rh')
+ if (ngrid.le.0) then
+ call bilinear_spatial_interpolation(rho,field1,indz,dz1out,dz2out,nzmax)
+ else
+ call bilinear_spatial_interpolation_nests(rhon,field1,indz,dz1out,dz2out,nzmax)
+ endif
+ call temporal_interpolation(field1(1),field1(2),output)
+ end select
+end subroutine interpol_partoutput_value_meter
+
+subroutine interpol_mixinglayer_eta(zt,zteta,rhoa,rhograd)
+ implicit none
+ real, intent(in) :: zt,zteta
+ real, intent(inout) :: rhoa,rhograd
+ real :: dz1w,dz2w,dz1uv,dz2uv,dz1weta,dz2weta
+
+ call find_vertical_variables(height,zt,indz,dz1w,dz2w,lbounds,.false.)
+ call find_vertical_variables(uvheight,zteta,induv,dz1uv,dz2uv,lbounds_uv,.false.)
+ call find_vertical_variables(wheight,zteta,indzeta,dz1weta,dz2weta,lbounds_w,.true.)
+
+ call vertical_interpolation(wprof(indz),wprof(indzp),dz1w,dz2w,w)
+ call vertical_interpolation(uprof(induv),uprof(indpuv),dz1uv,dz2uv,u)
+ call vertical_interpolation(vprof(induv),vprof(indpuv),dz1uv,dz2uv,v)
+ call vertical_interpolation(rhoprof(induv),rhoprof(indpuv),dz1uv,dz2uv,rhoa)
+ call vertical_interpolation(rhogradprof(induv),rhogradprof(indpuv),dz1uv,dz2uv,rhograd)
+ call vertical_interpolation(wprofeta(indzeta),wprofeta(indzpeta),dz1weta,dz2weta,weta)
+end subroutine interpol_mixinglayer_eta
+
+subroutine standard_deviation_eta(iw,iuv,iweta)
+ ! Standard deviation of surrounding grid points
+ ! Only used in mesoscale turbulence calculations
+ !***********************************************
+ implicit none
+
+ integer,intent(in) :: iw(2),iuv(2),iweta(2)
+ real :: wsl,wsq,wxaux,usl,usq,uxaux,vsl,vsq,vxaux,wetasl,wetasq,wetaxaux
+ integer :: n,m
+ real,parameter :: eps=1.0e-30
+ ! Standard deviations
+ !********************
+ wsl=0.
+ wsq=0.
+ usl=0.
+ usq=0.
+ vsl=0.
+ vsq=0.
+ wetasl=0.
+ wetasq=0.
+
+ if (ngrid.le.0) then ! No nest
+ do m=1,2
+ do n=1,2
+ call compute_sl_sq(ww,wsl,wsq,iw(n),memind(m),nzmax)
+ call compute_sl_sq(wweta,wetasl,wetasq,iweta(n),memind(m),nzmax)
+ if (ngrid.lt.0) then
+ call compute_sl_sq(uupoleta,usl,usq,iuv(n),memind(m),nzmax)
+ call compute_sl_sq(vvpoleta,vsl,vsq,iuv(n),memind(m),nzmax)
+ else
+ call compute_sl_sq(uueta,usl,usq,iuv(n),memind(m),nzmax)
+ call compute_sl_sq(vveta,vsl,vsq,iuv(n),memind(m),nzmax)
+ endif
+ end do
+ end do
+ else ! Nest
+ do m=1,2
+ do n=1,2
+ call compute_sl_sq_nests(wwn,wsl,wsq,iw(n),memind(m),nzmax)
+ call compute_sl_sq_nests(wwetan,wetasl,wetasq,iweta(n),memind(m),nzmax)
+ call compute_sl_sq_nests(uuetan,usl,usq,iuv(n),memind(m),nzmax)
+ call compute_sl_sq_nests(vvetan,vsl,vsq,iuv(n),memind(m),nzmax)
+ end do
+ end do
+ endif
+
+ call standard_deviation(wsl,wsq,16.,wsig)
+ call standard_deviation(usl,usq,16.,usig)
+ call standard_deviation(vsl,vsq,16.,vsig)
+ call standard_deviation(wetasl,wetasq,16.,wsigeta)
+end subroutine standard_deviation_eta
+
+subroutine standard_deviation_meter(iw)
+ ! Standard deviation of surrounding grid points
+ ! Only used in mesoscale turbulence calculations
+ !***********************************************
+ implicit none
+
+ integer,intent(in) :: iw(2)
+ real :: wsl,wsq,wxaux,usl,usq,uxaux,vsl,vsq,vxaux
+ integer :: n,m
+ real,parameter :: eps=1.0e-30
+
+ ! Standard deviations
+ !********************
+ wsl=0.
+ wsq=0.
+ usl=0.
+ usq=0.
+ vsl=0.
+ vsq=0.
-end module interpol_mod
+ if (ngrid.le.0) then ! No nest
+ do m=1,2
+ do n=1,2
+ call compute_sl_sq(ww,wsl,wsq,iw(n),memind(m),nzmax)
+ if (ngrid.lt.0) then
+ call compute_sl_sq(uupol,usl,usq,iw(n),memind(m),nzmax)
+ call compute_sl_sq(vvpol,vsl,vsq,iw(n),memind(m),nzmax)
+ else
+ call compute_sl_sq(uu,usl,usq,iw(n),memind(m),nzmax)
+ call compute_sl_sq(vv,vsl,vsq,iw(n),memind(m),nzmax)
+ endif
+ end do
+ end do
+ else ! Nest
+ do m=1,2
+ do n=1,2
+ call compute_sl_sq_nests(wwn,wsl,wsq,iw(n),memind(m),nzmax)
+ call compute_sl_sq_nests(uun,usl,usq,iw(n),memind(m),nzmax)
+ call compute_sl_sq_nests(vvn,vsl,vsq,iw(n),memind(m),nzmax)
+ end do
+ end do
+ endif
+ call standard_deviation(wsl,wsq,16.,wsig)
+ call standard_deviation(usl,usq,16.,usig)
+ call standard_deviation(vsl,vsq,16.,vsig)
+end subroutine standard_deviation_meter
+end module interpol_mod
\ No newline at end of file
diff --git a/src/interpol_wind_short.f90 b/src/interpol_wind_short.f90
deleted file mode 100644
index 826e3897..00000000
--- a/src/interpol_wind_short.f90
+++ /dev/null
@@ -1,142 +0,0 @@
-! SPDX-FileCopyrightText: FLEXPART 1998-2019, see flexpart_license.txt
-! SPDX-License-Identifier: GPL-3.0-or-later
-
-subroutine interpol_wind_short(itime,xt,yt,zt)
-! i i i i
-!*****************************************************************************
-! *
-! This subroutine interpolates the wind data to current trajectory position.*
-! *
-! Author: A. Stohl *
-! *
-! 16 December 1997 *
-! *
-! Revision March 2005 by AST : all output variables in common block *
-! *
-!*****************************************************************************
-! *
-! Variables: *
-! u,v,w wind components *
-! itime [s] current temporal position *
-! memtime(3) [s] times of the wind fields in memory *
-! xt,yt,zt coordinates position for which wind data shall be *
-! calculated *
-! *
-! Constants: *
-! *
-!*****************************************************************************
-
- use par_mod
- use com_mod
- use interpol_mod
-
- implicit none
-
- integer, intent(in) :: itime
- real, intent(in) :: xt,yt,zt
-
- ! Auxiliary variables needed for interpolation
- real :: dz1,dz2,dz
- real :: u1(2),v1(2),w1(2),uh(2),vh(2),wh(2)
- integer :: i,m,n,indexh,indzh
-
-
- !********************************************
- ! Multilinear interpolation in time and space
- !********************************************
-
- ddx=xt-real(ix)
- ddy=yt-real(jy)
- rddx=1.-ddx
- rddy=1.-ddy
- p1=rddx*rddy
- p2=ddx*rddy
- p3=rddx*ddy
- p4=ddx*ddy
-
- ! Calculate variables for time interpolation
- !*******************************************
-
- dt1=real(itime-memtime(1))
- dt2=real(memtime(2)-itime)
- dtt=1./(dt1+dt2)
-
- ! Determine the level below the current position for u,v
- !*******************************************************
-
- do i=2,nz
- if (height(i).gt.zt) then
- indz=i-1
- goto 6
- endif
- end do
-6 continue
-
-
- ! Vertical distance to the level below and above current position
- !****************************************************************
-
- dz=1./(height(indz+1)-height(indz))
- dz1=(zt-height(indz))*dz
- dz2=(height(indz+1)-zt)*dz
-
-
- !**********************************************************************
- ! 1.) Bilinear horizontal interpolation
- ! This has to be done separately for 6 fields (Temporal(2)*Vertical(3))
- !**********************************************************************
-
- ! Loop over 2 time steps and 2 levels
- !************************************
-
- do m=1,2
- indexh=memind(m)
- do n=1,2
- indzh=indz+n-1
-
- if (ngrid.lt.0) then
- u1(n)=p1*uupol(ix ,jy ,indzh,indexh) &
- +p2*uupol(ixp,jy ,indzh,indexh) &
- +p3*uupol(ix ,jyp,indzh,indexh) &
- +p4*uupol(ixp,jyp,indzh,indexh)
- v1(n)=p1*vvpol(ix ,jy ,indzh,indexh) &
- +p2*vvpol(ixp,jy ,indzh,indexh) &
- +p3*vvpol(ix ,jyp,indzh,indexh) &
- +p4*vvpol(ixp,jyp,indzh,indexh)
- else
- u1(n)=p1*uu(ix ,jy ,indzh,indexh) &
- +p2*uu(ixp,jy ,indzh,indexh) &
- +p3*uu(ix ,jyp,indzh,indexh) &
- +p4*uu(ixp,jyp,indzh,indexh)
- v1(n)=p1*vv(ix ,jy ,indzh,indexh) &
- +p2*vv(ixp,jy ,indzh,indexh) &
- +p3*vv(ix ,jyp,indzh,indexh) &
- +p4*vv(ixp,jyp,indzh,indexh)
- endif
- w1(n)=p1*ww(ix ,jy ,indzh,indexh) &
- +p2*ww(ixp,jy ,indzh,indexh) &
- +p3*ww(ix ,jyp,indzh,indexh) &
- +p4*ww(ixp,jyp,indzh,indexh)
- end do
-
-
- !**********************************
- ! 2.) Linear vertical interpolation
- !**********************************
-
- uh(m)=dz2*u1(1)+dz1*u1(2)
- vh(m)=dz2*v1(1)+dz1*v1(2)
- wh(m)=dz2*w1(1)+dz1*w1(2)
- end do
-
-
-
- !************************************
- ! 3.) Temporal interpolation (linear)
- !************************************
-
- u=(uh(1)*dt2+uh(2)*dt1)*dtt
- v=(vh(1)*dt2+vh(2)*dt1)*dtt
- w=(wh(1)*dt2+wh(2)*dt1)*dtt
-
-end subroutine interpol_wind_short
diff --git a/src/list-of-modules.txt b/src/list-of-modules.txt
new file mode 100644
index 00000000..e16dc5e1
--- /dev/null
+++ b/src/list-of-modules.txt
@@ -0,0 +1,39 @@
+ 10 xmass_mod.f90 WHY DO WE NEED EXTRA MODULE?
+ 99 unc_mod.f90 A BIT STRANGE FOR ME. SHOULD GO IN OUTG?
+ 135 point_mod.f90 WHY IS THIS A MODULE? BUNDLE WITH READINPUT?
+ 154 date_mod.f90
+ 171 txt_output_mod.f90 SHOULD GO IN OUTPUT?
+ 179 random_mod.f90 MAYBE BUNDLE WITH ERF?
+ 197 qvsat_mod.f90 MAYBE BUNDLE WITH OTHER THERMODY STUFF?
+ 201 erf_mod.f90
+ 217 settling_mod.f90 MAYBE BUNDLE WITH DRYDEPO?
+ 233 mean_mod.f90
+ 320 par_mod.f90
+ 400 FLEXPART.f90
+ 419 cbl_mod.f90
+ 419 class_gribfile_mod.f90 WILL REPLACE THIS WITH MY CODE
+ 450 oh_mod.f90
+ 475 coordinates_ecmwf_mod.f90 NEED A NEW NAME
+ 525 com_mod.f90
+ 545 flux_mod.f90
+ 663 timemanager_mod.f90
+ 686 plume_mod.f90
+ 717 turbulence_mod.f90 RENAME TURB_MOD?
+ 746 particle_mod.f90 RENAME PART_MOD?
+ 814 advance_mod.f90
+ 816 cmapf_mod.f90
+ 838 wetdepo_mod.f90
+ 876 outg_mod.f90 RENAME OUTGRID_MOD?
+ 952 output_mod_old.f90 REMOVE?
+ 1495 output_mod.f90
+ 1540 drydepo_mod.f90
+ 1558 interpol_mod.f90 RENAME INTERP_MOD?
+ 1684 getfields_mod.f90
+ 1949 verttransform_mod.f90
+ 2009 initialise_mod.f90 IF DOMAINFILLING ONLY, RENAME INITDOMFILL_MOD?
+ 2196 conv_mod.f90
+ 2767 netcdf_output_mod.f90
+ 3309 readoptions_mod.f90
+ 4115 windfields_mod.f90
+ 4546 binary_output_mod.f90
+ 39425 total
diff --git a/src/makefile b/src/makefile
deleted file mode 100644
index 43d335d9..00000000
--- a/src/makefile
+++ /dev/null
@@ -1,417 +0,0 @@
-SHELL = /bin/bash
-################################################################################
-# DESCRIPTION
-# Makefile for FLEXPART. Standard (serial) and parallel (MPI) version
-#
-# Dependencies are resolved in this makefile, so parallel make is
-# possible ("make -j")
-#
-# At NILU we have installed gcc-4.9.1 and libraries under user /homevip/flexpart
-# ("ROOT_DIR")
-# To use gfortran version 4.9, add "gcc=4.9" to the make command, e.g.
-# 'make -j ecmwf gcc=4.9',
-# also set environment variable LD_LIBRARY_PATH to point to compiler libraries
-#
-# Makefile was modified to produce unified executable for both ECMWF and GFS meteo data formats
-# gributils were included to detect format of meteo data
-#
-# Cpp directives USE_MPIINPLACE were added to three source files. The effect of these directives
-# are to enable the MPI_IN_PLACE option only if compiled with a -DUSE_MPIINPLACE directive.
-# Otherwise, a safer option (which requires the allocation of another array) is used by default.
-# In makefile added the -x f95-cpp-input flag for compiling of cpp directives.
-#
-# USAGE
-# Compile serial FLEXPART
-# make [-j] serial
-#
-# Compile parallel FLEXPART
-# make [-j] mpi
-#
-# Compile for debugging parallel FLEXPART
-# make [-j] mpi-dbg
-#
-# NETCDF OUTPUT
-# To add support for output in netCDF format, append `ncf=yes` to the
-# `make` command
-#
-################################################################################
-
-## PROGRAMS
-# Unified executable names
-# The same executable is used for both ECMWF and GFS metdata
-
-# Parallel processing executable
-FLEXPART-MPI = FLEXPART_MPI
-
-# Parallel processing executable with debugging info
-FLEXPART-MPI-DBG = DBG_FLEXPART_MPI
-
-# Serial processing executable
-FLEXPART-SERIAL = FLEXPART
-
-
-ifeq ($(gcc), 4.9)
-# Compiled libraries under user ~flexpart, gfortran v4.9
- ROOT_DIR = /homevip/flexpart/
-
- F90 = ${ROOT_DIR}/gcc-4.9.1/bin/gfortran
- MPIF90 = ${ROOT_DIR}/bin/mpifort
-
- INCPATH1 = ${ROOT_DIR}/gcc-4.9.1/include
- INCPATH2 = ${ROOT_DIR}/include
- LIBPATH1 = ${ROOT_DIR}/lib
-else
-# Compiled libraries under user ~flexpart, gfortran v5.4
- ROOT_DIR = /homevip/flexpart/
-
- F90 = /usr/bin/gfortran
- MPIF90 = /usr/bin/mpifort
-
- INCPATH1 = ${ROOT_DIR}/gcc-5.4.0/include
- INCPATH2 = /usr/include
- LIBPATH1 = ${ROOT_DIR}/gcc-5.4.0/lib
-endif
-
-
-### Enable netCDF output?
-ifeq ($(ncf), yes)
- NCOPT = -DUSE_NCF -lnetcdff
-else
- NCOPT = -UUSE_NCF
-endif
-
-
-
-# path to gributils used to detect meteodata format
-VPATH = gributils/
-
-
-## OPTIMIZATION LEVEL
-O_LEV = 0 # [0,1,2,3,g,s,fast]
-O_LEV_DBG = g # [0,g]
-
-## LIBRARIES
-#LIBS = -lgrib_api_f90 -lgrib_api -lm -ljasper -lnetcdff
-LIBS = -lgrib_api_f90 -lgrib_api -lm -ljasper $(NCOPT)
-
-FFLAGS = -I$(INCPATH1) -I$(INCPATH2) -O$(O_LEV) -g -cpp -m64 -mcmodel=medium -fconvert=little-endian -frecord-marker=4 -fmessage-length=0 -flto=jobserver -O$(O_LEV) $(NCOPT) $(FUSER) #-Warray-bounds -fcheck=all # -march=native
-
-DBGFLAGS = -I$(INCPATH1) -I$(INCPATH2) -O$(O_LEV_DBG) -g3 -ggdb3 -cpp -m64 -mcmodel=medium -fconvert=little-endian -frecord-marker=4 -fmessage-length=0 -flto=jobserver -O$(O_LEV_DBG) $(NCOPT) -fbacktrace -Wall -fdump-core $(FUSER) # -ffpe-trap=invalid,overflow,denormal,underflow,zero -Warray-bounds -fcheck=all
-
-LDFLAGS = $(FFLAGS) -L$(LIBPATH1) -Wl,-rpath,$(LIBPATH1) $(LIBS) #-L$(LIBPATH2)
-LDDEBUG = $(DBGFLAGS) -L$(LIBPATH1) $(LIBS) #-L$(LIBPATH2)
-
-MODOBJS = \
-par_mod.o com_mod.o \
-conv_mod.o hanna_mod.o \
-interpol_mod.o cmapf_mod.o \
-unc_mod.o oh_mod.o \
-xmass_mod.o flux_mod.o \
-point_mod.o outg_mod.o \
-mean_mod.o random_mod.o \
-class_gribfile_mod.o
-
-MPI_MODOBJS = \
-mpi_mod.o
-
-## Serial versions (MPI version with same functionality and name '_mpi.f90' exists)
-OBJECTS_SERIAL = \
- releaseparticles.o partoutput.o \
- partoutput_average.o \
- conccalc.o \
- init_domainfill.o concoutput.o \
- timemanager.o FLEXPART.o \
- readpartpositions.o \
- partoutput_short.o \
- concoutput_nest.o \
- boundcond_domainfill.o \
- redist.o \
- concoutput_surf.o concoutput_surf_nest.o \
- concoutput_inversion_nest.o \
- concoutput_inversion.o \
- getfields.o \
- readwind_ecmwf.o
-
-## For MPI version
-OBJECTS_MPI = releaseparticles_mpi.o partoutput_mpi.o \
- partoutput_average_mpi.o conccalc_mpi.o \
- init_domainfill_mpi.o concoutput_mpi.o \
- timemanager_mpi.o FLEXPART_MPI.o \
- readpartpositions_mpi.o \
- partoutput_short_mpi.o \
- concoutput_nest_mpi.o \
- boundcond_domainfill_mpi.o \
- redist_mpi.o \
- concoutput_surf_mpi.o concoutput_surf_nest_mpi.o \
- getfields_mpi.o \
- readwind_ecmwf_mpi.o
-
-OBJECTS_NCF = netcdf_output_mod.o
-
-OBJECTS = \
-advance.o initialize.o \
-writeheader.o writeheader_txt.o \
-partpos_average.o writeprecip.o \
-writeheader_surf.o assignland.o\
-part0.o gethourlyOH.o\
-caldate.o partdep.o \
-coordtrafo.o psih.o \
-raerod.o readcommand.o \
-drydepokernel.o readreceptors.o \
-erf.o readavailable.o \
-ew.o readreleases.o \
-readdepo.o get_vdep_prob.o \
-get_wetscav.o readwind_gfs.o \
-psim.o outgrid_init.o \
-outgrid_init_nest.o calcmatrix.o \
-photo_O1D.o readlanduse.o \
-interpol_wind.o readoutgrid.o \
-interpol_all.o readpaths.o \
-getrb.o obukhov.o \
-getrc.o convmix.o \
-getvdep.o readspecies.o \
-interpol_misslev.o richardson.o \
-scalev.o verttransform_ecmwf.o \
-pbl_profile.o readOHfield.o \
-juldate.o verttransform_gfs.o \
-interpol_vdep.o interpol_rain.o \
-hanna.o wetdepokernel.o \
-calcpar.o wetdepo.o \
-hanna_short.o windalign.o \
-hanna1.o gridcheck_ecmwf.o \
-gridcheck_gfs.o gridcheck_nests.o \
-readwind_nests.o calcpar_nests.o \
-verttransform_nests.o interpol_all_nests.o \
-interpol_wind_nests.o interpol_misslev_nests.o \
-interpol_vdep_nests.o interpol_rain_nests.o \
-readageclasses.o detectformat.o \
-calcfluxes.o fluxoutput.o \
-qvsat.o skplin.o \
-convect43c.o \
-sort2.o distance.o \
-centerofmass.o plumetraj.o \
-openouttraj.o calcpv.o \
-calcpv_nests.o distance2.o \
-clustering.o interpol_wind_short.o \
-interpol_wind_short_nests.o shift_field_0.o \
-shift_field.o \
-openreceptors.o \
-readoutgrid_nest.o \
-writeheader_nest.o writeheader_nest_surf.o \
-wetdepokernel_nest.o \
-drydepokernel_nest.o zenithangle.o \
-ohreaction.o getvdep_nests.o \
-initial_cond_calc.o initial_cond_output.o initial_cond_output_inversion.o \
-dynamic_viscosity.o get_settling.o \
-initialize_cbl_vel.o re_initialize_particle.o \
-cbl.o
-
-ifeq ($(ncf), yes)
- OBJECTS := $(OBJECTS) $(OBJECTS_NCF)
-endif
-
-%.o: %.mod
-
-# serial executable
-serial: $(FLEXPART-SERIAL)
-serial: FC := $(F90)
-
-# parallel processing executable
-mpi: $(FLEXPART-MPI)
-mpi: FC := $(MPIF90)
-
-# parallel processing with debugging info
-mpi-dbg: $(FLEXPART-MPI-DBG)
-mpi-dbg: FFLAGS := $(DBGFLAGS)
-mpi-dbg: LDFLAGS:= $(LDDEBUG)
-mpi-dbg: FC := $(MPIF90)
-
-$(FLEXPART-SERIAL): $(MODOBJS) $(OBJECTS) $(OBJECTS_SERIAL)
- +$(FC) -o $@ $(MODOBJS) $(OBJECTS) $(OBJECTS_SERIAL) $(LDFLAGS)
-
-$(FLEXPART-MPI): $(MODOBJS) $(MPI_MODOBJS) $(OBJECTS) $(OBJECTS_MPI)
- +$(FC) -o $@ $(MODOBJS) $(MPI_MODOBJS) $(OBJECTS) $(OBJECTS_MPI) \
- $(LDFLAGS)
-
-$(FLEXPART-MPI-DBG): $(MODOBJS) $(MPI_MODOBJS) $(OBJECTS) $(OBJECTS_MPI)
- +$(FC) -o $@ $(MODOBJS) $(MPI_MODOBJS) $(OBJECTS) $(OBJECTS_MPI) \
- $(LDFLAGS)
-
-%.o: %.f90
- +$(FC) -c $(FFLAGS) $<
-
-clean:
- \rm -f *.o *.mod
-
-cleanall:
- \rm -f *.o *.mod $(FLEXPART-MPI) $(FLEXPART-MPI-DBG) $(FLEXPART-SERIAL)
-
-
-.SUFFIXES = $(SUFFIXES) .f90
-
-## DEPENDENCIES
-advance.o: cmapf_mod.o com_mod.o hanna_mod.o interpol_mod.o par_mod.o \
- point_mod.o random_mod.o
-assignland.o: com_mod.o par_mod.o
-boundcond_domainfill.o: com_mod.o par_mod.o point_mod.o random_mod.o
-boundcond_domainfill_mpi.o: com_mod.o mpi_mod.o par_mod.o point_mod.o \
- random_mod.o
-calcfluxes.o: com_mod.o flux_mod.o outg_mod.o par_mod.o
-calcmatrix.o: com_mod.o conv_mod.o par_mod.o
-calcpar.o: com_mod.o par_mod.o
-calcpar_nests.o: com_mod.o par_mod.o
-calcpv.o: com_mod.o par_mod.o
-calcpv_nests.o: com_mod.o par_mod.o
-caldate.o: par_mod.o
-cbl.o: com_mod.o par_mod.o
-centerofmass.o: par_mod.o
-clustering.o: par_mod.o
-cmapf_mod.o: par_mod.o
-com_mod.o: par_mod.o
-conccalc.o: com_mod.o outg_mod.o par_mod.o unc_mod.o
-conccalc_mpi.o: com_mod.o mpi_mod.o outg_mod.o par_mod.o unc_mod.o
-concoutput.o: com_mod.o mean_mod.o outg_mod.o par_mod.o point_mod.o unc_mod.o
-concoutput_inversion.o: com_mod.o mean_mod.o outg_mod.o par_mod.o point_mod.o \
- unc_mod.o
-concoutput_inversion_nest.o: com_mod.o mean_mod.o outg_mod.o par_mod.o \
- point_mod.o unc_mod.o
-concoutput_mpi.o: com_mod.o mean_mod.o mpi_mod.o outg_mod.o par_mod.o \
- point_mod.o unc_mod.o
-concoutput_nest.o: com_mod.o mean_mod.o outg_mod.o par_mod.o point_mod.o \
- unc_mod.o
-concoutput_nest_mpi.o: com_mod.o mean_mod.o mpi_mod.o outg_mod.o par_mod.o \
- point_mod.o unc_mod.o
-concoutput_surf.o: com_mod.o mean_mod.o outg_mod.o par_mod.o point_mod.o \
- unc_mod.o
-concoutput_surf_mpi.o: com_mod.o mean_mod.o mpi_mod.o outg_mod.o par_mod.o \
- point_mod.o unc_mod.o
-concoutput_surf_nest.o: com_mod.o mean_mod.o outg_mod.o par_mod.o point_mod.o \
- unc_mod.o
-concoutput_surf_nest_mpi.o: com_mod.o mean_mod.o mpi_mod.o outg_mod.o \
- par_mod.o point_mod.o unc_mod.o
-conv_mod.o: par_mod.o
-convect43c.o: conv_mod.o par_mod.o
-convmix.o: com_mod.o conv_mod.o flux_mod.o par_mod.o
-coordtrafo.o: com_mod.o par_mod.o point_mod.o
-detectformat.o: com_mod.o par_mod.o
-distance.o: par_mod.o
-distance2.o: par_mod.o
-drydepokernel.o: com_mod.o par_mod.o unc_mod.o
-drydepokernel_nest.o: com_mod.o par_mod.o unc_mod.o
-erf.o: par_mod.o
-FLEXPART.o: com_mod.o conv_mod.o netcdf_output_mod.o par_mod.o point_mod.o \
- random_mod.o
-FLEXPART_MPI.o: com_mod.o conv_mod.o mpi_mod.o netcdf_output_mod.o par_mod.o \
- point_mod.o random_mod.o
-fluxoutput.o: com_mod.o flux_mod.o outg_mod.o par_mod.o
-get_settling.o: com_mod.o par_mod.o
-get_vdep_prob.o: com_mod.o interpol_mod.o par_mod.o point_mod.o
-get_wetscav.o: com_mod.o par_mod.o point_mod.o
-getfields.o: com_mod.o par_mod.o
-getfields_mpi.o: com_mod.o mpi_mod.o par_mod.o
-gethourlyOH.o: com_mod.o oh_mod.o par_mod.o
-getrb.o: par_mod.o
-getrc.o: com_mod.o par_mod.o
-getvdep.o: com_mod.o par_mod.o
-getvdep_nests.o: com_mod.o par_mod.o
-grib2check.o: com_mod.o par_mod.o
-gridcheck_ecmwf.o: cmapf_mod.o com_mod.o conv_mod.o par_mod.o
-gridcheck_gfs.o: cmapf_mod.o com_mod.o conv_mod.o par_mod.o
-gridcheck_nests.o: com_mod.o par_mod.o
-hanna.o: com_mod.o hanna_mod.o par_mod.o
-hanna1.o: com_mod.o hanna_mod.o par_mod.o
-hanna_short.o: com_mod.o hanna_mod.o par_mod.o
-init_domainfill.o: com_mod.o par_mod.o point_mod.o random_mod.o
-init_domainfill_mpi.o: com_mod.o mpi_mod.o par_mod.o point_mod.o random_mod.o
-initial_cond_calc.o: com_mod.o outg_mod.o par_mod.o unc_mod.o
-initial_cond_output.o: com_mod.o outg_mod.o par_mod.o point_mod.o unc_mod.o
-initial_cond_output_inversion.o: com_mod.o outg_mod.o par_mod.o point_mod.o \
- unc_mod.o
-initialize.o: com_mod.o hanna_mod.o interpol_mod.o par_mod.o random_mod.o
-initialize_cbl_vel.o: com_mod.o par_mod.o random_mod.o
-interpol_all.o: com_mod.o hanna_mod.o interpol_mod.o par_mod.o
-interpol_all_nests.o: com_mod.o hanna_mod.o interpol_mod.o par_mod.o
-interpol_misslev.o: com_mod.o hanna_mod.o interpol_mod.o par_mod.o
-interpol_misslev_nests.o: com_mod.o hanna_mod.o interpol_mod.o par_mod.o
-interpol_mod.o: par_mod.o
-interpol_rain.o: par_mod.o
-interpol_rain_nests.o: par_mod.o
-interpol_vdep.o: com_mod.o interpol_mod.o par_mod.o
-interpol_vdep_nests.o: com_mod.o interpol_mod.o par_mod.o
-interpol_wind.o: com_mod.o interpol_mod.o par_mod.o
-interpol_wind_nests.o: com_mod.o interpol_mod.o par_mod.o
-interpol_wind_short.o: com_mod.o interpol_mod.o par_mod.o
-interpol_wind_short_nests.o: com_mod.o interpol_mod.o par_mod.o
-juldate.o: par_mod.o
-mean_mod.o: par_mod.o
-mpi_mod.o: com_mod.o par_mod.o unc_mod.o
-netcdf_output_mod.o: com_mod.o mean_mod.o outg_mod.o par_mod.o point_mod.o \
- unc_mod.o
-obukhov.o: par_mod.o
-ohreaction.o: com_mod.o oh_mod.o par_mod.o
-openouttraj.o: com_mod.o par_mod.o point_mod.o
-openreceptors.o: com_mod.o par_mod.o
-outg_mod.o: par_mod.o
-outgrid_init.o: com_mod.o flux_mod.o oh_mod.o outg_mod.o par_mod.o unc_mod.o
-outgrid_init_nest.o: com_mod.o outg_mod.o par_mod.o unc_mod.o
-part0.o: par_mod.o
-partdep.o: com_mod.o par_mod.o
-partoutput.o: com_mod.o par_mod.o
-partoutput_average.o: com_mod.o par_mod.o
-partoutput_average_mpi.o: com_mod.o mpi_mod.o par_mod.o
-partoutput_mpi.o: com_mod.o mpi_mod.o par_mod.o
-partoutput_short.o: com_mod.o par_mod.o
-partoutput_short_mpi.o: com_mod.o mpi_mod.o par_mod.o
-partpos_average.o: com_mod.o par_mod.o
-pbl_profile.o: par_mod.o
-plumetraj.o: com_mod.o mean_mod.o par_mod.o point_mod.o
-psih.o: par_mod.o
-psim.o: par_mod.o
-raerod.o: par_mod.o
-re_initialize_particle.o: com_mod.o par_mod.o
-readageclasses.o: com_mod.o par_mod.o
-readavailable.o: com_mod.o par_mod.o
-readcommand.o: com_mod.o par_mod.o
-readdepo.o: com_mod.o par_mod.o
-readlanduse.o: com_mod.o par_mod.o
-readOHfield.o: com_mod.o oh_mod.o par_mod.o
-readoutgrid.o: com_mod.o outg_mod.o par_mod.o
-readoutgrid_nest.o: com_mod.o outg_mod.o par_mod.o
-readpartpositions.o: com_mod.o par_mod.o random_mod.o
-readpartpositions_mpi.o: com_mod.o mpi_mod.o par_mod.o random_mod.o
-readpaths.o: com_mod.o par_mod.o
-readreceptors.o: com_mod.o par_mod.o
-readreleases.o: com_mod.o par_mod.o point_mod.o xmass_mod.o
-readspecies.o: com_mod.o par_mod.o
-readwind_ecmwf.o: com_mod.o par_mod.o
-readwind_ecmwf_mpi.o: com_mod.o mpi_mod.o par_mod.o
-readwind_emos.o: com_mod.o par_mod.o
-readwind_gfs.o: com_mod.o par_mod.o
-readwind_nests.o: com_mod.o par_mod.o
-redist.o: com_mod.o conv_mod.o par_mod.o random_mod.o
-redist_mpi.o: com_mod.o conv_mod.o mpi_mod.o par_mod.o random_mod.o
-releaseparticles.o: com_mod.o par_mod.o point_mod.o random_mod.o xmass_mod.o
-releaseparticles_mpi.o: com_mod.o mpi_mod.o par_mod.o point_mod.o \
- random_mod.o xmass_mod.o
-richardson.o: par_mod.o
-scalev.o: par_mod.o
-shift_field.o: par_mod.o
-shift_field_0.o: par_mod.o
-timemanager.o: com_mod.o flux_mod.o netcdf_output_mod.o oh_mod.o outg_mod.o \
- par_mod.o point_mod.o unc_mod.o xmass_mod.o
-timemanager_mpi.o: com_mod.o flux_mod.o mpi_mod.o netcdf_output_mod.o \
- oh_mod.o outg_mod.o par_mod.o point_mod.o unc_mod.o xmass_mod.o
-unc_mod.o: par_mod.o
-verttransform_ecmwf.o: cmapf_mod.o com_mod.o par_mod.o
-verttransform_gfs.o: cmapf_mod.o com_mod.o par_mod.o
-verttransform_nests.o: com_mod.o par_mod.o
-wetdepo.o: com_mod.o par_mod.o point_mod.o
-wetdepokernel.o: com_mod.o par_mod.o unc_mod.o
-wetdepokernel_nest.o: com_mod.o par_mod.o unc_mod.o
-writeheader.o: com_mod.o outg_mod.o par_mod.o point_mod.o
-writeheader_nest.o: com_mod.o outg_mod.o par_mod.o point_mod.o
-writeheader_nest_surf.o: com_mod.o outg_mod.o par_mod.o point_mod.o
-writeheader_surf.o: com_mod.o outg_mod.o par_mod.o point_mod.o
-writeheader_txt.o: com_mod.o outg_mod.o par_mod.o point_mod.o
-writeprecip.o: com_mod.o par_mod.o point_mod.o
-zenithangle.o: par_mod.o
diff --git a/src/makefile_gfortran b/src/makefile_gfortran
new file mode 100644
index 00000000..33f0b1fa
--- /dev/null
+++ b/src/makefile_gfortran
@@ -0,0 +1,194 @@
+SHELL = /bin/bash
+################################################################################
+# DESCRIPTION
+# Makefile for FLEXPART. Standard (serial) and parallel (MPI) version
+#
+# Dependencies are resolved in this makefile, so parallel make is
+# possible ("make -j")
+#
+# gcc 8+ is required.
+#
+# Makefile was modified to produce unified executable for both ECMWF and GFS meteo data formats
+# gributils were included to detect format of meteo data
+#
+# Cpp directives USE_MPIINPLACE were added to three source files. The effect of these directives
+# are to enable the MPI_IN_PLACE option only if compiled with a -DUSE_MPIINPLACE directive.
+# Otherwise, a safer option (which requires the allocation of another array) is used by default.
+# In makefile added the -x f95-cpp-input flag for compiling of cpp directives.
+#
+# USAGE
+# Compile serial FLEXPART
+# make [-j] serial
+#
+# NETCDF OUTPUT
+# To remove support for output in netCDF format, append `ncf=no` to the
+# `make` command
+#
+################################################################################
+
+## PROGRAMS
+# Unified executable names
+# The same executable is used for both ECMWF and GFS metdata
+
+# Serial processing executable
+FLEXPART-SERIAL = FLEXPART
+
+export OMP_NESTED=FALSE
+
+ROOT_DIR = . #MD
+
+#F90 = /usr/bin/gfortran
+#
+# JET (INCLUDE/CPATH and LIBRARY_PATH)
+# VSC (CPATH and LIBRARY_PATH)
+#
+ifndef CPATH
+ $(error CPATH is not set)
+endif
+ifndef LIBRARY_PATH
+ $(error LIBRARY_PATH is not set)
+endif
+# use the environmental variable $INCLUDE
+# split the paths separated by :
+INC = $(subst :, ,$(CPATH))
+# add a -I/path/to/include
+INC := $(INC:%=-I%)
+# use the environmental variable $LIBRARY_PATH
+LIBPATH := $(subst :, ,$(LIBRARY_PATH))
+LIBRPATH := $(LIBPATH:%=-Wl,-rpath=%)
+LIBPATH := $(LIBPATH:%=-L%)
+
+### Enable netCDF output?
+ifeq ($(ncf), no)
+ NCOPT = -UUSE_NCF
+else
+ NCOPT = -DUSE_NCF -lnetcdff
+endif
+
+## OPTIMIZATION LEVEL
+O_LEV = 3 # [0,1,2,3,g,s,fast]
+O_LEV_DBG = g # [0,g]
+# -fopenmp #-pg -fbacktrace -fcheck=all -fbounds-check #-fopenmp#-p -fbacktrace -fopenmp #-tau_options=-optCompInst -tau_makefile=/home/lucie/Codes/Tau/x86_64/lib/Makefile.tau-mpi-pdt-openmp-opari#-fdefault-real-8# -freal-8-real-4#-pg -fcheck=all
+#FUSER = -g -fopenmp -march=skylake-avx512
+FUSER = -g -fopenmp -march=native -mtune=native
+mpi: FUSER := $(FUSER) -Dusempi #-MM -MT -MD
+## LIBRARIES
+LIBS = -leccodes -leccodes_f90 -lm -ljasper $(NCOPT) #MD
+
+FFLAGS = $(INC) -O$(O_LEV) -m64 -cpp -mcmodel=large -O$(O_LEV) $(NCOPT) $(FUSER) #-convert little_endian -fpp -WB -check all
+
+DBGFLAGS = $(INC) -O$(O_LEV_DBG) -g3 -ggdb3 -cpp -m64 -mcmodel=large -fconvert=little-endian -frecord-marker=4 -fmessage-length=0 -flto=jobserver -O$(O_LEV_DBG) $(NCOPT) -fbacktrace -Wall -fdump-core $(FUSER) # -ffpe-trap=invalid,overflow,denormal,underflow,zero -Warray-bounds -fcheck=all
+
+LDFLAGS = $(FFLAGS) $(LIBPATH) $(LIBRPATH) $(LIBS)
+LDDEBUG = $(DBGFLAGS) $(LIBPATH) $(LIBRPATH) $(LIBS)
+
+MODOBJS = \
+advance_mod.o binary_output_mod.o \
+cbl_mod.o cmapf_mod.o \
+com_mod.o conv_mod.o \
+class_gribfile_mod.o coordinates_ecmwf_mod.o \
+date_mod.o drydepo_mod.o \
+erf_mod.o flux_mod.o \
+getfields_mod.o initialise_mod.o \
+interpol_mod.o mean_mod.o \
+oh_mod.o outg_mod.o \
+output_mod.o par_mod.o \
+particle_mod.o pbl_profile_mod.o \
+plume_mod.o point_mod.o \
+random_mod.o readoptions_mod.o \
+restart_mod.o settling_mod.o \
+timemanager_mod.o turbulence_mod.o \
+txt_output_mod.o unc_mod.o \
+verttransform_mod.o wetdepo_mod.o \
+windfields_mod.o qvsat_mod.o \
+xmass_mod.o
+
+OBJECTS_NCF = netcdf_output_mod.o
+
+OBJECTS = \
+FLEXPART.o
+
+ifeq ($(ncf), no)
+ OBJECTS := $(OBJECTS)
+else
+ OBJECTS := $(OBJECTS) $(OBJECTS_NCF)
+endif
+
+%.o: %.mod
+
+# serial executable
+serial: $(FLEXPART-SERIAL)
+serial: FC := $(FC)
+
+$(FLEXPART-SERIAL): $(MODOBJS) $(OBJECTS)
+ +$(FC) -o $@ $(MODOBJS) $(OBJECTS) $(LDFLAGS)
+
+%.o: %.f90
+ +$(FC) -c $(FFLAGS) $<
+
+clean:
+ \rm -f *.o *.mod
+
+cleanall:
+ \rm -f *.o *.mod $(FLEXPART-SERIAL)
+
+
+.SUFFIXES = $(SUFFIXES) .f90
+
+## DEPENDENCIES
+
+#1) Independent modules: par_mod.o, com_mod.o, qvsat_mod.o class_gribfile_mod.o
+
+#2) Modules that are only dependent on independent modules
+cmapf_mod.o: par_mod.o
+com_mod.o: par_mod.o
+date_mod.o: par_mod.o
+erf_mod.o: par_mod.o
+mean_mod.o: par_mod.o
+particle_mod.o: com_mod.o par_mod.o
+point_mod.o: com_mod.o par_mod.o
+unc_mod.o: par_mod.o com_mod.o
+cbl_mod.o: com_mod.o par_mod.o random_mod.o
+pbl_profile_mod.o: par_mod.o qvsat_mod.o
+
+#3) 3rd level dependencies
+turbulence_mod.o: particle_mod.o cbl_mod.o qvsat_mod.o
+windfields_mod.o: cmapf_mod.o point_mod.o class_gribfile_mod.o date_mod.o qvsat_mod.o
+
+#4) 4th level dependencies
+verttransform_mod.o: par_mod.o com_mod.o qvsat_mod.o windfields_mod.o
+settling_mod.o: windfields_mod.o
+interpol_mod.o: windfields_mod.o particle_mod.o
+oh_mod.o: windfields_mod.o particle_mod.o
+
+#5)
+coordinates_ecmwf_mod.o: interpol_mod.o
+drydepo_mod.o: unc_mod.o interpol_mod.o erf_mod.o
+
+#6)
+advance_mod.o: coordinates_ecmwf_mod.o settling_mod.o drydepo_mod.o turbulence_mod.o
+plume_mod.o: mean_mod.o coordinates_ecmwf_mod.o
+outg_mod.o: oh_mod.o unc_mod.o coordinates_ecmwf_mod.o
+wetdepo_mod.o: coordinates_ecmwf_mod.o unc_mod.o
+readoptions_mod.o: drydepo_mod.o xmass_mod.o
+
+#7)
+getfields_mod.o: wetdepo_mod.o verttransform_mod.o qvsat_mod.o
+flux_mod.o: outg_mod.o qvsat_mod.o
+txt_output_mod.o: outg_mod.o
+binary_output_mod.o: mean_mod.o outg_mod.o
+netcdf_output_mod.o: mean_mod.o outg_mod.o readoptions_mod.o drydepo_mod.o
+
+#8)
+conv_mod.o: flux_mod.o class_gribfile_mod.o qvsat_mod.o
+output_mod.o: netcdf_output_mod.o binary_output_mod.o txt_output_mod.o
+restart_mod.o: coordinates_ecmwf_mod.o unc_mod.o netcdf_output_mod.o
+
+#9)
+initialise_mod.o: xmass_mod.o output_mod.o turbulence_mod.o
+
+#10)
+timemanager_mod.o: advance_mod.o conv_mod.o plume_mod.o getfields_mod.o restart_mod.o initialise_mod.o
+
+#11)
+FLEXPART.o: timemanager_mod.o
\ No newline at end of file
diff --git a/src/makefile_intel b/src/makefile_intel
new file mode 100644
index 00000000..5ba6dd06
--- /dev/null
+++ b/src/makefile_intel
@@ -0,0 +1,191 @@
+SHELL = /bin/bash
+################################################################################
+# DESCRIPTION
+# Makefile for FLEXPART. Standard (serial) and parallel (MPI) version
+#
+# Dependencies are resolved in this makefile, so parallel make is
+# possible ("make -j")
+#
+# At NILU we have installed gcc-4.9.1 and libraries under user /homevip/flexpart
+# ("ROOT_DIR")
+# To use gfortran version 4.9, add "gcc=4.9" to the make command, e.g.
+# 'make -j ecmwf gcc=4.9',
+# also set environment variable LD_LIBRARY_PATH to point to compiler libraries
+#
+# Makefile was modified to produce unified executable for both ECMWF and GFS meteo data formats
+# gributils were included to detect format of meteo data
+#
+# Cpp directives USE_MPIINPLACE were added to three source files. The effect of these directives
+# are to enable the MPI_IN_PLACE option only if compiled with a -DUSE_MPIINPLACE directive.
+# Otherwise, a safer option (which requires the allocation of another array) is used by default.
+# In makefile added the -x f95-cpp-input flag for compiling of cpp directives.
+#
+# USAGE
+# Compile serial FLEXPART
+# make [-j] serial
+#
+# NETCDF OUTPUT
+# To remove support for output in netCDF format, append `ncf=no` to the
+# `make` command
+#
+################################################################################
+
+## PROGRAMS
+# Unified executable names
+# The same executable is used for both ECMWF and GFS metdata
+
+# Serial processing executable
+FLEXPART-SERIAL = FLEXPART
+
+export OMP_NESTED=FALSE
+
+#export TAU_MAKEFILE=/jetfs/home/lbakels/Codes/tau/x86_64/lib/Makefile.tau-pdt-openmp-opari
+#export TAU_OPTIONS='-optCompInst -optRevert'
+#export PROFILEDIR=/jetfs/home/lbakels/Profile2/
+ifeq ($(shell hostname), jet01.img.univie.ac.at)
+ export INTEL_LICENSE_FILE = /opt/intel/serverlicenses/l_5WHWBJ6D.lic
+endif
+
+ #ROOT_DIR = /homevip/flexpart/
+ ROOT_DIR = . #MD
+
+ F90 = /opt/intel/compilers_and_libraries_2020/linux/bin/intel64/ifort#/jetfs/home/lbakels/Codes/tau/x86_64/bin/tau_f90.sh#/opt/intel/compilers_and_libraries_2020/linux/bin/intel64/ifort
+
+ #MD for jet
+
+ INCPATH1 = /jetfs/spack/opt/spack/linux-rhel8-skylake_avx512/intel-20.0.2/eccodes-2.18.0-6tadpgreot7jf4yoaiqmqueiihhdcsxk/include
+ LIBPATH1 = /jetfs/spack/opt/spack/linux-rhel8-skylake_avx512/intel-20.0.2/eccodes-2.18.0-6tadpgreot7jf4yoaiqmqueiihhdcsxk/lib
+ INCPATH2 = /jetfs/spack/opt/spack/linux-rhel8-skylake_avx512/intel-20.0.2/netcdf-fortran-4.5.3-irdm5gqccsig2om7jqu376h6tlebh4bc/include
+ LIBPATH2 = /jetfs/spack/opt/spack/linux-rhel8-skylake_avx512/intel-20.0.2/netcdf-fortran-4.5.3-irdm5gqccsig2om7jqu376h6tlebh4bc/lib
+ LIBPATH3 =
+
+### Enable netCDF output?
+ifeq ($(ncf), no)
+ NCOPT = -UUSE_NCF
+else
+ NCOPT = -DUSE_NCF -lnetcdff
+endif
+
+
+## OPTIMIZATION LEVEL
+O_LEV = 2 # [0,1,2,3,g,s,fast]
+O_LEV_DBG = g # [0,g]
+FUSER = -qopenmp -xSKYLAKE-AVX512#-traceback -check bounds #-xSKYLAKE-AVX512
+## LIBRARIES
+LIBS = -leccodes -leccodes_f90 -lm -ljasper $(NCOPT) #MD
+
+FFLAGS = -I$(INCPATH1) -I$(INCPATH2) -O$(O_LEV) -g -m64 -fpp -convert little_endian -assume byterecl -mcmodel=large -O$(O_LEV) $(NCOPT) $(FUSER) #-convert little_endian -fpp -WB -check all
+
+DBGFLAGS = -I$(INCPATH1) -I$(INCPATH2) -O$(O_LEV_DBG) -g3 -ggdb3 -cpp -m64 -mcmodel=large -fconvert=little-endian -frecord-marker=4 -fmessage-length=0 -flto=jobserver -O$(O_LEV_DBG) $(NCOPT) -fbacktrace -Wall -fdump-core $(FUSER) # -ffpe-trap=invalid,overflow,denormal,underflow,zero -Warray-bounds -fcheck=all
+
+LDFLAGS = $(FFLAGS) -L$(LIBPATH1) -Wl,-rpath,$(LIBPATH1) $(LIBS) -L$(LIBPATH2) -Wl,-rpath,$(LIBPATH2) #-L$(LIBPATH3) #MD add LIBPATH2 and LIBPATH3 as rpath (for dynamic libraries)
+LDDEBUG = $(DBGFLAGS) -L$(LIBPATH1) -Wl,-rpath,$(LIBPATH1) $(LIBS) -L$(LIBPATH2) -Wl,-rpath,$(LIBPATH2) -Wl, -rpaht,$(LIBPATH3) #MD add LIBPATH2 and LIBPATH3 as rpath (for dynamic libraries)
+
+MODOBJS = \
+par_mod.o class_gribfile_mod.o \
+particle_mod.o interpol_mod.o \
+coordinates_ecmwf.o conv_mod.o \
+windfields_mod.o txt_output_mod.o \
+turbulence_mod.o cmapf_mod.o \
+unc_mod.o oh_mod.o \
+xmass_mod.o flux_mod.o \
+point_mod.o outg_mod.o \
+mean_mod.o random_mod.o \
+com_mod.o advance_mod.o \
+readoptions.o binary_output_mod.o \
+drydepo_mod.o wetdepo_mod.o \
+timemanager_mod.o qvsat_mod.o \
+plume_mod.o settling_mod.o \
+initialise_mod.o getfields_mod.o \
+date_mod.o output_mod.o \
+stability_correction.o cbl_mod.o \
+verttransform_mod.o
+
+OBJECTS_NCF = netcdf_output_mod.o
+
+OBJECTS = \
+FLEXPART.o
+
+ifeq ($(ncf), no)
+ OBJECTS := $(OBJECTS)
+else
+ OBJECTS := $(OBJECTS) $(OBJECTS_NCF)
+endif
+
+%.o: %.mod
+
+# serial executable
+serial: $(FLEXPART-SERIAL)
+serial: FC := $(F90)
+
+$(FLEXPART-SERIAL): $(MODOBJS) $(OBJECTS)
+ +$(FC) -o $@ $(MODOBJS) $(OBJECTS) $(LDFLAGS)
+
+%.o: %.f90
+ +$(FC) -c $(FFLAGS) $<
+
+clean:
+ \rm -f *.o *.mod
+
+cleanall:
+ \rm -f *.o *.mod $(FLEXPART-SERIAL)
+
+
+.SUFFIXES = $(SUFFIXES) .f90
+
+## DEPENDENCIES
+advance_mod.o: cmapf_mod.o com_mod.o turbulence_mod.o interpol_mod.o par_mod.o \
+ point_mod.o random_mod.o coordinates_ecmwf.o particle_mod.o settling_mod.o \
+ drydepo_mod.o
+binary_output_mod.o: com_mod.o mean_mod.o outg_mod.o par_mod.o point_mod.o unc_mod.o \
+ windfields_mod.o date_mod.o
+cbl_mod.o: com_mod.o par_mod.o random_mod.o
+cmapf_mod.o: par_mod.o
+com_mod.o: par_mod.o
+conv_mod.o: par_mod.o com_mod.o flux_mod.o par_mod.o particle_mod.o class_gribfile_mod.o \
+ random_mod.o interpol_mod.o coordinates_ecmwf.o windfields_mod.o qvsat_mod.o
+coordinates_ecmwf.o: par_mod.o com_mod.o interpol_mod.o particle_mod.o windfields_mod.o
+date_mod.o: par_mod.o
+drydepo_mod.o: com_mod.o par_mod.o unc_mod.o interpol_mod.o point_mod.o windfields_mod.o \
+ date_mod.o stability_correction.o
+FLEXPART.o: com_mod.o conv_mod.o par_mod.o point_mod.o drydepo_mod.o interpol_mod.o \
+ random_mod.o readoptions.o windfields_mod.o getfields_mod.o \
+ timemanager_mod.o plume_mod.o initialise_mod.o output_mod.o netcdf_output_mod.o
+flux_mod.o: com_mod.o outg_mod.o par_mod.o coordinates_ecmwf.o particle_mod.o date_mod.o \
+ windfields_mod.o
+getfields_mod.o: com_mod.o par_mod.o drydepo_mod.o wetdepo_mod.o windfields_mod.o qvsat_mod.o \
+ verttransform_mod.o
+settling_mod.o: com_mod.o par_mod.o windfields_mod.o
+initial_cond_calc.o: com_mod.o outg_mod.o par_mod.o unc_mod.o particle_mod.o \
+ coordinates_ecmwf.o
+initialise_mod.o: com_mod.o turbulence_mod.o interpol_mod.o par_mod.o random_mod.o \
+ coordinates_ecmwf.o particle_mod.o windfields_mod.o date_mod.o \
+ netcdf_output_mod.o xmass_mod.o point_mod.o cbl_mod.o output_mod.o unc_mod.o
+interpol_mod.o: par_mod.o com_mod.o turbulence_mod.o particle_mod.o windfields_mod.o
+mean_mod.o: par_mod.o
+netcdf_output_mod.o: com_mod.o mean_mod.o outg_mod.o par_mod.o point_mod.o \
+ unc_mod.o particle_mod.o windfields_mod.o date_mod.o readoptions.o drydepo_mod.o
+oh_mod.o: com_mod.o par_mod.o date_mod.o particle_mod.o windfields_mod.o
+outg_mod.o: par_mod.o com_mod.o oh_mod.o par_mod.o unc_mod.o windfields_mod.o interpol_mod.o \
+ coordinates_ecmwf.o particle_mod.o
+output_mod.o: com_mod.o par_mod.o interpol_mod.o coordinates_ecmwf.o netcdf_output_mod.o \
+ particle_mod.o date_mod.o binary_output_mod.o txt_output_mod.o outg_mod.o unc_mod.o
+particle_mod.o: com_mod.o par_mod.o
+plume_mod.o: com_mod.o mean_mod.o par_mod.o point_mod.o particle_mod.o coordinates_ecmwf.o \
+ windfields_mod.o
+point_mod.o: com_mod.o par_mod.o
+readoptions.o: com_mod.o par_mod.o date_mod.o drydepo_mod.o point_mod.o windfields_mod.o
+stability_correction.o: par_mod.o
+timemanager_mod.o: com_mod.o flux_mod.o oh_mod.o outg_mod.o advance_mod.o\
+ par_mod.o point_mod.o unc_mod.o xmass_mod.o particle_mod.o coordinates_ecmwf.o \
+ drydepo_mod.o wetdepo_mod.o conv_mod.o windfields_mod.o netcdf_output_mod.o \
+ plume_mod.o initialise_mod.o getfields_mod.o output_mod.o
+turbulence_mod.o: par_mod.o com_mod.o random_mod.o particle_mod.o cbl_mod.o windfields_mod.o
+txt_output_mod.o: com_mod.o par_mod.o point_mod.o outg_mod.o date_mod.o
+unc_mod.o: par_mod.o com_mod.o
+verttransform_mod.o: par_mod.o com_mod.o cmapf_mod.o qvsat_mod.o windfields_mod.o \
+ initialise_mod.o output_mod.o
+wetdepo_mod.o: com_mod.o par_mod.o point_mod.o particle_mod.o interpol_mod.o \
+ coordinates_ecmwf.o unc_mod.o windfields_mod.o
+windfields_mod.o: par_mod.o com_mod.o cmapf_mod.o point_mod.o class_gribfile_mod.o qvsat_mod.o \
+ date_mod.o stability_correction.o
diff --git a/src/netcdf_output_mod.f90 b/src/netcdf_output_mod.f90
index 3d2c4249..651a498a 100644
--- a/src/netcdf_output_mod.f90
+++ b/src/netcdf_output_mod.f90
@@ -24,6 +24,10 @@
! 'dep_prec' in par_mod
! - Hardcoded options 'write_vol' and 'write_area' for grid cell
! volume and area
+ !
+ ! LB: 2021 *
+ ! - Particle dump and initial particle positions in NetCDF *
+ ! - Receptor files in NetCDF format *
!*****************************************************************************
@@ -31,61 +35,69 @@ module netcdf_output_mod
use netcdf
- use point_mod, only: ireleasestart,ireleaseend,kindz,&
+ use point_mod, only: ireleasestart,ireleaseend,kindz,dx,xlon0,dy,ylat0,&
xpoint1,ypoint1,xpoint2,ypoint2,zpoint1,zpoint2,npart,xmass
use outg_mod, only: outheight,oroout,densityoutgrid,factor3d,volume,&
wetgrid,wetgridsigma,drygrid,drygridsigma,grid,gridsigma,&
- area,arean,volumen, orooutn
+ area,arean,volumen,orooutn
use par_mod, only: dep_prec, sp, dp, maxspec, maxreceptor, nclassunc,&
- unitoutrecept,unitoutreceptppt, nxmax,unittmp
- use com_mod, only: path,length,ldirect,ibdate,ibtime,iedate,ietime, &
+ unitoutrecept,unitoutreceptppt,unittmp
+ use com_mod, only: path,length,ldirect,ibdate,ibtime,iedate,ietime,itime_init, &
loutstep,loutaver,loutsample,outlon0,outlat0,&
- numxgrid,numygrid,dxout,dyout,numzgrid, height, &
+ numxgrid,numygrid,dxout,dyout,numzgrid, &
outlon0n,outlat0n,dxoutn,dyoutn,numxgridn,numygridn, &
nspec,maxpointspec_act,species,numpoint,&
- dx,xlon0,dy,ylat0,compoint,method,lsubgrid,lconvection,&
+ compoint,method,lsubgrid,lconvection,&
ind_source,ind_receptor,nageclass,lage,&
drydep,wetdep,decay,weta_gas,wetb_gas, numbnests, &
- ccn_aero,in_aero, & ! wetc_in,wetd_in, &
+ ccn_aero,in_aero, mintime, & ! wetc_in,wetd_in, &
reldiff,henry,f0,density,dquer,dsigma,dryvel,&
weightmolar,ohcconst,ohdconst,vsetaver,&
- ! for concoutput_netcdf and concoutput_nest_netcdf
- nxmin1,nymin1,nz,oro,oron,rho,rhon,&
- memind,xresoln,yresoln,xrn, xln, yrn,yln,nxn,nyn,&
- xreceptor,yreceptor,numreceptor,creceptor,iout, &
+ numparticlecount,receptorname, &
+ memind,xreceptor,yreceptor,numreceptor,creceptor,iout, &
itsplit, lsynctime, ctl, ifine, lagespectra, ipin, &
ioutputforeachrelease, iflux, mdomainfill, mquasilag, &
nested_output, ipout, surf_only, linit_cond, &
- flexversion,mpi_mode,DRYBKDEP,WETBKDEP
-
+ flexversion,mpi_mode,DRYBKDEP,WETBKDEP,numpart,numpoint, &
+ partopt,num_partopt
+ use windfields_mod, only: oro,rho,nxmax,height,nxmin1,nymin1,nz,nx,ny,hmix, &
+ ! for concoutput_netcdf and concoutput_nest_netcdf
+ tropopause,oron,rhon,xresoln,yresoln,xrn,xln,yrn,yln,nxn,nyn
use mean_mod
implicit none
- private
-
- public :: writeheader_netcdf,concoutput_surf_nest_netcdf,concoutput_netcdf,&
- &concoutput_nest_netcdf,concoutput_surf_netcdf
-
-! include 'netcdf.inc'
+ ! include 'netcdf.inc'
! parameter for data compression (1-9, 9 = most aggressive)
- integer, parameter :: deflate_level = 9
+ integer, parameter :: deflate_level = 5
logical, parameter :: min_size = .false. ! if set true, redundant fields (topography) are not written to minimize file size
character(len=255), parameter :: institution = 'NILU'
- integer :: tpointer=0
- character(len=255) :: ncfname, ncfnamen
+ integer :: tpointer=0,tpointer_part=0,ppointer_part=0,partinitpointer=0,partinitpointer1=0
+ character(len=255) :: ncfname, ncfnamen, ncfname_part, ncfname_partinit!(maxpoint)
! netcdf dimension and variable IDs for main and nested output grid
integer, dimension(maxspec) :: specID,specIDppt, wdspecID,ddspecID
- integer, dimension(maxspec) :: specIDn,specIDnppt, wdspecIDn,ddspecIDn
- integer :: timeID, timeIDn
+ integer, dimension(maxspec) :: specIDn,specIDnppt, wdspecIDn,ddspecIDn,recconcID,recpptvID
+ integer :: timeID, timeIDn, timeIDpart
integer, dimension(6) :: dimids, dimidsn
integer, dimension(5) :: depdimids, depdimidsn
- real,parameter :: eps=nxmax/3.e5
-! private:: writemetadata, output_units, nf90_err
+ !IDs for partoutput
+ integer :: partID
+ integer :: itramemID,topoID,pvID,qvID,rhoID,prID,uID,vID,wID,vsetID
+ integer :: hmixID,trID,ttID,lonIDpart,latIDpart,levIDpart,massID(maxspec)
+ integer :: wdID(maxspec),ddID(maxspec)
+ ! For averaged output
+ integer :: lonavIDpart,latavIDpart,levavIDpart,pvavID,qvavID,pravID, &
+ rhoavID,ttavID,topoavID,hmixavID,travID,uavID,vavID,wavID,vsetavID,massavID(maxspec)
+ ! For initial particle outputs
+ integer :: partIDi,tIDi,lonIDi,latIDi,levIDi,relIDi,pvIDi,prIDi,qvIDi, &
+ rhoIDi,ttIDi,uIDi,vIDi,wIDi,vsetIDi,massIDi(maxspec),topoIDi,trIDi,hmixIDi
+
+ real :: eps
+ ! private:: writemetadata, output_units, nf90_err
! switch output of release point information on/off
logical, parameter :: write_releases = .true.
@@ -94,14 +106,29 @@ module netcdf_output_mod
logical, parameter :: write_vol = .false.
logical, parameter :: write_area = .false.
+ ! switch for first time topo output in case of domainfill
+ logical :: topo_written=.false.
+ logical :: mass_written=.false.
+ logical :: massav_written=.false.
+
! coordinate transformation from internal to world coord
real :: xp1,yp1,xp2,yp2
+
+
+ private
+
+ public :: writeheader_netcdf,concoutput_surf_nest_netcdf,concoutput_netcdf,&
+ &concoutput_nest_netcdf,concoutput_surf_netcdf,writeheader_partoutput,partoutput_netcdf,&
+ open_partoutput_file,close_partoutput_file,readpartpositions_netcdf,create_particles_initialoutput,&
+ write_particles_initialoutput,topo_written,mass_written,partinit_netcdf,open_partinit_file,&
+ readinitconditions_netcdf,partinitpointer1,tpointer
contains
!****************************************************************
! determine output units (see table 1 in Stohl et al., ACP 2005
!****************************************************************
subroutine output_units(units)
+ implicit none
character(len=15), intent(out) :: units
if (ldirect.eq.1) then
! forward simulation
@@ -141,6 +168,8 @@ end subroutine output_units
! write metadata to netCDF file
!****************************************************************
subroutine writemetadata(ncid,lnest)
+
+ implicit none
integer, intent(in) :: ncid
logical, intent(in) :: lnest
@@ -149,12 +178,12 @@ subroutine writemetadata(ncid,lnest)
character(5) :: zone
character(255) :: login_name, host_name
-! gather system information
+ ! gather system information
call date_and_time(date,time,zone)
call getlog(login_name)
call hostnm(host_name)
-! hes CF convention requires these attributes
+ ! hes CF convention requires these attributes
call nf90_err(nf90_put_att(ncid, nf90_global, 'Conventions', 'CF-1.6'))
call nf90_err(nf90_put_att(ncid, nf90_global, 'title', 'FLEXPART model output'))
call nf90_err(nf90_put_att(ncid, nf90_global, 'institution', trim(institution)))
@@ -179,7 +208,7 @@ subroutine writemetadata(ncid,lnest)
call nf90_err(nf90_put_att(ncid, nf90_global, 'dxout', dxout))
call nf90_err(nf90_put_att(ncid, nf90_global, 'dyout', dyout))
endif
-! vertical levels stored in grid structure
+ ! vertical levels stored in grid structure
! COMMAND file settings
call nf90_err(nf90_put_att(ncid, nf90_global, 'ldirect', ldirect))
@@ -213,14 +242,14 @@ subroutine writemetadata(ncid,lnest)
call nf90_err(nf90_put_att(ncid, nf90_global, 'nested_output', nested_output))
call nf90_err(nf90_put_att(ncid, nf90_global, 'surf_only', surf_only))
call nf90_err(nf90_put_att(ncid, nf90_global, 'linit_cond', linit_cond))
-
end subroutine writemetadata
-!****************************************************************
-! netcdf error message handling
-!****************************************************************
subroutine nf90_err(status)
+ !****************************************************************
+ ! netcdf error message handling
+ !****************************************************************
+ implicit none
integer, intent (in) :: status
if(status /= nf90_noerr) then
print *, trim(nf90_strerror(status))
@@ -228,22 +257,21 @@ subroutine nf90_err(status)
end if
end subroutine nf90_err
-
-!****************************************************************
-! Create netcdf file and write header/metadata information
-! lnest = .false. : Create main output file
-! lnest = .true. : Create nested output file
-!****************************************************************
subroutine writeheader_netcdf(lnest)
+ !****************************************************************
+ ! Create netcdf file and write header/metadata information
+ ! lnest = .false. : Create main output file
+ ! lnest = .true. : Create nested output file
+ !****************************************************************
implicit none
logical, intent(in) :: lnest
integer :: ncid, sID, wdsID, ddsID
- integer :: timeDimID, latDimID, lonDimID, levDimID
+ integer :: timeDimID, latDimID, lonDimID, levDimID, receptorDimID
integer :: nspecDimID, npointDimID, nageclassDimID, ncharDimID, pointspecDimID
- integer :: tID, lonID, latID, levID, poleID, lageID, oroID
+ integer :: tID, lonID, latID, levID, poleID, lageID, oroID, ncharrecDimID
integer :: volID, areaID
integer :: rellng1ID, rellng2ID, rellat1ID, rellat2ID, relzz1ID, relzz2ID
integer :: relcomID, relkindzID, relstartID, relendID, relpartID, relxmassID
@@ -311,10 +339,15 @@ subroutine writeheader_netcdf(lnest)
cache_size = 16 * nnx * nny * numzgrid
+ ! If starting from a restart file, new data will be added to the existing grid file
+ if ((ipin.eq.1).or.(ipin.eq.4)) then
+ call read_gridIDs(lnest)
+ return
+ endif
+
! setting cache size in bytes. It is set to 4 times the largest data block that is written
! size_type x nx x ny x nz
! create file
-
call nf90_err(nf90_create(trim(fname), cmode = nf90_hdf5, ncid = ncid, &
cache_size = cache_size))
@@ -339,6 +372,8 @@ subroutine writeheader_netcdf(lnest)
call nf90_err(nf90_def_dim(ncid, 'nageclass', nageclass, nageclassDimID))
! dimension for release point characters
call nf90_err(nf90_def_dim(ncid, 'nchar', 45, ncharDimID))
+ ! dimension for receptor point characters
+ call nf90_err(nf90_def_dim(ncid, 'ncharrec', 16, ncharrecDimID))
! number of actual release points
call nf90_err(nf90_def_dim(ncid, 'numpoint', numpoint, npointDimID))
@@ -375,7 +410,7 @@ subroutine writeheader_netcdf(lnest)
! height
call nf90_err(nf90_def_var(ncid, 'height', nf90_float, (/ levDimID /), levID))
-! call nf90_err(nf90_put_att(ncid, levID, 'axis', 'Z'))
+ ! call nf90_err(nf90_put_att(ncid, levID, 'axis', 'Z'))
call nf90_err(nf90_put_att(ncid, levID, 'units', 'meters'))
call nf90_err(nf90_put_att(ncid, levID, 'positive', 'up'))
call nf90_err(nf90_put_att(ncid, levID, 'standard_name', 'height'))
@@ -461,6 +496,14 @@ subroutine writeheader_netcdf(lnest)
call nf90_err(nf90_put_att(ncid, oroID, 'units', 'm'))
end if
+ ! Receptors
+ if (numreceptor.ge.1) then
+ call nf90_err(nf90_def_dim(ncid, 'receptor', nf90_unlimited, receptorDimID))
+ call nf90_err(nf90_def_var(ncid, 'receptor', nf90_char, (/ ncharrecDimID,receptorDimID /), sID))
+ call nf90_err(nf90_put_var(ncid, sID, receptorname, (/ 1,1 /), (/ 16,numreceptor /)))
+ call nf90_err(nf90_put_att(ncid, sID, 'long_name', 'receptor name'))
+ endif
+
! concentration output, wet and dry deposition variables (one per species)
call output_units(units)
@@ -476,95 +519,111 @@ subroutine writeheader_netcdf(lnest)
! set chunksizes according to largest written portion of data in an individual call to
! nf90_put_var
- chunksizes = (/ nnx, nny, numzgrid, 1, 1, 1 /)
+ if (int(nnx,kind=8)*int(nny,kind=8)*int(numzgrid,kind=8).gt.2147483647) then ! Larger than an
+ chunksizes = (/ nnx, nny, 1, 1, 1, 1 /)
+ else
+ chunksizes = (/ nnx, nny, numzgrid, 1, 1, 1 /)
+ endif
dep_chunksizes = (/ nnx, nny, 1, 1, 1 /)
do i = 1,nspec
- write(anspec,'(i3.3)') i
-
- ! concentration output
- if (iout.eq.1.or.iout.eq.3.or.iout.eq.5) then
- call nf90_err(nf90_def_var(ncid,'spec'//anspec//'_mr', nf90_float, dIDs, sID , &
- deflate_level = deflate_level, &
- chunksizes = chunksizes ))
- call nf90_err(nf90_put_att(ncid, sID, 'units', units))
- call nf90_err(nf90_put_att(ncid, sID, 'long_name', species(i)))
- call nf90_err(nf90_put_att(ncid, sID, 'decay', decay(i)))
- call nf90_err(nf90_put_att(ncid, sID, 'weightmolar', weightmolar(i)))
-! call nf90_err(nf90_put_att(ncid, sID, 'ohreact', ohreact(i)))
- call nf90_err(nf90_put_att(ncid, sID, 'ohcconst', ohcconst(i)))
- call nf90_err(nf90_put_att(ncid, sID, 'ohdconst', ohdconst(i)))
- call nf90_err(nf90_put_att(ncid, sID, 'vsetaver', vsetaver(i)))
-
- if (lnest) then
- specIDn(i) = sID
- else
- specID(i) = sID
- endif
- endif
+ write(anspec,'(i3.3)') i
+
+ ! concentration output
+ if ((iout.eq.1).or.(iout.eq.3).or.(iout.eq.5)) then
+ call nf90_err(nf90_def_var(ncid,'spec'//anspec//'_mr', nf90_float, dIDs, sID , &
+ deflate_level = deflate_level, &
+ chunksizes = chunksizes ))
+ call nf90_err(nf90_put_att(ncid, sID, 'units', units))
+ call nf90_err(nf90_put_att(ncid, sID, 'long_name', species(i)))
+ call nf90_err(nf90_put_att(ncid, sID, 'decay', decay(i)))
+ call nf90_err(nf90_put_att(ncid, sID, 'weightmolar', weightmolar(i)))
+ ! call nf90_err(nf90_put_att(ncid, sID, 'ohreact', ohreact(i)))
+ call nf90_err(nf90_put_att(ncid, sID, 'ohcconst', ohcconst(i)))
+ call nf90_err(nf90_put_att(ncid, sID, 'ohdconst', ohdconst(i)))
+ call nf90_err(nf90_put_att(ncid, sID, 'vsetaver', vsetaver(i)))
+
+ if (lnest) then
+ specIDn(i) = sID
+ else
+ specID(i) = sID
+ endif
+ endif
- ! mixing ratio output
- if (iout.eq.2.or.iout.eq.3) then
- call nf90_err(nf90_def_var(ncid,'spec'//anspec//'_pptv', nf90_float, dIDs, sID , &
- deflate_level = deflate_level, &
- chunksizes = chunksizes ))
- call nf90_err(nf90_put_att(ncid, sID, 'units', 'pptv'))
- call nf90_err(nf90_put_att(ncid, sID, 'long_name', species(i)))
- call nf90_err(nf90_put_att(ncid, sID, 'decay', decay(i)))
- call nf90_err(nf90_put_att(ncid, sID, 'weightmolar', weightmolar(i)))
-! call nf90_err(nf90_put_att(ncid, sID, 'ohreact', ohreact(i)))
- call nf90_err(nf90_put_att(ncid, sID, 'ohcconst', ohcconst(i)))
- call nf90_err(nf90_put_att(ncid, sID, 'ohdconst', ohdconst(i)))
- call nf90_err(nf90_put_att(ncid, sID, 'vsetaver', vsetaver(i)))
-
- if (lnest) then
- specIDnppt(i) = sID
- else
- specIDppt(i) = sID
- endif
- endif
+ ! mixing ratio output
+ if ((iout.eq.2).or.(iout.eq.3)) then
+ call nf90_err(nf90_def_var(ncid,'spec'//anspec//'_pptv', nf90_float, dIDs, sID , &
+ deflate_level = deflate_level, &
+ chunksizes = chunksizes ))
+ call nf90_err(nf90_put_att(ncid, sID, 'units', 'pptv'))
+ call nf90_err(nf90_put_att(ncid, sID, 'long_name', species(i)))
+ call nf90_err(nf90_put_att(ncid, sID, 'decay', decay(i)))
+ call nf90_err(nf90_put_att(ncid, sID, 'weightmolar', weightmolar(i)))
+ ! call nf90_err(nf90_put_att(ncid, sID, 'ohreact', ohreact(i)))
+ call nf90_err(nf90_put_att(ncid, sID, 'ohcconst', ohcconst(i)))
+ call nf90_err(nf90_put_att(ncid, sID, 'ohdconst', ohdconst(i)))
+ call nf90_err(nf90_put_att(ncid, sID, 'vsetaver', vsetaver(i)))
+
+ if (lnest) then
+ specIDnppt(i) = sID
+ else
+ specIDppt(i) = sID
+ endif
+ endif
- ! wet and dry deposition fields for forward runs
- if (wetdep) then
- call nf90_err(nf90_def_var(ncid,'WD_spec'//anspec, nf90_float, depdIDs, &
- wdsID, deflate_level = deflate_level, &
- chunksizes = dep_chunksizes))
- call nf90_err(nf90_put_att(ncid, wdsID, 'units', '1e-12 kg m-2'))
- call nf90_err(nf90_put_att(ncid, wdsID, 'weta_gas', weta_gas(i)))
- call nf90_err(nf90_put_att(ncid, wdsID, 'wetb_gas', wetb_gas(i)))
- call nf90_err(nf90_put_att(ncid, wdsID, 'ccn_aero', ccn_aero(i)))
- call nf90_err(nf90_put_att(ncid, wdsID, 'in_aero', in_aero(i)))
- ! call nf90_err(nf90_put_att(ncid, wdsID, 'wetc_in', wetc_in(i)))
- ! call nf90_err(nf90_put_att(ncid, wdsID, 'wetd_in', wetd_in(i)))
- call nf90_err(nf90_put_att(ncid, wdsID, 'dquer', dquer(i)))
- call nf90_err(nf90_put_att(ncid, wdsID, 'henry', henry(i)))
- if (lnest) then
- wdspecIDn(i) = wdsID
- else
- wdspecID(i) = wdsID
- endif
- endif
- if (drydep) then
- call nf90_err(nf90_def_var(ncid,'DD_spec'//anspec, nf90_float, depdIDs, &
- ddsID, deflate_level = deflate_level, &
- chunksizes = dep_chunksizes))
- call nf90_err(nf90_put_att(ncid, ddsID, 'units', '1e-12 kg m-2'))
- call nf90_err(nf90_put_att(ncid, ddsID, 'dryvel', dryvel(i)))
- call nf90_err(nf90_put_att(ncid, ddsID, 'reldiff', reldiff(i)))
- call nf90_err(nf90_put_att(ncid, ddsID, 'henry', henry(i)))
- call nf90_err(nf90_put_att(ncid, ddsID, 'f0', f0(i)))
- call nf90_err(nf90_put_att(ncid, ddsID, 'dquer', dquer(i)))
- call nf90_err(nf90_put_att(ncid, ddsID, 'density', density(i)))
- call nf90_err(nf90_put_att(ncid, ddsID, 'dsigma', dsigma(i)))
- if (lnest) then
- ddspecIDn(i) = ddsID
- else
- ddspecID(i) = ddsID
- endif
- endif
+ ! wet and dry deposition fields for forward runs
+ if ((ldirect.eq.1).and.(wetdep)) then
+ call nf90_err(nf90_def_var(ncid,'WD_spec'//anspec, nf90_float, depdIDs, &
+ wdsID, deflate_level = deflate_level, &
+ chunksizes = dep_chunksizes))
+ call nf90_err(nf90_put_att(ncid, wdsID, 'units', '1e-12 kg m-2'))
+ call nf90_err(nf90_put_att(ncid, wdsID, 'weta_gas', weta_gas(i)))
+ call nf90_err(nf90_put_att(ncid, wdsID, 'wetb_gas', wetb_gas(i)))
+ call nf90_err(nf90_put_att(ncid, wdsID, 'ccn_aero', ccn_aero(i)))
+ call nf90_err(nf90_put_att(ncid, wdsID, 'in_aero', in_aero(i)))
+ ! call nf90_err(nf90_put_att(ncid, wdsID, 'wetc_in', wetc_in(i)))
+ ! call nf90_err(nf90_put_att(ncid, wdsID, 'wetd_in', wetd_in(i)))
+ call nf90_err(nf90_put_att(ncid, wdsID, 'dquer', dquer(i)))
+ call nf90_err(nf90_put_att(ncid, wdsID, 'henry', henry(i)))
+ if (lnest) then
+ wdspecIDn(i) = wdsID
+ else
+ wdspecID(i) = wdsID
+ endif
+ endif
+ if ((ldirect.eq.1).and.(drydep)) then
+ call nf90_err(nf90_def_var(ncid,'DD_spec'//anspec, nf90_float, depdIDs, &
+ ddsID, deflate_level = deflate_level, &
+ chunksizes = dep_chunksizes))
+ call nf90_err(nf90_put_att(ncid, ddsID, 'units', '1e-12 kg m-2'))
+ call nf90_err(nf90_put_att(ncid, ddsID, 'dryvel', dryvel(i)))
+ call nf90_err(nf90_put_att(ncid, ddsID, 'reldiff', reldiff(i)))
+ call nf90_err(nf90_put_att(ncid, ddsID, 'henry', henry(i)))
+ call nf90_err(nf90_put_att(ncid, ddsID, 'f0', f0(i)))
+ call nf90_err(nf90_put_att(ncid, ddsID, 'dquer', dquer(i)))
+ call nf90_err(nf90_put_att(ncid, ddsID, 'density', density(i)))
+ call nf90_err(nf90_put_att(ncid, ddsID, 'dsigma', dsigma(i)))
+ if (lnest) then
+ ddspecIDn(i) = ddsID
+ else
+ ddspecID(i) = ddsID
+ endif
+ endif
+ ! RECEPTORS
+ if (numreceptor.ge.1) then
+ if ((iout.eq.1).or.(iout.eq.3).or.(iout.eq.5)) then
+ call write_to_file(ncid,'receptor_conc'//anspec, nf90_float, (/ timeDimID,receptorDimID /), &
+ sID, (/ 1, numreceptor /), 'ng m-3', .true., 'receptor_conc', 'receptor_concentration')
+ recconcID(i)=sID
+ endif
+ if ((iout.eq.2).or.(iout.eq.3)) then
+ call write_to_file(ncid,'receptor_pptv'//anspec, nf90_float, (/ timeDimID,receptorDimID /), &
+ sID, (/ 1, numreceptor /), 'pptv', .true., 'receptor_pptv', 'receptor_mixingratio')
+ recpptvID(i)=sID
+ endif
+ endif
end do
-
! global (metadata) attributes
!*******************************
call writemetadata(ncid,lnest)
@@ -573,21 +632,21 @@ subroutine writeheader_netcdf(lnest)
! moves the file from define to data mode
call nf90_err(nf90_enddef(ncid))
-! ! hes: inquire var definition
-! do i = 1,nspec
-! write(anspec,'(i3.3)') i
-!
-! ! concentration output
-! if (iout.eq.1.or.iout.eq.3.or.iout.eq.5) then
-! if (lnest) then
-! sID = specIDn(i)
-! else
-! sID = specID(i)
-! endif
-! call nf90_err(nf90_inquire_variable(ncid, sID, chunksizes=inq_chunksizes))
-! write(*,*) "Chunksizes for var "//anspec//": ", inq_chunksizes
-! endif
-! end do
+ ! ! hes: inquire var definition
+ ! do i = 1,nspec
+ ! write(anspec,'(i3.3)') i
+ !
+ ! ! concentration output
+ ! if (iout.eq.1.or.iout.eq.3.or.iout.eq.5) then
+ ! if (lnest) then
+ ! sID = specIDn(i)
+ ! else
+ ! sID = specID(i)
+ ! endif
+ ! call nf90_err(nf90_inquire_variable(ncid, sID, chunksizes=inq_chunksizes))
+ ! write(*,*) "Chunksizes for var "//anspec//": ", inq_chunksizes
+ ! endif
+ ! end do
! fill with data
@@ -645,7 +704,7 @@ subroutine writeheader_netcdf(lnest)
end if
end if
- if (write_releases.eqv..true.) then
+ if ((write_releases.eqv..true.).and.(ipin.ne.3).and.(ipin.ne.4)) then
! release point information
do i = 1,numpoint
call nf90_err(nf90_put_var(ncid, relstartID, ireleasestart(i), (/i/)))
@@ -662,7 +721,7 @@ subroutine writeheader_netcdf(lnest)
call nf90_err(nf90_put_var(ncid, relzz1ID, zpoint1(i), (/i/)))
call nf90_err(nf90_put_var(ncid, relzz2ID, zpoint2(i), (/i/)))
call nf90_err(nf90_put_var(ncid, relpartID, npart(i), (/i/)))
- if (i .le. 1000) then
+ if ((i .le. 1000).and.(ipin.ne.3).and.(ipin.ne.4)) then
call nf90_err(nf90_put_var(ncid, relcomID, compoint(i), (/1,i/), (/45,1/)))
else
call nf90_err(nf90_put_var(ncid, relcomID, 'NA', (/1,i/), (/45,1/)))
@@ -686,9 +745,67 @@ subroutine writeheader_netcdf(lnest)
call nf90_err(nf90_close(ncid))
return
-
end subroutine writeheader_netcdf
+subroutine read_gridIDs(lnest)
+
+ implicit none
+ logical, intent(in) :: lnest
+
+ integer :: ncid,i
+ character(len=3) :: anspec
+
+ if (.not. lnest) then
+ ! open output file
+ call nf90_err(nf90_open(trim(ncfname), nf90_write, ncid))
+
+ call nf90_err(nf90_inq_varid(ncid=ncid,name='time',varid=timeID))
+
+ do i = 1,nspec
+ write(anspec,'(i3.3)') i
+
+ if ((iout.eq.1).or.(iout.eq.3).or.(iout.eq.5)) then
+ call nf90_err(nf90_inq_varid(ncid=ncid,name='spec'//anspec//'_mr',varid=specID(i)))
+ endif
+ if ((iout.eq.2).or.(iout.eq.3)) then
+ call nf90_err(nf90_inq_varid(ncid=ncid,name='spec'//anspec//'_pptv',varid=specIDppt(i)))
+ endif
+ if ((ldirect.eq.1).and.(wetdep)) then
+ call nf90_err(nf90_inq_varid(ncid=ncid,name='WD_spec'//anspec,varid=wdspecID(i)))
+ endif
+ if ((ldirect.eq.1).and.(drydep)) then
+ call nf90_err(nf90_inq_varid(ncid=ncid,name='DD_spec'//anspec,varid=ddspecID(i)))
+ endif
+ end do
+
+ else
+
+ ! open output file
+ call nf90_err(nf90_open(trim(ncfnamen), nf90_write, ncid))
+
+ call nf90_err(nf90_inq_varid(ncid=ncid,name='time',varid=timeIDn))
+
+ do i = 1,nspec
+ write(anspec,'(i3.3)') i
+
+ if ((iout.eq.1).or.(iout.eq.3).or.(iout.eq.5)) then
+ call nf90_err(nf90_inq_varid(ncid=ncid,name='spec'//anspec//'_mr',varid=specIDn(i)))
+ endif
+ if ((iout.eq.2).or.(iout.eq.3)) then
+ call nf90_err(nf90_inq_varid(ncid=ncid,name='spec'//anspec//'_pptv',varid=specIDnppt(i)))
+ endif
+ if ((ldirect.eq.1).and.(wetdep)) then
+ call nf90_err(nf90_inq_varid(ncid=ncid,name='WD_spec'//anspec,varid=wdspecIDn(i)))
+ endif
+ if ((ldirect.eq.1).and.(drydep)) then
+ call nf90_err(nf90_inq_varid(ncid=ncid,name='DD_spec'//anspec,varid=ddspecIDn(i)))
+ endif
+ end do
+ endif
+
+ call nf90_err(nf90_close(ncid))
+
+end subroutine read_gridIDs
subroutine concoutput_netcdf(itime,outnum,gridtotalunc,wetgridtotalunc,drygridtotalunc)
@@ -729,6 +846,10 @@ subroutine concoutput_netcdf(itime,outnum,gridtotalunc,wetgridtotalunc,drygridto
! April 2013, Dominik Brunner, Empa *
! Adapted for netcdf output *
! *
+ ! 2022, Lucie Bakels: *
+ ! - OpenMP parallelisation *
+ ! - Receptor output to NetCDF instead of binary format *
+ ! *
!*****************************************************************************
! *
! Variables: *
@@ -747,7 +868,7 @@ subroutine concoutput_netcdf(itime,outnum,gridtotalunc,wetgridtotalunc,drygridto
real, intent(in) :: outnum
real(dep_prec),intent(out):: wetgridtotalunc,drygridtotalunc
real, intent(out) :: gridtotalunc
- real :: densityoutrecept(maxreceptor)
+ real :: densityoutrecept(maxreceptor),recout(maxreceptor)
integer :: ncid,kp,ks,kz,ix,jy,iix,jjy,kzz,kzzm1,ngrid
integer :: nage,i,l,jj
real :: tot_mu(maxspec,maxpointspec_act)
@@ -763,6 +884,7 @@ subroutine concoutput_netcdf(itime,outnum,gridtotalunc,wetgridtotalunc,drygridto
real, parameter :: weightair=28.97
+ eps=nxmax/3.e5
! open output file
call nf90_err(nf90_open(trim(ncfname), nf90_write, ncid))
@@ -791,6 +913,16 @@ subroutine concoutput_netcdf(itime,outnum,gridtotalunc,wetgridtotalunc,drygridto
endif
+ gridtotal=0.
+ gridsigmatotal=0.
+ gridtotalunc=0.
+ wetgridtotal=0._dep_prec
+ wetgridsigmatotal=0._dep_prec
+ wetgridtotalunc=0._dep_prec
+ drygridtotal=0._dep_prec
+ drygridsigmatotal=0._dep_prec
+ drygridtotalunc=0._dep_prec
+
!*******************************************************************
! Compute air density:
! brd134: we now take into account whether we are in the mother or in
@@ -798,7 +930,10 @@ subroutine concoutput_netcdf(itime,outnum,gridtotalunc,wetgridtotalunc,drygridto
! Determine center altitude of output layer, and interpolate density
! data to that altitude
!*******************************************************************
-
+!$OMP PARALLEL PRIVATE(halfheight,kzz,dz1,dz2,dz,xl,yl,ngrid,iix,jjy, &
+!$OMP kz,ix,jy,l,ks,kp,nage,auxgrid) REDUCTION(+:wetgridtotal,wetgridsigmatotal, &
+!$OMP drygridtotal,drygridsigmatotal,gridtotal,gridsigmatotal)
+!$OMP DO
do kz=1,numzgrid
if (kz.eq.1) then
halfheight=outheight(1)/2.
@@ -836,7 +971,7 @@ subroutine concoutput_netcdf(itime,outnum,gridtotalunc,wetgridtotalunc,drygridto
jjy=max(min(nint(yl),nymin1),0)
densityoutgrid(ix,jy,kz)=(rho(iix,jjy,kzz,memind(2))*dz1+ &
- rho(iix,jjy,kzz-1,memind(2))*dz2)/dz
+ rho(iix,jjy,kzz-1,memind(2))*dz2)/dz
else
xl=(xl-xln(ngrid))*xresoln(ngrid)
yl=(yl-yln(ngrid))*yresoln(ngrid)
@@ -844,39 +979,48 @@ subroutine concoutput_netcdf(itime,outnum,gridtotalunc,wetgridtotalunc,drygridto
jjy=max(min(nint(yl),nyn(ngrid)-1),0)
densityoutgrid(ix,jy,kz)=(rhon(iix,jjy,kzz,memind(2), ngrid)*dz1+ &
- rhon(iix,jjy,kzz-1,memind(2), ngrid)*dz2)/dz
+ rhon(iix,jjy,kzz-1,memind(2), ngrid)*dz2)/dz
endif
end do
end do
end do
+!$OMP END DO NOWAIT
! brd134: for receptor points no option for nests yet to specify density
! and also altitude zreceptor not considered yet (needs revision)
- do i=1,numreceptor
- xl=xreceptor(i)
- yl=yreceptor(i)
- iix=max(min(nint(xl),nxmin1),0)
- jjy=max(min(nint(yl),nymin1),0)
- densityoutrecept(i)=rho(iix,jjy,1,memind(2))
- end do
+ if (numreceptor.gt.0) then
+!$OMP DO
+ do i=1,numreceptor
+ xl=xreceptor(i)
+ yl=yreceptor(i)
+ iix=max(min(nint(xl),nxmin1),0)
+ jjy=max(min(nint(yl),nymin1),0)
+ densityoutrecept(i)=rho(iix,jjy,1,memind(2))
+ end do
+!$OMP END DO NOWAIT
+ endif
! Output is different for forward and backward simulations
if (ldirect.eq.1) then
- do kz=1,numzgrid
- do jy=0,numygrid-1
- do ix=0,numxgrid-1
- factor3d(ix,jy,kz)=1.e12/volume(ix,jy,kz)/outnum
- end do
- end do
- end do
+!$OMP DO
+ do kz=1,numzgrid
+ do jy=0,numygrid-1
+ do ix=0,numxgrid-1
+ factor3d(ix,jy,kz)=1.e12/volume(ix,jy,kz)/outnum
+ end do
+ end do
+ end do
+!$OMP END DO
else
- do kz=1,numzgrid
- do jy=0,numygrid-1
- do ix=0,numxgrid-1
- factor3d(ix,jy,kz)=real(abs(loutaver))/outnum
- end do
- end do
- end do
+!$OMP DO
+ do kz=1,numzgrid
+ do jy=0,numygrid-1
+ do ix=0,numxgrid-1
+ factor3d(ix,jy,kz)=real(abs(loutaver))/outnum
+ end do
+ end do
+ end do
+!$OMP END DO
endif
!*********************************************************************
@@ -884,21 +1028,12 @@ subroutine concoutput_netcdf(itime,outnum,gridtotalunc,wetgridtotalunc,drygridto
! ratio (uncertainty of the output) and the dry and wet deposition
!*********************************************************************
- gridtotal=0.
- gridsigmatotal=0.
- gridtotalunc=0.
- wetgridtotal=0._dep_prec
- wetgridsigmatotal=0._dep_prec
- wetgridtotalunc=0._dep_prec
- drygridtotal=0._dep_prec
- drygridsigmatotal=0._dep_prec
- drygridtotalunc=0._dep_prec
do ks=1,nspec
do kp=1,maxpointspec_act
do nage=1,nageclass
-
+!$OMP DO
do jy=0,numygrid-1
do ix=0,numxgrid-1
@@ -970,8 +1105,8 @@ subroutine concoutput_netcdf(itime,outnum,gridtotalunc,wetgridtotalunc,drygridto
end do
end do
end do
-
-! print*,gridtotal,maxpointspec_act
+!$OMP END DO
+ ! print*,gridtotal,maxpointspec_act
!*******************************************************************
! Generate output: may be in concentration (ng/m3) or in mixing
@@ -983,6 +1118,7 @@ subroutine concoutput_netcdf(itime,outnum,gridtotalunc,wetgridtotalunc,drygridto
! Concentration output
!*********************
+!$OMP SINGLE
if ((iout.eq.1).or.(iout.eq.3).or.(iout.eq.5)) then
! Wet deposition
@@ -1034,16 +1170,13 @@ subroutine concoutput_netcdf(itime,outnum,gridtotalunc,wetgridtotalunc,drygridto
(/ 1,1,1,tpointer,kp,nage /), (/ numxgrid,numygrid,numzgrid,1,1,1 /)))
endif ! output for ppt
-
+!$OMP END SINGLE
+!$OMP BARRIER
end do
end do
end do
-
- ! Close netCDF file
- !**************************
- call nf90_err(nf90_close(ncid))
-
+!$OMP END PARALLEL
if (gridtotal.gt.0.) gridtotalunc=gridsigmatotal/gridtotal
if (wetgridtotal.gt.0.) wetgridtotalunc=wetgridsigmatotal/ &
@@ -1053,31 +1186,32 @@ subroutine concoutput_netcdf(itime,outnum,gridtotalunc,wetgridtotalunc,drygridto
! Dump of receptor concentrations
- if (numreceptor.gt.0 .and. (iout.eq.2 .or. iout.eq.3) ) then
- write(unitoutreceptppt) itime
- do ks=1,nspec
- write(unitoutreceptppt) (1.e12*creceptor(i,ks)/outnum* &
- weightair/weightmolar(ks)/densityoutrecept(i),i=1,numreceptor)
- end do
- endif
+ if (numreceptor.ge.1) then
+ if (iout.eq.2 .or. iout.eq.3) then
+ do ks=1,nspec
+ recout(:)=1.e12*creceptor(:,ks)/outnum*weightair/weightmolar(ks)/densityoutrecept(:)
+ call nf90_err(nf90_put_var(ncid,recpptvID(ks),recout(1:numreceptor),(/ tpointer,1 /),(/ 1,numreceptor /)))
+ end do
+ endif
- ! Dump of receptor concentrations
+ ! Dump of receptor concentrations
- if (numreceptor.gt.0) then
- write(unitoutrecept) itime
- do ks=1,nspec
- write(unitoutrecept) (1.e12*creceptor(i,ks)/outnum,i=1,numreceptor)
- end do
+ if ((iout.eq.1).or.(iout.eq.3).or.(iout.eq.5)) then
+ do ks=1,nspec
+ recout(:)=1.e12*creceptor(:,ks)/outnum
+ call nf90_err(nf90_put_var(ncid,recconcID(ks),recout(1:numreceptor),(/ tpointer,1 /),(/ 1,numreceptor /)))
+ end do
+ endif
endif
+ ! Close netCDF file
+ !**************************
+ call nf90_err(nf90_close(ncid))
! Reinitialization of grid
!*************************
-
- creceptor(1:numreceptor,1:nspec) = 0.
+ if (numreceptor.gt.0) creceptor(1:numreceptor,1:nspec) = 0.
gridunc(:,:,:,1:nspec,:,:,1:nageclass) = 0.
-
-
end subroutine concoutput_netcdf
subroutine concoutput_surf_netcdf(itime,outnum,gridtotalunc,wetgridtotalunc,drygridtotalunc)
@@ -1092,7 +1226,6 @@ subroutine concoutput_surf_netcdf(itime,outnum,gridtotalunc,wetgridtotalunc,dryg
real(dep_prec), intent(out) :: wetgridtotalunc,drygridtotalunc
print*,'Netcdf output for surface only not yet implemented'
-
end subroutine concoutput_surf_netcdf
subroutine concoutput_nest_netcdf(itime,outnum)
@@ -1149,6 +1282,8 @@ subroutine concoutput_nest_netcdf(itime,outnum)
real :: gridtotal
real, parameter :: weightair=28.97
+ eps=nxmax/3.e5
+
! open output file
call nf90_err(nf90_open(trim(ncfnamen), nf90_write, ncid))
@@ -1174,7 +1309,7 @@ subroutine concoutput_nest_netcdf(itime,outnum)
end do
endif
-
+ gridtotal=0.
!*******************************************************************
! Compute air density:
! brd134: we now take into account whether we are in the mother or in
@@ -1182,7 +1317,9 @@ subroutine concoutput_nest_netcdf(itime,outnum)
! Determine center altitude of output layer, and interpolate density
! data to that altitude
!*******************************************************************
-
+!$OMP PARALLEL PRIVATE(halfheight,kzz,dz1,dz2,dz,xl,yl,ngrid,iix,jjy, &
+!$OMP kz,ix,jy,l,ks,kp,nage,auxgrid) REDUCTION(+:gridtotal)
+!$OMP DO
do kz=1,numzgrid
if (kz.eq.1) then
halfheight=outheight(1)/2.
@@ -1232,17 +1369,23 @@ subroutine concoutput_nest_netcdf(itime,outnum)
end do
end do
end do
+!$OMP END DO NOWAIT
- do i=1,numreceptor
- xl=xreceptor(i)
- yl=yreceptor(i)
- iix=max(min(nint(xl),nxmin1),0)
- jjy=max(min(nint(yl),nymin1),0)
- densityoutrecept(i)=rho(iix,jjy,1,memind(2))
- end do
+ if (numreceptor.gt.0) then
+!$OMP DO
+ do i=1,numreceptor
+ xl=xreceptor(i)
+ yl=yreceptor(i)
+ iix=max(min(nint(xl),nxmin1),0)
+ jjy=max(min(nint(yl),nymin1),0)
+ densityoutrecept(i)=rho(iix,jjy,1,memind(2))
+ end do
+!$OMP END DO NOWAIT
+ endif
! Output is different for forward and backward simulations
if (ldirect.eq.1) then
+!$OMP DO
do kz=1,numzgrid
do jy=0,numygridn-1
do ix=0,numxgridn-1
@@ -1250,7 +1393,9 @@ subroutine concoutput_nest_netcdf(itime,outnum)
end do
end do
end do
+!$OMP END DO
else
+!$OMP DO
do kz=1,numzgrid
do jy=0,numygridn-1
do ix=0,numxgridn-1
@@ -1258,6 +1403,7 @@ subroutine concoutput_nest_netcdf(itime,outnum)
end do
end do
end do
+!$OMP END DO
endif
!*********************************************************************
@@ -1265,13 +1411,11 @@ subroutine concoutput_nest_netcdf(itime,outnum)
! ratio (uncertainty of the output) and the dry and wet deposition
!*********************************************************************
- gridtotal=0.
-
do ks=1,nspec
do kp=1,maxpointspec_act
do nage=1,nageclass
-
+!$OMP DO
do jy=0,numygridn-1
do ix=0,numxgridn-1
! WET DEPOSITION
@@ -1334,8 +1478,8 @@ subroutine concoutput_nest_netcdf(itime,outnum)
end do
end do
end do
-
-! print*,gridtotal,maxpointspec_act
+!$OMP END DO
+ ! print*,gridtotal,maxpointspec_act
!*******************************************************************
! Generate output: may be in concentration (ng/m3) or in mixing
@@ -1347,6 +1491,7 @@ subroutine concoutput_nest_netcdf(itime,outnum)
! Concentration output
!*********************
+!$OMP SINGLE
if ((iout.eq.1).or.(iout.eq.3).or.(iout.eq.5)) then
! Wet deposition
@@ -1397,12 +1542,13 @@ subroutine concoutput_nest_netcdf(itime,outnum)
(/ 1,1,1,tpointer,kp,nage /), (/ numxgridn,numygridn,numzgrid,1,1,1 /)))
endif ! output for ppt
-
+!$OMP END SINGLE
+!$OMP BARRIER
end do
end do
end do
-
+!$OMP END PARALLEL
! Close netCDF file
!**************************
call nf90_err(nf90_close(ncid))
@@ -1410,9 +1556,8 @@ subroutine concoutput_nest_netcdf(itime,outnum)
! Reinitialization of grid
!*************************
- creceptor(1:numreceptor,1:nspec) = 0.
+ if (numreceptor.gt.0) creceptor(1:numreceptor,1:nspec) = 0.
griduncn(:,:,:,1:nspec,:,:,1:nageclass) = 0.
-
end subroutine concoutput_nest_netcdf
subroutine concoutput_surf_nest_netcdf(itime,outnum)
@@ -1423,9 +1568,1200 @@ subroutine concoutput_surf_nest_netcdf(itime,outnum)
real, intent(in) :: outnum
print*,'Netcdf output for surface only not yet implemented'
-
end subroutine concoutput_surf_nest_netcdf
-end module netcdf_output_mod
+subroutine create_particles_initialoutput(itime,idate,itime_start,idate_start)
+
+ !*****************************************************************************
+ ! *
+ ! This subroutine creates an initial particle positions and properties *
+ ! NetCDF file: partinit_xxx.nc *
+ ! The release time, release number and positions, together with all fields *
+ ! specified in the PARTOPTIONS option file will saved. *
+ ! *
+ ! Author: L. Bakels 2022 *
+ ! *
+ !*****************************************************************************
+
+ implicit none
+
+ integer, intent(in) :: itime,idate,itime_start,idate_start
+ ! integer, intent(in) :: irelease
+ integer :: cache_size,ncid,j,totpart,np
+ integer :: partDimID
+ character(len=11) :: fprefix
+ character(len=3) :: anspec,arelease
+ character :: adate*8,atime*6,adate_start*8,atime_start*6,timeunit*32
+ character(len=255) :: fname_partoutput
+ real :: fillval
+
+ write(adate,'(i8.8)') idate
+ write(atime,'(i6.6)') itime
+ write(adate_start,'(i8.8)') idate_start
+ write(atime_start,'(i6.6)') itime_start
+ ! write(arelease, '(i3.3)') irelease
+ fprefix = 'partinit_'!rel'//arelease//'_'
+
+ fname_partoutput = path(2)(1:length(2))//trim(fprefix)//adate//atime//'.nc'
+ !ncfname_part(irelease) = fname_partoutput
+ ncfname_partinit = fname_partoutput
+
+ call nf90_err(nf90_create(trim(fname_partoutput), cmode = nf90_hdf5, ncid = ncid))!, &
+ ! cache_size = cache_size))
+
+ ! create dimensions:
+ !*************************
+
+ ! particle
+ partinitpointer=0
+ call nf90_err(nf90_def_dim(ncid, 'particle', nf90_unlimited, partDimID))
+
+ ! create variables
+ !*************************
+
+ ! particles
+ call nf90_err(nf90_def_var(ncid, 'particle', nf90_int, (/ partDimID/), partIDi))
+ call nf90_err(nf90_put_att(ncid, partIDi, 'long_name', 'particle index'))
+
+ fillval = -1.
+ ! time
+ timeunit = 'seconds since '//adate_start(1:4)//'-'//adate_start(5:6)// &
+ '-'//adate_start(7:8)//' '//atime_start(1:2)//':'//atime_start(3:4)
+
+ call write_to_file(ncid,'time',nf90_int,(/ partDimID /),tIDi,(/ 1 /), &
+ timeunit,.false.,'time','time of release')
+ call nf90_err(nf90_put_att(ncid, tIDi, 'axis', 't'))
+ call nf90_err(nf90_put_att(ncid, tIDi, 'calendar', 'proleptic_gregorian'))
+ call nf90_err(nf90_put_att(ncid, tIDi, 'description', 'time of release'))
+
+ ! lon
+ call write_to_file(ncid,'longitude',nf90_float,(/ partDimID /),lonIDi,(/ 1 /), &
+ 'degrees_east',.false.,'longitude','longitude in degree east')
+ call nf90_err(nf90_put_att(ncid, lonIDi, 'axis', 'Lon'))
+ call nf90_err(nf90_put_att(ncid, lonIDi, 'description', 'longitude of particles'))
+
+ ! lat
+ call write_to_file(ncid,'latitude',nf90_float,(/ partDimID /),latIDi,(/ 1 /), &
+ 'degrees_north',.false.,'latitude','latitude in degree north')
+ call nf90_err(nf90_put_att(ncid, latIDi, 'axis', 'Lat'))
+ call nf90_err(nf90_put_att(ncid, latIDi, 'description', 'latitude of particles'))
+
+ ! height
+ call write_to_file(ncid,'height',nf90_float,(/ partDimID /),levIDi,(/ 1 /), &
+ 'meters',.true.,'height','height above ground')
+
+ ! release
+ call write_to_file(ncid,'release',nf90_int,(/ partDimID /),relIDi,(/ 1 /), &
+ '',.true.,'release','particle release')
+
+ do np=1,num_partopt
+ if (.not. partopt(np)%print) cycle
+ select case(partopt(np)%name)
+ case ('PV') ! Potential vorticity
+ call write_to_file(ncid,'pv',nf90_float,(/ partDimID /),pvIDi,(/ 1 /), &
+ 'pvu',.false.,'potential_vorticity','potential vorticity')
+ case ('PR') ! Pressure
+ call write_to_file(ncid,'pr',nf90_float,(/ partDimID /),prIDi,(/ 1 /), &
+ 'Pa',.false.,'pressure','pressure')
+ case ('QV') ! Specific humidity
+ call write_to_file(ncid,'qv',nf90_float,(/ partDimID /),qvIDi,(/ 1 /), &
+ '',.false.,'specific_humidity','specific humidity')
+ case ('RH') ! Density
+ call write_to_file(ncid,'rho',nf90_float,(/ partDimID /),rhoIDi,(/ 1 /), &
+ 'kg/m3',.true.,'density','density')
+ case ('TT') ! Temperature
+ call write_to_file(ncid,'temperature',nf90_float,(/ partDimID /),ttIDi,(/ 1 /), &
+ 'K',.true.,'temperature','temperature')
+ case ('UU')
+ call write_to_file(ncid,'u',nf90_float,(/ partDimID /),uIDi,(/ 1 /), &
+ 'm/s',.false.,'u','longitudinal velocity')
+ case ('VV')
+ call write_to_file(ncid,'v',nf90_float,(/ partDimID /),vIDi,(/ 1 /), &
+ 'm/s',.false.,'v','latitudinal velocity')
+ case ('WW')
+ call write_to_file(ncid,'w',nf90_float,(/ partDimID /),wIDi,(/ 1 /), &
+ 'm/s',.false.,'w','vertical velocity')
+ case ('MA')
+ do j=1,nspec
+ ! Masses
+ write(anspec, '(i3.3)') j
+ call write_to_file(ncid,'mass'//anspec,nf90_float,(/ partDimID /),massIDi(j), &
+ (/ 1 /),'kg',.true.,'mass'//anspec,'mass for nspec'//anspec)
+ end do
+ case ('TO')
+ call write_to_file(ncid,'topo',nf90_float,(/ partDimID /),topoIDi,(/ 1 /), &
+ 'meters',.false.,'topography','topography above sealevel')
+ case ('TR')
+ call write_to_file(ncid,'tr',nf90_float,(/ partDimID /),trIDi,(/ 1 /), &
+ 'meters',.true.,'htropo','height above ground of tropopause')
+ case ('HM') ! Mixing layer height
+ call write_to_file(ncid,'hmix',nf90_float,(/ partDimID /),hmixIDi,(/ 1 /), &
+ 'meters',.true.,'hmix','height above ground of mixing layer')
+ case default
+ cycle
+ end select
+ end do
+
+ ! moves the file from define to data mode
+ call nf90_err(nf90_enddef(ncid))
+ call nf90_err(nf90_close(ncid))
+end subroutine create_particles_initialoutput
+
+subroutine write_particles_initialoutput(itime,istart,iend)
+
+ !*****************************************************************************
+ ! *
+ ! This subroutine saves initial particle positions, release time and *
+ ! releasenumber to a NetCDF file created in create_particles_initialoutput *
+ ! evertime a new particle is spawned. *
+ ! *
+ ! Author: L. Bakels 2022 *
+ ! *
+ !*****************************************************************************
+
+ use particle_mod
+
+ implicit none
+
+ integer, intent(in) :: &
+ itime, & ! time of particle release
+ istart, & ! index of first newly released particle
+ iend ! index of last newly released partile
+ integer, allocatable :: partindices(:),releasetimes(:)
+ integer :: newpart,ncid,j
+
+ newpart = iend-istart
+ if (newpart.eq.0) return
+ write(*,*) newpart, ' particles are being added to partinit.'
+ call nf90_err(nf90_open(trim(ncfname_partinit), nf90_write, ncid))
+ allocate ( partindices(newpart) )
+
+ do j=1,newpart
+ partindices(j)=j+partinitpointer
+ end do
+
+ partinitpointer1= partinitpointer+1 ! this is also used in partinit_netcdf
+ call nf90_err(nf90_put_var(ncid,partIDi,partindices,(/ partinitpointer1 /),(/ newpart /)))
+ deallocate (partindices)
+
+ allocate ( releasetimes(newpart) )
+ releasetimes=itime
+ call nf90_err(nf90_put_var(ncid,tIDi,releasetimes,(/ partinitpointer1 /),(/ newpart /)))
+ deallocate (releasetimes)
+ call nf90_err(nf90_put_var(ncid,lonIDi,xlon0+part(partinitpointer1:iend)%xlon*dx, (/ partinitpointer1 /),(/ newpart /)))
+ call nf90_err(nf90_put_var(ncid,latIDi,ylat0+part(partinitpointer1:iend)%ylat*dy, (/ partinitpointer1 /),(/ newpart /)))
+ call nf90_err(nf90_put_var(ncid,levIDi,part(partinitpointer1:iend)%z, (/ partinitpointer1 /),(/ newpart /)))
+ call nf90_err(nf90_put_var(ncid,relIDi,part(partinitpointer1:iend)%npoint, (/ partinitpointer1 /),(/ newpart /)))
+
+ call nf90_err(nf90_close(ncid))
+
+ partinitpointer = partinitpointer+newpart
+end subroutine write_particles_initialoutput
+
+subroutine partinit_netcdf(itime,field,fieldname,imass,ncid)
+
+ !*****************************************************************************
+ ! *
+ ! This subroutine saves properties chosen by the user in PARTOPTIONS *
+ ! to a NetCDF file created in create_particles_initialoutput. *
+ ! This happens whenever a new particle is spawned. *
+ ! *
+ ! Author: L. Bakels 2022 *
+ ! *
+ !*****************************************************************************
+
+ implicit none
+
+ integer, intent(in) :: itime,imass
+ real, intent(in) :: field(:)
+ character(2), intent(in) :: fieldname ! input field to interpolate over
+ integer, allocatable :: partindices(:)
+ integer :: ncid,newpart,j,iend
+
+ newpart = partinitpointer - (partinitpointer1-1)
+
+ select case(fieldname)
+ case('TO') ! Topography
+ call nf90_err(nf90_put_var(ncid,topoIDi,field(partinitpointer1:partinitpointer), &
+ (/ partinitpointer1 /),(/ newpart /)))
+ case('PV') ! Potential vorticity
+ call nf90_err(nf90_put_var(ncid,pvIDi,field(partinitpointer1:partinitpointer), &
+ (/ partinitpointer1 /),(/ newpart /)))
+ case('PR') ! Pressure
+ call nf90_err(nf90_put_var(ncid,prIDi,field(partinitpointer1:partinitpointer), &
+ (/ partinitpointer1 /),(/ newpart /)))
+ case('QV') ! Specific humidity
+ call nf90_err(nf90_put_var(ncid,qvIDi,field(partinitpointer1:partinitpointer), &
+ (/ partinitpointer1 /),(/ newpart /)))
+ case('RH') ! Air density
+ call nf90_err(nf90_put_var(ncid,rhoIDi,field(partinitpointer1:partinitpointer), &
+ (/ partinitpointer1 /),(/ newpart /)))
+ case('UU') ! Longitudinal velocity
+ call nf90_err(nf90_put_var(ncid,uIDi,field(partinitpointer1:partinitpointer), &
+ (/ partinitpointer1 /),(/ newpart /)))
+ case('VV') ! Latitudinal velocity
+ call nf90_err(nf90_put_var(ncid,vIDi,field(partinitpointer1:partinitpointer), &
+ (/ partinitpointer1 /),(/ newpart /)))
+ case('WW') ! Vertical velocity
+ call nf90_err(nf90_put_var(ncid,wIDi,field(partinitpointer1:partinitpointer), &
+ (/ partinitpointer1 /),(/ newpart /)))
+ case('TT') ! Temperature
+ call nf90_err(nf90_put_var(ncid,ttIDi,field(partinitpointer1:partinitpointer), &
+ (/ partinitpointer1 /),(/ newpart /)))
+ case('MA') ! Mass
+ call nf90_err(nf90_put_var(ncid,massIDi(imass),field(partinitpointer1:partinitpointer), &
+ (/ partinitpointer1 /),(/ newpart /)))
+ case('TR') ! Tropopause
+ call nf90_err(nf90_put_var(ncid,trIDi,field(partinitpointer1:partinitpointer), &
+ (/ partinitpointer1 /),(/ newpart /)))
+ case('HM') ! Mixing height
+ call nf90_err(nf90_put_var(ncid,hmixIDi,field(partinitpointer1:partinitpointer), &
+ (/ partinitpointer1 /),(/ newpart /)))
+ case default
+ return
+ end select
+end subroutine partinit_netcdf
+
+subroutine writeheader_partoutput(itime,idate,itime_start,idate_start)!,irelease)
+
+ !*****************************************************************************
+ ! *
+ ! This subroutine creates a file (partoutput_xxx.nc), where every time *
+ ! interval particle properties specified in the PARTOPTIONS option file *
+ ! are saved to. Running options are saved as header informtion to this *
+ ! file as well. *
+ ! *
+ ! Author: L. Bakels 2021 *
+ ! *
+ !*****************************************************************************
+
+ implicit none
+
+ integer, intent(in) :: itime,idate,itime_start,idate_start
+ ! integer, intent(in) :: irelease
+ integer :: cache_size,ncid,j,i,totpart,np
+ integer :: timeDimID,partDimID,tID,memDimID
+ integer :: latDimID, lonDimID, lonID, latID
+ character(len=11) :: fprefix
+ character(len=3) :: anspec,arelease
+ character :: adate*8,atime*6,adate_start*8,atime_start*6,timeunit*32
+ character(len=255) :: fname_partoutput
+ real :: fillval
+ real, allocatable, dimension(:) :: coord
+
+ logical,save :: first_time=.true.
+
+ open(unit=unittmp,file=trim(path(2)(1:length(2)))//'test_dir.txt',status='replace',&
+ &err=110)
+ close (unittmp, status='delete')
+
+ write(adate,'(i8.8)') idate
+ write(atime,'(i6.6)') itime
+ write(adate_start,'(i8.8)') idate_start
+ write(atime_start,'(i6.6)') itime_start
+ ! write(arelease, '(i3.3)') irelease
+ fprefix = 'partoutput_'!rel'//arelease//'_'
+
+ ! Reset logicals that ensure ony 1 write out in case of domainfill
+ topo_written=.false.
+ mass_written=.false.
+ massav_written=.false.
+
+ if (first_time) then
+ fname_partoutput = path(2)(1:length(2))//trim(fprefix)//adate//atime//'_init.nc'
+ first_time=.false.
+ else
+ fname_partoutput = path(2)(1:length(2))//trim(fprefix)//adate//atime//'.nc'
+ endif
+ !ncfname_part(irelease) = fname_partoutput
+ ncfname_part = fname_partoutput
+
+ totpart=0
+ if (ipin.gt.1) then ! Not reading from a release has no npart
+ totpart=numpart
+ else
+ do j=1,numpoint
+ totpart = totpart+npart(j)
+ end do
+ endif
+ !totpart = maxpart!max(numpart,totpart)
+ !cache_size = 4 * 1 * (12+nspec)
+
+ write(*,*) 'Write header, nspec,numpart,totpart: ', nspec,numpart,totpart
+
+ call nf90_err(nf90_create(trim(fname_partoutput), cmode = nf90_hdf5, ncid = ncid))!, &
+ ! cache_size = cache_size))
+
+ ! create dimensions:
+ !*************************
+ ! time
+ call nf90_err(nf90_def_dim(ncid, 'time', nf90_unlimited, timeDimID))
+ timeunit = 'seconds since '//adate_start(1:4)//'-'//adate_start(5:6)// &
+ '-'//adate_start(7:8)//' '//atime_start(1:2)//':'//atime_start(3:4)
+
+ ! particle
+ call nf90_err(nf90_def_dim(ncid, 'particle', nf90_unlimited, partDimID)) !totpart needs to be the actual number of particles
+
+ ! If domainfill, save topo, hmix, and htropo to grid to save space
+ !*****************************************************************
+ if (mdomainfill.ge.1) then
+ call nf90_err(nf90_def_dim(ncid, 'lon', nx, lonDimID))
+ call nf90_err(nf90_def_dim(ncid, 'lat', ny, latDimID))
+
+ ! lon
+ call write_to_file(ncid,'lon',nf90_float,(/ lonDimID /),lonID,(/ 1 /), &
+ 'degrees_east',.false.,'grid_longitude','longitude in degree east')
+ call nf90_err(nf90_put_att(ncid, lonID, 'axis', 'Lon'))
+ call nf90_err(nf90_put_att(ncid, lonID, 'description', 'grid cell centers'))
+
+ ! lat
+ call write_to_file(ncid,'lat',nf90_float,(/ latDimID /),latID,(/ 1 /), &
+ 'degrees_east',.false.,'grid_latitude','latitude in degree north')
+ call nf90_err(nf90_put_att(ncid, latID, 'axis', 'Lat'))
+ call nf90_err(nf90_put_att(ncid, latID, 'description', 'grid cell centers'))
+
+ if (.not.allocated(coord)) allocate(coord(nx))
+ do i = 1,nx
+ coord(i) = xlon0 + i*dx
+ enddo
+ call nf90_err(nf90_put_var(ncid, lonID, coord(1:nx)))
+ deallocate(coord)
+
+ if (.not.allocated(coord)) allocate(coord(ny))
+ do i = 1,ny
+ coord(i) = ylat0 + i*dy
+ enddo
+ call nf90_err(nf90_put_var(ncid, latID, coord(1:ny)))
+ deallocate(coord)
+
+ endif
+ ! create variables
+ !*************************
+
+ ! time
+ tpointer_part=0
+ call nf90_err(nf90_def_var(ncid, 'time', nf90_int, (/ timeDimID /), tID))
+ call nf90_err(nf90_put_att(ncid, tID, 'units', timeunit))
+ call nf90_err(nf90_put_att(ncid, tID, 'calendar', 'proleptic_gregorian'))
+
+ timeIDpart=tID
+ ! particles
+ call nf90_err(nf90_def_var(ncid, 'particle', nf90_int, (/ partDimID/), partID))
+ call nf90_err(nf90_put_att(ncid, partID, 'long_name', 'particle index'))
+
+ fillval = -1.
+ do np=1,num_partopt
+ if (.not. partopt(np)%print) cycle
+ select case(partopt(np)%name)
+ case ('LO') ! Longitude
+ call write_to_file(ncid,'longitude',nf90_float,(/ timeDimID,partDimID /),lonIDpart,(/ 1,totpart /), &
+ 'degrees_east',.false.,'longitude','longitude of particles')
+ call nf90_err(nf90_put_att(ncid, lonIDpart, 'axis', 'Lon'))
+ call nf90_err(nf90_put_att(ncid, lonIDpart, 'description', 'longitude of particles'))
+ case ('lo') ! Longitude averaged
+ call write_to_file(ncid,'longitude_av',nf90_float,(/ timeDimID,partDimID /),lonavIDpart,(/ 1,totpart /), &
+ 'degrees_east',.false.,'longitude_average','averaged longitude of particles')
+ call nf90_err(nf90_put_att(ncid, lonavIDpart, 'axis', 'Lon'))
+ call nf90_err(nf90_put_att(ncid, lonavIDpart, 'description', 'averaged longitude of particles'))
+ case ('LA') ! Latitude
+ call write_to_file(ncid,'latitude',nf90_float,(/ timeDimID,partDimID /),latIDpart,(/ 1,totpart /), &
+ 'degrees_north',.false.,'latitude','latitude in degree north')
+ call nf90_err(nf90_put_att(ncid, latIDpart, 'axis', 'Lat'))
+ call nf90_err(nf90_put_att(ncid, latIDpart, 'description', 'latitude of particles'))
+ case ('la') ! Latitude averaged
+ call write_to_file(ncid,'latitude_av',nf90_float,(/ timeDimID,partDimID /),latavIDpart,(/ 1,totpart /), &
+ 'degrees_north',.false.,'latitude_average','averaged latitude in degree north')
+ call nf90_err(nf90_put_att(ncid, latavIDpart, 'axis', 'Lat'))
+ call nf90_err(nf90_put_att(ncid, latavIDpart, 'description', 'averaged latitude of particles'))
+ case ('ZZ') ! Height
+ call write_to_file(ncid,'height',nf90_float,(/ timeDimID,partDimID /),levIDpart,(/ 1,totpart /), &
+ 'meters',.false.,'height','height above ground')
+ case ('zz') ! Heights averaged
+ call write_to_file(ncid,'height_av',nf90_float,(/ timeDimID,partDimID /),levavIDpart,(/ 1,totpart /), &
+ 'meters',.false.,'height_average','averaged height above ground')
+ case ('PV') ! Potential vorticity
+ call write_to_file(ncid,'pv',nf90_float,(/ timeDimID,partDimID /),pvID,(/ 1,totpart /), &
+ 'pvu',.false.,'potential_vorticity','potential vorticity')
+ case ('pv') ! Potential vorticity averaged
+ call write_to_file(ncid,'pv_av',nf90_float,(/ timeDimID,partDimID /),pvavID,(/ 1,totpart /), &
+ 'pvu',.false.,'potential_vorticity_average','averaged potential vorticity')
+ case ('PR') ! Pressure
+ call write_to_file(ncid,'pr',nf90_float,(/ timeDimID,partDimID /),prID,(/ 1,totpart /), &
+ 'Pa',.false.,'pressure','pressure')
+ case ('pr') ! Pressure averaged
+ call write_to_file(ncid,'pr_av',nf90_float,(/ timeDimID,partDimID /),pravID,(/ 1,totpart /), &
+ 'Pa',.false.,'pressure_average','averaged pressure')
+ case ('QV') ! Specific humidity
+ call write_to_file(ncid,'qv',nf90_float,(/ timeDimID,partDimID /),qvID,(/ 1,totpart /), &
+ '',.false.,'specific_humidity','specific humidity')
+ case ('qv') ! Specific humidity averaged
+ call write_to_file(ncid,'qv_av',nf90_float,(/ timeDimID,partDimID /),qvavID,(/ 1,totpart /), &
+ '',.false.,'specific_humidity_average','averaged specific humidity')
+ case ('RH') ! Density
+ call write_to_file(ncid,'rho',nf90_float,(/ timeDimID,partDimID /),rhoID,(/ 1,totpart /), &
+ 'kg/m3',.true.,'density','density')
+ case ('rh') ! Density averaged
+ call write_to_file(ncid,'rho_av',nf90_float,(/ timeDimID,partDimID /),rhoavID,(/ 1,totpart /), &
+ 'kg/m3',.true.,'density_average','averaged density')
+ case ('TT') ! Temperature
+ call write_to_file(ncid,'temperature',nf90_float,(/ timeDimID,partDimID /),ttID,(/ 1,totpart /), &
+ 'K',.true.,'temperature','temperature')
+ case ('tt') ! Temperature averaged
+ call write_to_file(ncid,'temperature_av',nf90_float,(/ timeDimID,partDimID /),ttavID,(/ 1,totpart /), &
+ 'K',.true.,'temperature_average','averaged temperature')
+ case ('UU')
+ call write_to_file(ncid,'u',nf90_float,(/ timeDimID,partDimID /),uID,(/ 1,totpart /), &
+ 'm/s',.false.,'u','longitudinal velocity')
+ case ('uu')
+ call write_to_file(ncid,'u_av',nf90_float,(/ timeDimID,partDimID /),uavID,(/ 1,totpart /), &
+ 'm/s',.false.,'u_av','averaged longitudinal velocity')
+ case ('VV')
+ call write_to_file(ncid,'v',nf90_float,(/ timeDimID,partDimID /),vID,(/ 1,totpart /), &
+ 'm/s',.false.,'v','latitudinal velocity')
+ case ('vv')
+ call write_to_file(ncid,'v_av',nf90_float,(/ timeDimID,partDimID /),vavID,(/ 1,totpart /), &
+ 'm/s',.false.,'v_average','latitudinal velocity averaged')
+ case ('WW')
+ call write_to_file(ncid,'w',nf90_float,(/ timeDimID,partDimID /),wID,(/ 1,totpart /), &
+ 'm/s',.false.,'w','vertical velocity')
+ case ('ww')
+ call write_to_file(ncid,'w_av',nf90_float,(/ timeDimID,partDimID /),wavID,(/ 1,totpart /), &
+ 'm/s',.false.,'w_average','vertical velocity averaged')
+ case ('VS')
+ call write_to_file(ncid,'settling',nf90_float,(/ timeDimID,partDimID /),vsetID,(/ 1,totpart /), &
+ 'm/s',.false.,'settling_velocity','settling velocity')
+ case ('vs')
+ call write_to_file(ncid,'settling_av',nf90_float,(/ timeDimID,partDimID /),vsetavID,(/ 1,totpart /), &
+ 'm/s',.false.,'settling_velocity_average','settling velocity averaged')
+ case ('MA') ! Mass
+ if (mdomainfill.ge.1) then
+ call nf90_err(nf90_def_var(ncid=ncid, name='mass', xtype=nf90_float, dimids=1, varid=massID(1)))
+ call nf90_err(nf90_put_att(ncid, massID(1), 'units', 'kg'))
+ call nf90_err(nf90_put_att(ncid, massID(1), '_FillValue', fillval))
+ call nf90_err(nf90_put_att(ncid, massID(1), 'positive', 'up'))
+ call nf90_err(nf90_put_att(ncid, massID(1), 'standard_name', 'mass'))
+ call nf90_err(nf90_put_att(ncid, massID(1), 'long_name', 'mass of each particle'))
+ else
+ do j=1,nspec
+ ! Masses
+ write(anspec, '(i3.3)') j
+ call write_to_file(ncid,'mass'//anspec,nf90_float,(/ timeDimID,partDimID /),massID(j), &
+ (/ 1,totpart /),'kg',.true.,'mass'//anspec,'mass for nspec'//anspec)
+ end do
+ endif
+ case ('ma') ! Mass averaged
+ if (mdomainfill.ge.1) then
+ call nf90_err(nf90_def_var(ncid=ncid, name='mass_av', xtype=nf90_float, dimids=1, varid=massavID(1)))
+ call nf90_err(nf90_put_att(ncid, massavID(1), 'units', 'kg'))
+ call nf90_err(nf90_put_att(ncid, massavID(1), '_FillValue', fillval))
+ call nf90_err(nf90_put_att(ncid, massavID(1), 'positive', 'up'))
+ call nf90_err(nf90_put_att(ncid, massavID(1), 'standard_name', 'mass'))
+ call nf90_err(nf90_put_att(ncid, massavID(1), 'long_name', 'averaged mass of each particle'))
+ else
+ do j=1,nspec
+ ! Masses averaged
+ write(anspec, '(i3.3)') j
+ call write_to_file(ncid,'mass_av'//anspec,nf90_float,(/ timeDimID,partDimID /),massavID(j), &
+ (/ 1,totpart /),'kg',.true.,'mass'//anspec,'averaged mass for nspec'//anspec)
+ end do
+ endif
+ case ('WD') ! Cumulative mass of wet deposition
+ do j=1,nspec
+ ! Masses
+ write(anspec, '(i3.3)') j
+ call write_to_file(ncid,'wetdepo'//anspec,nf90_float,(/ timeDimID,partDimID /),wdID(j), &
+ (/ 1,totpart /),'kg',.true.,'mass'//anspec,'cumulative wet deposition for nspec'//anspec)
+ end do
+ case ('DD') ! Cumulative mass of dry deposition
+ do j=1,nspec
+ ! Masses
+ write(anspec, '(i3.3)') j
+ call write_to_file(ncid,'drydepo'//anspec,nf90_float,(/ timeDimID,partDimID /),ddID(j), &
+ (/ 1,totpart /),'kg',.true.,'mass'//anspec,'cumulative dry deposition for nspec'//anspec)
+ end do
+ case ('TO') ! Topography, written to grid if domainfill
+ if (mdomainfill.lt.1) then
+ call write_to_file(ncid,'topo',nf90_float,(/ timeDimID,partDimID /),topoID,(/ 1,totpart /), &
+ 'meters',.false.,'topography','topography above sealevel')
+ else
+ call write_to_file(ncid,'topo',nf90_float,(/ lonDimID,latDimID /),topoID,(/ nx,ny /), &
+ 'meters',.false.,'topography','topography above sealevel')
+ endif
+ case ('to') ! Topography averaged, no grid when domainfill
+ call write_to_file(ncid,'topo_av',nf90_float,(/ timeDimID,partDimID /),topoavID,(/ 1,totpart /), &
+ 'meters',.false.,'topography','averaged topography above sealevel')
+ case ('HM') ! Mixing layer height
+ if (mdomainfill.lt.1) then
+ call write_to_file(ncid,'hmix',nf90_float,(/ timeDimID,partDimID /),hmixID,(/ 1,totpart /), &
+ 'meters',.true.,'hmix','height above ground of mixing layer')
+ else
+ call write_to_file(ncid,'hmix',nf90_float,(/ timeDimID,lonDimID,latDimID /),hmixID,(/ 1,nx,ny /), &
+ 'meters',.true.,'hmix','height above ground of mixing layer')
+ endif
+ case ('hm') ! Mixing layer height averaged
+ call write_to_file(ncid,'hmix_av',nf90_float,(/ timeDimID,partDimID /),hmixavID,(/ 1,totpart /), &
+ 'meters',.true.,'hmix_average','averaged height above ground of mixing layer')
+ case ('TR') ! Tropopause
+ if (mdomainfill.lt.1) then
+ call write_to_file(ncid,'tr',nf90_float,(/ timeDimID,partDimID /),trID,(/ 1,totpart /), &
+ 'meters',.true.,'htropo','height above ground of tropopause')
+ else
+ call write_to_file(ncid,'tr',nf90_float,(/ timeDimID,lonDimID,latDimID /),trID,(/ 1,nx,ny /), &
+ 'meters',.true.,'htropo','height above ground of tropopause')
+ endif
+ case ('tr') ! Tropopause averaged
+ call write_to_file(ncid,'tr_av',nf90_float,(/ timeDimID,partDimID /),travID,(/ 1,totpart /), &
+ 'meters',.true.,'htropo_average','averaged height above ground of tropopause')
+ case default
+ write(*,*) 'The field you are trying to write to file is not coded in yet: ', partopt(np)%long_name
+ stop
+ end select
+ end do
+ ! global (metadata) attributes
+ !*******************************
+ call writemetadata(ncid,lnest=.false.)
+
+ ! moves the file from define to data mode
+ call nf90_err(nf90_enddef(ncid))
+
+ call nf90_err(nf90_close(ncid))
+
+ return
+110 write(*,FMT='(80("#"))')
+ write(*,*) 'ERROR: output directory ', trim(path(2)(1:length(2))), ' does not exist&
+ & (or failed to write there).'
+ write(*,*) 'EXITING'
+ write(*,FMT='(80("#"))')
+ stop
+end subroutine writeheader_partoutput
+
+subroutine write_to_file(ncid,short_name,xtype,dimids,varid,chunksizes,units,l_positive, &
+ standard_name,long_name)
+
+ !*****************************************************************************
+ ! *
+ ! Generalised writing data to netcdf file *
+ ! *
+ ! Author: L. Bakels 2022 *
+ ! *
+ !*****************************************************************************
+
+ implicit none
+
+ integer, intent(in) :: ncid, xtype
+ integer, intent(out) :: varid
+ character(len = *), intent(in) :: short_name,standard_name,long_name,units
+ integer, dimension(:), intent(in) :: dimids,chunksizes
+ logical, intent(in) :: l_positive
+
+ call nf90_err(nf90_def_var(ncid, short_name, xtype, dimids, varid))
+ call nf90_err(nf90_def_var_chunking(ncid,varid,NF90_CHUNKED,chunksizes=chunksizes))
+ call nf90_err(nf90_def_var_deflate(ncid,varid,shuffle=0,deflate=1,deflate_level=1))
+ call nf90_err(nf90_put_att(ncid, varid, 'units', units))
+ if(xtype.eq.nf90_float) then
+ call nf90_err(nf90_put_att(ncid, varid, '_FillValue', -1.))
+ else
+ call nf90_err(nf90_put_att(ncid, varid, '_FillValue', -1))
+ endif
+ if(l_positive) call nf90_err(nf90_put_att(ncid, varid, 'positive', 'up'))
+ call nf90_err(nf90_put_att(ncid, varid, 'standard_name', standard_name))
+ call nf90_err(nf90_put_att(ncid, varid, 'long_name', long_name))
+end subroutine write_to_file
+
+subroutine open_partoutput_file(ncid)!,irelease)
+
+ implicit none
+
+ integer, intent(inout) :: ncid
+ !integer, intent(in) :: irelease
+
+ call nf90_err(nf90_open(trim(ncfname_part), nf90_write, ncid))
+end subroutine open_partoutput_file
+
+subroutine close_partoutput_file(ncid)
+
+ implicit none
+
+ integer :: ncid
+
+ call nf90_err(nf90_close(ncid))
+end subroutine close_partoutput_file
+
+subroutine open_partinit_file(ncid)!,irelease)
+
+ implicit none
+
+ integer, intent(inout) :: ncid
+ !integer, intent(in) :: irelease
+
+ call nf90_err(nf90_open(trim(ncfname_partinit), nf90_write, ncid))
+end subroutine open_partinit_file
+
+subroutine partoutput_netcdf(itime,field,fieldname,imass,ncid)
+
+
+ !*****************************************************************************
+ ! *
+ ! Writing a field from PARTOPTIONS to partoutput_xxx.nc created in *
+ ! writeheader_partoutput *
+ ! *
+ ! Author: L. Bakels 2021 *
+ ! *
+ !*****************************************************************************
+
+ implicit none
+
+ integer, intent(in) :: itime,imass
+ real, intent(in) :: field(:)
+ character(2), intent(in) :: fieldname ! input field to interpolate over
+ integer, allocatable :: partindices(:)
+ integer :: ncid,newpart,j
+ ! ! open output file
+ ! call nf90_err(nf90_open(trim(ncfname_part), nf90_write, ncid))
+ select case(fieldname)
+ case('TI')
+ ! write time
+ tpointer_part = tpointer_part + 1
+ call nf90_err(nf90_put_var(ncid, timeIDpart, itime, (/ tpointer_part /)))
+ case('PA')
+ newpart = numpart - ppointer_part
+
+ if (tpointer_part.eq.1) then
+ allocate ( partindices(numpart) )
+ do j=1,numpart
+ partindices(j)=j
+ end do
+
+ call nf90_err(nf90_put_var(ncid, partID,partindices, (/ 1 /),(/ numpart /)))
+
+ deallocate (partindices)
+
+ ppointer_part = numpart
+
+ else if (newpart.ge.0) then
+
+ allocate ( partindices(newpart) )
+ do j=1,newpart
+ partindices(j)=j+ppointer_part
+ end do
+
+ call nf90_err(nf90_put_var(ncid, partID,partindices, (/ ppointer_part+1 /),(/ newpart /)))
+
+ deallocate (partindices)
+
+ ppointer_part = numpart
+ endif
+ case('LO') ! Longitude
+ call nf90_err(nf90_put_var(ncid,lonIDpart,field, (/ tpointer_part,1 /),(/ 1,numpart /)))
+ case('lo') ! Longitude averaged
+ call nf90_err(nf90_put_var(ncid,lonavIDpart,field, (/ tpointer_part,1 /),(/ 1,numpart /)))
+ case('LA') ! Latitude
+ call nf90_err(nf90_put_var(ncid,latIDpart,field, (/ tpointer_part,1 /),(/ 1,numpart /)))
+ case('la') ! Latitude averaged
+ call nf90_err(nf90_put_var(ncid,latavIDpart,field, (/ tpointer_part,1 /),(/ 1,numpart /)))
+ case('ZZ') ! Height
+ call nf90_err(nf90_put_var(ncid,levIDpart,field, (/ tpointer_part,1 /),(/ 1,numpart /)))
+ case('zz') ! Height averaged
+ call nf90_err(nf90_put_var(ncid,levavIDpart,field, (/ tpointer_part,1 /),(/ 1,numpart /)))
+ case('IT') ! Itramem (not in use atm)
+ call nf90_err(nf90_put_var(ncid,itramemID,field, (/ tpointer_part,1 /),(/ 1,numpart /)))
+ case('TO') ! Topography
+ if (mdomainfill.ge.1) then
+ if (topo_written.eqv..false.) call nf90_err(nf90_put_var(ncid,topoID,oro(0:nx-1,0:ny-1), (/ 1,1 /),(/ nx,ny /)))
+ topo_written=.true.
+ else
+ call nf90_err(nf90_put_var(ncid,topoID,field, (/ tpointer_part,1 /),(/ 1,numpart /)))
+ endif
+ case('to') ! topography averaged
+ call nf90_err(nf90_put_var(ncid,topoavID,field, (/ tpointer_part,1 /),(/ 1,numpart /)))
+ case('PV') ! Potential vorticity
+ call nf90_err(nf90_put_var(ncid,pvID,field, (/ tpointer_part,1 /),(/ 1,numpart /)))
+ case('pv') ! Potential vorticity averaged
+ call nf90_err(nf90_put_var(ncid,pvavID,field, (/ tpointer_part,1 /),(/ 1,numpart /)))
+ case('PR') ! Pressure
+ call nf90_err(nf90_put_var(ncid,prID,field, (/ tpointer_part,1 /),(/ 1,numpart /)))
+ case('pr') ! Pressure averaged
+ call nf90_err(nf90_put_var(ncid,pravID,field, (/ tpointer_part,1 /),(/ 1,numpart /)))
+ case('QV') ! Specific humidity
+ call nf90_err(nf90_put_var(ncid,qvID,field, (/ tpointer_part,1 /),(/ 1,numpart /)))
+ case('qv') ! Specific humidity averaged
+ call nf90_err(nf90_put_var(ncid,qvavID,field, (/ tpointer_part,1 /),(/ 1,numpart /)))
+ case('RH') ! Air density
+ call nf90_err(nf90_put_var(ncid,rhoID,field, (/ tpointer_part,1 /),(/ 1,numpart /)))
+ case('rh') ! Air density averaged
+ call nf90_err(nf90_put_var(ncid,rhoavID,field, (/ tpointer_part,1 /),(/ 1,numpart /)))
+ case('UU') ! Longitudinal velocity
+ call nf90_err(nf90_put_var(ncid,uID,field, (/ tpointer_part,1 /),(/ 1,numpart /)))
+ case('uu') ! Longitudinal velocity averaged
+ call nf90_err(nf90_put_var(ncid,uavID,field, (/ tpointer_part,1 /),(/ 1,numpart /)))
+ case('VV') ! Latitudinal velocity
+ call nf90_err(nf90_put_var(ncid,vID,field, (/ tpointer_part,1 /),(/ 1,numpart /)))
+ case('vv') ! Latitudinal velocity averaged
+ call nf90_err(nf90_put_var(ncid,vavID,field, (/ tpointer_part,1 /),(/ 1,numpart /)))
+ case('WW') ! Vertical velocity
+ call nf90_err(nf90_put_var(ncid,wID,field, (/ tpointer_part,1 /),(/ 1,numpart /)))
+ case('ww') ! Vertical velocity averaged
+ call nf90_err(nf90_put_var(ncid,wavID,field, (/ tpointer_part,1 /),(/ 1,numpart /)))
+ case('VS') ! Settling velocity
+ call nf90_err(nf90_put_var(ncid,vsetID,field, (/ tpointer_part,1 /),(/ 1,numpart /)))
+ case('vs') ! Settling velocity averaged
+ call nf90_err(nf90_put_var(ncid,vsetavID,field, (/ tpointer_part,1 /),(/ 1,numpart /)))
+ case('HM') ! Mixing height
+ if (mdomainfill.ge.1) then
+ call nf90_err(nf90_put_var(ncid,hmixID,hmix(0:nx-1,0:ny-1,1,memind(1)), &
+ (/ tpointer_part,1,1 /),(/ 1,nx,ny /)))
+ else
+ call nf90_err(nf90_put_var(ncid,hmixID,field, (/ tpointer_part,1 /),(/ 1,numpart /)))
+ endif
+ case('hm') ! Mixing height averaged
+ call nf90_err(nf90_put_var(ncid,hmixavID,field, (/ tpointer_part,1 /),(/ 1,numpart /)))
+ case('TR') ! Tropopause
+ if (mdomainfill.ge.1) then
+ call nf90_err(nf90_put_var(ncid,trID,tropopause(0:nx-1,0:ny-1,1,memind(1)), &
+ (/ tpointer_part,1,1 /),(/ 1,nx,ny /)))
+ else
+ call nf90_err(nf90_put_var(ncid,trID,field, (/ tpointer_part,1 /),(/ 1,numpart /)))
+ endif
+ case('tr') ! Tropopause averaged
+ call nf90_err(nf90_put_var(ncid,travID,field, (/ tpointer_part,1 /),(/ 1,numpart /)))
+ case('TT') ! Temperature
+ call nf90_err(nf90_put_var(ncid,ttID,field, (/ tpointer_part,1 /),(/ 1,numpart /)))
+ case('tt') ! Temperature averaged
+ call nf90_err(nf90_put_var(ncid,ttavID,field, (/ tpointer_part,1 /),(/ 1,numpart /)))
+ case('MA') ! Mass
+ if ((mdomainfill.ge.1).and.(imass.eq.1)) then
+ if (mass_written.eqv..false.) call nf90_err(nf90_put_var(ncid=ncid,varid=massID(1),values=field(1)))
+ mass_written=.true.
+ else
+ call nf90_err(nf90_put_var(ncid,massID(imass),field, (/ tpointer_part,1 /),(/ 1,numpart /)))
+ endif
+ case('ma') ! Mass averaged
+ if ((mdomainfill.ge.1).and.(imass.eq.1)) then
+ if (mass_written.eqv..false.) call nf90_err(nf90_put_var(ncid=ncid,varid=massavID(1),values=field(1)))
+ massav_written=.true.
+ else
+ call nf90_err(nf90_put_var(ncid,massavID(imass),field, (/ tpointer_part,1 /),(/ 1,numpart /)))
+ endif
+ case('WD') ! Cumulative mass of wet deposition
+ call nf90_err(nf90_put_var(ncid,wdID(imass),field, (/ tpointer_part,1 /),(/ 1,numpart /)))
+ case('DD') ! Cumulative mass of wet deposition
+ call nf90_err(nf90_put_var(ncid,ddID(imass),field, (/ tpointer_part,1 /),(/ 1,numpart /)))
+ end select
+
+ ! call nf90_err(nf90_close(ncid))
+end subroutine partoutput_netcdf
+
+subroutine readpartpositions_netcdf(ibtime,ibdate)
+
+ !*****************************************************************************
+ ! *
+ ! IPIN=2: restarting from a partoutput_xxx.nc file written by a previous *
+ ! run, depending on what PARTOPTIONS the user has chosen, this *
+ ! option might not be possible to use *
+ ! *
+ ! Author: L. Bakels 2022 *
+ ! *
+ !*****************************************************************************
+
+ use random_mod
+ use particle_mod
+ use date_mod
+
+ implicit none
+
+ integer, intent(in) :: ibtime,ibdate
+ integer :: ncidend,tIDend,pIDend,tempIDend
+ integer :: tlen,plen,tend,i,j
+ integer :: idate_start,itime_start
+ character :: adate*8,atime*6,timeunit*32,adate_start*8,atime_start*6
+ character(len=3) :: anspec
+ real(kind=dp) :: julin,julcommand,julpartin
+
+ integer :: idummy = -8
+
+ write(adate,'(i8.8)') ibdate
+ write(atime,'(i6.6)') ibtime
+
+ if (mquasilag.ne.0) then
+ write(*,*) 'Combination of ipin, netcdf partoutput, and mquasilag!=0 does not work yet'
+ stop
+ endif
+
+ ! Open partoutput_end.nc file
+ call nf90_err(nf90_open(trim('partoutput_end.nc'), mode=NF90_NOWRITE,ncid=ncidend))
+
+ ! Take the positions of the particles at the last timestep in the file
+ ! It needs to be the same as given in the COMMAND file, this is arbitrary
+ ! and should be removed in the future for easier use
+
+ ! First get the time dimension
+ call nf90_err(nf90_inq_dimid(ncid=ncidend,name='time',dimid=tIDend))
+ call nf90_err(nf90_inquire_dimension(ncid=ncidend,dimid=tIDend,len=tlen))
+
+ ! Check if the time corresponds to the one given in the COMMAND file
+ call nf90_err(nf90_inq_varid(ncid=ncidend,name='time',varid=tIDend))
+ call nf90_err(nf90_get_att(ncid=ncidend,varid=tIDend,name='units',values=timeunit))
+ call nf90_err(nf90_get_var(ncid=ncidend,varid=tIDend,values=tend,start=(/ tlen /)))!,count=(/ 1 /)))
+ adate_start(1:4) = timeunit(15:18)
+ adate_start(5:6) = timeunit(20:21)
+ adate_start(7:8) = timeunit(23:24)
+ atime_start = '000000'
+ atime_start(1:2) = timeunit(26:27)
+ atime_start(3:4) = timeunit(29:30)
+ read(adate_start,*) idate_start
+ read(atime_start,*) itime_start
+ julin = juldate(idate_start,itime_start)+real(tend,kind=dp)/86400._dp
+ julcommand = juldate(ibdate,ibtime)
+ if (abs(julin-julcommand).gt.1.e-5) then
+ write(*,*) 'ERROR: The given starting time and date do not correspond to'
+ write(*,*) 'the last timestep of partoutput_end.nc:'
+ write(*,*) julin,julcommand,tend
+ stop
+ endif
+
+ ! Then the particle dimension
+ call nf90_err(nf90_inq_dimid(ncid=ncidend,name='particle',dimid=pIDend))
+ call nf90_err(nf90_inquire_dimension(ncid=ncidend,dimid=pIDend,len=plen))
+
+ ! Now spawn the correct number of particles
+ write(*,*) 'Npart:',plen
+ call spawn_particles(0,plen)
+
+ ! And give them the correct positions
+ ! Longitude
+ call nf90_err(nf90_inq_varid(ncid=ncidend,name='longitude',varid=tempIDend))
+ call nf90_err(nf90_get_var(ncid=ncidend,varid=tempIDend,values=part(:)%xlon, &
+ start=(/ tlen, 1 /),count=(/ 1, plen /)))
+ part(:)%xlon=(part(:)%xlon-xlon0)/dx
+ ! Latitude
+ call nf90_err(nf90_inq_varid(ncid=ncidend,name='latitude',varid=tempIDend))
+ call nf90_err(nf90_get_var(ncid=ncidend,varid=tempIDend,values=part(:)%ylat, &
+ start=(/ tlen, 1 /),count=(/ 1, plen /)))
+ part(:)%ylat=(part(:)%ylat-ylat0)/dx
+ ! Height
+ call nf90_err(nf90_inq_varid(ncid=ncidend,name='height',varid=tempIDend))
+ call nf90_err(nf90_get_var(ncid=ncidend,varid=tempIDend,values=part(:)%z, &
+ start=(/ tlen, 1 /),count=(/ 1, plen /)))
+ ! Mass
+ if (mdomainfill.eq.0) then
+ do j=1,nspec
+ write(anspec, '(i3.3)') j
+ call nf90_err(nf90_inq_varid(ncid=ncidend,name='mass'//anspec,varid=tempIDend))
+ call nf90_err(nf90_get_var(ncid=ncidend,varid=tempIDend,values=part(:)%mass(j), &
+ start=(/ tlen, 1 /),count=(/ 1, plen /)))
+ end do
+ endif
+
+ do i=1,plen
+ if (part(i)%z.lt.0) then
+ call terminate_particle(i,0)
+ write(*,*) 'Particle ',i,'is not alive in the restart file.'
+ endif
+ part(i)%nclass=min(int(ran1(idummy,0)*real(nclassunc))+1, &
+ nclassunc)
+ part(i)%idt=mintime
+ part(i)%npoint=1
+ end do
+
+ call nf90_err(nf90_close(ncidend))
+end subroutine readpartpositions_netcdf
+
+subroutine readinitconditions_netcdf()
+
+ !*****************************************************************************
+ ! *
+ ! IPIN=3: starting a run from a user defined initial particle conditions, *
+ ! more on how to create such a file can be found in the manual *
+ ! IPIN=4: restarting a run, while also reading in the initial particle *
+ ! conditions *
+ ! *
+ ! Author: L. Bakels 2022 *
+ ! *
+ !*****************************************************************************
+
+ use random_mod
+ use particle_mod
+ use date_mod
+ use coordinates_ecmwf_mod
+ use readoptions_mod
+ use drydepo_mod
+
+ implicit none
+
+ integer :: ncidend,tIDend,pIDend,tempIDend,stat
+ integer :: plen,tend,i,j,release_max,nsp
+ integer :: zkind
+ real :: totmass,cun
+ integer,allocatable, dimension (:) :: specnum_rel,numpoint_max
+ real,allocatable,dimension(:,:) :: mass_temp
+ real,allocatable,dimension(:) :: vsh,fracth,schmih
+
+ integer :: idummy = -8
+
+ if (mquasilag.ne.0) then
+ write(*,*) 'Combination of ipin, netcdf partoutput, and mquasilag!=0 does not work yet'
+ stop
+ endif
+
+ ! Open part_ic.nc file
+ call nf90_err(nf90_open(trim(path(2)(1:length(2))//'part_ic.nc'), mode=NF90_NOWRITE,ncid=ncidend))
+
+ ! allocate with maxspec for first input loop
+ allocate(specnum_rel(maxspec),stat=stat)
+ if (stat.ne.0) write(*,*)'ERROR: could not allocate specnum_rel'
+
+ ! How many species are contained in each particle?
+ call nf90_err(nf90_inquire_attribute(ncid=ncidend,name='nspecies',varid=NF90_GLOBAL))
+ call nf90_err(nf90_get_att(ncid=ncidend,varid=NF90_GLOBAL,name='nspecies',values=nspec))
+
+ ! Which species?
+ call nf90_err(nf90_inquire_attribute(ncid=ncidend,name='species',varid=NF90_GLOBAL))
+ call nf90_err(nf90_get_att(ncid=ncidend,varid=NF90_GLOBAL,name='species',values=specnum_rel(1:nspec)))
+
+ ! Get the particle dimension
+ call nf90_err(nf90_inq_dimid(ncid=ncidend,name='particle',dimid=pIDend))
+ call nf90_err(nf90_inquire_dimension(ncid=ncidend,dimid=pIDend,len=plen))
+
+ ! Now spawn the correct number of particles
+ write(*,*) 'Npart:',plen
+ call allocate_particles( plen )
+ ! allocate temporary mass array
+ allocate(mass_temp(plen,nspec))
+
+ ! And give them the correct positions
+ ! Longitude
+ call nf90_err(nf90_inq_varid(ncid=ncidend,name='longitude',varid=tempIDend))
+ call nf90_err(nf90_get_var(ncid=ncidend,varid=tempIDend,values=part(:)%xlon, &
+ start=(/ 1 /),count=(/ plen /)))
+ part(:)%xlon=(part(:)%xlon-xlon0)/dx
+ ! Latitude
+ call nf90_err(nf90_inq_varid(ncid=ncidend,name='latitude',varid=tempIDend))
+ call nf90_err(nf90_get_var(ncid=ncidend,varid=tempIDend,values=part(:)%ylat, &
+ start=(/ 1 /),count=(/ plen /)))
+ part(:)%ylat=(part(:)%ylat-ylat0)/dx
+ ! Height
+ call nf90_err(nf90_inq_varid(ncid=ncidend,name='height',varid=tempIDend))
+ call nf90_err(nf90_get_var(ncid=ncidend,varid=tempIDend,values=part(:)%z, &
+ start=(/ 1 /),count=(/ plen /)))
+ ! Spawning time
+ call nf90_err(nf90_inq_varid(ncid=ncidend,name='time',varid=tempIDend))
+ call nf90_err(nf90_get_var(ncid=ncidend,varid=tempIDend,values=part(:)%tstart, &
+ start=(/ 1 /),count=(/ plen /)))
+ ! Mass
+ call nf90_err(nf90_inq_varid(ncid=ncidend,name='mass',varid=tempIDend))
+ call nf90_err(nf90_get_var(ncid=ncidend,varid=tempIDend,values=mass_temp, &
+ start=(/ 1,1 /),count=(/ plen,nspec /)))
+ do nsp=1,nspec
+ part(:)%mass(nsp)=mass_temp(1:plen,nsp)
+ end do
+ deallocate(mass_temp)
+ ! Release
+ call nf90_err(nf90_inq_varid(ncid=ncidend,name='release',varid=tempIDend))
+ call nf90_err(nf90_get_var(ncid=ncidend,varid=tempIDend,values=part(:)%npoint, &
+ start=(/ 1 /),count=(/ plen /)))
+ ! ! Species
+ ! call nf90_err(nf90_inq_varid(ncid=ncidend,name='species',varid=tempIDend))
+ ! call nf90_err(nf90_get_var(ncid=ncidend,varid=tempIDend,values=part(:)%species, &
+ ! start=(/ 1 /),count=(/ plen /)))
+
+ ! Count number of releases
+ numpoint=1
+ allocate(numpoint_max(plen),stat=stat)
+ numpoint_max=0
+ release_max=0
+
+ l1: do i=1,plen
+ l2: do j=1,numpoint
+ if (part(i)%npoint.eq.numpoint_max(numpoint)) then
+ cycle l1
+ endif
+ end do l2
+ numpoint = numpoint+1
+ numpoint_max(numpoint)=part(i)%npoint
+ if (part(i)%npoint.gt.release_max) release_max=part(i)%npoint
+ end do l1
+
+ allocate(kindz(numpoint),stat=stat)
+ kindz=-1
+ if (stat.ne.0) write(*,*)'ERROR: could not allocate kindz'
+ ! Above sea-level or ground?
+ call nf90_err(nf90_inquire_attribute(ncid=ncidend,name='kindz',varid=NF90_GLOBAL))
+ call nf90_err(nf90_get_att(ncid=ncidend,varid=NF90_GLOBAL,name='kindz',values=zkind))
+ kindz=zkind
+ do nsp=1,nspec
+ if ((kindz(nsp).le.0).or.(kindz(nsp).ge.4)) then
+ write(*,*) 'ERROR: kindz should be an integer between 1 and 3, not', kindz(nsp)
+ stop
+ endif
+ end do
+
+ if (ioutputforeachrelease.eq.1) then
+ maxpointspec_act=numpoint
+ else
+ maxpointspec_act=1
+ endif
+
+ if (release_max.gt.numpoint) then
+ write(*,*) "WARNING: release numbers in part_ic.nc are not consecutive:", &
+ release_max, "is larger than the total number of releases:", numpoint, &
+ " Releases will be renumbered."
+
+ do j=1,numpoint
+ do i=1,plen
+ if (part(i)%npoint.eq.numpoint_max(j)) then
+ part(i)%npoint=numpoint_max(j)
+ endif
+ end do
+ end do
+ endif
+ deallocate(numpoint_max)
+
+ allocate(xmass(numpoint,nspec), npart(numpoint),ireleasestart(numpoint),ireleaseend(numpoint))
+ xmass=0
+ npart=0
+ ireleasestart=-1
+ ireleaseend=-1
+ do i=1,plen
+ do j=1,numpoint
+ do nsp=1,nspec
+ xmass(j,nsp) = xmass(j,nsp)+part(i)%mass(nsp)
+ end do
+ if (part(i)%npoint.eq.j) then
+ npart(j)=npart(j)+1
+ if ((ireleasestart(j).gt.part(i)%tstart).or.(ireleasestart(j).eq.-1)) ireleasestart(j)=part(i)%tstart
+ if ((ireleaseend(j).le.part(i)%tstart).or.(ireleaseend(j).eq.-1)) ireleaseend(j)=part(i)%tstart
+ endif
+ end do
+ end do
+ if ((iout.eq.4).or.(iout.eq.5)) then
+ write(*,*) "ERROR: IPIN=3 or IPIN=4, using the part_ic.nc file, is not possible in combination with plume", &
+ "computations (IOUT=4 or 5)."
+ stop
+ endif
+
+ part(:)%idt=part(:)%tstart
+ do i=1,plen
+ part(i)%nclass=min(int(ran1(idummy,0)*real(nclassunc))+1, &
+ nclassunc)
+ part(i)%mass_init=part(i)%mass
+ ! Activate particles that are alive from the start of the simulation
+ if (part(i)%tstart.eq.0) then
+ call spawn_particle(0,i)
+ endif
+ end do
+ write(*,FMT='(A,ES14.7)') ' Total mass to be released:', sum(xmass(1:numpoint,1:nspec))
+ call get_total_part_num(numpart)
+ numparticlecount=numpart
+ call nf90_err(nf90_close(ncidend))
+
+
+ ! Read species and derive initial conditions
+
+ !now save the information
+ DEP=.false.
+ DRYDEP=.false.
+ WETDEP=.false.
+ OHREA=.false.
+ do nsp=1,maxspec
+ DRYDEPSPEC(nsp)=.false.
+ WETDEPSPEC(nsp)=.false.
+ end do
+
+ do nsp=1,nspec
+ call readspecies(specnum_rel(nsp),nsp)
+ ! Allocate temporary memory necessary for the different diameter bins
+ !********************************************************************
+ allocate(vsh(ndia(nsp)),fracth(ndia(nsp)),schmih(ndia(nsp)))
+
+ ! Molecular weight
+ !*****************
+ if (((iout.eq.2).or.(iout.eq.3)).and.(weightmolar(nsp).lt.0.)) then
+ write(*,*) 'For mixing ratio output, valid molar weight'
+ write(*,*) 'must be specified for all simulated species.'
+ write(*,*) 'Check table SPECIES or choose concentration'
+ write(*,*) 'output instead if molar weight is not known.'
+ stop
+ endif
+
+ ! Radioactive decay
+ !******************
+ decay(nsp)=0.693147/decay(nsp) !conversion half life to decay constant
+
+ ! Dry deposition of gases
+ !************************
+
+ if (reldiff(nsp).gt.0.) rm(nsp)=1./(henry(nsp)/3000.+100.*f0(nsp)) ! mesophyll resistance
+
+ ! Dry deposition of particles
+ !****************************
+
+ vsetaver(nsp)=0.
+ cunningham(nsp)=0.
+ dquer(nsp)=dquer(nsp)*1000000. ! Conversion m to um
+ if (density(nsp).gt.0.) then ! Additional parameters
+ call part0(dquer(nsp),dsigma(nsp),density(nsp),ndia(nsp),fracth,schmih,cun,vsh)
+ do j=1,ndia(nsp)
+ fract(nsp,j)=fracth(j)
+ schmi(nsp,j)=schmih(j)
+ vset(nsp,j)=vsh(j)
+ cunningham(nsp)=cunningham(nsp)+cun*fract(nsp,j)
+ vsetaver(nsp)=vsetaver(nsp)-vset(nsp,j)*fract(nsp,j)
+ end do
+ if (lroot) write(*,*) 'Average settling velocity: ',i,vsetaver(nsp)
+ endif
+
+ ! Dry deposition for constant deposition velocity
+ !************************************************
+
+ dryvel(nsp)=dryvel(nsp)*0.01 ! conversion to m/s
+
+ ! Check if wet deposition or OH reaction shall be calculated
+ !***********************************************************
+
+ ! ESO 04.2016 check for below-cloud scavenging (gas or aerosol)
+ if ((dquer(nsp).le.0..and.(weta_gas(nsp).gt.0. .or. wetb_gas(nsp).gt.0.)) .or. &
+ &(dquer(nsp).gt.0. .and. (crain_aero(nsp) .gt. 0. .or. csnow_aero(nsp).gt.0.))) then
+ WETDEP=.true.
+ WETDEPSPEC(nsp)=.true.
+ if (lroot) then
+ write (*,*) ' Below-cloud scavenging: ON'
+ end if
+ else
+ if (lroot) write (*,*) ' Below-cloud scavenging: OFF'
+ endif
+
+ ! NIK 31.01.2013 + 10.12.2013 + 15.02.2015
+ if (dquer(nsp).gt.0..and.(ccn_aero(nsp).gt.0. .or. in_aero(nsp).gt.0.)) then
+ WETDEP=.true.
+ WETDEPSPEC(nsp)=.true.
+ if (lroot) then
+ write (*,*) ' In-cloud scavenging: ON'
+ end if
+ else
+ if (lroot) write (*,*) ' In-cloud scavenging: OFF'
+ endif
+
+ if (ohcconst(nsp).gt.0.) then
+ OHREA=.true.
+ if (lroot) write (*,*) ' OHreaction switched on: ',ohcconst(nsp),nsp
+ endif
+
+ if ((reldiff(nsp).gt.0.).or.(density(nsp).gt.0.).or.(dryvel(nsp).gt.0.)) then
+ DRYDEP=.true.
+ DRYDEPSPEC(nsp)=.true.
+ endif
+
+ deallocate(vsh,fracth,schmih)
+ end do ! end loop over species
+
+ if (WETDEP.or.DRYDEP) then
+ DEP=.true.
+ endif
+
+
+ deallocate(specnum_rel)
+end subroutine readinitconditions_netcdf
+
+end module netcdf_output_mod
diff --git a/src/oh_mod.f90 b/src/oh_mod.f90
index d9584950..b909464f 100644
--- a/src/oh_mod.f90
+++ b/src/oh_mod.f90
@@ -5,7 +5,8 @@ module oh_mod
!includes OH concentration field as well as the height information
!for this field
-
+ use date_mod
+
implicit none
integer :: nxOH,nyOH,nzOH
@@ -17,4 +18,435 @@ module oh_mod
real, dimension(360) :: lonjr
real, dimension(180) :: latjr
+contains
+
+real function photo_O1D(sza)
+
+ !*****************************************************************************
+ ! *
+ ! *
+ ! Author: A. Stohl *
+ ! *
+ ! Nov 2014 *
+ ! *
+ ! *
+ !*****************************************************************************
+ ! *
+ ! INPUT: *
+ ! sza solar zenith angle (degrees) *
+ ! *
+ ! OUTPUT: *
+ ! photo_O1D J(O1D) photoylsis rate *
+ ! *
+ !*****************************************************************************
+
+ implicit none
+
+ integer :: iz,ik
+ real :: sza
+ real :: z1,z2,zg,f1,f2,dummy
+ real :: photo_NO2
+ integer, parameter :: nzenith=11
+ real, parameter :: pi=3.1415927
+ real, dimension(nzenith) :: zangle,fact_photo
+
+ ! zangle: zenith angles for which fact_photo is tabulated
+ ! fact_photo: conversion of photolysis rate of NO2 to photolysis
+ ! rate of O3 into O1D as a function of solar zenith angle
+
+ zangle=(/0.,10.,20.,30.,40.,50.,60.,70.,78.,86.,90.0001/)
+ fact_photo=(/0.4616E-02,0.4478E-02,0.4131E-02,0.3583E-02,0.2867E-02,&
+ &0.2081E-02,0.1235E-02,0.5392E-03,0.2200E-03,0.1302E-03,0.0902E-03/)
+
+ if (sza.lt.90.) then
+ do iz=1,nzenith-1
+ if(sza.ge.zangle(iz)) ik=iz
+ end do
+ z1=1./cos(zangle(ik)*pi/180.)
+ z2=1./cos(zangle(ik+1)*pi/180.)
+ zg=1./cos(sza*pi/180.)
+ dummy=(zg-z1)/(z2-z1)
+ f1=alog(fact_photo(ik))
+ f2=alog(fact_photo(ik+1))
+ photo_NO2=1.45e-2*exp(-0.4/cos(sza*pi/180.))
+ photo_O1D=photo_NO2*exp(f1+(f2-f1)*dummy)
+ else
+ photo_O1D=0.
+ endif
+
+ return
+
+end function photo_O1D
+
+real function zenithangle(ylat,xlon,jul)
+
+ !*********************************************************************
+ ! *
+ ! Author: G. WOTAWA *
+ ! Date: 1993-11-17 *
+ ! Project: POP-M *
+ ! Last update: *
+ ! *
+ !*********************************************************************
+ ! *
+ ! DESCRIPTION: This function returns the sinus of solar *
+ ! elevation as a function of geographic longitude, *
+ ! latitude and GMT-Time. *
+ ! *
+ !*********************************************************************
+ ! *
+ ! INPUT: *
+ ! *
+ ! ylat geographical latitude [DEG] *
+ ! xlon geographical longitude [DEG] *
+ ! jjjj Year *
+ ! mm Month *
+ ! dd Day *
+ ! hh Hour *
+ ! minute Minute *
+ ! *
+ !*********************************************************************
+
+ use par_mod, only: dp
+
+ implicit none
+
+ integer :: jjjj,mm,id,iu,minute,yyyymmdd,hhmmss
+ integer :: ndaynum
+ real :: sinsol,solelev,ylat,xlon
+ real :: rnum,rylat,ttime,dekl,rdekl,eq
+ real,parameter :: pi=3.1415927
+ real(kind=dp) :: jul
+
+ call caldate(jul,yyyymmdd,hhmmss)
+ jjjj=yyyymmdd/10000
+ mm=yyyymmdd/100-jjjj*100
+ id=yyyymmdd-jjjj*10000-mm*100
+ iu=hhmmss/10000
+ minute=hhmmss/100-100*iu
+
+ ndaynum=31*(mm-1)+id
+ if(mm.gt.2) ndaynum=ndaynum-int(0.4*mm+2.3)
+ if((mm.gt.2).and.(jjjj/4*4.eq.jjjj)) ndaynum=ndaynum+1
+
+ rnum=2.*pi*ndaynum/365.
+ rylat=pi*ylat/180.
+ ttime=real(iu)+real(minute)/60.
+
+ dekl=0.396+3.631*sin(rnum)+0.038*sin(2.*rnum)+0.077*sin(3.*rnum)- &
+ 22.97*cos(rnum)-0.389*cos(2.*rnum)-0.158*cos(3.*rnum)
+ rdekl=pi*dekl/180.
+
+ eq=(0.003-7.343*sin(rnum)-9.47*sin(2.*rnum)- &
+ 0.329*sin(3.*rnum)-0.196*sin(4.*rnum)+ &
+ 0.552*cos(rnum)-3.020*cos(2.*rnum)- &
+ 0.076*cos(3.*rnum)-0.125*cos(4.*rnum))/60.
+
+ sinsol=sin(rylat)*sin(rdekl)+cos(rylat)*cos(rdekl)* &
+ cos((ttime-12.+xlon/15.+eq)*pi/12.)
+ ! Calculate the maximum solar elevation on that day
+ !sinsol=sin(rylat)*sin(rdekl)+cos(rylat)*cos(rdekl)*
+ ! & cos((eq)*pi/12.)
+ solelev=asin(sinsol)*180./pi
+ zenithangle=90.-solelev
+
+ return
+end function zenithangle
+
+subroutine ohreaction(itime,ltsample,loutnext)
+ ! i i i
+ !*****************************************************************************
+ ! *
+ ! *
+ ! Author: R.L. Thompson *
+ ! *
+ ! Nov 2014 *
+ ! *
+ ! *
+ !*****************************************************************************
+ ! Variables: *
+ ! ix,jy indices of output grid cell for each particle *
+ ! itime [s] actual simulation time [s] *
+ ! jpart particle index *
+ ! ldeltat [s] interval since radioactive decay was computed *
+ ! loutnext [s] time for which gridded deposition is next output *
+ ! loutstep [s] interval at which gridded deposition is output *
+ ! oh_average [molecule/cm^3] OH Concentration *
+ ! ltsample [s] interval over which mass is deposited *
+ ! *
+ !*****************************************************************************
+ use par_mod
+ use com_mod
+ use windfields_mod
+ use particle_mod
+
+ implicit none
+
+ integer :: jpart,itime,ltsample,loutnext,ldeltat,j,k,ix,jy!,ijx,jjy
+!PS integer :: ngrid,interp_time,m,n,ih,indz,i!,ia,il
+ integer :: ngrid,interp_time,n,indz,i!,ia,il
+!PS integer :: jjjjmmdd,hhmmss,
+ integer OHx,OHy,OHz
+ real, dimension(nzOH) :: altOHtop
+ real :: xlon,ylat
+ real :: xtn,ytn
+ real :: restmass,ohreacted,oh_average
+ real :: ohrate,temp
+ real, parameter :: smallnum = tiny(0.0) ! smallest number that can be handled
+ real(kind=dp) :: jul
+
+ ! Compute interval since radioactive decay of deposited mass was computed
+ !************************************************************************
+
+ if (itime.le.loutnext) then
+ ldeltat=itime-(loutnext-loutstep)
+ else ! first half of next interval
+ ldeltat=itime-loutnext
+ endif
+
+!PS jul=bdate+real(itime,kind=dp)/86400.
+!PS call caldate(jul,jjjjmmdd,hhmmss)
+!PS m=(jjjjmmdd-(jjjjmmdd/10000)*10000)/100
+!PS h=hhmmss/10000
+
+ ! Loop over particles
+ !*****************************************
+!$OMP PARALLEL PRIVATE(jpart,xtn,ytn,j,k,ix,jy,interp_time, &
+!$OMP n,indz,i,xlon,ylat,OHx,OHy,OHz,oh_average,temp,ohrate, &
+!$OMP restmass,ohreacted,altOHtop,ngrid)
+
+!$OMP DO
+ do jpart=1,numpart
+
+ ! Determine which nesting level to be used
+ ngrid=0
+ do j=numbnests,1,-1 ! Why is there a +/- eps everywhere else for ngrid but not here?
+ if ((part(jpart)%xlon.gt.xln(j)).and.(part(jpart)%xlon.lt.xrn(j)).and. &
+ (part(jpart)%ylat.gt.yln(j)).and.(part(jpart)%ylat.lt.yrn(j))) then
+ ngrid=j
+ exit
+ endif
+ end do
+
+ ! Determine nested grid coordinates
+ if (ngrid.gt.0) then
+ xtn=(part(jpart)%xlon-xln(ngrid))*xresoln(ngrid)
+ ytn=(part(jpart)%ylat-yln(ngrid))*yresoln(ngrid)
+ ix=int(xtn)
+ jy=int(ytn)
+ else
+ ix=int(part(jpart)%xlon)
+ jy=int(part(jpart)%ylat)
+ endif
+
+ interp_time=nint(itime-0.5*ltsample)
+ n=2
+ if(abs(memtime(1)-interp_time).lt.abs(memtime(2)-interp_time)) n=1
+
+ indz=nz-1
+ do i=2,nz
+ if (height(i).gt.part(jpart)%z) then
+ indz=i-1
+ exit
+ endif
+ end do
+
+ ! Get OH from nearest grid-cell and specific month
+ !*************************************************
+
+ ! world coordinates
+ xlon=part(jpart)%xlon*dx+xlon0
+ if (xlon.gt.180) then
+ xlon=xlon-360
+ endif
+ ylat=part(jpart)%ylat*dy+ylat0
+
+ ! get position in the OH field
+ OHx=minloc(abs(lonOH-xlon),dim=1,mask=abs(lonOH-xlon).eq.minval(abs(lonOH-xlon)))
+ OHy=minloc(abs(latOH-ylat),dim=1,mask=abs(latOH-ylat).eq.minval(abs(latOH-ylat)))
+
+ ! get the level of the OH field for the particle
+ ! z is the z-coord of the trajectory above model orography in metres
+ ! altOH is the height of the centre of the level in the OH field above orography
+ do i=2,nzOH
+ altOHtop(i-1)=altOH(i)+0.5*(altOH(i)-altOH(i-1))
+ end do
+ altOHtop(nzOH)=altOH(nzOH)+0.5*(altOH(nzOH)-altOH(nzOH-1))
+ OHz=minloc(abs(altOHtop-part(jpart)%z),dim=1,mask=abs(altOHtop-part(jpart)%z) &
+ .eq.minval(abs(altOHtop-part(jpart)%z)))
+
+ ! Interpolate between hourly OH fields to current time
+ !*****************************************************
+
+ oh_average=OH_hourly(OHx,OHy,OHz,1)+ &
+ (OH_hourly(OHx,OHy,OHz,2)-OH_hourly(OHx,OHy,OHz,1))* &
+ (itime-memOHtime(1))/(memOHtime(2)-memOHtime(1))
+
+ if (oh_average.gt.smallnum) then
+
+ ! Computation of the OH reaction
+ !**********************************************************
+
+ temp=tt(ix,jy,indz,n)
+
+ do k=1,nspec
+ if (ohcconst(k).gt.0.) then
+ ohrate=ohcconst(k)*temp**ohnconst(k)*exp(-ohdconst(k)/temp)*oh_average
+ ! new particle mass
+ restmass = part(jpart)%mass(k)*exp(-1*ohrate*abs(ltsample))
+ if (restmass .gt. smallnum) then
+ part(jpart)%mass(k)=restmass
+ else
+ part(jpart)%mass(k)=0.
+ endif
+ ohreacted=part(jpart)%mass(k)*(1-exp(-1*ohrate*abs(ltsample)))
+ if (jpart.eq.1) write(*,*) 'ohreaction', part(jpart)%mass(k),k
+ else
+ ohreacted=0.
+ endif
+ end do
+ endif ! oh_average.gt.smallnum
+
+ end do !continue loop over all particles
+
+!$OMP END DO
+!$OMP END PARALLEL
+end subroutine ohreaction
+
+subroutine gethourlyOH(itime)
+ ! i
+ !*****************************************************************************
+ ! *
+ ! *
+ ! Author: R.L. Thompson *
+ ! *
+ ! Nov 2014 *
+ ! *
+ ! *
+ !*****************************************************************************
+ ! Variables: *
+ ! *
+ !*****************************************************************************
+ use par_mod
+ use com_mod
+
+ implicit none
+
+ integer :: itime
+ integer :: ix,jy,kz,m1,m2
+ integer :: ijx,jjy
+ integer :: jjjjmmdd,hhmmss
+ real :: sza,jrate
+ real(kind=dp) :: jul1,jul2
+
+
+ ! Check hourly OH field is available for the current time step
+ !**************************************************************
+
+ if ((ldirect*memOHtime(1).le.ldirect*itime).and. &
+ (ldirect*memOHtime(2).gt.ldirect*itime)) then
+
+ ! The right OH fields are already in memory -> don't do anything
+ !****************************************************************
+
+ return
+
+ else if ((ldirect*memOHtime(2).le.ldirect*itime).and. &
+ (memOHtime(2).ne.0.)) then
+
+ ! Current time is after 2nd OH field
+ !************************************
+
+ memOHtime(1)=memOHtime(2)
+ memOHtime(2)=memOHtime(1)+ldirect*3600.
+ OH_hourly(:,:,:,1)=OH_hourly(:,:,:,2)
+
+ ! Compute new hourly value of OH
+ !**********************************************************
+
+ jul2=bdate+memOHtime(2)/86400._dp ! date for next hour
+ call caldate(jul2,jjjjmmdd,hhmmss)
+ m2=(jjjjmmdd-(jjjjmmdd/10000)*10000)/100
+
+!$OMP PARALLEL PRIVATE(kz,jy,ix,ijx,jjy,sza,jrate)
+!$OMP DO COLLAPSE(3)
+ do kz=1,nzOH
+ do jy=1,nyOH
+ do ix=1,nxOH
+ ijx=minloc(abs(lonjr-lonOH(ix)),dim=1,mask=abs(lonjr-lonOH(ix)).eq.minval(abs(lonjr-lonOH(ix))))
+ jjy=minloc(abs(latjr-latOH(jy)),dim=1,mask=abs(latjr-latOH(jy)).eq.minval(abs(latjr-latOH(jy))))
+ ! calculate solar zenith angle in degrees (sza)
+ sza=zenithangle(latOH(jy),lonOH(ix),jul2)
+ ! calculate J(O1D) (jrate)
+ jrate=photo_O1D(sza)
+ ! apply hourly correction to OH
+ if(jrate_average(ijx,jjy,m2).gt.0.) then
+ OH_hourly(ix,jy,kz,2)=OH_field(ix,jy,kz,m2)*jrate/jrate_average(ijx,jjy,m2)
+ else
+ OH_hourly(ix,jy,kz,2)=0.
+ endif
+ !! for testing !!
+ ! if(jy.eq.36.and.ix.eq.36.and.kz.eq.1) then
+ ! write(999,fmt='(F6.3)') jrate/jrate_average(ijx,jjy,m2)
+ ! endif
+ ! if(jy.eq.11.and.ix.eq.36.and.kz.eq.1) then
+ ! write(998,fmt='(F6.3)') jrate/jrate_average(ijx,jjy,m2)
+ ! endif
+ end do
+ end do
+ end do
+!$OMP END DO
+!$OMP END PARALLEL
+
+ else
+
+ ! No OH fields in memory -> compute both hourly OH fields
+ !**********************************************************
+
+ jul1=bdate ! begin date of simulation (julian)
+ call caldate(jul1,jjjjmmdd,hhmmss)
+ m1=(jjjjmmdd-(jjjjmmdd/10000)*10000)/100
+ memOHtime(1)=0.
+
+ jul2=bdate+ldirect*real(1./24.,kind=dp) ! date for next hour
+ call caldate(jul2,jjjjmmdd,hhmmss)
+ m2=(jjjjmmdd-(jjjjmmdd/10000)*10000)/100
+ memOHtime(2)=ldirect*3600.
+
+!$OMP PARALLEL PRIVATE(kz,jy,ix,ijx,jjy,sza,jrate)
+!$OMP DO COLLAPSE(3)
+ do kz=1,nzOH
+ do jy=1,nyOH
+ do ix=1,nxOH
+ ijx=minloc(abs(lonjr-lonOH(ix)),dim=1,mask=abs(lonjr-lonOH(ix)).eq.minval(abs(lonjr-lonOH(ix))))
+ jjy=minloc(abs(latjr-latOH(jy)),dim=1,mask=abs(latjr-latOH(jy)).eq.minval(abs(latjr-latOH(jy))))
+ ! calculate solar zenith angle in degrees (sza), beginning
+ sza=zenithangle(latOH(jy),lonOH(ix),jul1)
+ ! calculate J(O1D) (jrate), beginning
+ jrate=photo_O1D(sza)
+ ! apply hourly correction to OH
+ if(jrate_average(ijx,jjy,m1).gt.0.) then
+ OH_hourly(ix,jy,kz,1)=OH_field(ix,jy,kz,m1)*jrate/jrate_average(ijx,jjy,m1)
+ else
+ OH_hourly(ix,jy,kz,1)=0.
+ endif
+ ! calculate solar zenith angle in degrees (sza), after 1-hour
+ sza=zenithangle(latOH(jy),lonOH(ix),jul2)
+ ! calculate J(O1D) (jrate), after 1-hour
+ jrate=photo_O1D(sza)
+ ! apply hourly correction to OH
+ if(jrate_average(ijx,jjy,m2).gt.0.) then
+ OH_hourly(ix,jy,kz,2)=OH_field(ix,jy,kz,m2)*jrate/jrate_average(ijx,jjy,m2)
+ else
+ OH_hourly(ix,jy,kz,2)=0.
+ endif
+ end do
+ end do
+ end do
+!$OMP END DO
+!$OMP END PARALLEL
+
+ endif
+end subroutine gethourlyOH
+
end module oh_mod
diff --git a/src/outg_mod.f90 b/src/outg_mod.f90
index 2e29f199..b656b91d 100644
--- a/src/outg_mod.f90
+++ b/src/outg_mod.f90
@@ -2,7 +2,13 @@
! SPDX-License-Identifier: GPL-3.0-or-later
module outg_mod
-
+ !*****************************************************************************
+ ! Module storing and initialising grids *
+ ! *
+ ! Changes *
+ ! 2022 L. Bakels: moved outgrid_init, outgrid_init_nest and *
+ ! initial_cond_calc to this module *
+ !*****************************************************************************
use par_mod, only: dep_prec, sp
implicit none
@@ -22,8 +28,8 @@ module outg_mod
real,allocatable, dimension (:,:,:) :: factor_drygrid ! added RLT
real,allocatable, dimension (:,:,:) :: factor3d
real,allocatable, dimension (:,:,:) :: grid
- real(sp),allocatable, dimension (:,:) :: wetgrid
- real(sp),allocatable, dimension (:,:) :: drygrid
+ real(dep_prec),allocatable, dimension (:,:) :: wetgrid
+ real(dep_prec),allocatable, dimension (:,:) :: drygrid
real,allocatable, dimension (:,:,:) :: gridsigma
real(dep_prec),allocatable, dimension (:,:) :: drygridsigma
real(dep_prec),allocatable, dimension (:,:) :: wetgridsigma
@@ -31,4 +37,845 @@ module outg_mod
real,allocatable, dimension (:) :: sparse_dump_u
integer,allocatable, dimension (:) :: sparse_dump_i
+ real,allocatable, dimension (:,:,:,:,:,:,:) :: flux
+ real,allocatable, dimension (:,:,:,:,:,:,:,:) :: flux_omp
+
+ real,allocatable, dimension (:,:,:,:,:) :: init_cond
+ real,allocatable, dimension (:,:,:,:,:,:) :: init_cond_omp
+
+ !1 fluxw west - east
+ !2 fluxe east - west
+ !3 fluxs south - north
+ !4 fluxn north - south
+ !5 fluxu upward
+ !6 fluxd downward
+ !real,allocatable, dimension (:,:,:) :: areanorth
+ !real,allocatable, dimension (:,:,:) :: areaeast
+contains
+
+subroutine outgrid_init
+ !
+ !*****************************************************************************
+ ! *
+ ! This routine initializes the output grids *
+ ! *
+ ! Author: A. Stohl *
+ ! *
+ ! 7 August 2002 *
+ ! *
+ ! Changes *
+ ! 2022 L. Bakels: OpenMP parallelisation *
+ !*****************************************************************************
+ ! *
+ ! Variables: *
+ ! *
+ ! area surface area of all output grid cells *
+ ! areaeast eastward facing wall area of all output grid cells *
+ ! areanorth northward facing wall area of all output grid cells *
+ ! volume volumes of all output grid cells *
+ ! *
+ !*****************************************************************************
+
+ use oh_mod
+ use unc_mod
+ use par_mod
+ use com_mod
+ use windfields_mod
+
+ implicit none
+
+ integer :: ix,jy,kz,i,nage,l,iix,jjy,ixp,jyp,i1,j1,j,ngrid
+ integer :: ks,kp,stat
+ real :: ylat,gridarea,ylatp,ylatm,hzone,cosfactm,cosfactp
+ real :: xlon,xl,yl,ddx,ddy,rddx,rddy,p1,p2,p3,p4,xtn,ytn,oroh
+ real :: eps
+
+ eps=nxmax/3.e5
+
+ ! Compute surface area and volume of each grid cell: area, volume;
+ ! and the areas of the northward and eastward facing walls: areaeast, areanorth
+ !***********************************************************************
+ do jy=0,numygrid-1
+ ylat=outlat0+(real(jy)+0.5)*dyout
+ ylatp=ylat+0.5*dyout
+ ylatm=ylat-0.5*dyout
+ if ((ylatm.lt.0).and.(ylatp.gt.0.)) then
+ hzone=dyout*r_earth*pi180
+ else
+
+ ! Calculate area of grid cell with formula M=2*pi*R*h*dx/360,
+ ! see Netz, Formeln der Mathematik, 5. Auflage (1983), p.90
+ !************************************************************
+
+ cosfactp=cos(ylatp*pi180)
+ cosfactm=cos(ylatm*pi180)
+ if (cosfactp.lt.cosfactm) then
+ hzone=sqrt(1-cosfactp**2)- &
+ sqrt(1-cosfactm**2)
+ hzone=hzone*r_earth
+ else
+ hzone=sqrt(1-cosfactm**2)- &
+ sqrt(1-cosfactp**2)
+ hzone=hzone*r_earth
+ endif
+ endif
+
+ ! Surface are of a grid cell at a latitude ylat
+ !**********************************************
+
+ gridarea=2.*pi*r_earth*hzone*dxout/360.
+
+ do ix=0,numxgrid-1
+ area(ix,jy)=gridarea
+
+ ! Volume = area x box height
+ !***************************
+
+ volume(ix,jy,1)=area(ix,jy)*outheight(1)
+ areaeast(ix,jy,1)=dyout*r_earth*pi180*outheight(1)
+ areanorth(ix,jy,1)=cos(ylat*pi180)*dxout*r_earth*pi180* &
+ outheight(1)
+ do kz=2,numzgrid
+ areaeast(ix,jy,kz)=dyout*r_earth*pi180* &
+ (outheight(kz)-outheight(kz-1))
+ areanorth(ix,jy,kz)=cos(ylat*pi180)*dxout*r_earth*pi180* &
+ (outheight(kz)-outheight(kz-1))
+ volume(ix,jy,kz)=area(ix,jy)*(outheight(kz)-outheight(kz-1))
+ end do
+ end do
+ end do
+
+
+
+
+ !******************************************************************
+ ! Determine average height of model topography in output grid cells
+ !******************************************************************
+
+ ! Loop over all output grid cells
+ !********************************
+
+ do jjy=0,numygrid-1
+ do iix=0,numxgrid-1
+ oroh=0.
+
+ ! Take 100 samples of the topography in every grid cell
+ !******************************************************
+
+ do j1=1,10
+ ylat=outlat0+(real(jjy)+real(j1)/10.-0.05)*dyout
+ yl=(ylat-ylat0)/dy
+ do i1=1,10
+ xlon=outlon0+(real(iix)+real(i1)/10.-0.05)*dxout
+ xl=(xlon-xlon0)/dx
+
+ ! Determine the nest we are in
+ !*****************************
+
+ ngrid=0
+ ! Temporary fix for nested layer edges: replaced eps with dxn and dyn (LB)
+ do j=numbnests,1,-1
+ if ((xl.gt.xln(j)+dxn(j)).and.(xl.lt.xrn(j)-dxn(j)).and. &
+ (yl.gt.yln(j)+dyn(j)).and.(yl.lt.yrn(j)-dyn(j))) then
+ ngrid=j
+ exit
+ endif
+ end do
+
+ ! Determine (nested) grid coordinates and auxiliary parameters used for interpolation
+ !*****************************************************************************
+
+ if (ngrid.gt.0) then
+ xtn=(xl-xln(ngrid))*xresoln(ngrid)
+ ytn=(yl-yln(ngrid))*yresoln(ngrid)
+ ix=max(min(nint(xtn),nxn(ngrid)-1),0)
+ jy=max(min(nint(ytn),nyn(ngrid)-1),0)
+ ! ix=int(xtn)
+ ! jy=int(ytn)
+ ddy=ytn-real(jy)
+ ddx=xtn-real(ix)
+
+ else
+ ix=int(xl)
+ jy=int(yl)
+ ddy=yl-real(jy)
+ ddx=xl-real(ix)
+ endif
+ ixp=ix+1
+ jyp=jy+1
+ rddx=1.-ddx
+ rddy=1.-ddy
+ p1=rddx*rddy
+ p2=ddx*rddy
+ p3=rddx*ddy
+ p4=ddx*ddy
+
+ if (ngrid.gt.0) then
+ oroh=oroh+p1*oron(ix ,jy ,ngrid) &
+ + p2*oron(ixp,jy ,ngrid) &
+ + p3*oron(ix ,jyp,ngrid) &
+ + p4*oron(ixp,jyp,ngrid)
+ else
+ oroh=oroh+p1*oro(ix ,jy) &
+ + p2*oro(ixp,jy) &
+ + p3*oro(ix ,jyp) &
+ + p4*oro(ixp,jyp)
+ endif
+ end do
+ end do
+
+ ! Divide by the number of samples taken
+ !**************************************
+
+ oroout(iix,jjy)=oroh/100.
+ end do
+ end do
+
+ ! if necessary allocate flux fields
+ if (iflux.eq.1) then
+ allocate(flux(6,0:numxgrid-1,0:numygrid-1,numzgrid, &
+ 1:nspec,1:maxpointspec_act,1:nageclass),stat=stat)
+ if (stat.ne.0) write(*,*)'ERROR: could not allocate flux array '
+#ifdef _OPENMP
+ allocate(flux_omp(6,0:numxgrid-1,0:numygrid-1,numzgrid, &
+ 1:nspec,1:maxpointspec_act,1:nageclass,numthreads))
+ if (stat.ne.0) write(*,*)'ERROR: could not allocate flux_omp array '
+#endif
+ endif
+
+ ! gridunc,griduncn uncertainty of outputted concentrations
+ allocate(gridunc(0:numxgrid-1,0:numygrid-1,numzgrid,maxspec, &
+ maxpointspec_act,nclassunc,maxageclass),stat=stat)
+ if (stat.ne.0) write(*,*)'ERROR: could not allocate gridunc'
+#ifdef _OPENMP
+ allocate(gridunc_omp(0:numxgrid-1,0:numygrid-1,numzgrid,maxspec, &
+ maxpointspec_act,nclassunc,maxageclass,numthreads_grid),stat=stat)
+ if (stat.ne.0) then
+ write(*,*)'ERROR: could not allocate gridunc_omp'
+ write(*,*)'increase the memory or reduce max_numthreads_grid in par_mod.f90.'
+ stop
+ endif
+#endif
+ if (ldirect.gt.0) then
+ allocate(wetgridunc(0:numxgrid-1,0:numygrid-1,maxspec, &
+ maxpointspec_act,nclassunc,maxageclass),stat=stat)
+ if (stat.ne.0) write(*,*)'ERROR: could not allocate wetgridunc'
+ allocate(drygridunc(0:numxgrid-1,0:numygrid-1,maxspec, &
+ maxpointspec_act,nclassunc,maxageclass),stat=stat)
+ if (stat.ne.0) write(*,*)'ERROR: could not allocate drygridunc'
+#ifdef _OPENMP
+ allocate(wetgridunc_omp(0:numxgrid-1,0:numygrid-1,maxspec, &
+ maxpointspec_act,nclassunc,maxageclass,numthreads_grid),stat=stat)
+ if (stat.ne.0) write(*,*)'ERROR: could not allocate wetgridunc_omp'
+ allocate(drygridunc_omp(0:numxgrid-1,0:numygrid-1,maxspec, &
+ maxpointspec_act,nclassunc,maxageclass,numthreads_grid),stat=stat)
+ if (stat.ne.0) write(*,*)'ERROR: could not allocate drygridunc_omp'
+#endif
+ endif
+
+#ifdef USE_MPIINPLACE
+#else
+! Extra field for totals at MPI root process
+ if (lroot.and.mpi_mode.gt.0) then
+! If MPI_IN_PLACE option is not used in mpi_mod.f90::mpif_tm_reduce_grid(),
+! then an aux array is needed for parallel grid reduction
+ allocate(gridunc0(0:numxgrid-1,0:numygrid-1,numzgrid,maxspec, &
+ maxpointspec_act,nclassunc,maxageclass),stat=stat)
+ if (stat.ne.0) write(*,*)'ERROR: could not allocate gridunc0'
+ else if (.not.lroot.and.mpi_mode.gt.0) then
+ allocate(gridunc0(1,1,1,1,1,1,1),stat=stat)
+ if (stat.ne.0) write(*,*)'ERROR: could not allocate gridunc0'
+ end if
+#endif
+ if (ldirect.gt.0) then
+ if (lroot.and.mpi_mode.gt.0) then
+ allocate(wetgridunc0(0:numxgrid-1,0:numygrid-1,maxspec, &
+ maxpointspec_act,nclassunc,maxageclass),stat=stat)
+ if (stat.ne.0) write(*,*)'ERROR: could not allocate wetgridunc0'
+ allocate(drygridunc0(0:numxgrid-1,0:numygrid-1,maxspec, &
+ maxpointspec_act,nclassunc,maxageclass),stat=stat)
+ if (stat.ne.0) write(*,*)'ERROR: could not allocate drygridunc0'
+
+ ! allocate a dummy to avoid compilator complaints
+ else if (.not.lroot.and.mpi_mode.gt.0) then
+ allocate(wetgridunc0(1,1,1,1,1,1),stat=stat)
+ allocate(drygridunc0(1,1,1,1,1,1),stat=stat)
+ end if
+ end if
+
+ !write (*,*) 'Dimensions for fields', numxgrid,numygrid, &
+ ! maxspec,maxpointspec_act,nclassunc,maxageclass
+
+ if (lroot) then
+ write (*,*) 'Allocating fields for global output (x,y): ', numxgrid,numygrid
+ write (*,*) 'Allocating fields for nested output (x,y): ', numxgridn,numygridn
+ end if
+
+ ! allocate fields for concoutput with maximum dimension of outgrid
+ ! and outgrid_nest
+
+ allocate(gridsigma(0:max(numxgrid,numxgridn)-1, &
+ 0:max(numygrid,numygridn)-1,numzgrid),stat=stat)
+ if (stat.ne.0) write(*,*)'ERROR: could not allocate gridunc'
+ allocate(grid(0:max(numxgrid,numxgridn)-1, &
+ 0:max(numygrid,numygridn)-1,numzgrid),stat=stat)
+ if (stat.ne.0) write(*,*)'ERROR: could not allocate gridunc'
+ allocate(densityoutgrid(0:max(numxgrid,numxgridn)-1, &
+ 0:max(numygrid,numygridn)-1,numzgrid),stat=stat)
+ if (stat.ne.0) write(*,*)'ERROR: could not allocate gridunc'
+ ! RLT
+ allocate(densitydrygrid(0:max(numxgrid,numxgridn)-1, &
+ 0:max(numygrid,numygridn)-1,numzgrid),stat=stat)
+ if (stat.ne.0) write(*,*)'ERROR: could not allocate gridunc'
+ allocate(factor_drygrid(0:max(numxgrid,numxgridn)-1, &
+ 0:max(numygrid,numygridn)-1,numzgrid),stat=stat)
+ if (stat.ne.0) write(*,*)'ERROR: could not allocate gridunc'
+
+ allocate(factor3d(0:max(numxgrid,numxgridn)-1, &
+ 0:max(numygrid,numygridn)-1,numzgrid),stat=stat)
+ if (stat.ne.0) write(*,*)'ERROR: could not allocate gridunc'
+ allocate(sparse_dump_r(max(numxgrid,numxgridn)* &
+ max(numygrid,numygridn)*numzgrid),stat=stat)
+ if (stat.ne.0) write(*,*)'ERROR: could not allocate gridunc'
+
+ allocate(sparse_dump_u(max(numxgrid,numxgridn)* &
+ max(numygrid,numygridn)*numzgrid),stat=stat)
+ if (stat.ne.0) write(*,*)'ERROR: could not allocate gridunc'
+
+ allocate(sparse_dump_i(max(numxgrid,numxgridn)* &
+ max(numygrid,numygridn)*numzgrid),stat=stat)
+ if (stat.ne.0) write(*,*)'ERROR: could not allocate gridunc'
+
+ ! deposition fields are only allocated for forward runs
+ if (ldirect.gt.0) then
+ allocate(wetgridsigma(0:max(numxgrid,numxgridn)-1, &
+ 0:max(numygrid,numygridn)-1),stat=stat)
+ if (stat.ne.0) write(*,*)'ERROR: could not allocate gridunc'
+ allocate(drygridsigma(0:max(numxgrid,numxgridn)-1, &
+ 0:max(numygrid,numygridn)-1),stat=stat)
+ if (stat.ne.0) write(*,*)'ERROR: could not allocate gridunc'
+ allocate(wetgrid(0:max(numxgrid,numxgridn)-1, &
+ 0:max(numygrid,numygridn)-1),stat=stat)
+ if (stat.ne.0) write(*,*)'ERROR: could not allocate gridunc'
+ allocate(drygrid(0:max(numxgrid,numxgridn)-1, &
+ 0:max(numygrid,numygridn)-1),stat=stat)
+ if (stat.ne.0) write(*,*)'ERROR: could not allocate gridunc'
+ endif
+
+ ! Initial condition field
+
+ if (linit_cond.gt.0) then
+ allocate(init_cond(0:numxgrid-1,0:numygrid-1,numzgrid,maxspec, &
+ maxpointspec_act),stat=stat)
+ if (stat.ne.0) write(*,*)'ERROR: could not allocate init_cond'
+#ifdef _OPENMP
+ allocate(init_cond_omp(0:numxgrid-1,0:numygrid-1,numzgrid,maxspec, &
+ maxpointspec_act,numthreads),stat=stat)
+ if (stat.ne.0) write(*,*)'ERROR: could not allocate init_cond_omp'
+#endif
+ endif
+
+ !************************
+ ! Initialize output grids
+ !************************
+
+ do ks=1,nspec
+ do kp=1,maxpointspec_act
+ if (numreceptor.gt.0) then
+ do i=1,numreceptor
+ ! Receptor points
+ creceptor(i,ks)=0.
+ end do
+ endif
+ do nage=1,nageclass
+ do jy=0,numygrid-1
+ do ix=0,numxgrid-1
+ do l=1,nclassunc
+ ! Deposition fields
+ if (ldirect.gt.0) then
+ wetgridunc(ix,jy,ks,kp,l,nage)=0.
+ drygridunc(ix,jy,ks,kp,l,nage)=0.
+#ifdef _OPENMP
+ wetgridunc_omp(ix,jy,ks,kp,l,nage,:)=0.
+ drygridunc_omp(ix,jy,ks,kp,l,nage,:)=0.
+#endif
+ endif
+ do kz=1,numzgrid
+ if (iflux.eq.1) then
+ ! Flux fields
+ do i=1,5
+ flux(i,ix,jy,kz,ks,kp,nage)=0.
+#ifdef _OPENMP
+ flux_omp(i,ix,jy,kz,ks,kp,nage,:)=0.
+#endif
+ end do
+ endif
+ ! Initial condition field
+ if ((l.eq.1).and.(nage.eq.1).and.(linit_cond.gt.0)) then
+ init_cond(ix,jy,kz,ks,kp)=0.
+#ifdef _OPENMP
+ init_cond_omp(ix,jy,kz,ks,kp,:)=0.
+#endif
+ endif
+ ! Concentration fields
+ gridunc(ix,jy,kz,ks,kp,l,nage)=0.
+#ifdef _OPENMP
+ gridunc_omp(ix,jy,kz,ks,kp,l,nage,:)=0.
+#endif
+ end do
+ end do
+ end do
+ end do
+ end do
+ end do
+ end do
+end subroutine outgrid_init
+
+subroutine outgrid_init_nest
+ !
+ !*****************************************************************************
+ ! *
+ ! This routine calculates, for each grid cell of the output nest, the *
+ ! volume and the surface area. *
+ ! *
+ ! Author: A. Stohl *
+ ! *
+ ! 30 August 2004 *
+ ! *
+ ! Changes *
+ ! 2022 L. Bakels: OpenMP parallelisation *
+ !*****************************************************************************
+ ! *
+ ! Variables: *
+ ! *
+ ! arean surface area of all output nest cells *
+ ! volumen volumes of all output nest cells *
+ ! *
+ !*****************************************************************************
+
+ use unc_mod
+ use par_mod
+ use com_mod
+ use windfields_mod
+
+ implicit none
+
+ integer :: ix,jy,kz,ks,kp,nage,l,iix,jjy,ixp,jyp,i1,j1,j,ngrid
+ integer :: stat
+ real :: ylat,gridarea,ylatp,ylatm,hzone,cosfactm,cosfactp
+ real :: xlon,xl,yl,ddx,ddy,rddx,rddy,p1,p2,p3,p4,xtn,ytn,oroh
+ real :: eps
+
+ eps=nxmax/3.e5
+
+ ! gridunc,griduncn uncertainty of outputted concentrations
+ allocate(griduncn(0:numxgridn-1,0:numygridn-1,numzgrid,maxspec, &
+ maxpointspec_act,nclassunc,maxageclass),stat=stat)
+ if (stat.ne.0) write(*,*)'ERROR:could not allocate nested gridunc'
+#ifdef _OPENMP
+ allocate(griduncn_omp(0:numxgridn-1,0:numygridn-1,numzgrid,maxspec, &
+ maxpointspec_act,nclassunc,maxageclass,numthreads_grid),stat=stat)
+ if (stat.ne.0) write(*,*)'ERROR:could not allocate nested gridunc_omp'
+#endif
+
+ if (ldirect.gt.0) then
+ allocate(wetgriduncn(0:numxgridn-1,0:numygridn-1,maxspec, &
+ maxpointspec_act,nclassunc,maxageclass),stat=stat)
+ if (stat.ne.0) write(*,*)'ERROR:could not allocate nested gridunc'
+ allocate(drygriduncn(0:numxgridn-1,0:numygridn-1,maxspec, &
+ maxpointspec_act,nclassunc,maxageclass),stat=stat)
+ if (stat.ne.0) write(*,*)'ERROR:could not allocate nested gridunc'
+#ifdef _OPENMP
+ allocate(wetgriduncn_omp(0:numxgridn-1,0:numygridn-1,maxspec, &
+ maxpointspec_act,nclassunc,maxageclass,numthreads_grid),stat=stat)
+ if (stat.ne.0) write(*,*)'ERROR:could not allocate nested wetgridunc_omp'
+ allocate(drygriduncn_omp(0:numxgridn-1,0:numygridn-1,maxspec, &
+ maxpointspec_act,nclassunc,maxageclass,numthreads_grid),stat=stat)
+ if (stat.ne.0) write(*,*)'ERROR:could not allocate nested drygriduncn_omp'
+#endif
+ endif
+
+#ifdef USE_MPIINPLACE
+#else
+ ! Extra field for totals at MPI root process
+ if (lroot.and.mpi_mode.gt.0) then
+ ! If MPI_IN_PLACE option is not used in mpi_mod.f90::mpif_tm_reduce_grid_nest(),
+ ! then an aux array is needed for parallel grid reduction
+ allocate(griduncn0(0:numxgridn-1,0:numygridn-1,numzgrid,maxspec, &
+ maxpointspec_act,nclassunc,maxageclass),stat=stat)
+ if (stat.ne.0) write(*,*)'ERROR:could not allocate nested gridunc'
+ ! allocate a dummy to avoid compilator complaints
+ else if (.not.lroot.and.mpi_mode.gt.0) then
+ allocate(griduncn0(1,1,1,1,1,1,1),stat=stat)
+ end if
+#endif
+ if (ldirect.gt.0) then
+ if (lroot.and.mpi_mode.gt.0) then
+ allocate(wetgriduncn0(0:numxgridn-1,0:numygridn-1,maxspec, &
+ maxpointspec_act,nclassunc,maxageclass),stat=stat)
+ if (stat.ne.0) write(*,*)'ERROR:could not allocate nested gridunc'
+ allocate(drygriduncn0(0:numxgridn-1,0:numygridn-1,maxspec, &
+ maxpointspec_act,nclassunc,maxageclass),stat=stat)
+ if (stat.ne.0) write(*,*)'ERROR:could not allocate nested gridunc'
+ ! endif
+ ! allocate a dummy to avoid compilator complaints
+ else if (.not.lroot.and.mpi_mode.gt.0) then
+ allocate(wetgriduncn0(1,1,1,1,1,1),stat=stat)
+ allocate(drygriduncn0(1,1,1,1,1,1),stat=stat)
+ end if
+ end if
+
+ ! Compute surface area and volume of each grid cell: area, volume;
+ ! and the areas of the northward and eastward facing walls: areaeast, areanorth
+ !***********************************************************************
+
+ do jy=0,numygridn-1
+ ylat=outlat0n+(real(jy)+0.5)*dyoutn
+ ylatp=ylat+0.5*dyoutn
+ ylatm=ylat-0.5*dyoutn
+ if ((ylatm.lt.0).and.(ylatp.gt.0.)) then
+ hzone=dyoutn*r_earth*pi180
+ else
+
+ ! Calculate area of grid cell with formula M=2*pi*R*h*dx/360,
+ ! see Netz, Formeln der Mathematik, 5. Auflage (1983), p.90
+ !************************************************************
+
+ cosfactp=cos(ylatp*pi180)
+ cosfactm=cos(ylatm*pi180)
+ if (cosfactp.lt.cosfactm) then
+ hzone=sqrt(1-cosfactp**2)- &
+ sqrt(1-cosfactm**2)
+ hzone=hzone*r_earth
+ else
+ hzone=sqrt(1-cosfactm**2)- &
+ sqrt(1-cosfactp**2)
+ hzone=hzone*r_earth
+ endif
+ endif
+
+
+
+ ! Surface are of a grid cell at a latitude ylat
+ !**********************************************
+
+ gridarea=2.*pi*r_earth*hzone*dxoutn/360.
+
+ do ix=0,numxgridn-1
+ arean(ix,jy)=gridarea
+
+ ! Volume = area x box height
+ !***************************
+
+ volumen(ix,jy,1)=arean(ix,jy)*outheight(1)
+ do kz=2,numzgrid
+ volumen(ix,jy,kz)=arean(ix,jy)*(outheight(kz)-outheight(kz-1))
+ end do
+ end do
+ end do
+
+
+ !**************************************************************************
+ ! Determine average height of model topography in nesteed output grid cells
+ !**************************************************************************
+
+ ! Loop over all output grid cells
+ !********************************
+
+ do jjy=0,numygridn-1
+ do iix=0,numxgridn-1
+ oroh=0.
+
+ ! Take 100 samples of the topography in every grid cell
+ !******************************************************
+
+ do j1=1,10
+ ylat=outlat0n+(real(jjy)+real(j1)/10.-0.05)*dyoutn
+ yl=(ylat-ylat0)/dy
+ do i1=1,10
+ xlon=outlon0n+(real(iix)+real(i1)/10.-0.05)*dxoutn
+ xl=(xlon-xlon0)/dx
+
+ ! Determine the nest we are in
+ !*****************************
+
+ ngrid=0
+ do j=numbnests,1,-1
+ ! Temporary fix for nested layer edges: replaced eps with dxn and dyn (LB)
+ if ((xl.gt.xln(j)+dxn(j)).and.(xl.lt.xrn(j)-dxn(j)).and. &
+ (yl.gt.yln(j)+dyn(j)).and.(yl.lt.yrn(j)-dyn(j))) then
+ ngrid=j
+ exit
+ endif
+ end do
+
+ ! Determine (nested) grid coordinates and auxiliary parameters used for interpolation
+ !*****************************************************************************
+
+ if (ngrid.gt.0) then
+ xtn=(xl-xln(ngrid))*xresoln(ngrid)
+ ytn=(yl-yln(ngrid))*yresoln(ngrid)
+ ix=int(xtn)
+ jy=int(ytn)
+ ddy=ytn-real(jy)
+ ddx=xtn-real(ix)
+ else
+ ix=int(xl)
+ jy=int(yl)
+ ddy=yl-real(jy)
+ ddx=xl-real(ix)
+ endif
+ ixp=ix+1
+ jyp=jy+1
+ rddx=1.-ddx
+ rddy=1.-ddy
+ p1=rddx*rddy
+ p2=ddx*rddy
+ p3=rddx*ddy
+ p4=ddx*ddy
+
+ if (ngrid.gt.0) then
+ oroh=oroh+p1*oron(ix ,jy ,ngrid) &
+ + p2*oron(ixp,jy ,ngrid) &
+ + p3*oron(ix ,jyp,ngrid) &
+ + p4*oron(ixp,jyp,ngrid)
+ else
+ oroh=oroh+p1*oro(ix ,jy) &
+ + p2*oro(ixp,jy) &
+ + p3*oro(ix ,jyp) &
+ + p4*oro(ixp,jyp)
+ endif
+ end do
+ end do
+
+ ! Divide by the number of samples taken
+ !**************************************
+
+ orooutn(iix,jjy)=oroh/100.
+ end do
+ end do
+
+ !*******************************
+ ! Initialization of output grids
+ !*******************************
+
+ do kp=1,maxpointspec_act
+ do ks=1,nspec
+ do nage=1,nageclass
+ do jy=0,numygridn-1
+ do ix=0,numxgridn-1
+ do l=1,nclassunc
+ ! Deposition fields
+ if (ldirect.gt.0) then
+ wetgriduncn(ix,jy,ks,kp,l,nage)=0.
+ drygriduncn(ix,jy,ks,kp,l,nage)=0.
+#ifdef _OPENMP
+ wetgriduncn_omp(ix,jy,ks,kp,l,nage,:)=0.
+ drygriduncn_omp(ix,jy,ks,kp,l,nage,:)=0.
+#endif
+ endif
+ ! Concentration fields
+ do kz=1,numzgrid
+ griduncn(ix,jy,kz,ks,kp,l,nage)=0.
+ end do
+ end do
+ end do
+ end do
+ end do
+ end do
+ end do
+end subroutine outgrid_init_nest
+
+subroutine initial_cond_calc(itime,i,thread)
+ ! i i
+ !*****************************************************************************
+ ! *
+ ! Calculation of the sensitivity to initial conditions for BW runs *
+ ! *
+ ! Author: A. Stohl *
+ ! *
+ ! 15 January 2010 *
+ ! *
+ ! Changes *
+ ! 2022 L. Bakels: OpenMP parallelisation *
+ !*****************************************************************************
+
+ use par_mod
+ use com_mod
+ use interpol_mod, only: interpol_density,ix,jy,ixp,jyp
+ use coordinates_ecmwf_mod
+ use particle_mod
+ use windfields_mod
+
+ implicit none
+
+ integer, intent(in) :: itime,i,thread
+ integer :: kz,ks
+ integer :: il,ind,indz,indzp,nrelpointer
+ real :: rddx,rddy,p1,p2,p3,p4,dz1,dz2,dz
+ real :: ddx,ddy
+ real :: rhoprof(2),rhoi,xl,yl,wx,wy,w
+ integer :: mind2
+ ! mind2 eso: pointer to 2nd windfield in memory
+
+
+ ! For forward simulations, make a loop over the number of species;
+ ! for backward simulations, make an additional loop over the release points
+ !**************************************************************************
+
+
+ if (.not. part(i)%alive) return
+
+ ! Depending on output option, calculate air density or set it to 1
+ ! linit_cond: 1=mass unit, 2=mass mixing ratio unit
+ !*****************************************************************
+
+
+ if (linit_cond.eq.1) then ! mass unit
+ call update_zeta_to_z(itime,i)
+ call interpol_density(itime,i,rhoi)
+ elseif (linit_cond.eq.2) then ! mass mixing ratio unit
+ rhoi=1.
+ endif
+
+ !****************************************************************************
+ ! 1. Evaluate grid concentrations using a uniform kernel of bandwidths dx, dy
+ !****************************************************************************
+
+
+ ! For backward simulations, look from which release point the particle comes from
+ ! For domain-filling trajectory option, npoint contains a consecutive particle
+ ! number, not the release point information. Therefore, nrelpointer is set to 1
+ ! for the domain-filling option.
+ !*****************************************************************************
+
+ if ((ioutputforeachrelease.eq.0).or.(mdomainfill.eq.1)) then
+ nrelpointer=1
+ else
+ nrelpointer=part(i)%npoint
+ endif
+
+ do kz=1,numzgrid ! determine height of cell
+ if (real(outheight(kz),kind=dp).gt.part(i)%z) exit
+ end do
+
+ if (kz.le.numzgrid) then ! inside output domain
+
+
+ xl=(part(i)%xlon*dx+xoutshift)/dxout
+ yl=(part(i)%ylat*dy+youtshift)/dyout
+ ix=int(xl)
+ if (xl.lt.0.) ix=ix-1
+ jy=int(yl)
+ if (yl.lt.0.) jy=jy-1
+
+
+ ! If a particle is close to the domain boundary, do not use the kernel either
+ !****************************************************************************
+
+ if ((xl.lt.0.5).or.(yl.lt.0.5).or. &
+ (xl.gt.real(numxgrid-1)-0.5).or. &
+ (yl.gt.real(numygrid-1)-0.5)) then ! no kernel, direct attribution to grid cell
+ if ((ix.ge.0).and.(jy.ge.0).and.(ix.le.numxgrid-1).and. &
+ (jy.le.numygrid-1)) then
+ do ks=1,nspec
+#ifdef _OPENMP
+ init_cond_omp(ix,jy,kz,ks,nrelpointer,thread)= &
+ init_cond_omp(ix,jy,kz,ks,nrelpointer,thread)+ &
+ part(i)%mass(ks)/rhoi
+#else
+ init_cond(ix,jy,kz,ks,nrelpointer)= &
+ init_cond(ix,jy,kz,ks,nrelpointer)+ &
+ part(i)%mass(ks)/rhoi
+#endif
+ end do
+ endif
+
+ else ! attribution via uniform kernel
+
+ ddx=xl-real(ix) ! distance to left cell border
+ ddy=yl-real(jy) ! distance to lower cell border
+ if (ddx.gt.0.5) then
+ ixp=ix+1
+ wx=1.5-ddx
+ else
+ ixp=ix-1
+ wx=0.5+ddx
+ endif
+
+ if (ddy.gt.0.5) then
+ jyp=jy+1
+ wy=1.5-ddy
+ else
+ jyp=jy-1
+ wy=0.5+ddy
+ endif
+
+
+ ! Determine mass fractions for four grid points
+ !**********************************************
+
+ if ((ix.ge.0).and.(ix.le.numxgrid-1)) then
+ if ((jy.ge.0).and.(jy.le.numygrid-1)) then
+ w=wx*wy
+ do ks=1,nspec
+#ifdef _OPENMP
+ init_cond_omp(ix,jy,kz,ks,nrelpointer,thread)= &
+ init_cond_omp(ix,jy,kz,ks,nrelpointer,thread)+part(i)%mass(ks)/rhoi*w
+#else
+ init_cond(ix,jy,kz,ks,nrelpointer)= &
+ init_cond(ix,jy,kz,ks,nrelpointer)+part(i)%mass(ks)/rhoi*w
+#endif
+ end do
+ endif
+
+ if ((jyp.ge.0).and.(jyp.le.numygrid-1)) then
+ w=wx*(1.-wy)
+ do ks=1,nspec
+#ifdef _OPENMP
+ init_cond_omp(ix,jyp,kz,ks,nrelpointer,thread)= &
+ init_cond_omp(ix,jyp,kz,ks,nrelpointer,thread)+part(i)%mass(ks)/rhoi*w
+#else
+ init_cond(ix,jyp,kz,ks,nrelpointer)= &
+ init_cond(ix,jyp,kz,ks,nrelpointer)+part(i)%mass(ks)/rhoi*w
+#endif
+ end do
+ endif
+ endif
+
+
+ if ((ixp.ge.0).and.(ixp.le.numxgrid-1)) then
+ if ((jyp.ge.0).and.(jyp.le.numygrid-1)) then
+ w=(1.-wx)*(1.-wy)
+ do ks=1,nspec
+#ifdef _OPENMP
+ init_cond_omp(ixp,jyp,kz,ks,nrelpointer,thread)= &
+ init_cond_omp(ixp,jyp,kz,ks,nrelpointer,thread)+part(i)%mass(ks)/rhoi*w
+#else
+ init_cond(ixp,jyp,kz,ks,nrelpointer)= &
+ init_cond(ixp,jyp,kz,ks,nrelpointer)+part(i)%mass(ks)/rhoi*w
+#endif
+ end do
+ endif
+
+ if ((jy.ge.0).and.(jy.le.numygrid-1)) then
+ w=(1.-wx)*wy
+ do ks=1,nspec
+#ifdef _OPENMP
+ init_cond_omp(ixp,jy,kz,ks,nrelpointer,thread)= &
+ init_cond_omp(ixp,jy,kz,ks,nrelpointer,thread)+part(i)%mass(ks)/rhoi*w
+#else
+ init_cond(ixp,jy,kz,ks,nrelpointer)= &
+ init_cond(ixp,jy,kz,ks,nrelpointer)+part(i)%mass(ks)/rhoi*w
+#endif
+ end do
+ endif
+ endif
+ endif
+
+ endif
+
+end subroutine initial_cond_calc
+
+
end module outg_mod
diff --git a/src/output_mod.f90 b/src/output_mod.f90
new file mode 100644
index 00000000..b7e7998c
--- /dev/null
+++ b/src/output_mod.f90
@@ -0,0 +1,1369 @@
+! SPDX-FileCopyrightText: FLEXPART 1998-2019, see flexpart_license.txt
+! SPDX-License-Identifier: GPL-3.0-or-later
+
+!*****************************************************************************
+! *
+! L. Bakels 2022: This module contains most output related subroutines *
+! *
+!*****************************************************************************
+
+module output_mod
+
+ use com_mod
+ use par_mod
+ use date_mod
+#ifdef USE_NCF
+ use netcdf_output_mod
+#endif
+ use binary_output_mod
+ use txt_output_mod
+
+ implicit none
+
+contains
+
+subroutine initialise_output(itime,filesize)
+
+ implicit none
+
+ integer, intent(in) :: itime
+ real, intent(inout) :: filesize
+#ifdef USE_NCF
+ real(kind=dp) :: &
+ jul
+ integer :: &
+ jjjjmmdd,ihmmss,i
+#endif
+
+ ! Writing header information to either binary or NetCDF format
+ if (itime.eq.itime_init) then
+ if (iout.ne.0) then ! No gridded output
+#ifdef USE_NCF
+ if (lnetcdfout.eq.1) then
+ call writeheader_netcdf(lnest=.false.)
+ else
+ call writeheader_binary
+ end if
+
+ if (nested_output.eq.1) then
+ if (lnetcdfout.eq.1) then
+ call writeheader_netcdf(lnest=.true.)
+ else if ((nested_output.eq.1).and.(surf_only.ne.1)) then
+ call writeheader_binary_nest
+ else if ((nested_output.eq.1).and.(surf_only.eq.1)) then
+ call writeheader_binary_nest_surf
+ else if ((nested_output.ne.1).and.(surf_only.eq.1)) then
+ call writeheader_binary_surf
+ endif
+ endif
+#else
+ call writeheader_binary
+
+ !if (nested_output.eq.1) call writeheader_nest
+ if ((nested_output.eq.1).and.(surf_only.ne.1)) call writeheader_binary_nest
+ if ((nested_output.eq.1).and.(surf_only.eq.1)) call writeheader_binary_nest_surf
+ if ((nested_output.ne.1).and.(surf_only.eq.1)) call writeheader_binary_surf
+#endif
+ endif ! iout.ne.0
+ ! FLEXPART 9.2 ticket ?? write header in ASCII format
+ call writeheader_txt
+
+ ! NetCDF only: Create file for storing initial particle positions.
+#ifdef USE_NCF
+ if (itime_init.ne.0) then
+ jul=bdate+real(itime,kind=dp)/86400._dp
+ call caldate(jul,jjjjmmdd,ihmmss)
+ endif
+ if ((mdomainfill.eq.0).and.(ipout.ge.1).and.(ipin.le.1)) then
+ if (itime_init.ne.0) then
+ if (ldirect.eq.1) then
+ call create_particles_initialoutput(ihmmss,jjjjmmdd,ibtime,ibdate)
+ else
+ call create_particles_initialoutput(ihmmss,jjjjmmdd,ietime,iedate)
+ endif
+ else if (ldirect.eq.1) then
+ call create_particles_initialoutput(ibtime,ibdate,ibtime,ibdate)
+ else
+ call create_particles_initialoutput(ietime,iedate,ietime,iedate)
+ endif
+ endif
+ ! Create header files for files that store the particle dump output
+ if (ipout.ge.1) then
+ if (itime_init.ne.0) then
+ if (ldirect.eq.1) then
+ call writeheader_partoutput(ihmmss,jjjjmmdd,ibtime,ibdate)
+ else
+ call writeheader_partoutput(ihmmss,jjjjmmdd,ietime,iedate)
+ endif
+ else if (ldirect.eq.1) then
+ call writeheader_partoutput(ibtime,ibdate,ibtime,ibdate)
+ else
+ call writeheader_partoutput(ietime,iedate,ietime,iedate)
+ endif
+ endif
+#endif
+
+ ! In case the particle output file is becoming larger than the maximum set
+ ! in par_mod, create a new one while keeping track of the filesize.
+ ! Also if a new restart file is created.
+ else if ((mod(itime,ipoutfac*loutstep).eq.0).and.(ipout.ge.1)) then
+#ifdef USE_NCF
+ if ((filesize.ge.max_partoutput_filesize).or. &
+ ((loutrestart.ne.-1).and.(mod(itime,loutrestart).eq.0))) then
+ jul=bdate+real(itime,kind=dp)/86400._dp
+ call caldate(jul,jjjjmmdd,ihmmss)
+ if (ldirect.eq.1) then
+ call writeheader_partoutput(ihmmss,jjjjmmdd,ibtime,ibdate)
+ else
+ call writeheader_partoutput(ihmmss,jjjjmmdd,ietime,iedate)
+ endif
+ filesize = 0.
+ endif
+ do i=1,numpoint
+ filesize = filesize + npart(i)*13.*4./1000000.
+ end do
+#endif
+ endif
+end subroutine initialise_output
+
+subroutine finalise_output(itime)
+ ! Complete the calculation of initial conditions for particles not yet terminated
+
+ implicit none
+
+ integer, intent(in) :: itime
+ integer :: j,ithread
+
+ if (linit_cond.ge.1) then
+ do j=1,numpart
+ call initial_cond_calc(itime,j,1)
+ end do
+#ifdef _OPENMP
+ do ithread=1,numthreads
+ init_cond(:,:,:,:,:)=init_cond(:,:,:,:,:)+init_cond_omp(:,:,:,:,:,ithread)
+ end do
+#endif
+ endif
+
+
+ if (ipout.eq.2) call output_particles(itime)!,active_per_rel) ! dump particle positions
+
+ if (linit_cond.ge.1) then
+ if(linversionout.eq.1) then
+ call initial_cond_output_inversion(itime) ! dump initial cond. field
+ else
+ call initial_cond_output(itime) ! dump initial cond. fielf
+ endif
+ endif
+end subroutine finalise_output
+
+subroutine output_particles(itime,initial_output)
+ ! i
+ !*****************************************************************************
+ ! *
+ ! Dump all particle positions *
+ ! Author: A. Stohl *
+ ! *
+ ! 12 March 1999 *
+ ! *
+ ! Changes L. Bakels, 2021 *
+ ! Output is chosen by the fields set in PARTOPTIONS *
+ ! Binary output is no longer supported. If required, function can be *
+ ! added below at "Put binary function here" *
+ !*****************************************************************************
+ ! *
+ ! Variables: *
+ ! *
+ !*****************************************************************************
+
+ use interpol_mod
+ use coordinates_ecmwf_mod
+ use particle_mod
+#ifdef USE_NCF
+ use netcdf
+ use netcdf_output_mod, only: partoutput_netcdf,open_partoutput_file, &
+ close_partoutput_file,partinitpointer1
+ use omp_lib, only: OMP_GET_THREAD_NUM
+#endif
+
+ implicit none
+
+ integer,intent(in) :: itime
+ logical,optional,intent(in) :: initial_output
+ logical :: init_out
+ integer :: i,j,m,jjjjmmdd,ihmmss,np,ns,i_av
+ real(kind=dp) :: jul
+ real :: tmp(2)
+ character :: adate*8,atime*6
+
+ real :: xlon(numpart),ylat(numpart),ztemp1,ztemp2,val_av(numpart,2),z_av(numpart)
+ real :: tti(numpart),rhoi(numpart),pvi(numpart),qvi(numpart),pri(numpart)
+ real :: topo(numpart),hmixi(numpart),tri(numpart),ztemp(numpart)
+ real :: masstemp(numpart,nspec),masstemp_av(numpart,nspec)
+ real :: wetdepotemp(numpart,nspec),drydepotemp(numpart,nspec)
+
+ real :: output(num_partopt, numpart)
+
+ ! For averaged output
+ real :: xlon_av(numpart),ylat_av(numpart)
+
+ real :: cartxyz(3)
+ logical :: cartxyz_comp
+
+#ifdef USE_NCF
+ integer :: ncid, mythread, thread_divide(12),mass_divide(nspec)
+#else
+ write(*,*) 'NETCDF missing! Please compile with netcdf if you want the particle dump.'
+ stop
+#endif
+
+#ifdef USE_NCF
+ if (present(initial_output)) then
+ init_out=initial_output
+ else
+ init_out=.false.
+ endif
+
+!$OMP PARALLEL PRIVATE(i,j,m,tmp,ns,i_av,cartxyz_comp,cartxyz,np)
+ ! Some variables needed for temporal interpolation
+ !*************************************************
+ call find_time_variables(itime)
+
+!$OMP DO
+ do i=1,numpart
+ if (((.not. part(i)%alive).and.(abs(part(i)%tend-itime).ge.ipoutfac*loutstep)) .or. &
+ (init_out .and. (i.lt.partinitpointer1-1))) then ! Only freshly spawned particles need to be computed for init_out
+ output(:,i) = -1
+ masstemp(i,:) = -1
+ masstemp_av(i,:) = -1
+ wetdepotemp(i,:) = -1
+ drydepotemp(i,:) = -1
+ cycle
+ endif
+ !*****************************************************************************
+ ! Interpolate several variables (PV, specific humidity, etc.) to particle position
+ !*****************************************************************************
+ ! Where in the grid? Stereographic (ngrid<0) or nested (ngrid>0)
+ !***************************************************************
+ call find_ngrid(real(part(i)%xlon),real(part(i)%ylat))
+ call determine_grid_coordinates(real(part(i)%xlon),real(part(i)%ylat))
+ call find_grid_distances(real(part(i)%xlon),real(part(i)%ylat))
+ ! First set dz1out from interpol_mod to -1 so it only is calculated once per particle
+ !************************************************************************************
+ dz1out=-1
+ cartxyz_comp=.false.
+ do np=1,num_partopt
+ if (.not. partopt(np)%print) cycle ! Only compute when field should be printed
+ i_av = partopt(np)%i_average
+ if (init_out.and.(i_av.ne.0)) cycle ! no averages for initial particle output
+ if ((i_av.ne.0).and.(part(i)%ntime.eq.0)) then
+ if (partopt(np)%name.eq.'ma') then
+ masstemp_av(i,1:nspec) = -1
+ else
+ output(np,i) = -1
+ endif
+ cycle ! no averages for freshly spawned particles
+ endif
+ select case (partopt(np)%name)
+ case ('LO')
+ output(np,i)=xlon0+part(i)%xlon*dx
+ cycle
+ case ('LA')
+ output(np,i)=ylat0+part(i)%ylat*dy
+ cycle
+ case ('TO') ! Topography
+ if (ngrid.le.0) then
+ call horizontal_interpolation(oro,output(np,i))
+ else
+ call horizontal_interpolation_nests(oron,output(np,i))
+ endif
+ cycle
+ case ('TR') ! Tropopause
+ if (ngrid.le.0) then
+ do m=1,2
+ call horizontal_interpolation(tropopause,tmp(m),1,memind(m),1)
+ end do
+ else
+ do m=1,2
+ call horizontal_interpolation_nests(tropopausen,tmp(m),1,memind(m),1)
+ end do
+ endif
+ call temporal_interpolation(tmp(1),tmp(2),output(np,i))
+ cycle
+ case ('HM') ! PBL height
+ if (ngrid.le.0) then
+ do m=1,2
+ call horizontal_interpolation(hmix,tmp(m),1,memind(m),1)
+ end do
+ else
+ do m=1,2
+ call horizontal_interpolation_nests(hmixn,tmp(m),1,memind(m),1)
+ end do
+ endif
+ call temporal_interpolation(tmp(1),tmp(2),output(np,i))
+ cycle
+ case ('ZZ') ! Height
+ call update_zeta_to_z(itime, i) ! Convert eta z coordinate to meters if necessary
+ output(np,i)=part(i)%z
+ cycle
+ ! case ('UU') ! Longitudinal velocity
+ ! output(np,i)=part(i)%vel%u !This would be preferred, but not implemented yet
+ ! cycle
+ case ('VS') ! Settling velocity
+ output(np,i)=part(i)%settling
+ cycle
+ case ('MA') ! Mass
+ do ns=1,nspec
+ masstemp(i,ns)=part(i)%mass(ns)
+ end do
+ cycle
+ case ('ma') ! Mass averaged
+ do ns=1,nspec
+ masstemp_av(i,ns)=part(i)%val_av(i_av+(ns-1))/part(i)%ntime
+ end do
+ cycle
+ case ('WD') ! Wet deposition
+ do ns=1,nspec
+ wetdepotemp(i,ns)=part(i)%wetdepo(ns)
+ end do
+ cycle
+ case ('DD') ! dry deposition
+ do ns=1,nspec
+ drydepotemp(i,ns)=part(i)%drydepo(ns)
+ end do
+ cycle
+ case ('lo')
+ if (.not. cartxyz_comp) then
+ cartxyz(1) = part(i)%cartx_av/part(i)%ntime
+ cartxyz(2) = part(i)%carty_av/part(i)%ntime
+ cartxyz(3) = part(i)%cartz_av/part(i)%ntime
+ cartxyz_comp=.true.
+ endif
+ output(np,i) = atan2(cartxyz(1),-1.*cartxyz(2))/pi180
+ if (output(np,i).gt.360.) output(np,i)=output(np,i)-360.
+ if (output(np,i).lt.0.) output(np,i)=output(np,i)+360.
+ cycle
+ case ('la')
+ if (.not. cartxyz_comp) then
+ cartxyz(1) = part(i)%cartx_av/part(i)%ntime
+ cartxyz(2) = part(i)%carty_av/part(i)%ntime
+ cartxyz(3) = part(i)%cartz_av/part(i)%ntime
+ cartxyz_comp=.true.
+ endif
+ output(np,i) = atan2(cartxyz(3),sqrt(cartxyz(1)*cartxyz(1)+ &
+ cartxyz(2)*cartxyz(2)))/pi180
+ case default
+ if (.not. partopt(np)%average) then
+ call interpol_partoutput_value(partopt(np)%name,output(np,i),i)
+ else
+ output(np,i) = part(i)%val_av(i_av)/part(i)%ntime
+ endif
+ end select
+ end do
+ ! Reset dz1out
+ !*************
+ dz1out=-1
+ cartxyz_comp=.false.
+
+ if ((.not. init_out).and.(n_average.gt.0)) then
+ part(i)%val_av = 0.
+ part(i)%ntime = 0.
+ part(i)%cartx_av = 0.
+ part(i)%carty_av = 0.
+ part(i)%cartz_av = 0.
+ endif
+ end do
+
+!$OMP END DO
+!$OMP END PARALLEL
+
+ if ((.not. init_out).and.(numpart.gt.0)) then
+ do np=1,num_partopt
+ if (.not. partopt(np)%print) cycle
+ if (partopt(np)%name.eq.'MA') then
+ write(*,*) partopt(np)%long_name, masstemp(1,:)
+ else if (partopt(np)%name.eq.'ma') then
+ write(*,*) partopt(np)%long_name, masstemp_av(1,:)
+ else if (partopt(np)%name.eq.'WD') then
+ write(*,*) partopt(np)%long_name, wetdepotemp(1,:)
+ else if (partopt(np)%name.eq.'DD') then
+ write(*,*) partopt(np)%long_name, drydepotemp(1,:)
+ else
+ write(*,*) partopt(np)%long_name, output(np,1)
+ endif
+ end do
+ write(*,*) part(1)%prob,part(1)%alive
+ write(*,*) 'Alive: ', count%alive, 'Total spawned: ', count%spawned, 'Terminated: ', count%terminated
+ endif
+
+ ! Determine current calendar date, needed for the file name
+ !**********************************************************
+
+ jul=bdate+real(itime,kind=dp)/86400._dp
+ call caldate(jul,jjjjmmdd,ihmmss)
+ write(adate,'(i8.8)') jjjjmmdd
+ write(atime,'(i6.6)') ihmmss
+ j=1
+ if (lnetcdfout.eq.1) then
+ ! open output file
+ if (init_out) then
+ call open_partinit_file(ncid)
+ else
+ call open_partoutput_file(ncid)
+
+ ! First allocate the time and particle dimensions within the netcdf file
+ call partoutput_netcdf(itime,xlon,'TI',j,ncid)
+ call partoutput_netcdf(itime,xlon,'PA',j,ncid)
+ endif
+
+ ! Fill the fields in parallel
+ if (numpart.gt.0) then
+!$OMP PARALLEL PRIVATE(np,ns)
+!$OMP DO SCHEDULE(dynamic)
+ do np=1,num_partopt
+ !write(*,*) partopt(np)%name, output(np,1)
+ if (.not. partopt(np)%print) cycle
+ if (init_out.and.(partopt(np)%i_average.ne.0)) cycle ! no averages for initial particle output
+ !write(*,*) partopt(np)%name
+ if (partopt(np)%name.eq.'MA') then
+ do ns=1,nspec
+ if (init_out) then
+ call partinit_netcdf(itime,masstemp(:,ns),'MA',ns,ncid)
+ else
+ call partoutput_netcdf(itime,masstemp(:,ns),'MA',ns,ncid)
+ endif
+ end do
+ else if (partopt(np)%name.eq.'ma') then
+ do ns=1,nspec
+ call partoutput_netcdf(itime,masstemp_av(:,ns),'ma',ns,ncid)
+ end do
+ else if ((.not. init_out).and.(partopt(np)%name.eq.'WD')) then
+ do ns=1,nspec
+ call partoutput_netcdf(itime,wetdepotemp(:,ns),'WD',ns,ncid)
+ end do
+ else if ((.not. init_out).and.(partopt(np)%name.eq.'DD')) then
+ do ns=1,nspec
+ call partoutput_netcdf(itime,drydepotemp(:,ns),'DD',ns,ncid)
+ end do
+ else
+ if (init_out) then
+ call partinit_netcdf(itime,output(np,:),partopt(np)%name,j,ncid)
+ else
+ call partoutput_netcdf(itime,output(np,:),partopt(np)%name,j,ncid)
+ endif
+ endif
+ end do
+!$OMP END DO
+!$OMP END PARALLEL
+ endif
+ call close_partoutput_file(ncid)
+ if (.not. init_out) then
+ mass_written=.true. ! needs to be reduced within openmp loop
+ topo_written=.true. ! same
+ endif
+ else
+ ! Put binary function here
+ endif
+#else
+ ! Put binary function here
+#endif
+end subroutine output_particles
+
+subroutine output_concentrations(itime,loutstart,loutend,loutnext,outnum)
+ use unc_mod
+ use outg_mod
+ use par_mod
+ use com_mod
+#ifdef USE_NCF
+ use netcdf_output_mod, only: concoutput_netcdf,concoutput_nest_netcdf,&
+ &concoutput_surf_netcdf,concoutput_surf_nest_netcdf
+#endif
+ use binary_output_mod
+
+ implicit none
+
+ integer,intent(in) :: &
+ itime ! time index
+ integer,intent(inout) :: &
+ loutstart,loutend, & ! concentration calculation starting and ending time
+ loutnext
+ real,intent(inout) :: &
+ outnum ! concentration calculation sample number
+ real(sp) :: &
+ gridtotalunc ! concentration calculation related
+ real(dep_prec) :: &
+ wetgridtotalunc, & ! concentration calculation related
+ drygridtotalunc ! concentration calculation related
+ real :: &
+ weight ! concentration calculation sample weight
+
+
+ ! Is the time within the computation interval, if not, return
+ !************************************************************
+ if ((ldirect*itime.lt.ldirect*loutstart).or.(ldirect*itime.gt.ldirect*loutend)) then
+ return
+ endif
+
+ ! If we are exactly at the start or end of the concentration averaging interval,
+ ! give only half the weight to this sample
+ !*****************************************************************************
+ if (mod(itime-loutstart,loutsample).eq.0) then
+ if ((itime.eq.loutstart).or.(itime.eq.loutend)) then
+ weight=0.5
+ else
+ weight=1.0
+ endif
+ outnum=outnum+weight
+ if (iout.ne.0) call conccalc(itime,weight)
+ endif
+
+ ! If no grid is to be written to file, return (LB)
+ !*************************************************
+ if (iout.eq.0) then
+ if (itime.ne.loutend) return
+ loutnext=loutnext+loutstep
+ loutstart=loutnext-loutaver/2
+ loutend=loutnext+loutaver/2
+ if (itime.eq.loutstart) then
+ weight=0.5
+ outnum=outnum+weight
+ endif
+ return
+ endif
+
+ ! If it is not time yet to write outputs, return
+ !***********************************************
+ if ((itime.ne.loutend).or.(outnum.le.0)) then
+ return
+ endif
+
+ ! Output and reinitialization of grid
+ ! If necessary, first sample of new grid is also taken
+ !*****************************************************
+ if ((iout.le.3.).or.(iout.eq.5)) then
+ if (surf_only.ne.1) then
+#ifdef USE_NCF
+ call concoutput_netcdf(itime,outnum,gridtotalunc,wetgridtotalunc,drygridtotalunc)
+#else
+ call concoutput(itime,outnum,gridtotalunc,wetgridtotalunc,drygridtotalunc)
+#endif
+ else
+#ifdef USE_NCF
+ call concoutput_surf_netcdf(itime,outnum,gridtotalunc,wetgridtotalunc,drygridtotalunc)
+#else
+ if (linversionout.eq.1) then
+ call concoutput_inversion(itime,outnum,gridtotalunc,wetgridtotalunc,drygridtotalunc)
+ else
+ call concoutput_surf(itime,outnum,gridtotalunc,wetgridtotalunc,drygridtotalunc)
+ endif
+#endif
+ endif
+
+ if (nested_output .eq. 1) then
+#ifdef USE_NCF
+ if (surf_only.ne.1) then
+ call concoutput_nest_netcdf(itime,outnum)
+ else
+ call concoutput_surf_nest_netcdf(itime,outnum)
+ endif
+#else
+ if (surf_only.ne.1) then
+ call concoutput_nest(itime,outnum)
+ else
+ if(linversionout.eq.1) then
+ call concoutput_inversion_nest(itime,outnum)
+ else
+ call concoutput_surf_nest(itime,outnum)
+ endif
+ endif
+#endif
+ endif
+ outnum=0.
+ endif
+
+ write(*,45) itime,numpart,gridtotalunc,wetgridtotalunc,drygridtotalunc
+
+45 format(i13,' Seconds simulated: ',i13, ' Particles: Uncertainty: ',3f7.3)
+
+ loutnext=loutnext+loutstep
+ loutstart=loutnext-loutaver/2
+ loutend=loutnext+loutaver/2
+ if (itime.eq.loutstart) then
+ weight=0.5
+ outnum=outnum+weight
+ call conccalc(itime,weight)
+ endif
+end subroutine output_concentrations
+
+subroutine conccalc(itime,weight)
+ ! i i
+ !*****************************************************************************
+ ! *
+ ! Calculation of the concentrations on a regular grid using volume *
+ ! sampling *
+ ! *
+ ! Author: A. Stohl *
+ ! *
+ ! 24 May 1996 *
+ ! *
+ ! April 2000: Update to calculate age spectra *
+ ! Bug fix to avoid negative conc. at the domain boundaries, *
+ ! as suggested by Petra Seibert *
+ ! *
+ ! 2 July 2002: re-order if-statements in order to optimize CPU time *
+ ! *
+ ! 2021, LB: OpenMP parallelisation *
+ ! *
+ !*****************************************************************************
+ ! *
+ ! Variables: *
+ ! nspeciesdim = nspec for forward runs, 1 for backward runs *
+ ! *
+ !*****************************************************************************
+
+ use unc_mod
+ use outg_mod
+ use par_mod
+ use com_mod
+ use omp_lib, only: OMP_GET_THREAD_NUM
+ use interpol_mod, only: interpol_density
+ use coordinates_ecmwf_mod
+ use particle_mod
+
+ implicit none
+
+ integer,intent(in) :: itime
+ real,intent(in) :: weight
+ integer :: itage,i,kz,ks,n,nage,inage,thread,ithread
+ integer :: il,ind,indz,indzp,nrelpointer
+ integer :: ix,jy,ixp,jyp
+ real :: ddx,ddy
+ real(kind=dp) :: mm3
+ real :: hx,hy,hz,hxyz,xd,yd,zd,xkern,r2,c(maxspec)
+ real :: rhoi
+ real :: xl,yl,wx,wy,w
+ real,parameter :: factor=.596831, hxmax=6.0, hymax=4.0, hzmax=150.
+ ! integer xscav_count
+
+ ! For forward simulations, make a loop over the number of species;
+ ! for backward simulations, make an additional loop over the
+ ! releasepoints
+ !***************************************************************************
+ ! xscav_count=0
+#ifdef _OPENMP
+ call omp_set_num_threads(numthreads_grid)
+#endif
+!$OMP PARALLEL PRIVATE(i,itage,nage,inage,rhoi,nrelpointer,kz,xl,yl,ks,wx,wy,w,thread,ddx,ddy, &
+!$OMP ix,jy,ixp,jyp)
+#if (defined _OPENMP)
+ thread = OMP_GET_THREAD_NUM()+1 ! Starts with 1
+#else
+ thread = 1
+#endif
+
+!$OMP DO
+ do i=1,numpart
+ if (.not.part(i)%alive) cycle
+
+ ! Determine age class of the particle
+ itage=abs(itime-part(i)%tstart)
+ nage=1
+ do inage=1,nageclass
+ nage=inage
+ if (itage.lt.lage(nage)) exit
+ end do
+
+ ! if (xscav_frac1(i,1).lt.0) xscav_count=xscav_count+1
+
+ ! For special runs, interpolate the air density to the particle position
+ !************************************************************************
+ !***********************************************************************
+ !AF IND_SOURCE switches between different units for concentrations at the source
+ !Af NOTE that in backward simulations the release of particles takes place
+ !Af at the receptor and the sampling at the source.
+ !Af 1="mass"
+ !Af 2="mass mixing ratio"
+ !Af IND_RECEPTOR switches between different units for concentrations at the receptor
+ !Af 1="mass"
+ !Af 2="mass mixing ratio"
+
+ !Af switches for the conccalcfile:
+ !AF IND_SAMP = 0 : xmass * 1
+ !Af IND_SAMP = -1 : xmass / rho
+
+ !Af ind_samp is defined in readcommand.f
+
+ if ( ind_samp .eq. -1 ) then
+ call update_zeta_to_z(itime,i)
+ call interpol_density(itime,i,rhoi)
+ elseif (ind_samp.eq.0) then
+ rhoi = 1.
+ endif
+
+ !****************************************************************************
+ ! 1. Evaluate grid concentrations using a uniform kernel of bandwidths dx, dy
+ !****************************************************************************
+
+
+ ! For backward simulations, look from which release point the particle comes from
+ ! For domain-filling trajectory option, npoint contains a consecutive particle
+ ! number, not the release point information. Therefore, nrelpointer is set to 1
+ ! for the domain-filling option.
+ !*****************************************************************************
+
+ if ((ioutputforeachrelease.eq.0).or.(mdomainfill.eq.1)) then
+ nrelpointer=1
+ else
+ nrelpointer=part(i)%npoint
+ endif
+
+ do kz=1,numzgrid ! determine height of cell
+ if (outheight(kz).gt.part(i)%z) exit
+ end do
+
+ if (kz.le.numzgrid) then ! inside output domain
+
+
+ !********************************
+ ! Do everything for mother domain
+ !********************************
+
+ xl=(part(i)%xlon*dx+xoutshift)/dxout
+ yl=(part(i)%ylat*dy+youtshift)/dyout
+ ix=int(xl)
+ if (xl.lt.0.) ix=ix-1
+ jy=int(yl)
+ if (yl.lt.0.) jy=jy-1
+
+
+
+ ! For particles aged less than 3 hours, attribute particle mass to grid cell
+ ! it resides in rather than use the kernel, in order to avoid its smoothing effect.
+ ! For older particles, use the uniform kernel.
+ ! If a particle is close to the domain boundary, do not use the kernel either.
+ !*****************************************************************************
+
+ if ((.not.lusekerneloutput).or.(itage.lt.10800).or. &
+ (xl.lt.0.5).or.(yl.lt.0.5).or. &
+ (xl.gt.real(numxgrid-1)-0.5).or. &
+ (yl.gt.real(numygrid-1)-0.5)) then ! no kernel, direct attribution to grid cell
+
+ if ((ix.ge.0).and.(jy.ge.0).and.(ix.le.numxgrid-1).and. &
+ (jy.le.numygrid-1)) then
+ if (DRYBKDEP.or.WETBKDEP) then
+ do ks=1,nspec
+#ifdef _OPENMP
+ gridunc_omp(ix,jy,kz,ks,nrelpointer,part(i)%nclass,nage,thread)= &
+ gridunc_omp(ix,jy,kz,ks,nrelpointer,part(i)%nclass,nage,thread)+ &
+ part(i)%mass(ks)/rhoi*weight*max(xscav_frac1(i,ks),0.0)
+#else
+ gridunc(ix,jy,kz,ks,nrelpointer,part(i)%nclass,nage)= &
+ gridunc(ix,jy,kz,ks,nrelpointer,part(i)%nclass,nage)+ &
+ part(i)%mass(ks)/rhoi*weight*max(xscav_frac1(i,ks),0.0)
+#endif
+ end do
+ else
+ if (lparticlecountoutput) then
+ do ks=1,nspec
+#ifdef _OPENMP
+ gridunc_omp(ix,jy,kz,ks,nrelpointer,part(i)%nclass,nage,thread)= &
+ gridunc_omp(ix,jy,kz,ks,nrelpointer,part(i)%nclass,nage,thread)+1
+#else
+ gridunc(ix,jy,kz,ks,nrelpointer,part(i)%nclass,nage)= &
+ gridunc(ix,jy,kz,ks,nrelpointer,part(i)%nclass,nage)+1
+#endif
+ end do
+ else
+ do ks=1,nspec
+#ifdef _OPENMP
+ gridunc_omp(ix,jy,kz,ks,nrelpointer,part(i)%nclass,nage,thread)= &
+ gridunc_omp(ix,jy,kz,ks,nrelpointer,part(i)%nclass,nage,thread)+ &
+ part(i)%mass(ks)/rhoi*weight
+#else
+ gridunc(ix,jy,kz,ks,nrelpointer,part(i)%nclass,nage)= &
+ gridunc(ix,jy,kz,ks,nrelpointer,part(i)%nclass,nage)+ &
+ part(i)%mass(ks)/rhoi*weight
+#endif
+ end do
+ end if
+ endif
+ endif
+
+ else ! attribution via uniform kernel
+
+ ddx=xl-real(ix) ! distance to left cell border
+ ddy=yl-real(jy) ! distance to lower cell border
+ if (ddx.gt.0.5) then
+ ixp=ix+1
+ wx=1.5-ddx
+ else
+ ixp=ix-1
+ wx=0.5+ddx
+ endif
+
+ if (ddy.gt.0.5) then
+ jyp=jy+1
+ wy=1.5-ddy
+ else
+ jyp=jy-1
+ wy=0.5+ddy
+ endif
+
+ ! Determine mass fractions for four grid points
+ !**********************************************
+
+ if ((ix.ge.0).and.(ix.le.numxgrid-1)) then
+ if ((jy.ge.0).and.(jy.le.numygrid-1)) then
+ w=wx*wy
+ if (DRYBKDEP.or.WETBKDEP) then
+ do ks=1,nspec
+#ifdef _OPENMP
+ gridunc_omp(ix,jy,kz,ks,nrelpointer,part(i)%nclass,nage,thread)= &
+ gridunc_omp(ix,jy,kz,ks,nrelpointer,part(i)%nclass,nage,thread)+ &
+ part(i)%mass(ks)/rhoi*w*weight*max(xscav_frac1(i,ks),0.0)
+#else
+ gridunc(ix,jy,kz,ks,nrelpointer,part(i)%nclass,nage)= &
+ gridunc(ix,jy,kz,ks,nrelpointer,part(i)%nclass,nage)+ &
+ part(i)%mass(ks)/rhoi*w*weight*max(xscav_frac1(i,ks),0.0)
+#endif
+ end do
+ else
+ do ks=1,nspec
+#ifdef _OPENMP
+ gridunc_omp(ix,jy,kz,ks,nrelpointer,part(i)%nclass,nage,thread)= &
+ gridunc_omp(ix,jy,kz,ks,nrelpointer,part(i)%nclass,nage,thread)+ &
+ part(i)%mass(ks)/rhoi*weight*w
+#else
+ gridunc(ix,jy,kz,ks,nrelpointer,part(i)%nclass,nage)= &
+ gridunc(ix,jy,kz,ks,nrelpointer,part(i)%nclass,nage)+ &
+ part(i)%mass(ks)/rhoi*weight*w
+#endif
+ end do
+ endif
+ endif
+
+ if ((jyp.ge.0).and.(jyp.le.numygrid-1)) then
+ w=wx*(1.-wy)
+ if (DRYBKDEP.or.WETBKDEP) then
+ do ks=1,nspec
+#ifdef _OPENMP
+ gridunc_omp(ix,jyp,kz,ks,nrelpointer,part(i)%nclass,nage,thread)= &
+ gridunc_omp(ix,jyp,kz,ks,nrelpointer,part(i)%nclass,nage,thread)+ &
+ part(i)%mass(ks)/rhoi*weight*w*max(xscav_frac1(i,ks),0.0)
+#else
+ gridunc(ix,jyp,kz,ks,nrelpointer,part(i)%nclass,nage)= &
+ gridunc(ix,jyp,kz,ks,nrelpointer,part(i)%nclass,nage)+ &
+ part(i)%mass(ks)/rhoi*weight*w*max(xscav_frac1(i,ks),0.0)
+#endif
+ end do
+ else
+ do ks=1,nspec
+#ifdef _OPENMP
+ gridunc_omp(ix,jyp,kz,ks,nrelpointer,part(i)%nclass,nage,thread)= &
+ gridunc_omp(ix,jyp,kz,ks,nrelpointer,part(i)%nclass,nage,thread)+ &
+ part(i)%mass(ks)/rhoi*weight*w
+#else
+ gridunc(ix,jyp,kz,ks,nrelpointer,part(i)%nclass,nage)= &
+ gridunc(ix,jyp,kz,ks,nrelpointer,part(i)%nclass,nage)+ &
+ part(i)%mass(ks)/rhoi*weight*w
+#endif
+ end do
+ endif
+ endif
+ endif !ix ge 0
+
+
+ if ((ixp.ge.0).and.(ixp.le.numxgrid-1)) then
+ if ((jyp.ge.0).and.(jyp.le.numygrid-1)) then
+ w=(1.-wx)*(1.-wy)
+ if (DRYBKDEP.or.WETBKDEP) then
+ do ks=1,nspec
+#ifdef _OPENMP
+ gridunc_omp(ixp,jyp,kz,ks,nrelpointer,part(i)%nclass,nage,thread)= &
+ gridunc_omp(ixp,jyp,kz,ks,nrelpointer,part(i)%nclass,nage,thread)+ &
+ part(i)%mass(ks)/rhoi*w*weight*max(xscav_frac1(i,ks),0.0)
+#else
+ gridunc(ixp,jyp,kz,ks,nrelpointer,part(i)%nclass,nage)= &
+ gridunc(ixp,jyp,kz,ks,nrelpointer,part(i)%nclass,nage)+ &
+ part(i)%mass(ks)/rhoi*w*weight*max(xscav_frac1(i,ks),0.0)
+#endif
+ end do
+ else
+ do ks=1,nspec
+#ifdef _OPENMP
+ gridunc_omp(ixp,jyp,kz,ks,nrelpointer,part(i)%nclass,nage,thread)= &
+ gridunc_omp(ixp,jyp,kz,ks,nrelpointer,part(i)%nclass,nage,thread)+ &
+ part(i)%mass(ks)/rhoi*weight*w
+#else
+ gridunc(ixp,jyp,kz,ks,nrelpointer,part(i)%nclass,nage)= &
+ gridunc(ixp,jyp,kz,ks,nrelpointer,part(i)%nclass,nage)+ &
+ part(i)%mass(ks)/rhoi*weight*w
+#endif
+ end do
+ endif
+ endif
+
+ if ((jy.ge.0).and.(jy.le.numygrid-1)) then
+ w=(1.-wx)*wy
+ if (DRYBKDEP.or.WETBKDEP) then
+ do ks=1,nspec
+#ifdef _OPENMP
+ gridunc_omp(ixp,jy,kz,ks,nrelpointer,part(i)%nclass,nage,thread)= &
+ gridunc_omp(ixp,jy,kz,ks,nrelpointer,part(i)%nclass,nage,thread)+ &
+ part(i)%mass(ks)/rhoi*weight*w*max(xscav_frac1(i,ks),0.0)
+#else
+ gridunc(ixp,jy,kz,ks,nrelpointer,part(i)%nclass,nage)= &
+ gridunc(ixp,jy,kz,ks,nrelpointer,part(i)%nclass,nage)+ &
+ part(i)%mass(ks)/rhoi*weight*w*max(xscav_frac1(i,ks),0.0)
+#endif
+ end do
+ else
+ do ks=1,nspec
+#ifdef _OPENMP
+ gridunc_omp(ixp,jy,kz,ks,nrelpointer,part(i)%nclass,nage,thread)= &
+ gridunc_omp(ixp,jy,kz,ks,nrelpointer,part(i)%nclass,nage,thread)+ &
+ part(i)%mass(ks)/rhoi*weight*w
+#else
+ gridunc(ixp,jy,kz,ks,nrelpointer,part(i)%nclass,nage)= &
+ gridunc(ixp,jy,kz,ks,nrelpointer,part(i)%nclass,nage)+ &
+ part(i)%mass(ks)/rhoi*weight*w
+#endif
+ end do
+ endif
+ endif
+ endif !ixp ge 0
+ endif
+
+ !************************************
+ ! Do everything for the nested domain
+ !************************************
+
+ if (nested_output.eq.1) then
+ xl=(part(i)%xlon*dx+xoutshiftn)/dxoutn
+ yl=(part(i)%ylat*dy+youtshiftn)/dyoutn
+ ix=int(xl)
+ if (xl.lt.0.) ix=ix-1
+ jy=int(yl)
+ if (yl.lt.0.) jy=jy-1
+
+
+ ! For particles aged less than 3 hours, attribute particle mass to grid cell
+ ! it resides in rather than use the kernel, in order to avoid its smoothing effect.
+ ! For older particles, use the uniform kernel.
+ ! If a particle is close to the domain boundary, do not use the kernel either.
+ !*****************************************************************************
+
+ if ((itage.lt.10800).or.(xl.lt.0.5).or.(yl.lt.0.5).or. &
+ (xl.gt.real(numxgridn-1)-0.5).or. &
+ (yl.gt.real(numygridn-1)-0.5).or.((.not.lusekerneloutput))) then
+ ! no kernel, direct attribution to grid cell
+ if ((ix.ge.0).and.(jy.ge.0).and.(ix.le.numxgridn-1).and. &
+ (jy.le.numygridn-1)) then
+ if (DRYBKDEP.or.WETBKDEP) then
+ do ks=1,nspec
+#ifdef _OPENMP
+ griduncn_omp(ix,jy,kz,ks,nrelpointer,part(i)%nclass,nage,thread)= &
+ griduncn_omp(ix,jy,kz,ks,nrelpointer,part(i)%nclass,nage,thread)+ &
+ part(i)%mass(ks)/rhoi*weight*max(xscav_frac1(i,ks),0.0)
+#else
+ griduncn(ix,jy,kz,ks,nrelpointer,part(i)%nclass,nage)= &
+ griduncn(ix,jy,kz,ks,nrelpointer,part(i)%nclass,nage)+ &
+ part(i)%mass(ks)/rhoi*weight*max(xscav_frac1(i,ks),0.0)
+#endif
+ end do
+ else
+ if (lparticlecountoutput) then
+ do ks=1,nspec
+#ifdef _OPENMP
+ griduncn_omp(ix,jy,kz,ks,nrelpointer,part(i)%nclass,nage,thread)= &
+ griduncn_omp(ix,jy,kz,ks,nrelpointer,part(i)%nclass,nage,thread)+1
+#else
+ griduncn(ix,jy,kz,ks,nrelpointer,part(i)%nclass,nage)= &
+ griduncn(ix,jy,kz,ks,nrelpointer,part(i)%nclass,nage)+1
+#endif
+ end do
+ else
+ do ks=1,nspec
+#ifdef _OPENMP
+ griduncn_omp(ix,jy,kz,ks,nrelpointer,part(i)%nclass,nage,thread)= &
+ griduncn_omp(ix,jy,kz,ks,nrelpointer,part(i)%nclass,nage,thread)+ &
+ part(i)%mass(ks)/rhoi*weight
+#else
+ griduncn(ix,jy,kz,ks,nrelpointer,part(i)%nclass,nage)= &
+ griduncn(ix,jy,kz,ks,nrelpointer,part(i)%nclass,nage)+ &
+ part(i)%mass(ks)/rhoi*weight
+#endif
+ end do
+ endif
+ endif
+ endif
+
+ else ! attribution via uniform kernel
+
+ ddx=xl-real(ix) ! distance to left cell border
+ ddy=yl-real(jy) ! distance to lower cell border
+ if (ddx.gt.0.5) then
+ ixp=ix+1
+ wx=1.5-ddx
+ else
+ ixp=ix-1
+ wx=0.5+ddx
+ endif
+
+ if (ddy.gt.0.5) then
+ jyp=jy+1
+ wy=1.5-ddy
+ else
+ jyp=jy-1
+ wy=0.5+ddy
+ endif
+
+
+ ! Determine mass fractions for four grid points
+ !**********************************************
+
+ if ((ix.ge.0).and.(ix.le.numxgridn-1)) then
+ if ((jy.ge.0).and.(jy.le.numygridn-1)) then
+ w=wx*wy
+ if (DRYBKDEP.or.WETBKDEP) then
+ do ks=1,nspec
+#ifdef _OPENMP
+ griduncn_omp(ix,jy,kz,ks,nrelpointer,part(i)%nclass,nage,thread)= &
+ griduncn_omp(ix,jy,kz,ks,nrelpointer,part(i)%nclass,nage,thread)+ &
+ part(i)%mass(ks)/rhoi*weight*w*max(xscav_frac1(i,ks),0.0)
+#else
+ griduncn(ix,jy,kz,ks,nrelpointer,part(i)%nclass,nage)= &
+ griduncn(ix,jy,kz,ks,nrelpointer,part(i)%nclass,nage)+ &
+ part(i)%mass(ks)/rhoi*weight*w*max(xscav_frac1(i,ks),0.0)
+#endif
+ end do
+ else
+ do ks=1,nspec
+#ifdef _OPENMP
+ griduncn_omp(ix,jy,kz,ks,nrelpointer,part(i)%nclass,nage,thread)= &
+ griduncn_omp(ix,jy,kz,ks,nrelpointer,part(i)%nclass,nage,thread)+ &
+ part(i)%mass(ks)/rhoi*weight*w
+#else
+ griduncn(ix,jy,kz,ks,nrelpointer,part(i)%nclass,nage)= &
+ griduncn(ix,jy,kz,ks,nrelpointer,part(i)%nclass,nage)+ &
+ part(i)%mass(ks)/rhoi*weight*w
+#endif
+ end do
+ endif
+ endif
+
+ if ((jyp.ge.0).and.(jyp.le.numygridn-1)) then
+ w=wx*(1.-wy)
+ if (DRYBKDEP.or.WETBKDEP) then
+ do ks=1,nspec
+#ifdef _OPENMP
+ griduncn_omp(ix,jyp,kz,ks,nrelpointer,part(i)%nclass,nage,thread)= &
+ griduncn_omp(ix,jyp,kz,ks,nrelpointer,part(i)%nclass,nage,thread)+ &
+ part(i)%mass(ks)/rhoi*weight*w*max(xscav_frac1(i,ks),0.0)
+#else
+ griduncn(ix,jyp,kz,ks,nrelpointer,part(i)%nclass,nage)= &
+ griduncn(ix,jyp,kz,ks,nrelpointer,part(i)%nclass,nage)+ &
+ part(i)%mass(ks)/rhoi*weight*w*max(xscav_frac1(i,ks),0.0)
+#endif
+ end do
+ else
+ do ks=1,nspec
+#ifdef _OPENMP
+ griduncn_omp(ix,jyp,kz,ks,nrelpointer,part(i)%nclass,nage,thread)= &
+ griduncn_omp(ix,jyp,kz,ks,nrelpointer,part(i)%nclass,nage,thread)+ &
+ part(i)%mass(ks)/rhoi*weight*w
+#else
+ griduncn(ix,jyp,kz,ks,nrelpointer,part(i)%nclass,nage)= &
+ griduncn(ix,jyp,kz,ks,nrelpointer,part(i)%nclass,nage)+ &
+ part(i)%mass(ks)/rhoi*weight*w
+#endif
+ end do
+ endif
+ endif
+ endif
+
+
+ if ((ixp.ge.0).and.(ixp.le.numxgridn-1)) then
+ if ((jyp.ge.0).and.(jyp.le.numygridn-1)) then
+ w=(1.-wx)*(1.-wy)
+ if (DRYBKDEP.or.WETBKDEP) then
+ do ks=1,nspec
+#ifdef _OPENMP
+ griduncn_omp(ixp,jyp,kz,ks,nrelpointer,part(i)%nclass,nage,thread)= &
+ griduncn_omp(ixp,jyp,kz,ks,nrelpointer,part(i)%nclass,nage,thread)+ &
+ part(i)%mass(ks)/rhoi*weight*w*max(xscav_frac1(i,ks),0.0)
+#else
+ griduncn(ixp,jyp,kz,ks,nrelpointer,part(i)%nclass,nage)= &
+ griduncn(ixp,jyp,kz,ks,nrelpointer,part(i)%nclass,nage)+ &
+ part(i)%mass(ks)/rhoi*weight*w*max(xscav_frac1(i,ks),0.0)
+#endif
+ end do
+ else
+ do ks=1,nspec
+#ifdef _OPENMP
+ griduncn_omp(ixp,jyp,kz,ks,nrelpointer,part(i)%nclass,nage,thread)= &
+ griduncn_omp(ixp,jyp,kz,ks,nrelpointer,part(i)%nclass,nage,thread)+ &
+ part(i)%mass(ks)/rhoi*weight*w
+#else
+ griduncn(ixp,jyp,kz,ks,nrelpointer,part(i)%nclass,nage)= &
+ griduncn(ixp,jyp,kz,ks,nrelpointer,part(i)%nclass,nage)+ &
+ part(i)%mass(ks)/rhoi*weight*w
+#endif
+ end do
+ endif
+ endif
+
+ if ((jy.ge.0).and.(jy.le.numygridn-1)) then
+ w=(1.-wx)*wy
+ if (DRYBKDEP.or.WETBKDEP) then
+ do ks=1,nspec
+#ifdef _OPENMP
+ griduncn_omp(ixp,jy,kz,ks,nrelpointer,part(i)%nclass,nage,thread)= &
+ griduncn_omp(ixp,jy,kz,ks,nrelpointer,part(i)%nclass,nage,thread)+ &
+ part(i)%mass(ks)/rhoi*weight*w*max(xscav_frac1(i,ks),0.0)
+#else
+ griduncn(ixp,jy,kz,ks,nrelpointer,part(i)%nclass,nage)= &
+ griduncn(ixp,jy,kz,ks,nrelpointer,part(i)%nclass,nage)+ &
+ part(i)%mass(ks)/rhoi*weight*w*max(xscav_frac1(i,ks),0.0)
+#endif
+ end do
+ else
+ do ks=1,nspec
+#ifdef _OPENMP
+ griduncn_omp(ixp,jy,kz,ks,nrelpointer,part(i)%nclass,nage,thread)= &
+ griduncn_omp(ixp,jy,kz,ks,nrelpointer,part(i)%nclass,nage,thread)+ &
+ part(i)%mass(ks)/rhoi*weight*w
+#else
+ griduncn(ixp,jy,kz,ks,nrelpointer,part(i)%nclass,nage)= &
+ griduncn(ixp,jy,kz,ks,nrelpointer,part(i)%nclass,nage)+ &
+ part(i)%mass(ks)/rhoi*weight*w
+#endif
+ end do
+ endif
+ endif
+ endif
+ endif
+ endif
+ endif
+ end do
+!$OMP END DO
+!$OMP END PARALLEL
+#ifdef _OPENMP
+ call omp_set_num_threads(numthreads)
+#endif
+ ! Reduction of gridunc and griduncn
+#ifdef _OPENMP
+ do ithread=1,numthreads_grid
+ gridunc(:,:,:,:,:,:,:)=gridunc(:,:,:,:,:,:,:)+gridunc_omp(:,:,:,:,:,:,:,ithread)
+ gridunc_omp(:,:,:,:,:,:,:,ithread)=0.
+ end do
+ if (nested_output.eq.1) then
+ do ithread=1,numthreads_grid
+ griduncn(:,:,:,:,:,:,:)=griduncn(:,:,:,:,:,:,:)+griduncn_omp(:,:,:,:,:,:,:,ithread)
+ griduncn_omp(:,:,:,:,:,:,:,ithread)=0.
+ end do
+ endif
+#endif
+
+ !***********************************************************************
+ ! 2. Evaluate concentrations at receptor points, using the kernel method
+ !***********************************************************************
+ if (numreceptor.eq.0) return
+
+ do n=1,numreceptor
+
+
+ ! Reset concentrations
+ !*********************
+
+ do ks=1,nspec
+ c(ks)=0.
+ end do
+
+
+ ! Estimate concentration at receptor
+ !***********************************
+
+ do i=1,numpart
+
+ if (.not. part(i)%alive) cycle
+ itage=abs(itime-part(i)%tstart)
+
+ hz=min(50.+0.3*sqrt(real(itage)),hzmax)
+ zd=part(i)%z/hz
+ if (zd.gt.1.) cycle ! save computing time, leave loop
+
+ hx=min((0.29+2.222e-3*sqrt(real(itage)))*dx+ &
+ real(itage)*1.2e-5,hxmax) ! 80 km/day
+ xd=(part(i)%xlon-xreceptor(n))/hx
+ if (xd*xd.gt.1.) cycle ! save computing time, leave loop
+
+ hy=min((0.18+1.389e-3*sqrt(real(itage)))*dy+ &
+ real(itage)*7.5e-6,hymax) ! 80 km/day
+ yd=(part(i)%ylat-yreceptor(n))/hy
+ if (yd*yd.gt.1.) cycle ! save computing time, leave loop
+ hxyz=hx*hy*hz
+
+ r2=xd*xd+yd*yd+zd*zd
+ if (r2.lt.1.) then
+ xkern=factor*(1.-r2)
+ do ks=1,nspec
+ c(ks)=c(ks)+part(i)%mass(ks)*xkern/hxyz
+ end do
+ endif
+ end do
+
+ do ks=1,nspec
+ creceptor(n,ks)=creceptor(n,ks)+2.*weight*c(ks)/receptorarea(n)
+ end do
+ end do
+end subroutine conccalc
+
+subroutine partpos_average(itime,j)
+
+ !**********************************************************************
+ ! This subroutine averages particle quantities, to be used for particle
+ ! dump (in partoutput.f90). Averaging is done over output interval.
+ ! Author: A. Stohl
+ ! Changes L Bakels:
+ ! - Computing fields defined in PARTOPTIONS
+ !**********************************************************************
+
+ use par_mod
+ use com_mod
+ use interpol_mod
+ use coordinates_ecmwf_mod
+
+ implicit none
+
+ integer,intent(in) :: itime,j
+ integer :: np,i_av,ns,m
+ real :: xlon,ylat,x,y,z
+ real :: topo,hm(2),hmixi,pvi,qvi
+ real :: tti,rhoi,ttemp
+ real :: uui,vvi,output
+ real :: tr(2),tri!,energy
+
+ logical :: cart_comp
+
+ if (ipout.eq.0) return ! No need to compute averages since there is no particle output
+
+ if (n_average.eq.0) return
+
+ if (.not. part(j)%alive) return
+
+ if (part(j)%nstop) return ! If particle is to be killed, averages cannot be computed
+
+ ! Some variables needed for temporal interpolation
+ !*************************************************
+ call find_time_variables(itime)
+
+ xlon=xlon0+real(part(j)%xlon)*dx
+ ylat=ylat0+real(part(j)%ylat)*dy
+
+ !*****************************************************************************
+ ! Interpolate several variables (PV, specific humidity, etc.) to particle position
+ !*****************************************************************************
+ ! Where in the grid? Stereographic (ngrid<0) or nested (ngrid>0)
+ !***************************************************************
+ call find_ngrid(real(part(j)%xlon),real(part(j)%ylat))
+ call determine_grid_coordinates(real(part(j)%xlon),real(part(j)%ylat))
+ call find_grid_distances(real(part(j)%xlon),real(part(j)%ylat))
+
+ ! First set dz1out from interpol_mod to -1 so it only is calculated once per particle
+ !************************************************************************************
+ part(j)%ntime=part(j)%ntime + 1
+ dz1out=-1
+ cart_comp=.false.
+ do np=1,num_partopt
+ if ((.not. partopt(np)%print) .or. (.not. partopt(np)%average)) cycle
+ i_av = partopt(np)%i_average
+ select case (partopt(np)%name)
+ case ('to')
+ if (ngrid.le.0) then
+ call horizontal_interpolation(oro,output)
+ else
+ call horizontal_interpolation_nests(oron,output)
+ endif
+ part(j)%val_av(i_av)=part(j)%val_av(i_av)+output
+ case ('tr')
+ if (ngrid.le.0) then
+ do m=1,2
+ call horizontal_interpolation(tropopause,tr(m),1,memind(m),1)
+ end do
+ else
+ do m=1,2
+ call horizontal_interpolation_nests(tropopausen,tr(m),1,memind(m),1)
+ end do
+ endif
+ call temporal_interpolation(tr(1),tr(2),output)
+ part(j)%val_av(i_av)=part(j)%val_av(i_av)+output
+ case ('hm')
+ if (ngrid.le.0) then
+ do m=1,2
+ call horizontal_interpolation(hmix,hm(m),1,memind(m),1)
+ end do
+ else
+ do m=1,2
+ call horizontal_interpolation_nests(hmixn,hm(m),1,memind(m),1)
+ end do
+ endif
+ call temporal_interpolation(hm(1),hm(2),output)
+ part(j)%val_av(i_av)=part(j)%val_av(i_av)+output
+ case ('lo')
+ if (.not. cart_comp) then
+ ! Calculate Cartesian 3D coordinates suitable for averaging
+ !**********************************************************
+
+ xlon=xlon*pi180
+ ylat=ylat*pi180
+ x = cos(ylat)*sin(xlon)
+ y = -1.*cos(ylat)*cos(xlon)
+ z = sin(ylat)
+
+ part(j)%cartx_av=part(j)%cartx_av+x
+ part(j)%carty_av=part(j)%carty_av+y
+ part(j)%cartz_av=part(j)%cartz_av+z
+ cart_comp=.true.
+ endif
+ case ('la')
+ if (.not. cart_comp) then
+ ! Calculate Cartesian 3D coordinates suitable for averaging
+ !**********************************************************
+
+ xlon=xlon*pi180
+ ylat=ylat*pi180
+ x = cos(ylat)*sin(xlon)
+ y = -1.*cos(ylat)*cos(xlon)
+ z = sin(ylat)
+
+ part(j)%cartx_av=part(j)%cartx_av+x
+ part(j)%carty_av=part(j)%carty_av+y
+ part(j)%cartz_av=part(j)%cartz_av+z
+ cart_comp=.true.
+ endif
+ case ('zz')
+ ! Convert eta z coordinate to meters if necessary. Can be moved to output only
+ !************************************************
+ call update_zeta_to_z(itime,j)
+ part(j)%val_av(i_av)=part(j)%val_av(i_av)+part(j)%z
+ case ('ma')
+ do ns=1,nspec
+ part(j)%val_av(i_av+(ns-1))=part(j)%val_av(i_av+(ns-1))+part(j)%mass(ns)
+ end do
+ case ('vs')
+ part(j)%val_av(i_av)=part(j)%val_av(i_av)+part(j)%settling
+ case default
+ call interpol_partoutput_value(partopt(np)%name,output,j)
+ part(j)%val_av(i_av)=part(j)%val_av(i_av)+output
+ end select
+ end do
+ ! Reset dz1out
+ !*************
+ dz1out=-1
+ cart_comp=.false.
+
+ return
+end subroutine partpos_average
+
+end module output_mod
diff --git a/src/output_mod_old.f90 b/src/output_mod_old.f90
new file mode 100644
index 00000000..61ef64f2
--- /dev/null
+++ b/src/output_mod_old.f90
@@ -0,0 +1,952 @@
+! SPDX-FileCopyrightText: FLEXPART 1998-2019, see flexpart_license.txt
+! SPDX-License-Identifier: GPL-3.0-or-later
+
+module output_mod
+
+ use com_mod
+ use par_mod
+ use date_mod
+#ifdef USE_NCF
+ use netcdf_output_mod
+#endif
+ use binary_output_mod
+ use txt_output_mod
+
+ implicit none
+
+contains
+
+subroutine initialise_output(itime,filesize)
+ implicit none
+
+ integer, intent(in) :: itime
+ real, intent(inout) :: filesize
+#ifdef USE_NCF
+ real(kind=dp) :: &
+ jul
+ integer :: &
+ jjjjmmdd,ihmmss,i
+#endif
+
+ ! Writing header information to either binary or NetCDF format
+ if (itime.eq.0) then
+ if (iout.ne.0) then
+#ifdef USE_NCF
+ if (lnetcdfout.eq.1) then
+ call writeheader_netcdf(lnest=.false.)
+ else
+ call writeheader_binary
+ end if
+
+ if (nested_output.eq.1) then
+ if (lnetcdfout.eq.1) then
+ call writeheader_netcdf(lnest=.true.)
+ else
+ call writeheader_binary_nest
+ endif
+ endif
+#endif
+ endif
+
+ call writeheader_binary ! CHECK ETA
+ ! FLEXPART 9.2 ticket ?? write header in ASCII format
+ call writeheader_txt
+ !if (nested_output.eq.1) call writeheader_nest
+ if (nested_output.eq.1.and.surf_only.ne.1) call writeheader_binary_nest
+ if (nested_output.eq.1.and.surf_only.eq.1) call writeheader_binary_nest_surf
+ if (nested_output.ne.1.and.surf_only.eq.1) call writeheader_binary_surf
+
+ ! NetCDF only: Create file for storing initial particle positions.
+#ifdef USE_NCF
+ if (mdomainfill.eq.0) then
+ if (ldirect.eq.1) then
+ call create_particles_initialoutput(ibtime,ibdate,ibtime,ibdate)
+ else
+ call create_particles_initialoutput(ietime,iedate,ietime,iedate)
+ endif
+ endif
+ ! Create header files for files that store the particle output
+ if (ipout.ge.1) then
+ if (ldirect.eq.1) then
+ call writeheader_partoutput(ibtime,ibdate,ibtime,ibdate)
+ else
+ call writeheader_partoutput(ietime,iedate,ietime,iedate)
+ endif
+ endif
+#endif
+
+ ! In case the particle output file is becoming larger than the maximum set
+ ! in par_mod, create a new one while keeping track of the filesize.
+ else if ((mod(itime,ipoutfac*loutstep).eq.0).and.(ipout.ge.1)) then
+#ifdef USE_NCF
+ if (filesize.ge.max_partoutput_filesize) then
+ jul=bdate+real(itime,kind=dp)/86400._dp
+ call caldate(jul,jjjjmmdd,ihmmss)
+ if (ldirect.eq.1) then
+ call writeheader_partoutput(ihmmss,jjjjmmdd,ibtime,ibdate)
+ else
+ call writeheader_partoutput(ihmmss,jjjjmmdd,ietime,iedate)
+ endif
+ filesize = 0.
+ endif
+ do i=1,numpoint
+ filesize = filesize + npart(i)*13.*4./1000000.
+ end do
+#endif
+ endif
+end subroutine initialise_output
+
+subroutine finalise_output(itime)
+ ! Complete the calculation of initial conditions for particles not yet terminated
+
+ implicit none
+
+ integer, intent(in) :: itime
+ integer :: j
+
+ do j=1,numpart
+ if (linit_cond.ge.1) call initial_cond_calc(itime,j)
+ end do
+
+ if (ipout.eq.2) call output_particles(itime)!,active_per_rel) ! dump particle positions
+
+ if (linit_cond.ge.1) then
+ if(linversionout.eq.1) then
+ call initial_cond_output_inversion(itime) ! dump initial cond. field
+ else
+ call initial_cond_output(itime) ! dump initial cond. fielf
+ endif
+ endif
+end subroutine finalise_output
+
+subroutine output_particles(itime)
+ ! i
+ !*****************************************************************************
+ ! *
+ ! Dump all particle positions *
+ ! *
+ ! Author: A. Stohl *
+ ! *
+ ! 12 March 1999 *
+ ! *
+ !*****************************************************************************
+ ! *
+ ! Variables: *
+ ! *
+ !*****************************************************************************
+
+ use par_mod
+ use com_mod
+#ifdef USE_NCF
+ use netcdf
+ use netcdf_output_mod, only: partoutput_netcdf,open_partoutput_file,close_partoutput_file
+ use omp_lib, only: OMP_GET_THREAD_NUM
+#endif
+ use particle_mod
+ use windfields_mod
+ implicit none
+
+ real(kind=dp) :: jul
+ integer :: itime,i,j,jjjjmmdd,ihmmss
+ integer :: ix,jy,ixp,jyp,indexh,m,il,ind,indz,indzp
+ real :: dt1,dt2,dtt,ddx,ddy,rddx,rddy,p1,p2,p3,p4,dz1,dz2,dz
+ real :: hm(2),pv1(2),pvprof(2),qv1(2),qvprof(2),pr1(2),prprof(2)
+ real :: tt1(2),ttprof(2),rho1(2),rhoprof(2)
+ real :: tr(2)
+ character :: adate*8,atime*6
+
+ real :: xlon(numpart),ylat(numpart),ztemp(numpart)
+ real :: tti(numpart),rhoi(numpart),pvi(numpart),qvi(numpart),pri(numpart)
+ real :: topo(numpart),hmixi(numpart),tri(numpart)
+
+#ifdef USE_NCF
+ integer :: ncid
+#endif
+
+
+ ! Some variables needed for temporal interpolation
+ !*************************************************
+
+ dt1=real(itime-memtime(1))
+ dt2=real(memtime(2)-itime)
+ dtt=1./(dt1+dt2)
+
+
+ do i=1,numpart
+ ! Take only valid particles
+ !**************************
+ xlon(i)=-1.
+ ylat(i)=-1.
+ tti(i)=-1.
+ rhoi(i)=-1.
+ pvi(i)=-1.
+ qvi(i)=-1.
+ topo(i)=-1.
+ hmixi(i)=-1.
+ tri(i)=-1.
+ pri(i)=-1.
+ ztemp(i)=-1.
+ !if (part(i)%itra1.eq.itime) then
+ xlon(i)=xlon0+part(i)%xlon*dx
+ ylat(i)=ylat0+part(i)%ylat*dy
+
+ !*****************************************************************************
+ ! Interpolate several variables (PV, specific humidity, etc.) to particle position
+ !*****************************************************************************
+
+ ix=part(i)%xlon
+ jy=part(i)%ylat
+ ixp=ix+1
+ jyp=jy+1
+ ddx=part(i)%xlon-real(ix)
+ ddy=part(i)%ylat-real(jy)
+ rddx=1.-ddx
+ rddy=1.-ddy
+ p1=rddx*rddy
+ p2=ddx*rddy
+ p3=rddx*ddy
+ p4=ddx*ddy
+
+! eso: Temporary fix for particle exactly at north pole
+ if (jyp >= nymax) then
+ ! write(*,*) 'WARNING: conccalc.f90 jyp >= nymax'
+ jyp=jyp-1
+ end if
+
+ ! Topography
+ !***********
+
+ topo(i)=p1*oro(ix ,jy) &
+ + p2*oro(ixp,jy) &
+ + p3*oro(ix ,jyp) &
+ + p4*oro(ixp,jyp)
+
+
+ ! Potential vorticity, specific humidity, temperature, and density
+ !*****************************************************************
+
+ do il=2,nz
+ if (height(il).gt.part(i)%z) then
+ indz=il-1
+ indzp=il
+ exit
+ endif
+ end do
+
+ dz1=part(i)%z-height(indz)
+ dz2=height(indzp)-part(i)%z
+ dz=1./(dz1+dz2)
+ ztemp(i)=part(i)%z
+
+ do ind=indz,indzp
+ do m=1,2
+ indexh=memind(m)
+
+ ! Potential vorticity
+ pv1(m)=p1*pv(ix ,jy ,ind,indexh) &
+ +p2*pv(ixp,jy ,ind,indexh) &
+ +p3*pv(ix ,jyp,ind,indexh) &
+ +p4*pv(ixp,jyp,ind,indexh)
+ ! Specific humidity
+ qv1(m)=p1*qv(ix ,jy ,ind,indexh) &
+ +p2*qv(ixp,jy ,ind,indexh) &
+ +p3*qv(ix ,jyp,ind,indexh) &
+ +p4*qv(ixp,jyp,ind,indexh)
+ ! Temperature
+ tt1(m)=p1*tt(ix ,jy ,ind,indexh) &
+ +p2*tt(ixp,jy ,ind,indexh) &
+ +p3*tt(ix ,jyp,ind,indexh) &
+ +p4*tt(ixp,jyp,ind,indexh)
+ ! Density
+ rho1(m)=p1*rho(ix ,jy ,ind,indexh) &
+ +p2*rho(ixp,jy ,ind,indexh) &
+ +p3*rho(ix ,jyp,ind,indexh) &
+ +p4*rho(ixp,jyp,ind,indexh)
+ ! Pressure
+ pr1(m)=p1*prs(ix ,jy ,ind,indexh) &
+ +p2*prs(ixp,jy ,ind,indexh) &
+ +p3*prs(ix ,jyp,ind,indexh) &
+ +p4*prs(ixp,jyp,ind,indexh)
+ end do
+ pvprof(ind-indz+1)=(pv1(1)*dt2+pv1(2)*dt1)*dtt
+ qvprof(ind-indz+1)=(qv1(1)*dt2+qv1(2)*dt1)*dtt
+ ttprof(ind-indz+1)=(tt1(1)*dt2+tt1(2)*dt1)*dtt
+ rhoprof(ind-indz+1)=(rho1(1)*dt2+rho1(2)*dt1)*dtt
+ prprof(ind-indz+1)=(pr1(1)*dt2+pr1(2)*dt1)*dtt
+ end do
+ pvi(i)=(dz1*pvprof(2)+dz2*pvprof(1))*dz
+ qvi(i)=(dz1*qvprof(2)+dz2*qvprof(1))*dz
+ tti(i)=(dz1*ttprof(2)+dz2*ttprof(1))*dz
+ rhoi(i)=(dz1*rhoprof(2)+dz2*rhoprof(1))*dz
+ pri(i)=(dz1*prprof(2)+dz2*prprof(1))*dz
+
+ ! Tropopause and PBL height
+ !**************************
+
+ do m=1,2
+ indexh=memind(m)
+
+ ! Tropopause
+ tr(m)=p1*tropopause(ix ,jy ,1,indexh) &
+ + p2*tropopause(ixp,jy ,1,indexh) &
+ + p3*tropopause(ix ,jyp,1,indexh) &
+ + p4*tropopause(ixp,jyp,1,indexh)
+
+ ! PBL height
+ hm(m)=p1*hmix(ix ,jy ,1,indexh) &
+ + p2*hmix(ixp,jy ,1,indexh) &
+ + p3*hmix(ix ,jyp,1,indexh) &
+ + p4*hmix(ixp,jyp,1,indexh)
+ end do
+
+ hmixi(i)=(hm(1)*dt2+hm(2)*dt1)*dtt
+ tri(i)=(tr(1)*dt2+tr(2)*dt1)*dtt
+
+ !endif
+ end do
+ ! Determine current calendar date, needed for the file name
+ !**********************************************************
+ if (numpart.gt.0) then
+ write(*,*) 'topo: ', topo(1), 'z:', part(1)%z
+ write(*,*) 'xtra: ', xlon(1)
+ write(*,*) 'ytra: ', ylat(1)
+ !write(*,*) 'mass: ', xmass1(1,1)
+ write(*,*) pvi(1),qvi(1),tti(1),rhoi(1)
+ endif
+ jul=bdate+real(itime,kind=dp)/86400._dp
+ call caldate(jul,jjjjmmdd,ihmmss)
+ write(adate,'(i8.8)') jjjjmmdd
+ write(atime,'(i6.6)') ihmmss
+
+ if (lnetcdfout.eq.1) then
+#ifdef USE_NCF
+ ! open output file
+ call open_partoutput_file(ncid)
+ ! First allocate the time and particle dimention within the netcdf file
+ call partoutput_netcdf(itime,xlon,'TI',j,ncid)
+ call partoutput_netcdf(itime,xlon,'PA',j,ncid)
+ call partoutput_netcdf(itime,xlon,'LO',j,ncid)
+ call partoutput_netcdf(itime,ylat,'LA',j,ncid)
+ call partoutput_netcdf(itime,ztemp,'ZZ',j,ncid)
+ call partoutput_netcdf(itime,topo,'TO',j,ncid)
+ call partoutput_netcdf(itime,pvi,'PV',j,ncid)
+ call partoutput_netcdf(itime,qvi,'QV',j,ncid)
+ call partoutput_netcdf(itime,rhoi,'RH',j,ncid)
+ call partoutput_netcdf(itime,hmixi,'HM',j,ncid)
+ call partoutput_netcdf(itime,tri,'TR',j,ncid)
+ call partoutput_netcdf(itime,tti,'TT',j,ncid)
+ call partoutput_netcdf(itime,pri,'PR',j,ncid)
+ do j=1,nspec
+ ! call partoutput_netcdf(itime,xmass1(:,j),'MA',j,ncid)
+ end do
+ call close_partoutput_file(ncid)
+#endif
+ else
+ ! Open output file and write the output
+ !**************************************
+
+ if (ipout.eq.1.or.ipout.eq.3) then
+ open(unitpartout,file=path(2)(1:length(2))//'partposit_'//adate// &
+ atime,form='unformatted')
+ else
+ open(unitpartout,file=path(2)(1:length(2))//'partposit_end', &
+ form='unformatted')
+ endif
+
+ ! Write current time to file
+ !***************************
+
+ write(unitpartout) itime
+ do i=1,numpart
+ ! Take only valid particles
+ !**************************
+
+ !if (itra1(i).eq.itime) then
+ ! Write the output
+ !*****************
+ !write(unitpartout) npoint(i),xlon(i),ylat(i),ztra1(i), &
+ ! itramem(i),topo(i),pvi(i),qvi(i),rhoi(i),hmixi(i),tri(i),tti(i), &
+ ! (xmass1(i,j),j=1,nspec)
+ !endif
+ end do
+
+
+ write(unitpartout) -99999,-9999.9,-9999.9,-9999.9,-99999, &
+ -9999.9,-9999.9,-9999.9,-9999.9,-9999.9,-9999.9,-9999.9, &
+ (-9999.9,j=1,nspec)
+
+
+ close(unitpartout)
+ endif
+end subroutine output_particles
+
+subroutine output_concentrations(itime,loutstart,loutend,loutnext,outnum)
+ use unc_mod
+ use outg_mod
+ use par_mod
+ use com_mod
+#ifdef USE_NCF
+ use netcdf_output_mod, only: concoutput_netcdf,concoutput_nest_netcdf,&
+ &concoutput_surf_netcdf,concoutput_surf_nest_netcdf
+#endif
+ use binary_output_mod
+
+ implicit none
+
+ integer,intent(in) :: &
+ itime ! time index
+ integer,intent(inout) :: &
+ loutstart,loutend, & ! concentration calculation starting and ending time
+ loutnext
+ real,intent(inout) :: &
+ outnum ! concentration calculation sample number
+ real(sp) :: &
+ gridtotalunc ! concentration calculation related
+ real(dep_prec) :: &
+ wetgridtotalunc, & ! concentration calculation related
+ drygridtotalunc ! concentration calculation related
+ real :: &
+ weight ! concentration calculation sample weight
+
+ ! Is the time within the computation interval, if not, return
+ !************************************************************
+ if ((ldirect*itime.lt.ldirect*loutstart).or.(ldirect*itime.gt.ldirect*loutend)) then
+ return
+ endif
+
+ ! If we are exactly at the start or end of the concentration averaging interval,
+ ! give only half the weight to this sample
+ !*****************************************************************************
+ if (mod(itime-loutstart,loutsample).eq.0) then
+ if ((itime.eq.loutstart).or.(itime.eq.loutend)) then
+ weight=0.5
+ else
+ weight=1.0
+ endif
+ outnum=outnum+weight
+ call conccalc(itime,weight)
+ endif
+
+ ! If it is not time yet to write outputs, return
+ !***********************************************
+ if ((itime.ne.loutend).or.(outnum.le.0)) then
+ return
+ endif
+
+ ! Output and reinitialization of grid
+ ! If necessary, first sample of new grid is also taken
+ !*****************************************************
+ if ((iout.le.3.).or.(iout.eq.5)) then
+ if (surf_only.ne.1) then
+#ifdef USE_NCF
+ call concoutput_netcdf(itime,outnum,gridtotalunc,wetgridtotalunc,drygridtotalunc)
+#else
+ call concoutput(itime,outnum,gridtotalunc,wetgridtotalunc,drygridtotalunc)
+#endif
+ else
+#ifdef USE_NCF
+ call concoutput_surf_netcdf(itime,outnum,gridtotalunc,wetgridtotalunc,drygridtotalunc)
+#else
+ if (linversionout.eq.1) then
+ call concoutput_inversion(itime,outnum,gridtotalunc,wetgridtotalunc,drygridtotalunc)
+ else
+ call concoutput_surf(itime,outnum,gridtotalunc,wetgridtotalunc,drygridtotalunc)
+ endif
+#endif
+ endif
+
+ if (nested_output .eq. 1) then
+#ifdef USE_NCF
+ if (surf_only.ne.1) then
+ call concoutput_nest_netcdf(itime,outnum)
+ else
+ call concoutput_surf_nest_netcdf(itime,outnum)
+ endif
+#else
+ if (surf_only.ne.1) then
+ call concoutput_nest(itime,outnum)
+ else
+ if(linversionout.eq.1) then
+ call concoutput_inversion_nest(itime,outnum)
+ else
+ call concoutput_surf_nest(itime,outnum)
+ endif
+ endif
+#endif
+ endif
+ outnum=0.
+ endif
+
+ write(*,45) itime,numpart,gridtotalunc,wetgridtotalunc,drygridtotalunc
+
+45 format(i13,' Seconds simulated: ',i13, ' Particles: Uncertainty: ',3f7.3)
+
+ loutnext=loutnext+loutstep
+ loutstart=loutnext-loutaver/2
+ loutend=loutnext+loutaver/2
+ if (itime.eq.loutstart) then
+ weight=0.5
+ outnum=outnum+weight
+ call conccalc(itime,weight)
+ endif
+end subroutine output_concentrations
+
+subroutine conccalc(itime,weight)
+ ! i i
+ !*****************************************************************************
+ ! *
+ ! Calculation of the concentrations on a regular grid using volume *
+ ! sampling *
+ ! *
+ ! Author: A. Stohl *
+ ! *
+ ! 24 May 1996 *
+ ! *
+ ! April 2000: Update to calculate age spectra *
+ ! Bug fix to avoid negative conc. at the domain boundaries, *
+ ! as suggested by Petra Seibert *
+ ! *
+ ! 2 July 2002: re-order if-statements in order to optimize CPU time *
+ ! *
+ ! *
+ !*****************************************************************************
+ ! *
+ ! Variables: *
+ ! nspeciesdim = nspec for forward runs, 1 for backward runs *
+ ! *
+ !*****************************************************************************
+
+ use unc_mod
+ use outg_mod
+ use par_mod
+ use com_mod
+ use omp_lib, only: OMP_GET_THREAD_NUM
+ use interpol_mod, only: interpol_density,ix,jy,ixp,jyp,ddx,ddy
+ use coordinates_ecmwf_mod
+ use particle_mod
+
+ implicit none
+
+ integer,intent(in) :: itime
+ real,intent(in) :: weight
+ integer :: itage,i,kz,ks,n,nage
+ integer :: il,ind,indz,indzp,nrelpointer
+ real :: hx,hy,hz,h,xd,yd,zd,xkern,r2,c(maxspec)
+ real :: rhoi
+ real :: xl,yl,wx,wy,w
+ real,parameter :: factor=.596831, hxmax=6.0, hymax=4.0, hzmax=150.
+ ! integer xscav_count
+
+ ! For forward simulations, make a loop over the number of species;
+ ! for backward simulations, make an additional loop over the
+ ! releasepoints
+ !***************************************************************************
+ ! xscav_count=0
+ do i=1,numpart
+ if (.not.part(i)%alive) cycle
+
+ ! Determine age class of the particle
+ itage=abs(itime-part(i)%tstart)
+ do nage=1,nageclass
+ if (itage.lt.lage(nage)) exit
+ end do
+
+ ! if (xscav_frac1(i,1).lt.0) xscav_count=xscav_count+1
+
+ ! For special runs, interpolate the air density to the particle position
+ !************************************************************************
+ !***********************************************************************
+ !AF IND_SOURCE switches between different units for concentrations at the source
+ !Af NOTE that in backward simulations the release of particles takes place
+ !Af at the receptor and the sampling at the source.
+ !Af 1="mass"
+ !Af 2="mass mixing ratio"
+ !Af IND_RECEPTOR switches between different units for concentrations at the receptor
+ !Af 1="mass"
+ !Af 2="mass mixing ratio"
+
+ !Af switches for the conccalcfile:
+ !AF IND_SAMP = 0 : xmass * 1
+ !Af IND_SAMP = -1 : xmass / rho
+
+ !Af ind_samp is defined in readcommand.f
+
+ if ( ind_samp .eq. -1 ) then
+ call update_zeta_to_z(itime,i)
+ call interpol_density(i,rhoi)
+ elseif (ind_samp.eq.0) then
+ rhoi = 1.
+ endif
+
+ !****************************************************************************
+ ! 1. Evaluate grid concentrations using a uniform kernel of bandwidths dx, dy
+ !****************************************************************************
+
+
+ ! For backward simulations, look from which release point the particle comes from
+ ! For domain-filling trajectory option, npoint contains a consecutive particle
+ ! number, not the release point information. Therefore, nrelpointer is set to 1
+ ! for the domain-filling option.
+ !*****************************************************************************
+
+ if ((ioutputforeachrelease.eq.0).or.(mdomainfill.eq.1)) then
+ nrelpointer=1
+ else
+ nrelpointer=part(i)%npoint
+ endif
+
+ do kz=1,numzgrid ! determine height of cell
+ if (outheight(kz).gt.part(i)%z) exit
+ end do
+
+ if (kz.le.numzgrid) then ! inside output domain
+
+
+ !********************************
+ ! Do everything for mother domain
+ !********************************
+
+ xl=(part(i)%xlon*dx+xoutshift)/dxout
+ yl=(part(i)%ylat*dy+youtshift)/dyout
+ ix=int(xl)
+ if (xl.lt.0.) ix=ix-1
+ jy=int(yl)
+ if (yl.lt.0.) jy=jy-1
+
+
+
+ ! For particles aged less than 3 hours, attribute particle mass to grid cell
+ ! it resides in rather than use the kernel, in order to avoid its smoothing effect.
+ ! For older particles, use the uniform kernel.
+ ! If a particle is close to the domain boundary, do not use the kernel either.
+ !*****************************************************************************
+
+ if ((.not.lusekerneloutput).or.(itage.lt.10800).or. &
+ (xl.lt.0.5).or.(yl.lt.0.5).or. &
+ (xl.gt.real(numxgrid-1)-0.5).or. &
+ (yl.gt.real(numygrid-1)-0.5)) then ! no kernel, direct attribution to grid cell
+ if ((ix.ge.0).and.(jy.ge.0).and.(ix.le.numxgrid-1).and. &
+ (jy.le.numygrid-1)) then
+ if (DRYBKDEP.or.WETBKDEP) then
+ do ks=1,nspec
+ gridunc(ix,jy,kz,ks,nrelpointer,part(i)%nclass,nage)= &
+ gridunc(ix,jy,kz,ks,nrelpointer,part(i)%nclass,nage)+ &
+ part(i)%mass(ks)/rhoi*weight*max(xscav_frac1(i,ks),0.0)
+ end do
+ else
+ if (lparticlecountoutput) then
+ do ks=1,nspec
+ gridunc(ix,jy,kz,ks,nrelpointer,part(i)%nclass,nage)= &
+ gridunc(ix,jy,kz,ks,nrelpointer,part(i)%nclass,nage)+1
+ end do
+ else
+ do ks=1,nspec
+ gridunc(ix,jy,kz,ks,nrelpointer,part(i)%nclass,nage)= &
+ gridunc(ix,jy,kz,ks,nrelpointer,part(i)%nclass,nage)+ &
+ part(i)%mass(ks)/rhoi*weight
+ end do
+ end if
+ endif
+ endif
+
+ else ! attribution via uniform kernel
+
+ ddx=xl-real(ix) ! distance to left cell border
+ ddy=yl-real(jy) ! distance to lower cell border
+ if (ddx.gt.0.5) then
+ ixp=ix+1
+ wx=1.5-ddx
+ else
+ ixp=ix-1
+ wx=0.5+ddx
+ endif
+
+ if (ddy.gt.0.5) then
+ jyp=jy+1
+ wy=1.5-ddy
+ else
+ jyp=jy-1
+ wy=0.5+ddy
+ endif
+
+
+ ! Determine mass fractions for four grid points
+ !**********************************************
+
+ if ((ix.ge.0).and.(ix.le.numxgrid-1)) then
+ if ((jy.ge.0).and.(jy.le.numygrid-1)) then
+ w=wx*wy
+ if (DRYBKDEP.or.WETBKDEP) then
+ do ks=1,nspec
+ gridunc(ix,jy,kz,ks,nrelpointer,part(i)%nclass,nage)= &
+ gridunc(ix,jy,kz,ks,nrelpointer,part(i)%nclass,nage)+ &
+ part(i)%mass(ks)/rhoi*w*weight*max(xscav_frac1(i,ks),0.0)
+ end do
+ else
+ do ks=1,nspec
+ gridunc(ix,jy,kz,ks,nrelpointer,part(i)%nclass,nage)= &
+ gridunc(ix,jy,kz,ks,nrelpointer,part(i)%nclass,nage)+ &
+ part(i)%mass(ks)/rhoi*weight*w
+ end do
+ endif
+ endif
+
+ if ((jyp.ge.0).and.(jyp.le.numygrid-1)) then
+ w=wx*(1.-wy)
+ if (DRYBKDEP.or.WETBKDEP) then
+ do ks=1,nspec
+ gridunc(ix,jyp,kz,ks,nrelpointer,part(i)%nclass,nage)= &
+ gridunc(ix,jyp,kz,ks,nrelpointer,part(i)%nclass,nage)+ &
+ part(i)%mass(ks)/rhoi*weight*w*max(xscav_frac1(i,ks),0.0)
+ end do
+ else
+ do ks=1,nspec
+ gridunc(ix,jyp,kz,ks,nrelpointer,part(i)%nclass,nage)= &
+ gridunc(ix,jyp,kz,ks,nrelpointer,part(i)%nclass,nage)+ &
+ part(i)%mass(ks)/rhoi*weight*w
+ end do
+ endif
+ endif
+ endif !ix ge 0
+
+
+ if ((ixp.ge.0).and.(ixp.le.numxgrid-1)) then
+ if ((jyp.ge.0).and.(jyp.le.numygrid-1)) then
+ w=(1.-wx)*(1.-wy)
+ if (DRYBKDEP.or.WETBKDEP) then
+ do ks=1,nspec
+ gridunc(ixp,jyp,kz,ks,nrelpointer,part(i)%nclass,nage)= &
+ gridunc(ixp,jyp,kz,ks,nrelpointer,part(i)%nclass,nage)+ &
+ part(i)%mass(ks)/rhoi*w*weight*max(xscav_frac1(i,ks),0.0)
+ end do
+ else
+ do ks=1,nspec
+ gridunc(ixp,jyp,kz,ks,nrelpointer,part(i)%nclass,nage)= &
+ gridunc(ixp,jyp,kz,ks,nrelpointer,part(i)%nclass,nage)+ &
+ part(i)%mass(ks)/rhoi*weight*w
+ end do
+ endif
+ endif
+
+ if ((jy.ge.0).and.(jy.le.numygrid-1)) then
+ w=(1.-wx)*wy
+ if (DRYBKDEP.or.WETBKDEP) then
+ do ks=1,nspec
+ gridunc(ixp,jy,kz,ks,nrelpointer,part(i)%nclass,nage)= &
+ gridunc(ixp,jy,kz,ks,nrelpointer,part(i)%nclass,nage)+ &
+ part(i)%mass(ks)/rhoi*weight*w*max(xscav_frac1(i,ks),0.0)
+ end do
+ else
+ do ks=1,nspec
+ gridunc(ixp,jy,kz,ks,nrelpointer,part(i)%nclass,nage)= &
+ gridunc(ixp,jy,kz,ks,nrelpointer,part(i)%nclass,nage)+ &
+ part(i)%mass(ks)/rhoi*weight*w
+ end do
+ endif
+ endif
+ endif !ixp ge 0
+ endif
+
+ !************************************
+ ! Do everything for the nested domain
+ !************************************
+
+ if (nested_output.eq.1) then
+ xl=(part(i)%xlon*dx+xoutshiftn)/dxoutn
+ yl=(part(i)%ylat*dy+youtshiftn)/dyoutn
+ ix=int(xl)
+ if (xl.lt.0.) ix=ix-1
+ jy=int(yl)
+ if (yl.lt.0.) jy=jy-1
+
+
+ ! For particles aged less than 3 hours, attribute particle mass to grid cell
+ ! it resides in rather than use the kernel, in order to avoid its smoothing effect.
+ ! For older particles, use the uniform kernel.
+ ! If a particle is close to the domain boundary, do not use the kernel either.
+ !*****************************************************************************
+
+ if ((itage.lt.10800).or.(xl.lt.0.5).or.(yl.lt.0.5).or. &
+ (xl.gt.real(numxgridn-1)-0.5).or. &
+ (yl.gt.real(numygridn-1)-0.5).or.((.not.lusekerneloutput))) then
+ ! no kernel, direct attribution to grid cell
+ if ((ix.ge.0).and.(jy.ge.0).and.(ix.le.numxgridn-1).and. &
+ (jy.le.numygridn-1)) then
+ if (DRYBKDEP.or.WETBKDEP) then
+ do ks=1,nspec
+ griduncn(ix,jy,kz,ks,nrelpointer,part(i)%nclass,nage)= &
+ griduncn(ix,jy,kz,ks,nrelpointer,part(i)%nclass,nage)+ &
+ part(i)%mass(ks)/rhoi*weight*max(xscav_frac1(i,ks),0.0)
+ end do
+ else
+ if (lparticlecountoutput) then
+ do ks=1,nspec
+ griduncn(ix,jy,kz,ks,nrelpointer,part(i)%nclass,nage)= &
+ griduncn(ix,jy,kz,ks,nrelpointer,part(i)%nclass,nage)+1
+ end do
+ else
+ do ks=1,nspec
+ griduncn(ix,jy,kz,ks,nrelpointer,part(i)%nclass,nage)= &
+ griduncn(ix,jy,kz,ks,nrelpointer,part(i)%nclass,nage)+ &
+ part(i)%mass(ks)/rhoi*weight
+ end do
+ endif
+ endif
+ endif
+
+ else ! attribution via uniform kernel
+
+ ddx=xl-real(ix) ! distance to left cell border
+ ddy=yl-real(jy) ! distance to lower cell border
+ if (ddx.gt.0.5) then
+ ixp=ix+1
+ wx=1.5-ddx
+ else
+ ixp=ix-1
+ wx=0.5+ddx
+ endif
+
+ if (ddy.gt.0.5) then
+ jyp=jy+1
+ wy=1.5-ddy
+ else
+ jyp=jy-1
+ wy=0.5+ddy
+ endif
+
+
+ ! Determine mass fractions for four grid points
+ !**********************************************
+
+ if ((ix.ge.0).and.(ix.le.numxgridn-1)) then
+ if ((jy.ge.0).and.(jy.le.numygridn-1)) then
+ w=wx*wy
+ if (DRYBKDEP.or.WETBKDEP) then
+ do ks=1,nspec
+ griduncn(ix,jy,kz,ks,nrelpointer,part(i)%nclass,nage)= &
+ griduncn(ix,jy,kz,ks,nrelpointer,part(i)%nclass,nage)+ &
+ part(i)%mass(ks)/rhoi*weight*w*max(xscav_frac1(i,ks),0.0)
+ end do
+ else
+ do ks=1,nspec
+ griduncn(ix,jy,kz,ks,nrelpointer,part(i)%nclass,nage)= &
+ griduncn(ix,jy,kz,ks,nrelpointer,part(i)%nclass,nage)+ &
+ part(i)%mass(ks)/rhoi*weight*w
+ end do
+ endif
+ endif
+
+ if ((jyp.ge.0).and.(jyp.le.numygridn-1)) then
+ w=wx*(1.-wy)
+ if (DRYBKDEP.or.WETBKDEP) then
+ do ks=1,nspec
+ griduncn(ix,jyp,kz,ks,nrelpointer,part(i)%nclass,nage)= &
+ griduncn(ix,jyp,kz,ks,nrelpointer,part(i)%nclass,nage)+ &
+ part(i)%mass(ks)/rhoi*weight*w*max(xscav_frac1(i,ks),0.0)
+ end do
+ else
+ do ks=1,nspec
+ griduncn(ix,jyp,kz,ks,nrelpointer,part(i)%nclass,nage)= &
+ griduncn(ix,jyp,kz,ks,nrelpointer,part(i)%nclass,nage)+ &
+ part(i)%mass(ks)/rhoi*weight*w
+ end do
+ endif
+ endif
+ endif
+
+
+ if ((ixp.ge.0).and.(ixp.le.numxgridn-1)) then
+ if ((jyp.ge.0).and.(jyp.le.numygridn-1)) then
+ w=(1.-wx)*(1.-wy)
+ if (DRYBKDEP.or.WETBKDEP) then
+ do ks=1,nspec
+ griduncn(ixp,jyp,kz,ks,nrelpointer,part(i)%nclass,nage)= &
+ griduncn(ixp,jyp,kz,ks,nrelpointer,part(i)%nclass,nage)+ &
+ part(i)%mass(ks)/rhoi*weight*w*max(xscav_frac1(i,ks),0.0)
+ end do
+ else
+ do ks=1,nspec
+ griduncn(ixp,jyp,kz,ks,nrelpointer,part(i)%nclass,nage)= &
+ griduncn(ixp,jyp,kz,ks,nrelpointer,part(i)%nclass,nage)+ &
+ part(i)%mass(ks)/rhoi*weight*w
+ end do
+ endif
+ endif
+
+ if ((jy.ge.0).and.(jy.le.numygridn-1)) then
+ w=(1.-wx)*wy
+ if (DRYBKDEP.or.WETBKDEP) then
+ do ks=1,nspec
+ griduncn(ixp,jy,kz,ks,nrelpointer,part(i)%nclass,nage)= &
+ griduncn(ixp,jy,kz,ks,nrelpointer,part(i)%nclass,nage)+ &
+ part(i)%mass(ks)/rhoi*weight*w*max(xscav_frac1(i,ks),0.0)
+ end do
+ else
+ do ks=1,nspec
+ griduncn(ixp,jy,kz,ks,nrelpointer,part(i)%nclass,nage)= &
+ griduncn(ixp,jy,kz,ks,nrelpointer,part(i)%nclass,nage)+ &
+ part(i)%mass(ks)/rhoi*weight*w
+ end do
+ endif
+ endif
+ endif
+ endif
+ endif
+ endif
+ end do
+ ! write(*,*) 'xscav count:',xscav_count
+
+ !***********************************************************************
+ ! 2. Evaluate concentrations at receptor points, using the kernel method
+ !***********************************************************************
+
+ do n=1,numreceptor
+
+
+ ! Reset concentrations
+ !*********************
+
+ do ks=1,nspec
+ c(ks)=0.
+ end do
+
+
+ ! Estimate concentration at receptor
+ !***********************************
+
+ do i=1,numpart
+
+ if (.not. part(i)%alive) cycle
+ itage=abs(itime-part(i)%tstart)
+
+ hz=min(50.+0.3*sqrt(real(itage)),hzmax)
+ zd=part(i)%z/hz
+ if (zd.gt.1.) cycle ! save computing time, leave loop
+
+ hx=min((0.29+2.222e-3*sqrt(real(itage)))*dx+ &
+ real(itage)*1.2e-5,hxmax) ! 80 km/day
+ xd=(part(i)%xlon-xreceptor(n))/hx
+ if (xd*xd.gt.1.) cycle ! save computing time, leave loop
+
+ hy=min((0.18+1.389e-3*sqrt(real(itage)))*dy+ &
+ real(itage)*7.5e-6,hymax) ! 80 km/day
+ yd=(part(i)%ylat-yreceptor(n))/hy
+ if (yd*yd.gt.1.) cycle ! save computing time, leave loop
+ h=hx*hy*hz
+
+ r2=xd*xd+yd*yd+zd*zd
+ if (r2.lt.1.) then
+ xkern=factor*(1.-r2)
+ do ks=1,nspec
+ c(ks)=c(ks)+part(i)%mass(ks)*xkern/h
+ end do
+ endif
+ end do
+
+ do ks=1,nspec
+ creceptor(n,ks)=creceptor(n,ks)+2.*weight*c(ks)/receptorarea(n)
+ end do
+ end do
+end subroutine conccalc
+
+end module output_mod
diff --git a/src/par_mod.f90 b/src/par_mod.f90
index 776996f4..19c9433c 100644
--- a/src/par_mod.f90
+++ b/src/par_mod.f90
@@ -30,7 +30,7 @@ module par_mod
! dp). sp is default, dp can be used for increased precision.
!****************************************************************
- integer,parameter :: dep_prec=sp
+ integer,parameter :: dep_prec=dp
!****************************************************************
! Set to F to disable use of kernel for concentrations/deposition
@@ -78,27 +78,28 @@ module par_mod
!real,parameter :: d_trop=50., d_strat=0.1
real :: d_trop=50., d_strat=0.1, turbmesoscale=0.16 ! turbulence factors can change for different runs
real,parameter :: rho_water=1000. !ZHG 2015 [kg/m3]
- !ZHG MAR2016
- real,parameter :: incloud_ratio=6.2
-
- ! karman Karman's constant
- ! href [m] Reference height for dry deposition
- ! konvke Relative share of kinetic energy used for parcel lifting
- ! hmixmin,hmixmax Minimum and maximum allowed PBL height
- ! turbmesoscale the factor by which standard deviations of winds at grid
- ! points surrounding the particle positions are scaled to
- ! yield the scales for the mesoscale wind velocity fluctuations
- ! d_trop [m2/s] Turbulent diffusivity for horizontal components in the troposphere
- ! d_strat [m2/s] Turbulent diffusivity for vertical component in the stratosphere
+ real,parameter :: incloud_ratio=6.2 !ZHG MAR2016
+
+ ! karman Karman's constant
+ ! href [m] Reference height for dry deposition
+ ! konvke Relative share of kinetic energy used for parcel lifting
+ ! hmixmin,hmixmax Minimum and maximum allowed PBL height
+ ! turbmesoscale the factor by which standard deviations of winds at grid
+ ! points surrounding the particle positions are scaled to
+ ! yield the scales for the mesoscale wind velocity fluctuations
+ ! d_trop [m2/s] Turbulent diffusivity for horiz components in the troposphere
+ ! d_strat [m2/s] Turbulent diffusivity for vertical component in the stratosphere
+
real,parameter :: xmwml=18.016/28.960
+ ! ratio of molar weights of water vapor and dry air
+
- ! xmwml ratio of molar weights of water vapor and dry air
!****************************************************
! Constants related to the stratospheric ozone tracer
!****************************************************
- real,parameter :: ozonescale=60., pvcrit=2.0
+ real,parameter :: ozonescale=60., pvcrit=2.
! ozonescale ppbv O3 per PV unit
! pvcrit PV level of the tropopause
@@ -131,22 +132,30 @@ module par_mod
!*********************************************
! ECMWF
-! integer,parameter :: nxmax=361,nymax=181,nuvzmax=92,nwzmax=92,nzmax=92,nxshift=359 ! 1.0 degree 92 level
-! integer,parameter :: nxmax=361,nymax=181,nuvzmax=138,nwzmax=138,nzmax=138,nxshift=0 ! 1.0 degree 138 level
-! integer,parameter :: nxmax=361,nymax=181,nuvzmax=138,nwzmax=138,nzmax=138,nxshift=359 ! 1.0 degree 138 level
-! integer,parameter :: nxmax=721,nymax=361,nuvzmax=138,nwzmax=138,nzmax=138,nxshift=359 ! 0.5 degree 138 level
-! integer,parameter :: nxmax=181,nymax=91,nuvzmax=92,nwzmax=92,nzmax=92,nxshift=0 ! CERA 2.0 degree 92 level
+! integer,parameter :: nxmax=361,nymax=181,nuvzmax=92,nwzmax=92,nzmax=92,nxshift=359 ! 1.0 deg 92 levels
+! integer,parameter :: nxmax=361,nymax=181,nuvzmax=138,nwzmax=138,nzmax=138,nxshift=0 ! 1.0 deg 138 levels
+! integer,parameter :: nxmax=361,nymax=181,nuvzmax=138,nwzmax=138,nzmax=138,nxshift=359 ! 1.0 deg 138 levels
+ integer,parameter :: nxmax=721,nymax=361,nuvzmax=138,nwzmax=138,nzmax=138!,nxshift=359 ! 0.5 deg 138 levels
+! integer,parameter :: nxmax=181,nymax=91,nuvzmax=92,nwzmax=92,nzmax=92,nxshift=0 ! CERA 2.0 deg 92 levels
! GFS
- integer,parameter :: nxmax=361,nymax=181,nuvzmax=138,nwzmax=138,nzmax=138
- integer :: nxshift=0 ! shift not fixed for the executable
+! integer,parameter :: nxmax=361,nymax=181,nuvzmax=138,nwzmax=138,nzmax=138
+! integer,parameter :: nxshift=0 ! shift not fixed for the executable
+
+ !*********************************
+ ! Parmaters for GRIB file decoding
+ !*********************************
+
+ ! integer,parameter :: jpack=4*nxmax*nymax, jpunp=4*jpack
+ integer,parameter :: jpack=4*361*181, jpunp=4*jpack
+ ! jpack,jpunp maximum dimensions needed for GRIB file decoding
!*********************************************
! Maximum dimensions of the nested input grids
!*********************************************
- integer,parameter :: maxnests=0,nxmaxn=0,nymaxn=0
+ integer,parameter :: maxnests=1,nxmaxn=201,nymaxn=201
! nxmax,nymax maximum dimension of wind fields in x and y
! direction, respectively
@@ -154,10 +163,6 @@ module par_mod
! direction (for fields on eta levels)
! nzmax maximum dimension of wind fields in z direction
! for the transformed Cartesian coordinates
- ! nxshift for global grids (in x), the grid can be shifted by
- ! nxshift grid points, in order to accomodate nested
- ! grids, and output grids overlapping the domain "boundary"
- ! nxshift must not be negative; "normal" setting would be 0
integer,parameter :: nconvlevmax = nuvzmax-1
@@ -168,15 +173,6 @@ module par_mod
! na parameter used in Emanuel's convect subroutine
- !*********************************
- ! Parmaters for GRIB file decoding
- !*********************************
-
- integer,parameter :: jpack=4*nxmax*nymax, jpunp=4*jpack
-
- ! jpack,jpunp maximum dimensions needed for GRIB file decoding
-
-
!**************************************
! Maximum dimensions of the output grid
!**************************************
@@ -204,36 +200,36 @@ module par_mod
! Maximum number of particles, species, and similar
!**************************************************
- integer,parameter :: maxpart=100000
+ !integer,parameter :: maxpart=5000000
integer,parameter :: maxspec=1
- real,parameter :: minmass=0.0001
+ real,parameter :: minmassfrac=0.0
- ! maxpart Maximum number of particles
- ! maxspec Maximum number of chemical species per release
- ! minmass Terminate particles carrying less mass
+ ! maxpart Maximum number of particles
+ ! maxspec Maximum number of chemical species per release
+ ! minmassfrac Terminate particles carrying a lower fraction
+ ! compared to their initial mass
! maxpoint is also set dynamically during runtime
- ! maxpoint Maximum number of release locations
+ ! maxpoint Maximum number of release locations
! ---------
! Sabine Eckhardt: change of landuse inventary numclass=13
- ! ---------
- integer,parameter :: maxwf=50000, maxtable=1000, numclass=13, ni=11
+ integer,parameter :: maxwf=1000000, maxtable=1000, numclass=13, maxndia=100
integer,parameter :: numwfmem=2 ! Serial version/MPI with 2 fields
!integer,parameter :: numwfmem=3 ! MPI with 3 fields
- ! maxwf maximum number of wind fields to be used for simulation
- ! maxtable Maximum number of chemical species that can be
- ! tabulated for FLEXPART
- ! numclass Number of landuse classes available to FLEXPART
- ! ni Number of diameter classes of particles
- ! numwfmem Number of windfields kept in memory. 2 for serial
- ! version, 2 or 3 for MPI version
+ ! maxwf maximum number of wind fields to be used for simulation
+ ! maxtable Maximum number of chemical species that can be tabulated
+ ! numclass Number of landuse classes available to FLEXPART
+ ! maxndia Maximum number of diameter classes of particles
+ ! numwfmem Number of windfields kept in memory. 2 for serial version,
+ ! 2 or 3 for MPI version
!**************************************************************************
! dimension of the OH field
!**************************************************************************
+
integer,parameter :: maxxOH=72, maxyOH=46, maxzOH=7
!**************************************************************************
@@ -248,7 +244,7 @@ module par_mod
! Dimension of random number field
!*********************************
- integer,parameter :: maxrand=1000000
+ integer,parameter :: maxrand=6000000
! maxrand number of random numbers used
@@ -264,14 +260,18 @@ module par_mod
!************************************
integer,parameter :: unitpath=1, unitcommand=1, unitageclasses=1, unitgrid=1
- integer,parameter :: unitavailab=1, unitreleases=88, unitpartout=93, unitpartout_average=105
+ integer,parameter :: unitavailab=1, unitreleases=88, unitpartout=93
+ integer,parameter :: unitpartout_average=105, unitpartoptions=106
+ integer,parameter :: unitrestart=106,unitheightlevels=107
integer,parameter :: unitpartin=93, unitflux=98, unitouttraj=96
integer,parameter :: unitvert=1, unitoro=1, unitpoin=1, unitreceptor=1
+ integer,parameter :: unitreceptorout=2
integer,parameter :: unitoutgrid=97, unitoutgridppt=99, unitoutinfo=1
integer,parameter :: unitspecies=1, unitoutrecept=91, unitoutreceptppt=92
integer,parameter :: unitlsm=1, unitsurfdata=1, unitland=1, unitwesely=1
integer,parameter :: unitOH=1
- integer,parameter :: unitdates=94, unitheader=90,unitheader_txt=100, unitshortpart=95, unitprecip=101
+ integer,parameter :: unitdates=94, unitheader=90,unitheader_txt=100
+ integer,parameter :: unitshortpart=95, unitprecip=101
integer,parameter :: unitboundcond=89
integer,parameter :: unittmp=101
! RLT
@@ -283,5 +283,38 @@ module par_mod
integer,parameter :: icmv=-9999
+!*******************************************************************************
+! Maximum output of each partoutput NetCDF-4 file in Mb
+! before a new one is created
+!*******************************************************************************
+ integer,parameter :: max_partoutput_filesize=30000
+
+ ! Set maximum number of threads for doing grid computations.
+ ! Recommended to set this to max 16
+ ! High numbers create more overhead and a larger memory footprint
+ !***********************************************************************
+ integer,parameter :: max_numthreads_grid=16
+ ! Set the coordinate system. At the moment only ECMWF is possible. This bit
+ ! needs to be a parameter that can be set at compile time.
+ ! Throughout the code there will be SELECT CASE statements or IFDEFs
+ !*******************************************************************
+
+ character(len=256),parameter :: wind_coord_type='ETA'
+ !character(len=256),parameter :: wind_coord_type='METER'
+
+ ! This flag sets all vertical interpolation to logarithmic instead of linear
+ !***************************************************************************
+ logical,parameter :: logarithmic_interpolation=.false.
+
+ ! mesoscale turbulence is found to give issues, so turned off by default
+ !***********************************************************************
+ logical,parameter :: mesoscale_turbulence=.false.
+
+ ! Threshold equivalent diameter for interaction with surface sublayer
+ ! resistance (below 10 meters) in micrometer. Above this diameter there
+ ! is no interaction
+ !**********************************************************************
+ real,parameter :: d_thresheqv=20
+
end module par_mod
diff --git a/src/particle_mod.f90 b/src/particle_mod.f90
new file mode 100644
index 00000000..f3b7d15a
--- /dev/null
+++ b/src/particle_mod.f90
@@ -0,0 +1,746 @@
+
+ !*****************************************************************************
+ ! *
+ ! Module that organises particle information in derived types *
+ ! Particles are terminated and spawned using routines from this module so *
+ ! that global particle counts (spawned, allocated, terminated) are kept *
+ ! up to date *
+ ! *
+ ! Author: L. Bakels 2022 *
+ ! *
+ !*****************************************************************************
+
+module particle_mod
+ use com_mod, only: maxspec,DRYBKDEP,WETBKDEP,iout,n_average
+ use par_mod, only: dp
+
+ implicit none
+
+ type :: coordinates
+ real(kind=dp) :: &
+ xlon, & ! longitude in grid coordinates
+ ylat ! latitude in grid coordinates
+ real :: &
+ z ! height in meters
+ real :: &
+ zeta ! height in eta (ECMWF) coordinates
+ end type coordinates
+
+ type :: velocities
+ real :: &
+ u, & ! x velocity
+ v, & ! y velocity
+ w ! z velocity
+ real :: &
+ weta ! z velocity in eta (ECMWF) coordinates
+ end type velocities
+
+ type :: particle
+ real(kind=dp) :: &
+ xlon, & ! Longitude in grid coordinates
+ ylat, & ! Latitude in grid coordinates
+ xlon_prev, ylat_prev, & ! Keeping the previous positions in memory
+ z, & ! height in meters
+ z_prev ! Previous position
+ real(kind=dp) :: &
+ zeta, & ! Height in eta (ECMWF) coordinates
+ zeta_prev ! Previous position
+ type(velocities) :: &
+ vel, & ! Velocities from interpolated windfields
+ turbvel, & ! Random turbulent velocities
+ mesovel ! Mesoscale turbulent velocities
+ real :: &
+ settling ! Settling velocity for dry and wet(?) deposit
+ logical :: &
+ alive=.false., & ! Flag to show if the particle is still in the running
+ etaupdate=.false., & ! If false, z(meter) is more up-to-date than z(eta)
+ meterupdate=.false., & ! If false, z(eta) is more up-to-date than z(meter)
+ nstop=.false. ! Flag to stop particle (used in advance, stopped in timemanager)
+ integer(kind=2) :: &
+ icbt ! Forbidden state flag
+ integer :: &
+ tstart, & ! spawning time in seconds after start
+ tend, & ! termination time in seconds after start
+ npoint, & ! release point
+ nclass, &
+ !species(maxspec), & ! the number of the corresponding species file of the particle
+ idt ! internal time of the particle
+ real :: &
+ mass(maxspec), & ! Particle mass for each particle species
+ mass_init(maxspec), & ! Initial mass of each particle
+ wetdepo(maxspec)=0., & ! Wet deposition (cumulative)
+ drydepo(maxspec)=0., & ! Dry deposition (cumulative)
+ prob(maxspec) ! Probability of absorption at ground due to dry deposition
+
+ real,allocatable :: &
+ val_av(:) ! Averaged values; only used when average_output=.true.
+ real :: &
+ ntime=0., & ! Number of timesteps to average over
+ cartx_av=0., & ! Averaged x pos;
+ carty_av=0., & ! Averaged y pos;
+ cartz_av=0. ! Averaged z pos;
+
+ end type particle
+
+ type :: particlecount
+ integer :: &
+ alive=0, & ! Number of particles that are alive
+ spawned=0, & ! Total number of spawned particles
+ terminated=0, & ! Total number of particles that have been terminated
+ allocated=0, & ! Number of total allocated particle spaces
+ ninmem=0 ! Number of particles currently in memory
+ logical,allocatable :: &
+ inmem(:)
+ end type
+
+ type(particle), allocatable :: &
+ part(:) ! This is where all particles are being stored
+ type(particlecount) :: &
+ count ! Keeping track of global particle number within the simulation
+ real,allocatable :: &
+ xscav_frac1(:,:) ! Only allocated when wet or dry deposit backward mode is switched on
+ real,allocatable :: &
+ xplum(:),yplum(:),zplum(:) ! Only allocated for iout=4 or 5 (plumetraj)
+ integer,allocatable :: &
+ nclust(:) ! Only allocated for iout=4 or 5 (plumetraj)
+ ! private :: &
+ ! count
+ public :: &
+ particle, &
+ part, &
+ allocate_particles, &
+ deallocate_particle_range, &
+ deallocate_particle, &
+ deallocate_all_particles, &
+ terminate_particle, &
+ spawn_particles, &
+ spawn_particle, &
+ get_total_part_num, &
+ get_alive_part_num, &
+ get_new_part_index, &
+ is_particle_allocated, &
+ update_xlon, &
+ update_ylat, &
+ update_z, &
+ count
+
+ interface update_xlon
+ procedure update_xlon_dp, update_xlon_float, update_xlon_int
+ end interface update_xlon
+
+ interface set_xlon
+ procedure set_xlon_dp, set_xlon_float, set_xlon_int
+ end interface set_xlon
+
+ interface update_ylat
+ procedure update_ylat_dp, update_ylat_float, update_ylat_int
+ end interface update_ylat
+
+ interface set_ylat
+ procedure set_ylat_dp, set_ylat_float, set_ylat_int
+ end interface set_ylat
+
+ interface update_z
+ procedure update_z_dp,update_z_float
+ end interface update_z
+
+ interface set_z
+ procedure set_z_dp,set_z_float
+ end interface set_z
+
+ interface update_zeta
+ procedure update_zeta_dp,update_zeta_float
+ end interface update_zeta
+
+ interface set_zeta
+ procedure set_zeta_dp,set_zeta_float
+ end interface set_zeta
+
+contains
+
+ logical function is_particle_allocated(ipart)
+ !******************************************
+ ! Checks if the memory of the particle is *
+ ! still allocated *
+ !******************************************
+
+ implicit none
+
+ integer, intent(in) :: &
+ ipart ! Particle index
+ !logical :: is_particle_allocated
+
+ if (ipart.gt.count%allocated) then
+ is_particle_allocated = .false.
+ else
+ is_particle_allocated = count%inmem(ipart)
+ endif
+ end function is_particle_allocated
+
+ subroutine get_new_part_index(ipart)
+ !**************************************************
+ ! Returns the first free spot to put a new particle
+ !**************************************************
+ implicit none
+
+ integer, intent(inout) :: &
+ ipart ! First free index
+
+ ipart = count%spawned + 1
+ end subroutine get_new_part_index
+
+ subroutine get_total_part_num(npart)
+ !********************************************
+ ! Returns total number of particles spawned *
+ !********************************************
+ implicit none
+
+ integer, intent(inout) :: &
+ npart ! Number of particles
+
+ npart = count%spawned
+ end subroutine get_total_part_num
+
+ subroutine get_alive_part_num(npart)
+ !**********************************************
+ ! Returns number of particles currently alive *
+ !**********************************************
+ implicit none
+
+ integer, intent(inout) :: &
+ npart ! Number of particles
+
+ npart = count%alive
+ end subroutine get_alive_part_num
+
+ subroutine spawn_particles(itime, nmpart)
+ !******************************************************
+ ! Spawning particles
+ !
+ ! This routine spawns new particles and allocates the
+ ! memory if necessary.
+ !******************************************************
+ implicit none
+
+ integer, intent(in) :: &
+ itime, & ! spawning time
+ nmpart ! number of particles that are being spawned
+
+ ! Check if new memory needs to be allocated
+ !*******************************************
+ if (nmpart+count%spawned.gt.count%allocated) then
+ call allocate_particles( (nmpart+count%spawned) - count%allocated )
+ endif
+ ! Update the number of particles that are currently alive
+ !********************************************************
+ count%alive = count%alive + nmpart
+
+ ! Set the spawning time for each new particle and mark it as alive
+ !*****************************************************************
+ part(count%spawned+1:count%spawned+nmpart)%tstart = itime
+ part(count%spawned+1:count%spawned+nmpart)%alive = .true.
+
+ ! Update the total number of spawned particles
+ !*********************************************
+ count%spawned = count%spawned + nmpart
+ end subroutine spawn_particles
+
+ subroutine spawn_particle(itime, ipart)
+ !******************************************************
+ ! Spawning particles
+ !
+ ! This routine spawns new particles and allocates the
+ ! memory if necessary.
+ !******************************************************
+ implicit none
+
+ integer, intent(in) :: &
+ itime, & ! spawning time
+ ipart ! number of particles that are being spawned
+
+ ! Check if new memory needs to be allocated
+ !*******************************************
+ if (.not. is_particle_allocated(ipart)) then
+ call allocate_particle(ipart)
+ endif
+
+ if (part(ipart)%alive) stop 'Attempting to overwrite existing particle'
+
+ ! Update the number of particles that are currently alive
+ !********************************************************
+ count%alive = count%alive + 1
+
+ ! Set the spawning time for each new particle and mark it as alive
+ !*****************************************************************
+ part(ipart)%tstart = itime
+ part(ipart)%alive = .true.
+
+ ! Update the total number of spawned particles
+ !*********************************************
+ count%spawned = count%spawned + 1
+ end subroutine spawn_particle
+
+ subroutine terminate_particle(ipart,itime)
+ !*****************************************************
+ ! Terminating specified particle
+ !
+ ! This routine terminates a selected particle
+ !*****************************************************
+ implicit none
+
+ integer, intent(in) :: ipart ! to be terminated particle index
+ integer, intent(in) :: itime ! Time at which particle is terminated
+
+ ! Flagging the particle as having been terminated
+ !************************************************
+ part(ipart)%alive=.false.
+ part(ipart)%tend=itime
+
+ ! Update the number of current particles that are alive
+ !******************************************************
+ count%alive = count%alive - 1
+
+ ! Update the total number of terminated particles during the whole run
+ !**********************************************************************
+ count%terminated = count%terminated + 1
+ end subroutine terminate_particle
+
+ subroutine allocate_particles(nmpart)
+
+ implicit none
+
+ integer, intent(in) :: nmpart
+ type(particle),allocatable :: tmppart(:)
+ logical, allocatable :: tmpcount(:)
+ real, allocatable :: tmpxscav(:,:)
+ real, allocatable :: tmpxl(:),tmpyl(:),tmpzl(:)
+ integer, allocatable :: tmpnclust(:)
+ integer :: i
+
+ if (nmpart.gt.100) write(*,*) 'Allocating ',nmpart,' particles'
+
+ ! Keeping track of the allocated memory in case
+ ! there is a reason for deallocating some of it
+ !**********************************************
+ allocate( tmpcount(count%allocated+nmpart) )
+ if (count%allocated.gt.0) tmpcount(1:count%allocated) = count%inmem
+ call move_alloc(tmpcount,count%inmem)
+ count%inmem(count%allocated+1:count%allocated+nmpart) = .true.
+
+ ! Allocating new particle spaces
+ !*******************************
+
+ allocate( tmppart(count%allocated+nmpart) )
+ if (n_average.gt.0) then
+ do i=1,count%allocated+nmpart
+ allocate( tmppart(i)%val_av(n_average) )
+ tmppart(i)%val_av = 0
+ end do
+ endif
+ if (count%allocated.gt.0) tmppart(1:count%allocated) = part
+ call move_alloc(tmppart,part)
+
+ ! If wet or dry deposition backward mode is switched on, xscav_frac1
+ ! needs to be allocated
+ !*******************************************************************
+ if (WETBKDEP.or.DRYBKDEP) then
+ allocate( tmpxscav(count%allocated+nmpart,maxspec) )
+ if (count%allocated.gt.0) tmpxscav(1:count%allocated,:) = xscav_frac1
+ call move_alloc(tmpxscav,xscav_frac1)
+ endif
+
+ if ((iout.eq.4).or.(iout.eq.5)) then
+ allocate( tmpxl(count%allocated+nmpart) )
+ if (count%allocated.gt.0) tmpxl(1:count%allocated) = xplum
+ call move_alloc(tmpxl,xplum)
+
+ allocate( tmpyl(count%allocated+nmpart) )
+ if (count%allocated.gt.0) tmpyl(1:count%allocated) = yplum
+ call move_alloc(tmpyl,yplum)
+
+ allocate( tmpzl(count%allocated+nmpart) )
+ if (count%allocated.gt.0) tmpzl(1:count%allocated) = zplum
+ call move_alloc(tmpzl,zplum)
+
+ allocate( tmpnclust(count%allocated+nmpart) )
+ if (count%allocated.gt.0) tmpnclust(1:count%allocated) = nclust
+ call move_alloc(tmpnclust,nclust)
+ endif
+
+ count%allocated = count%allocated+nmpart
+ if (nmpart.gt.100) write(*,*) 'Finished allocation'
+ end subroutine allocate_particles
+
+ subroutine allocate_particle(ipart)
+
+ implicit none
+
+ integer, intent(in) :: ipart
+
+ ! Keeping track of the allocated memory in case
+ ! there is a reason for deallocating some of it
+ !**********************************************
+ if (ipart.gt.count%allocated) then
+ call allocate_particles(ipart-count%allocated)
+ else
+ stop 'Error: You are trying to allocate an already existing particle'
+ endif
+
+ end subroutine allocate_particle
+
+ subroutine deallocate_particle_range(istart,iend)
+
+ implicit none
+
+ integer, intent(in) :: istart,iend
+
+ !deallocate( part(istart:iend) )
+ count%inmem(istart:iend) = .false.
+ end subroutine deallocate_particle_range
+
+ subroutine deallocate_particle(ipart)
+
+ implicit none
+
+ integer, intent(in) :: ipart ! particle index
+
+ !deallocate( part(ipart) )
+ part = part(1:ipart) ! FORTRAN 2008 only
+ count%inmem(ipart+1:) = .false.
+ end subroutine deallocate_particle
+
+ subroutine deallocate_all_particles()
+
+ implicit none
+
+ integer :: i
+
+ if (n_average.gt.0) then
+ do i=1,count%allocated
+ deallocate( part(i)%val_av )
+ end do
+ endif
+ deallocate( part )
+ deallocate( count%inmem )
+
+ if (WETBKDEP.or.DRYBKDEP) then
+ deallocate( xscav_frac1 )
+ endif
+
+ if ((iout.eq.4).or.(iout.eq.5)) then
+ deallocate( xplum )
+ deallocate( yplum )
+ deallocate( zplum )
+ deallocate( nclust )
+ endif
+ end subroutine deallocate_all_particles
+
+! Update_xlon
+ subroutine update_xlon_dp(ipart,xchange)
+ !**************************************
+ ! Updates the longitude of the particle
+ !**************************************
+ implicit none
+
+ integer, intent(in) :: &
+ ipart ! particle index
+ real(kind=dp), intent(in) :: &
+ xchange
+
+ part(ipart)%xlon = part(ipart)%xlon + xchange
+ end subroutine update_xlon_dp
+
+ subroutine update_xlon_float(ipart,xchange)
+ !**************************************
+ ! Updates the longitude of the particle
+ !**************************************
+ implicit none
+
+ integer, intent(in) :: &
+ ipart ! particle index
+ real, intent(in) :: &
+ xchange
+
+ part(ipart)%xlon = part(ipart)%xlon + real(xchange,kind=dp)
+ end subroutine update_xlon_float
+
+ subroutine update_xlon_int(ipart,xchange)
+ !**************************************
+ ! Updates the longitude of the particle
+ !**************************************
+ implicit none
+
+ integer, intent(in) :: &
+ ipart ! particle index
+ integer, intent(in) :: &
+ xchange
+
+ part(ipart)%xlon = part(ipart)%xlon + real(xchange,kind=dp)
+ end subroutine update_xlon_int
+! End Update_xlon
+
+! Set_xlon
+ subroutine set_xlon_dp(ipart,xvalue)
+ !**************************************
+ ! Sets the longitude of the particle
+ !**************************************
+ implicit none
+
+ integer, intent(in) :: &
+ ipart ! particle index
+ real(kind=dp), intent(in) :: &
+ xvalue
+
+ part(ipart)%xlon = xvalue
+ end subroutine set_xlon_dp
+
+ subroutine set_xlon_float(ipart,xvalue)
+ !**************************************
+ ! Sets the longitude of the particle
+ !**************************************
+ implicit none
+
+ integer, intent(in) :: &
+ ipart ! particle index
+ real, intent(in) :: &
+ xvalue
+
+ part(ipart)%xlon = real(xvalue,kind=dp)
+ end subroutine set_xlon_float
+
+ subroutine set_xlon_int(ipart,xvalue)
+ !**************************************
+ ! Sets the longitude of the particle
+ !**************************************
+ implicit none
+
+ integer, intent(in) :: &
+ ipart ! particle index
+ integer, intent(in) :: &
+ xvalue
+
+ part(ipart)%xlon = real(xvalue,kind=dp)
+ end subroutine set_xlon_int
+! End Set_xlon
+
+! Update_ylat
+ subroutine update_ylat_dp(ipart,ychange)
+ !**************************************
+ ! Updates the latitude of the particle
+ !**************************************
+ implicit none
+
+ integer, intent(in) :: &
+ ipart ! particle index
+ real(kind=dp), intent(in) :: &
+ ychange
+
+ part(ipart)%ylat = part(ipart)%ylat + ychange
+ end subroutine update_ylat_dp
+
+ subroutine update_ylat_float(ipart,ychange)
+ !**************************************
+ ! Updates the latitude of the particle
+ !**************************************
+ implicit none
+
+ integer, intent(in) :: &
+ ipart ! particle index
+ real, intent(in) :: &
+ ychange
+
+ part(ipart)%ylat = part(ipart)%ylat + real(ychange,kind=dp)
+ end subroutine update_ylat_float
+
+ subroutine update_ylat_int(ipart,ychange)
+ !**************************************
+ ! Updates the latitude of the particle
+ !**************************************
+ implicit none
+
+ integer, intent(in) :: &
+ ipart ! particle index
+ integer, intent(in) :: &
+ ychange
+
+ part(ipart)%ylat = part(ipart)%ylat + real(ychange,kind=dp)
+ end subroutine update_ylat_int
+! End Update_ylat
+
+! Set_ylat
+ subroutine set_ylat_dp(ipart,yvalue)
+ !**************************************
+ ! Sets the latitude of the particle
+ !**************************************
+ implicit none
+
+ integer, intent(in) :: &
+ ipart ! particle index
+ real(kind=dp), intent(in) :: &
+ yvalue
+
+ part(ipart)%ylat = yvalue
+ end subroutine set_ylat_dp
+
+ subroutine set_ylat_float(ipart,yvalue)
+ !**************************************
+ ! Sets the latitude of the particle
+ !**************************************
+ implicit none
+
+ integer, intent(in) :: &
+ ipart ! particle index
+ real, intent(in) :: &
+ yvalue
+
+ part(ipart)%ylat = real(yvalue,kind=dp)
+ end subroutine set_ylat_float
+
+ subroutine set_ylat_int(ipart,yvalue)
+ !**************************************
+ ! Sets the latitude of the particle
+ !**************************************
+ implicit none
+
+ integer, intent(in) :: &
+ ipart ! particle index
+ integer, intent(in) :: &
+ yvalue
+
+ part(ipart)%ylat = real(yvalue,kind=dp)
+ end subroutine set_ylat_int
+! End Set_ylat
+
+! Update z positions
+ subroutine update_z_dp(ipart,zchange)
+ !**************************************
+ ! Updates the height of the particle
+ !**************************************
+ implicit none
+
+ integer, intent(in) :: &
+ ipart ! particle index
+ real(kind=dp), intent(in) :: &
+ zchange
+
+ part(ipart)%z = part(ipart)%z + zchange
+ part(ipart)%meterupdate=.false.
+ part(ipart)%etaupdate=.true.
+ end subroutine update_z_dp
+
+ subroutine update_z_float(ipart,zchange)
+ !**************************************
+ ! Updates the height of the particle
+ !**************************************
+ implicit none
+
+ integer, intent(in) :: &
+ ipart ! particle index
+ real, intent(in) :: &
+ zchange
+
+ part(ipart)%z = part(ipart)%z + real(zchange,kind=dp)
+ part(ipart)%meterupdate=.false.
+ part(ipart)%etaupdate=.true.
+ end subroutine update_z_float
+
+ subroutine update_zeta_dp(ipart,zchange)
+ !**************************************
+ ! Updates the height of the particle
+ !**************************************
+ implicit none
+
+ integer, intent(in) :: &
+ ipart ! particle index
+ real(kind=dp), intent(in) :: &
+ zchange
+
+ part(ipart)%zeta = part(ipart)%zeta + zchange
+ part(ipart)%etaupdate=.false.
+ part(ipart)%meterupdate=.true.
+ end subroutine update_zeta_dp
+
+ subroutine update_zeta_float(ipart,zchange)
+ !**************************************
+ ! Updates the height of the particle
+ !**************************************
+ implicit none
+
+ integer, intent(in) :: &
+ ipart ! particle index
+ real, intent(in) :: &
+ zchange
+
+ part(ipart)%zeta = part(ipart)%zeta + real(zchange,kind=dp)
+ part(ipart)%etaupdate=.false.
+ part(ipart)%meterupdate=.true.
+ end subroutine update_zeta_float
+! End update z positions
+
+! Update z positions
+ subroutine set_z_dp(ipart,zvalue)
+ !**************************************
+ ! Updates the height of the particle
+ !**************************************
+ implicit none
+
+ integer, intent(in) :: &
+ ipart ! particle index
+ real(kind=dp), intent(in) :: &
+ zvalue
+
+ part(ipart)%z = zvalue
+ part(ipart)%meterupdate=.false.
+ part(ipart)%etaupdate=.true.
+ end subroutine set_z_dp
+
+ subroutine set_z_float(ipart,zvalue)
+ !**************************************
+ ! Updates the height of the particle
+ !**************************************
+ implicit none
+
+ integer, intent(in) :: &
+ ipart ! particle index
+ real, intent(in) :: &
+ zvalue
+
+ part(ipart)%z = real(zvalue,kind=dp)
+ part(ipart)%meterupdate=.false.
+ part(ipart)%etaupdate=.true.
+ end subroutine set_z_float
+
+ subroutine set_zeta_dp(ipart,zvalue)
+ !**************************************
+ ! Updates the height of the particle
+ !**************************************
+ implicit none
+
+ integer, intent(in) :: &
+ ipart ! particle index
+ real(kind=dp), intent(in) :: &
+ zvalue
+
+ part(ipart)%zeta = zvalue
+ part(ipart)%etaupdate=.false.
+ part(ipart)%meterupdate=.true.
+ end subroutine set_zeta_dp
+
+ subroutine set_zeta_float(ipart,zvalue)
+ !**************************************
+ ! Updates the height of the particle
+ !**************************************
+ implicit none
+
+ integer, intent(in) :: &
+ ipart ! particle index
+ real, intent(in) :: &
+ zvalue
+
+ part(ipart)%zeta = real(zvalue,kind=dp)
+ part(ipart)%etaupdate=.false.
+ part(ipart)%meterupdate=.true.
+ end subroutine set_zeta_float
+! End update z positions
+
+end module particle_mod
diff --git a/src/partoutput.f90 b/src/partoutput.f90
deleted file mode 100644
index 5f6f53a7..00000000
--- a/src/partoutput.f90
+++ /dev/null
@@ -1,197 +0,0 @@
-! SPDX-FileCopyrightText: FLEXPART 1998-2019, see flexpart_license.txt
-! SPDX-License-Identifier: GPL-3.0-or-later
-
-subroutine partoutput(itime)
- ! i
- !*****************************************************************************
- ! *
- ! Dump all particle positions *
- ! *
- ! Author: A. Stohl *
- ! *
- ! 12 March 1999 *
- ! *
- !*****************************************************************************
- ! *
- ! Variables: *
- ! *
- !*****************************************************************************
-
- use par_mod
- use com_mod
-
- implicit none
-
- real(kind=dp) :: jul
- integer :: itime,i,j,jjjjmmdd,ihmmss
- integer :: ix,jy,ixp,jyp,indexh,m,il,ind,indz,indzp
- real :: xlon,ylat
- real :: dt1,dt2,dtt,ddx,ddy,rddx,rddy,p1,p2,p3,p4,dz1,dz2,dz
- real :: topo,hm(2),hmixi,pv1(2),pvprof(2),pvi,qv1(2),qvprof(2),qvi
- real :: tt1(2),ttprof(2),tti,rho1(2),rhoprof(2),rhoi
- real :: tr(2),tri
- character :: adate*8,atime*6
-
-
- ! Determine current calendar date, needed for the file name
- !**********************************************************
-
- jul=bdate+real(itime,kind=dp)/86400._dp
- call caldate(jul,jjjjmmdd,ihmmss)
- write(adate,'(i8.8)') jjjjmmdd
- write(atime,'(i6.6)') ihmmss
-
-
- ! Some variables needed for temporal interpolation
- !*************************************************
-
- dt1=real(itime-memtime(1))
- dt2=real(memtime(2)-itime)
- dtt=1./(dt1+dt2)
-
- ! Open output file and write the output
- !**************************************
-
- if (ipout.eq.1.or.ipout.eq.3) then
- open(unitpartout,file=path(2)(1:length(2))//'partposit_'//adate// &
- atime,form='unformatted')
- else
- open(unitpartout,file=path(2)(1:length(2))//'partposit_end', &
- form='unformatted')
- endif
-
- ! Write current time to file
- !***************************
-
- write(unitpartout) itime
- do i=1,numpart
-
- ! Take only valid particles
- !**************************
-
- if (itra1(i).eq.itime) then
- xlon=xlon0+xtra1(i)*dx
- ylat=ylat0+ytra1(i)*dy
-
- !*****************************************************************************
- ! Interpolate several variables (PV, specific humidity, etc.) to particle position
- !*****************************************************************************
-
- ix=xtra1(i)
- jy=ytra1(i)
- ixp=ix+1
- jyp=jy+1
- ddx=xtra1(i)-real(ix)
- ddy=ytra1(i)-real(jy)
- rddx=1.-ddx
- rddy=1.-ddy
- p1=rddx*rddy
- p2=ddx*rddy
- p3=rddx*ddy
- p4=ddx*ddy
-
-! eso: Temporary fix for particle exactly at north pole
- if (jyp >= nymax) then
- ! write(*,*) 'WARNING: conccalc.f90 jyp >= nymax'
- jyp=jyp-1
- end if
-
- ! Topography
- !***********
-
- topo=p1*oro(ix ,jy) &
- + p2*oro(ixp,jy) &
- + p3*oro(ix ,jyp) &
- + p4*oro(ixp,jyp)
-
- ! Potential vorticity, specific humidity, temperature, and density
- !*****************************************************************
-
- do il=2,nz
- if (height(il).gt.ztra1(i)) then
- indz=il-1
- indzp=il
- goto 6
- endif
- end do
-6 continue
-
- dz1=ztra1(i)-height(indz)
- dz2=height(indzp)-ztra1(i)
- dz=1./(dz1+dz2)
-
-
- do ind=indz,indzp
- do m=1,2
- indexh=memind(m)
-
- ! Potential vorticity
- pv1(m)=p1*pv(ix ,jy ,ind,indexh) &
- +p2*pv(ixp,jy ,ind,indexh) &
- +p3*pv(ix ,jyp,ind,indexh) &
- +p4*pv(ixp,jyp,ind,indexh)
- ! Specific humidity
- qv1(m)=p1*qv(ix ,jy ,ind,indexh) &
- +p2*qv(ixp,jy ,ind,indexh) &
- +p3*qv(ix ,jyp,ind,indexh) &
- +p4*qv(ixp,jyp,ind,indexh)
- ! Temperature
- tt1(m)=p1*tt(ix ,jy ,ind,indexh) &
- +p2*tt(ixp,jy ,ind,indexh) &
- +p3*tt(ix ,jyp,ind,indexh) &
- +p4*tt(ixp,jyp,ind,indexh)
- ! Density
- rho1(m)=p1*rho(ix ,jy ,ind,indexh) &
- +p2*rho(ixp,jy ,ind,indexh) &
- +p3*rho(ix ,jyp,ind,indexh) &
- +p4*rho(ixp,jyp,ind,indexh)
- end do
- pvprof(ind-indz+1)=(pv1(1)*dt2+pv1(2)*dt1)*dtt
- qvprof(ind-indz+1)=(qv1(1)*dt2+qv1(2)*dt1)*dtt
- ttprof(ind-indz+1)=(tt1(1)*dt2+tt1(2)*dt1)*dtt
- rhoprof(ind-indz+1)=(rho1(1)*dt2+rho1(2)*dt1)*dtt
- end do
- pvi=(dz1*pvprof(2)+dz2*pvprof(1))*dz
- qvi=(dz1*qvprof(2)+dz2*qvprof(1))*dz
- tti=(dz1*ttprof(2)+dz2*ttprof(1))*dz
- rhoi=(dz1*rhoprof(2)+dz2*rhoprof(1))*dz
-
- ! Tropopause and PBL height
- !**************************
-
- do m=1,2
- indexh=memind(m)
-
- ! Tropopause
- tr(m)=p1*tropopause(ix ,jy ,1,indexh) &
- + p2*tropopause(ixp,jy ,1,indexh) &
- + p3*tropopause(ix ,jyp,1,indexh) &
- + p4*tropopause(ixp,jyp,1,indexh)
-
- ! PBL height
- hm(m)=p1*hmix(ix ,jy ,1,indexh) &
- + p2*hmix(ixp,jy ,1,indexh) &
- + p3*hmix(ix ,jyp,1,indexh) &
- + p4*hmix(ixp,jyp,1,indexh)
- end do
-
- hmixi=(hm(1)*dt2+hm(2)*dt1)*dtt
- tri=(tr(1)*dt2+tr(2)*dt1)*dtt
-
-
- ! Write the output
- !*****************
-
- write(unitpartout) npoint(i),xlon,ylat,ztra1(i), &
- itramem(i),topo,pvi,qvi,rhoi,hmixi,tri,tti, &
- (xmass1(i,j),j=1,nspec)
- endif
- end do
- write(unitpartout) -99999,-9999.9,-9999.9,-9999.9,-99999, &
- -9999.9,-9999.9,-9999.9,-9999.9,-9999.9,-9999.9,-9999.9, &
- (-9999.9,j=1,nspec)
-
-
- close(unitpartout)
-
-end subroutine partoutput
diff --git a/src/partpos_average.f90 b/src/partpos_average.f90
deleted file mode 100644
index 48ee12cb..00000000
--- a/src/partpos_average.f90
+++ /dev/null
@@ -1,188 +0,0 @@
-! SPDX-FileCopyrightText: FLEXPART 1998-2019, see flexpart_license.txt
-! SPDX-License-Identifier: GPL-3.0-or-later
-
-
-subroutine partpos_average(itime,j)
-
-
-!**********************************************************************
-! This subroutine averages particle quantities, to be used for particle
-! dump (in partoutput.f90). Averaging is done over output interval.
-!**********************************************************************
-
- use par_mod
- use com_mod
-
- implicit none
-
- integer :: itime,j,ix,jy,ixp,jyp,indexh,m,il,ind,indz,indzp
- real :: xlon,ylat,x,y,z
- real :: dt1,dt2,dtt,ddx,ddy,rddx,rddy,p1,p2,p3,p4,dz1,dz2,dz
- real :: topo,hm(2),hmixi,pv1(2),pvprof(2),pvi,qv1(2),qvprof(2),qvi
- real :: tt1(2),ttprof(2),tti,rho1(2),rhoprof(2),rhoi
- real :: uu1(2),uuprof(2),uui,vv1(2),vvprof(2),vvi
- real :: tr(2),tri,energy
-
-
-
- ! Some variables needed for temporal interpolation
- !*************************************************
-
- dt1=real(itime-memtime(1))
- dt2=real(memtime(2)-itime)
- dtt=1./(dt1+dt2)
-
- xlon=xlon0+xtra1(j)*dx
- ylat=ylat0+ytra1(j)*dy
-
- !*****************************************************************************
- ! Interpolate several variables (PV, specific humidity, etc.) to particle position
- !*****************************************************************************
-
- ix=xtra1(j)
- jy=ytra1(j)
- ixp=ix+1
- jyp=jy+1
- ddx=xtra1(j)-real(ix)
- ddy=ytra1(j)-real(jy)
- rddx=1.-ddx
- rddy=1.-ddy
- p1=rddx*rddy
- p2=ddx*rddy
- p3=rddx*ddy
- p4=ddx*ddy
-
-! eso: Temporary fix for particle exactly at north pole
- if (jyp >= nymax) then
- ! write(*,*) 'WARNING: conccalc.f90 jyp >= nymax'
- jyp=jyp-1
- end if
-
- ! Topography
- !***********
-
- topo=p1*oro(ix,jy)+p2*oro(ixp,jy)+p3*oro(ix,jyp)+p4*oro(ixp,jyp)
-
- ! Potential vorticity, specific humidity, temperature, and density
- !*****************************************************************
-
- do il=2,nz
- if (height(il).gt.ztra1(j)) then
- indz=il-1
- indzp=il
- goto 6
- endif
- end do
-6 continue
-
- dz1=ztra1(j)-height(indz)
- dz2=height(indzp)-ztra1(j)
- dz=1./(dz1+dz2)
-
-
- do ind=indz,indzp
- do m=1,2
- indexh=memind(m)
-
- ! Potential vorticity
- pv1(m)=p1*pv(ix ,jy ,ind,indexh) &
- +p2*pv(ixp,jy ,ind,indexh) &
- +p3*pv(ix ,jyp,ind,indexh) &
- +p4*pv(ixp,jyp,ind,indexh)
- ! Specific humidity
- qv1(m)=p1*qv(ix ,jy ,ind,indexh) &
- +p2*qv(ixp,jy ,ind,indexh) &
- +p3*qv(ix ,jyp,ind,indexh) &
- +p4*qv(ixp,jyp,ind,indexh)
- ! Temperature
- tt1(m)=p1*tt(ix ,jy ,ind,indexh) &
- +p2*tt(ixp,jy ,ind,indexh) &
- +p3*tt(ix ,jyp,ind,indexh) &
- +p4*tt(ixp,jyp,ind,indexh)
- ! U wind
- uu1(m)=p1*uu(ix ,jy ,ind,indexh) &
- +p2*uu(ixp,jy ,ind,indexh) &
- +p3*uu(ix ,jyp,ind,indexh) &
- +p4*uu(ixp,jyp,ind,indexh)
- ! V wind
- vv1(m)=p1*vv(ix ,jy ,ind,indexh) &
- +p2*vv(ixp,jy ,ind,indexh) &
- +p3*vv(ix ,jyp,ind,indexh) &
- +p4*vv(ixp,jyp,ind,indexh)
- ! Density
- rho1(m)=p1*rho(ix ,jy ,ind,indexh) &
- +p2*rho(ixp,jy ,ind,indexh) &
- +p3*rho(ix ,jyp,ind,indexh) &
- +p4*rho(ixp,jyp,ind,indexh)
- end do
- pvprof(ind-indz+1)=(pv1(1)*dt2+pv1(2)*dt1)*dtt
- qvprof(ind-indz+1)=(qv1(1)*dt2+qv1(2)*dt1)*dtt
- ttprof(ind-indz+1)=(tt1(1)*dt2+tt1(2)*dt1)*dtt
- uuprof(ind-indz+1)=(uu1(1)*dt2+uu1(2)*dt1)*dtt
- vvprof(ind-indz+1)=(vv1(1)*dt2+vv1(2)*dt1)*dtt
- rhoprof(ind-indz+1)=(rho1(1)*dt2+rho1(2)*dt1)*dtt
- end do
- pvi=(dz1*pvprof(2)+dz2*pvprof(1))*dz
- qvi=(dz1*qvprof(2)+dz2*qvprof(1))*dz
- tti=(dz1*ttprof(2)+dz2*ttprof(1))*dz
- uui=(dz1*uuprof(2)+dz2*uuprof(1))*dz
- vvi=(dz1*vvprof(2)+dz2*vvprof(1))*dz
- rhoi=(dz1*rhoprof(2)+dz2*rhoprof(1))*dz
-
- ! Tropopause and PBL height
- !**************************
-
- do m=1,2
- indexh=memind(m)
-
- ! Tropopause
- tr(m)=p1*tropopause(ix ,jy ,1,indexh) &
- + p2*tropopause(ixp,jy ,1,indexh) &
- + p3*tropopause(ix ,jyp,1,indexh) &
- + p4*tropopause(ixp,jyp,1,indexh)
-
- ! PBL height
- hm(m)=p1*hmix(ix ,jy ,1,indexh) &
- + p2*hmix(ixp,jy ,1,indexh) &
- + p3*hmix(ix ,jyp,1,indexh) &
- + p4*hmix(ixp,jyp,1,indexh)
- end do
-
- hmixi=(hm(1)*dt2+hm(2)*dt1)*dtt
- tri=(tr(1)*dt2+tr(2)*dt1)*dtt
-
-
- energy=tti*cpa+(ztra1(j)+topo)*9.81+qvi*2501000.+(uui**2+vvi**2)/2.
-
- ! Add new values to sum and increase counter by one
- !**************************************************
-
- npart_av(j)=npart_av(j)+1
-
- ! Calculate Cartesian 3D coordinates suitable for averaging
- !**********************************************************
-
- xlon=xlon*pi180
- ylat=ylat*pi180
- x = cos(ylat)*sin(xlon)
- y = -1.*cos(ylat)*cos(xlon)
- z = sin(ylat)
-
- part_av_cartx(j)=part_av_cartx(j)+x
- part_av_carty(j)=part_av_carty(j)+y
- part_av_cartz(j)=part_av_cartz(j)+z
- part_av_z(j)=part_av_z(j)+ztra1(j)
- part_av_topo(j)=part_av_topo(j)+topo
- part_av_pv(j)=part_av_pv(j)+pvi
- part_av_qv(j)=part_av_qv(j)+qvi
- part_av_tt(j)=part_av_tt(j)+tti
- part_av_uu(j)=part_av_uu(j)+uui
- part_av_vv(j)=part_av_vv(j)+vvi
- part_av_rho(j)=part_av_rho(j)+rhoi
- part_av_tro(j)=part_av_tro(j)+tri
- part_av_hmix(j)=part_av_hmix(j)+hmixi
- part_av_energy(j)=part_av_energy(j)+energy
-
-
-return
-end subroutine partpos_average
diff --git a/src/pathnames b/src/pathnames
index 62310e9b..b3ffd4ac 100644
--- a/src/pathnames
+++ b/src/pathnames
@@ -1,5 +1,5 @@
../options/
-./output/
-/
-/xnilu_wrk/flex_wrk/WIND_FIELDS/AVAILABLE_ECMWF_OPER_fields_global
+/jetfs/home/lbakels/output_1e6_23_d/
+/jetfs/shared-data/ECMWF/ERA5_glob_0.5deg_1h/1995/01/
+../AVAILABLE
============================================
diff --git a/src/pbl_profile_mod.f90 b/src/pbl_profile_mod.f90
new file mode 100644
index 00000000..4f4584ae
--- /dev/null
+++ b/src/pbl_profile_mod.f90
@@ -0,0 +1,200 @@
+module pbl_profile_mod
+ use par_mod
+ use qvsat_mod
+
+ implicit none
+
+contains
+
+function psih (z,l)
+
+ !*****************************************************************************
+ ! *
+ ! Calculation of the stability correction term *
+ ! *
+ ! AUTHOR: Matthias Langer, adapted by Andreas Stohl (6 August 1993) *
+ ! Update: G. Wotawa, 11 October 1994 *
+ ! *
+ ! Literature: *
+ ! [1] C.A.Paulson (1970), A Mathematical Representation of Wind Speed *
+ ! and Temperature Profiles in the Unstable Atmospheric Surface *
+ ! Layer. J.Appl.Met.,Vol.9.(1970), pp.857-861. *
+ ! *
+ ! [2] A.C.M. Beljaars, A.A.M. Holtslag (1991), Flux Parameterization over*
+ ! Land Surfaces for Atmospheric Models. J.Appl.Met. Vol. 30,pp 327-*
+ ! 341 *
+ ! *
+ ! Variables: *
+ ! L = Monin-Obukhov-length [m] *
+ ! z = height [m] *
+ ! zeta = auxiliary variable *
+ ! *
+ ! Constants: *
+ ! eps = 1.2E-38, SUN-underflow: to avoid division by zero errors *
+ ! *
+ !*****************************************************************************
+
+ implicit none
+
+ real :: psih,x,z,zeta,l
+ real,parameter :: a=1.,b=0.667,c=5.,d=0.35,eps=1.e-20
+
+ if ((l.ge.0).and.(l.lt.eps)) then
+ l=eps
+ else if ((l.lt.0).and.(l.gt.(-1.*eps))) then
+ l=-1.*eps
+ endif
+
+ if ((log10(z)-log10(abs(l))).lt.log10(eps)) then
+ psih=0.
+ else
+ zeta=z/l
+ if (zeta.gt.0.) then
+ psih = - (1.+0.667*a*zeta)**(1.5) - b*(zeta-c/d)*exp(-d*zeta) &
+ - b*c/d + 1.
+ else
+ x=(1.-16.*zeta)**(.25)
+ psih=2.*log((1.+x*x)/2.)
+ end if
+ end if
+
+end function psih
+
+real function psim(z,al)
+
+ !**********************************************************************
+ ! *
+ ! DESCRIPTION: CALCULATION OF THE STABILITY CORRECTION FUNCTION FOR *
+ ! MOMENTUM AS FUNCTION OF HEIGHT Z AND OBUKHOV SCALE *
+ ! HEIGHT L *
+ ! *
+ !**********************************************************************
+
+ implicit none
+
+ real :: z,al,zeta,x,a1,a2
+
+ zeta=z/al
+ if(zeta.le.0.) then
+ ! UNSTABLE CASE
+ x=(1.-15.*zeta)**0.25
+ a1=((1.+x)/2.)**2
+ a2=(1.+x**2)/2.
+ psim=log(a1*a2)-2.*atan(x)+pi/2.
+ else
+ ! STABLE CASE
+ psim=-4.7*zeta
+ endif
+
+end function psim
+
+subroutine pbl_profile(ps,td2m,zml1,t2m,tml1,u10m,uml1,stress,hf)
+
+ !********************************************************************
+ ! *
+ ! G. WOTAWA, 1995-07-07 *
+ ! *
+ !********************************************************************
+ ! *
+ ! DESCRIPTION: CALCULATION OF FRICTION VELOCITY AND SURFACE SENS- *
+ ! IBLE HEAT FLUX USING THE PROFILE METHOD (BERKOVICZ *
+ ! AND PRAHM, 1982) *
+ ! *
+ ! Output now is surface stress instead of ustar *
+ ! *
+ ! *
+ !********************************************************************
+ ! *
+ ! INPUT: *
+ ! *
+ ! *
+ ! ps surface pressure(Pa) *
+ ! td2m two metre dew point(K) *
+ ! zml1 heigth of first model level (m) *
+ ! t2m two metre temperature (K) *
+ ! tml1 temperature first model level (K) *
+ ! u10m ten metre wind speed (ms-1) *
+ ! uml1 wind speed first model level (ms-1) *
+ ! *
+ !********************************************************************
+ ! *
+ ! OUTPUT: *
+ ! *
+ ! stress surface stress (i.e., friction velocity (ms-1) squared *
+ ! multiplied with air density) *
+ ! hf surface sensible heat flux (Wm-2) *
+ ! *
+ !********************************************************************
+ ! ustar friction velocity (ms-1) *
+ ! maxiter maximum number of iterations *
+ !********************************************************************
+
+ implicit none
+
+ integer :: iter
+ real :: ps,td2m,rhoa,zml1,t2m,tml1,u10m,uml1,ustar,hf
+ real :: al,alold,aldiff,tmean,crit
+ real :: deltau,deltat,thetastar,e,tv,stress
+ integer,parameter :: maxiter=10
+ real,parameter :: r1=0.74
+
+ e=ew(td2m,ps) ! vapor pressure
+ tv=t2m*(1.+0.378*e/ps) ! virtual temperature
+ rhoa=ps/(r_air*tv) ! air density
+
+ deltau=uml1-u10m !! Wind Speed difference between
+ !! Model level 1 and 10 m
+
+ if(deltau.le.0.001) then !! Monin-Obukhov Theory not
+ al=9999. !! applicable --> Set dummy values
+ ustar=0.01
+ stress=ustar*ustar*rhoa
+ hf=0.0
+ return
+ endif
+ deltat=tml1-t2m+0.0098*(zml1-2.) !! Potential temperature difference
+ !! between model level 1 and 10 m
+
+ if(abs(deltat).le.0.03) then !! Neutral conditions
+ hf=0.0
+ al=9999.
+ ustar=(vonkarman*deltau)/ &
+ (log(zml1/10.)-psim(zml1,al)+psim(10.,al))
+ stress=ustar*ustar*rhoa
+ return
+ endif
+
+ tmean=0.5*(t2m+tml1)
+ crit=(0.0219*tmean*(zml1-2.0)*deltau**2)/ &
+ (deltat*(zml1-10.0)**2)
+ if((deltat.gt.0).and.(crit.le.1.)) then
+ !! Successive approximation will
+ al=50. !! not converge
+ ustar=(vonkarman*deltau)/ &
+ (log(zml1/10.)-psim(zml1,al)+psim(10.,al))
+ thetastar=(vonkarman*deltat/r1)/ &
+ (log(zml1/2.)-psih(zml1,al)+psih(2.,al))
+ hf=rhoa*cpa*ustar*thetastar
+ stress=ustar*ustar*rhoa
+ return
+ endif
+
+ al=9999. ! Start iteration assuming neutral conditions
+ do iter=1,maxiter
+ alold=al
+ ustar=(vonkarman*deltau)/ &
+ (log(zml1/10.)-psim(zml1,al)+psim(10.,al))
+ thetastar=(vonkarman*deltat/r1)/ &
+ (log(zml1/2.)-psih(zml1,al)+psih(2.,al))
+ al=(tmean*ustar**2)/(ga*vonkarman*thetastar)
+ aldiff=abs((al-alold)/alold)
+ if(aldiff.lt.0.01) exit !! Successive approximation successful
+ end do
+ hf=rhoa*cpa*ustar*thetastar
+ if(al.gt.9999.) al=9999.
+ if(al.lt.-9999.) al=-9999.
+
+ stress=ustar*ustar*rhoa
+end subroutine pbl_profile
+
+end module pbl_profile_mod
\ No newline at end of file
diff --git a/src/plume_mod.f90 b/src/plume_mod.f90
new file mode 100644
index 00000000..71970fa3
--- /dev/null
+++ b/src/plume_mod.f90
@@ -0,0 +1,687 @@
+! SPDX-FileCopyrightText: FLEXPART 1998-2019, see flexpart_license.txt
+! SPDX-License-Identifier: GPL-3.0-or-later
+
+ !*****************************************************************************
+ ! *
+ ! L. Bakels 2022, This module contains routines that are relevant for the *
+ ! plume trajectory computations *
+ ! *
+ !*****************************************************************************
+module plume_mod
+
+ implicit none
+ private :: centerofmass,clustering,distance,distance2
+
+ public :: plumetraj,openouttraj
+contains
+
+subroutine plumetraj(itime)
+ ! i
+ !*****************************************************************************
+ ! *
+ ! Determines a plume centroid trajectory for each release site, and manages *
+ ! clustering of particle locations. Certain parameters (average PV, *
+ ! tropopause height, etc., are provided along the plume trajectories. *
+ ! At the end, output is written to file 'trajectories.txt'. *
+ ! *
+ ! Author: A. Stohl *
+ ! *
+ ! 24 January 2002 *
+ ! *
+ ! Variables: *
+ ! fclust fraction of particles belonging to each cluster *
+ ! hmixcenter mean mixing height for all particles *
+ ! ncluster number of clusters to be used *
+ ! pvcenter mean PV for all particles *
+ ! pvfract fraction of particles with PV<2pvu *
+ ! rms total horizontal rms distance after clustering *
+ ! rmsdist total horizontal rms distance before clustering *
+ ! rmsclust horizontal rms distance for each individual cluster *
+ ! topocenter mean topography underlying all particles *
+ ! tropocenter mean tropopause height at the positions of particles *
+ ! tropofract fraction of particles within the troposphere *
+ ! zrms total vertical rms distance after clustering *
+ ! zrmsdist total vertical rms distance before clustering *
+ ! xclust,yclust, Cluster centroid positions *
+ ! zclust *
+ ! *
+ !*****************************************************************************
+
+ use point_mod
+ use par_mod
+ use com_mod
+ use mean_mod
+ use particle_mod
+ use coordinates_ecmwf_mod
+ use windfields_mod
+
+ implicit none
+
+ integer :: itime,ix,jy,ixp,jyp,indexh,i,j,k,m,n,il,ind,indz,indzp
+ ! real :: xl(maxpart),yl(maxpart),zl(maxpart) ! moved to particle_mod and now xplum,yplum,zplum
+ real :: xcenter,ycenter,zcenter,dist,rmsdist,zrmsdist
+
+ real :: xclust(ncluster),yclust(ncluster),zclust(ncluster)
+ real :: fclust(ncluster),rms,rmsclust(ncluster),zrms
+
+ real :: dt1,dt2,dtt,ddx,ddy,rddx,rddy,p1,p2,p3,p4,dz1,dz2,dz
+ real :: topo,topocenter,hm(2),hmixi,hmixfract,hmixcenter
+ real :: pv1(2),pvprof(2),pvi,pvcenter,pvfract,tr(2),tri,tropofract
+ real :: tropocenter
+
+
+ dt1=real(itime-memtime(1))
+ dt2=real(memtime(2)-itime)
+ dtt=1./(dt1+dt2)
+
+
+ ! Loop about all release points
+ !******************************
+
+ do j=1,numpoint
+ if (abs(ireleasestart(j)-itime).gt.lage(nageclass)) cycle
+ topocenter=0.
+ hmixcenter=0.
+ hmixfract=0.
+ tropocenter=0.
+ tropofract=0.
+ pvfract=0.
+ pvcenter=0.
+ rmsdist=0.
+ zrmsdist=0.
+
+ n=0
+ do i=1,numpart
+ if (.not.part(i)%alive) cycle
+ if (part(i)%npoint.ne.j) cycle
+ n=n+1
+ xplum(n)=xlon0+part(i)%xlon*dx
+ yplum(n)=ylat0+part(i)%ylat*dy
+ call update_zeta_to_z(itime,i)
+ zplum(n)=part(i)%z
+
+ ! Interpolate PBL height, PV, and tropopause height to each
+ ! particle position in order to determine fraction of particles
+ ! within the PBL, above tropopause height, and average PV.
+ ! Interpolate topography, too, and convert to altitude asl
+ !**************************************************************
+
+ ix=int(part(i)%xlon)
+ jy=int(part(i)%ylat)
+ ixp=ix+1
+ jyp=jy+1
+
+ ! eso: Temporary fix for particle exactly at north pole
+ if (jyp >= nymax) then
+ write(*,*) 'WARNING: plume_mod.f90 jyp >= nymax. xt,yt:',part(i)%xlon,part(i)%ylat
+ jyp=jyp-1
+ end if
+
+ if (ixp >= nxmax) then
+ write(*,*) 'WARNING: plume_mod.f90 ixp >= nxmax. xt,yt:',part(i)%xlon,part(i)%ylat
+ ixp=ixp-nxmax
+ end if
+
+ ddx=part(i)%xlon-real(ix)
+ ddy=part(i)%ylat-real(jy)
+ rddx=1.-ddx
+ rddy=1.-ddy
+ p1=rddx*rddy
+ p2=ddx*rddy
+ p3=rddx*ddy
+ p4=ddx*ddy
+
+ ! Topography
+ !***********
+
+ topo=p1*oro(ix ,jy) &
+ + p2*oro(ixp,jy) &
+ + p3*oro(ix ,jyp) &
+ + p4*oro(ixp,jyp)
+ topocenter=topocenter+topo
+
+ ! Potential vorticity
+ !********************
+
+ do il=2,nz
+ if (height(il).gt.zplum(n)) then
+ indz=il-1
+ indzp=il
+ exit
+ endif
+ end do
+
+ dz1=zplum(n)-height(indz)
+ dz2=height(indzp)-zplum(n)
+ dz=1./(dz1+dz2)
+
+
+ do ind=indz,indzp
+ do m=1,2
+ indexh=memind(m)
+ pv1(m)=p1*pv(ix ,jy ,ind,indexh) &
+ +p2*pv(ixp,jy ,ind,indexh) &
+ +p3*pv(ix ,jyp,ind,indexh) &
+ +p4*pv(ixp,jyp,ind,indexh)
+ end do
+ pvprof(ind-indz+1)=(pv1(1)*dt2+pv1(2)*dt1)*dtt
+ end do
+ pvi=(dz1*pvprof(2)+dz2*pvprof(1))*dz
+ pvcenter=pvcenter+pvi
+ if (yplum(n).gt.0.) then
+ if (pvi.lt.2.) pvfract=pvfract+1.
+ else
+ if (pvi.gt.-2.) pvfract=pvfract+1.
+ endif
+
+
+ ! Tropopause and PBL height
+ !**************************
+
+ do m=1,2
+ indexh=memind(m)
+
+ tr(m)=p1*tropopause(ix ,jy ,1,indexh) &
+ + p2*tropopause(ixp,jy ,1,indexh) &
+ + p3*tropopause(ix ,jyp,1,indexh) &
+ + p4*tropopause(ixp,jyp,1,indexh)
+
+ hm(m)=p1*hmix(ix ,jy ,1,indexh) &
+ + p2*hmix(ixp,jy ,1,indexh) &
+ + p3*hmix(ix ,jyp,1,indexh) &
+ + p4*hmix(ixp,jyp,1,indexh)
+ end do
+
+ hmixi=(hm(1)*dt2+hm(2)*dt1)*dtt
+ tri=(tr(1)*dt2+tr(2)*dt1)*dtt
+ if (zplum(n).lt.tri) tropofract=tropofract+1.
+ tropocenter=tropocenter+tri+topo
+ if (zplum(n).lt.hmixi) hmixfract=hmixfract+1.
+ zplum(n)=zplum(n)+topo ! convert to height asl
+ hmixcenter=hmixcenter+hmixi
+
+ end do
+
+
+ ! Make statistics for all plumes with n>0 particles
+ !**************************************************
+
+ if (n.gt.0) then
+ topocenter=topocenter/real(n)
+ hmixcenter=hmixcenter/real(n)
+ pvcenter=pvcenter/real(n)
+ tropocenter=tropocenter/real(n)
+ hmixfract=100.*hmixfract/real(n)
+ pvfract=100.*pvfract/real(n)
+ tropofract=100.*tropofract/real(n)
+
+ ! Cluster the particle positions
+ !*******************************
+
+ call clustering(n,xclust,yclust,zclust,fclust,rms, &
+ rmsclust,zrms)
+
+
+ ! Determine center of mass position on earth and average height
+ !**************************************************************
+
+ call centerofmass(xplum,yplum,n,xcenter,ycenter)
+ call mean(zplum,zcenter,zrmsdist,n)
+
+ ! Root mean square distance from center of mass
+ !**********************************************
+
+ do k=1,n
+ dist=distance(yplum(k),xplum(k),ycenter,xcenter)
+ rmsdist=rmsdist+dist*dist
+ end do
+ if (rmsdist.gt.0.) rmsdist=sqrt(rmsdist/real(n))
+ rmsdist=max(rmsdist,0.)
+
+ ! Write out results in trajectory data file
+ !******************************************
+
+ write(unitouttraj,'(i5,i8,2f9.4,4f8.1,f8.2,4f8.1,3f6.1,&
+ &5(2f8.3,f7.0,f6.1,f8.1))')&
+ &j,itime-(ireleasestart(j)+ireleaseend(j))/2, &
+ xcenter,ycenter,zcenter,topocenter,hmixcenter,tropocenter, &
+ pvcenter,rmsdist,rms,zrmsdist,zrms,hmixfract,pvfract, &
+ tropofract, &
+ (xclust(k),yclust(k),zclust(k),fclust(k),rmsclust(k), &
+ k=1,ncluster)
+ endif
+
+ end do
+end subroutine plumetraj
+
+subroutine centerofmass(xl,yl,n,xcenter,ycenter)
+ ! i i i o o
+ !*****************************************************************************
+ ! *
+ ! This routine calculates the center of mass of n points on the Earth. *
+ ! Input are the longitudes (xl) and latitudes (yl) of the individual *
+ ! points, output is the longitude and latitude of the centre of mass. *
+ ! *
+ ! Author: A. Stohl *
+ ! *
+ ! 24 January 2002 *
+ ! *
+ !*****************************************************************************
+
+ use par_mod
+
+ implicit none
+
+ integer :: n,l
+ real :: xl(n),yl(n),xll,yll,xav,yav,zav,x,y,z,xcenter,ycenter
+
+
+ xav=0.
+ yav=0.
+ zav=0.
+
+ do l=1,n
+
+ ! Convert longitude and latitude from degrees to radians
+ !*******************************************************
+
+ xll=xl(l)*pi180
+ yll=yl(l)*pi180
+
+ ! Calculate 3D coordinates from longitude and latitude
+ !*****************************************************
+
+ x = cos(yll)*sin(xll)
+ y = -1.*cos(yll)*cos(xll)
+ z = sin(yll)
+
+
+ ! Find the mean location in Cartesian coordinates
+ !************************************************
+
+ xav=xav+x
+ yav=yav+y
+ zav=zav+z
+ end do
+
+ xav=xav/real(n)
+ yav=yav/real(n)
+ zav=zav/real(n)
+
+
+ ! Project the point back onto Earth's surface
+ !********************************************
+
+ xcenter=atan2(xav,-1.*yav)
+ ycenter=atan2(zav,sqrt(xav*xav+yav*yav))
+
+ ! Convert back to degrees
+ !************************
+
+ xcenter=xcenter/pi180
+ ycenter=ycenter/pi180
+end subroutine centerofmass
+
+subroutine clustering(n,xclust,yclust,zclust,fclust,rms, &
+ rmsclust,zrms)
+ ! i i i i o o o o o
+ ! o o
+ !*****************************************************************************
+ ! *
+ ! This routine clusters the particle position into ncluster custers. *
+ ! Input are the longitudes (xl) and latitudes (yl) of the individual *
+ ! points, output are the cluster mean positions (xclust,yclust). *
+ ! Vertical positions are not directly used for the clustering. *
+ ! *
+ ! For clustering, the procedure described in Dorling et al. (1992) is used.*
+ ! *
+ ! Dorling, S.R., Davies, T.D. and Pierce, C.E. (1992): *
+ ! Cluster analysis: a technique for estimating the synoptic meteorological *
+ ! controls on air and precipitation chemistry - method and applications. *
+ ! Atmospheric Environment 26A, 2575-2581. *
+ ! *
+ ! *
+ ! Author: A. Stohl *
+ ! *
+ ! 1 February 2002 *
+ ! *
+ ! Variables: *
+ ! fclust fraction of particles belonging to each cluster *
+ ! ncluster number of clusters to be used *
+ ! rms total horizontal rms distance after clustering *
+ ! rmsclust horizontal rms distance for each individual cluster *
+ ! zrms total vertical rms distance after clustering *
+ ! xclust,yclust, Cluster centroid positions *
+ ! zclust *
+ ! xl,yl,zl particle positions *
+ ! *
+ !*****************************************************************************
+
+ use par_mod
+ use particle_mod
+
+ implicit none
+
+ integer :: n,i,j,l,numb(ncluster),ncl
+ real :: xclust(ncluster),yclust(ncluster),x,y,z
+ real :: zclust(ncluster),distances,distancemin,rms,rmsold
+ real :: xav(ncluster),yav(ncluster),zav(ncluster),fclust(ncluster)
+ real :: rmsclust(ncluster)
+ real :: zdist,zrms
+
+
+
+ if (n.lt.ncluster) return
+ rmsold=-5.
+
+ ! Convert longitude and latitude from degrees to radians
+ !*******************************************************
+
+ do i=1,n
+ nclust(i)=i
+ xplum(i)=xplum(i)*pi180
+ yplum(i)=yplum(i)*pi180
+ end do
+
+
+ ! Generate a seed for each cluster
+ !*********************************
+
+ do j=1,ncluster
+ zclust(j)=0.
+ xclust(j)=xplum(j*n/ncluster)
+ yclust(j)=yplum(j*n/ncluster)
+ end do
+
+
+ ! Iterative loop to compute the cluster means
+ !********************************************
+
+ do l=1,100
+
+ ! Assign each particle to a cluster: criterion minimum distance to the
+ ! cluster mean position
+ !*********************************************************************
+
+
+ do i=1,n
+ distancemin=10.**10.
+ do j=1,ncluster
+ distances=distance2(yplum(i),xplum(i),yclust(j),xclust(j))
+ if (distances.lt.distancemin) then
+ distancemin=distances
+ ncl=j
+ endif
+ end do
+ nclust(i)=ncl
+ end do
+
+
+ ! Recalculate the cluster centroid position: convert to 3D Cartesian coordinates,
+ ! calculate mean position, and re-project this point onto the Earth's surface
+ !*****************************************************************************
+
+ do j=1,ncluster
+ xav(j)=0.
+ yav(j)=0.
+ zav(j)=0.
+ rmsclust(j)=0.
+ numb(j)=0
+ end do
+ rms=0.
+
+ do i=1,n
+ numb(nclust(i))=numb(nclust(i))+1
+ distances=distance2(yplum(i),xplum(i), &
+ yclust(nclust(i)),xclust(nclust(i)))
+
+ ! rms is the total rms of all particles
+ ! rmsclust is the rms for a particular cluster
+ !*********************************************
+
+ rms=rms+distances*distances
+ rmsclust(nclust(i))=rmsclust(nclust(i))+distances*distances
+
+ ! Calculate Cartesian 3D coordinates from longitude and latitude
+ !***************************************************************
+
+ x = cos(yplum(i))*sin(xplum(i))
+ y = -1.*cos(yplum(i))*cos(xplum(i))
+ z = sin(yplum(i))
+ xav(nclust(i))=xav(nclust(i))+x
+ yav(nclust(i))=yav(nclust(i))+y
+ zav(nclust(i))=zav(nclust(i))+z
+ end do
+
+ rms=sqrt(rms/real(n))
+
+
+ ! Find the mean location in Cartesian coordinates
+ !************************************************
+
+ do j=1,ncluster
+ if (numb(j).gt.0) then
+ rmsclust(j)=sqrt(rmsclust(j)/real(numb(j)))
+ xav(j)=xav(j)/real(numb(j))
+ yav(j)=yav(j)/real(numb(j))
+ zav(j)=zav(j)/real(numb(j))
+
+ ! Project the point back onto Earth's surface
+ !********************************************
+
+ xclust(j)=atan2(xav(j),-1.*yav(j))
+ yclust(j)=atan2(zav(j),sqrt(xav(j)*xav(j)+yav(j)*yav(j)))
+ endif
+ end do
+
+
+ ! Leave the loop if the RMS distance decreases only slightly between 2 iterations
+ !*****************************************************************************
+
+ if ((l.gt.1).and.(abs(rms-rmsold)/rmsold.lt.0.005)) exit
+ rmsold=rms
+
+ end do
+
+ ! Convert longitude and latitude from radians to degrees
+ !*******************************************************
+
+ do i=1,n
+ xplum(i)=xplum(i)/pi180
+ yplum(i)=yplum(i)/pi180
+ zclust(nclust(i))=zclust(nclust(i))+zplum(i)
+ end do
+
+ do j=1,ncluster
+ xclust(j)=xclust(j)/pi180
+ yclust(j)=yclust(j)/pi180
+ if (numb(j).gt.0) zclust(j)=zclust(j)/real(numb(j))
+ fclust(j)=100.*real(numb(j))/real(n)
+ end do
+
+ ! Determine total vertical RMS deviation
+ !***************************************
+
+ zrms=0.
+ do i=1,n
+ zdist=zplum(i)-zclust(nclust(i))
+ zrms=zrms+zdist*zdist
+ end do
+ if (zrms.gt.0.) zrms=sqrt(zrms/real(n))
+
+end subroutine clustering
+
+real function distance(rlat1,rlon1,rlat2,rlon2)
+
+ !$$$ SUBPROGRAM DOCUMENTATION BLOCK
+ !
+ ! SUBPROGRAM: GCDIST COMPUTE GREAT CIRCLE DISTANCE
+ ! PRGMMR: IREDELL ORG: W/NMC23 DATE: 96-04-10
+ !
+ ! ABSTRACT: THIS SUBPROGRAM COMPUTES GREAT CIRCLE DISTANCE
+ ! BETWEEN TWO POINTS ON THE EARTH.
+ !
+ ! PROGRAM HISTORY LOG:
+ ! 96-04-10 IREDELL
+ !
+ ! USAGE: ...GCDIST(RLAT1,RLON1,RLAT2,RLON2)
+ !
+ ! INPUT ARGUMENT LIST:
+ !rlat1 - REAL LATITUDE OF POINT 1 IN DEGREES
+ !rlon1 - REAL LONGITUDE OF POINT 1 IN DEGREES
+ !rlat2 - REAL LATITUDE OF POINT 2 IN DEGREES
+ !rlon2 - REAL LONGITUDE OF POINT 2 IN DEGREES
+ !
+ ! OUTPUT ARGUMENT LIST:
+ !distance - REAL GREAT CIRCLE DISTANCE IN KILOMETERS
+ !
+ ! ATTRIBUTES:
+ ! LANGUAGE: Fortran 90
+ !
+ !$$$
+
+ use par_mod, only: dp
+
+ implicit none
+
+ real :: rlat1,rlon1,rlat2,rlon2
+ real(kind=dp) :: clat1,clat2,slat1,slat2,cdlon,crd
+ real(kind=dp),parameter :: rerth=6.3712e6_dp
+ real(kind=dp),parameter :: pi=3.14159265358979_dp, dpr=180.0_dp/pi
+ ! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+ if ((abs(rlat1-rlat2).lt.0.03).and. &
+ (abs(rlon1-rlon2).lt.0.03)) then
+ distance=0.
+ else
+ clat1=cos(real(rlat1,kind=dp)/dpr)
+ slat1=sin(real(rlat1,kind=dp)/dpr)
+ clat2=cos(real(rlat2,kind=dp)/dpr)
+ slat2=sin(real(rlat2,kind=dp)/dpr)
+ cdlon=cos(real((rlon1-rlon2),kind=dp)/dpr)
+ crd=slat1*slat2+clat1*clat2*cdlon
+ distance=real(rerth*acos(crd)/1000.0_dp)
+ endif
+ ! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+end function distance
+
+real function distance2(rlat1,rlon1,rlat2,rlon2)
+
+ !$$$ SUBPROGRAM DOCUMENTATION BLOCK
+ !
+ ! SUBPROGRAM: GCDIST COMPUTE GREAT CIRCLE DISTANCE
+ ! PRGMMR: IREDELL ORG: W/NMC23 DATE: 96-04-10
+ !
+ ! ABSTRACT: THIS SUBPROGRAM COMPUTES GREAT CIRCLE DISTANCE
+ ! BETWEEN TWO POINTS ON THE EARTH. COORDINATES ARE GIVEN IN RADIANS!
+ !
+ ! PROGRAM HISTORY LOG:
+ ! 96-04-10 IREDELL
+ !
+ ! USAGE: ...GCDIST(RLAT1,RLON1,RLAT2,RLON2)
+ !
+ ! INPUT ARGUMENT LIST:
+ !rlat1 - REAL LATITUDE OF POINT 1 IN RADIANS
+ !rlon1 - REAL LONGITUDE OF POINT 1 IN RADIANS
+ !rlat2 - REAL LATITUDE OF POINT 2 IN RADIANS
+ !rlon2 - REAL LONGITUDE OF POINT 2 IN RADIANS
+ !
+ ! OUTPUT ARGUMENT LIST:
+ !distance2 - REAL GREAT CIRCLE DISTANCE IN KM
+ !
+ ! ATTRIBUTES:
+ ! LANGUAGE: Fortran 90
+ !
+ !$$$
+
+ use par_mod, only: dp
+
+ implicit none
+
+ real :: rlat1,rlon1,rlat2,rlon2
+ real(kind=dp) :: clat1,clat2,slat1,slat2,cdlon,crd
+ real(kind=dp),parameter :: rerth=6.3712e6_dp
+ real(kind=dp),parameter :: pi=3.14159265358979_dp
+
+ if ((abs(rlat1-rlat2).lt.0.0003).and. &
+ (abs(rlon1-rlon2).lt.0.0003)) then
+ distance2=0.0_dp
+ else
+
+ ! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+ clat1=cos(real(rlat1,kind=dp))
+ slat1=sin(real(rlat1,kind=dp))
+ clat2=cos(real(rlat2,kind=dp))
+ slat2=sin(real(rlat2,kind=dp))
+ cdlon=cos(real(rlon1-rlon2,kind=dp))
+ crd=slat1*slat2+clat1*clat2*cdlon
+ distance2=real(rerth*acos(crd)/1000.0_dp)
+ endif
+ ! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+end function distance2
+
+subroutine openouttraj
+
+ !*****************************************************************************
+ ! *
+ ! This routine opens the output file for the plume trajectory output *
+ ! produced by the cluster analysis. *
+ ! *
+ ! Author: A. Stohl *
+ ! *
+ ! 27 January 2001 *
+ ! *
+ !*****************************************************************************
+ ! *
+ ! Variables: *
+ ! *
+ !*****************************************************************************
+
+ use point_mod
+ use par_mod
+ use com_mod
+
+ implicit none
+
+ integer :: i
+ real :: xp1,yp1,xp2,yp2
+
+
+ ! Open output file for trajectory output
+ !***************************************
+
+ open(unitouttraj,file=path(2)(1:length(2))//'trajectories.txt', &
+ form='formatted',err=998)
+
+ if (ldirect.eq.1) then
+ write(unitouttraj,'(i8,1x,i6,1x,a)') ibdate,ibtime, trim(flexversion)
+ else
+ write(unitouttraj,'(i8,1x,i6,1x,a)') iedate,ietime, trim(flexversion)
+ endif
+ write(unitouttraj,*) method,lsubgrid,lconvection
+ write(unitouttraj,*) numpoint
+ do i=1,numpoint
+ xp1=xpoint1(i)*dx+xlon0
+ yp1=ypoint1(i)*dy+ylat0
+ xp2=xpoint2(i)*dx+xlon0
+ yp2=ypoint2(i)*dy+ylat0
+ write(unitouttraj,*) ireleasestart(i),ireleaseend(i), &
+ xp1,yp1,xp2,yp2,zpoint1(i),zpoint2(i),kindz(i),npart(i)
+ if (numpoint.le.1000) then
+ write(unitouttraj,'(a)') compoint(i)(1:40)
+ else
+ write(unitouttraj,'(a)') compoint(1001)(1:40)
+ endif
+ end do
+
+ return
+
+998 write(*,*) ' #### FLEXPART MODEL ERROR! THE FILE #### '
+ write(*,*) ' #### trajectories.txt #### '
+ write(*,*) ' #### CANNOT BE OPENED. IF A FILE WITH THIS #### '
+ write(*,*) ' #### NAME ALREADY EXISTS, DELETE IT AND START #### '
+ write(*,*) ' #### THE PROGRAM AGAIN. #### '
+ stop
+
+end subroutine openouttraj
+
+end module plume_mod
\ No newline at end of file
diff --git a/src/plumetraj.f90 b/src/plumetraj.f90
deleted file mode 100644
index fbd747c5..00000000
--- a/src/plumetraj.f90
+++ /dev/null
@@ -1,233 +0,0 @@
-! SPDX-FileCopyrightText: FLEXPART 1998-2019, see flexpart_license.txt
-! SPDX-License-Identifier: GPL-3.0-or-later
-
-subroutine plumetraj(itime)
- ! i
- !*****************************************************************************
- ! *
- ! Determines a plume centroid trajectory for each release site, and manages *
- ! clustering of particle locations. Certain parameters (average PV, *
- ! tropopause height, etc., are provided along the plume trajectories. *
- ! At the end, output is written to file 'trajectories.txt'. *
- ! *
- ! Author: A. Stohl *
- ! *
- ! 24 January 2002 *
- ! *
- ! Variables: *
- ! fclust fraction of particles belonging to each cluster *
- ! hmixcenter mean mixing height for all particles *
- ! ncluster number of clusters to be used *
- ! pvcenter mean PV for all particles *
- ! pvfract fraction of particles with PV<2pvu *
- ! rms total horizontal rms distance after clustering *
- ! rmsdist total horizontal rms distance before clustering *
- ! rmsclust horizontal rms distance for each individual cluster *
- ! topocenter mean topography underlying all particles *
- ! tropocenter mean tropopause height at the positions of particles *
- ! tropofract fraction of particles within the troposphere *
- ! zrms total vertical rms distance after clustering *
- ! zrmsdist total vertical rms distance before clustering *
- ! xclust,yclust, Cluster centroid positions *
- ! zclust *
- ! *
- !*****************************************************************************
-
- use point_mod
- use par_mod
- use com_mod
- use mean_mod
-
- implicit none
-
- integer :: itime,ix,jy,ixp,jyp,indexh,i,j,k,m,n,il,ind,indz,indzp
- real :: xl(maxpart),yl(maxpart),zl(maxpart)
- real :: xcenter,ycenter,zcenter,dist,distance,rmsdist,zrmsdist
-
- real :: xclust(ncluster),yclust(ncluster),zclust(ncluster)
- real :: fclust(ncluster),rms,rmsclust(ncluster),zrms
-
- real :: dt1,dt2,dtt,ddx,ddy,rddx,rddy,p1,p2,p3,p4,dz1,dz2,dz
- real :: topo,topocenter,hm(2),hmixi,hmixfract,hmixcenter
- real :: pv1(2),pvprof(2),pvi,pvcenter,pvfract,tr(2),tri,tropofract
- real :: tropocenter
-
-
- dt1=real(itime-memtime(1))
- dt2=real(memtime(2)-itime)
- dtt=1./(dt1+dt2)
-
-
- ! Loop about all release points
- !******************************
-
- do j=1,numpoint
- if (abs(ireleasestart(j)-itime).gt.lage(nageclass)) goto 10
- topocenter=0.
- hmixcenter=0.
- hmixfract=0.
- tropocenter=0.
- tropofract=0.
- pvfract=0.
- pvcenter=0.
- rmsdist=0.
- zrmsdist=0.
-
- n=0
- do i=1,numpart
- if (itra1(i).ne.itime) goto 20
- if (npoint(i).ne.j) goto 20
- n=n+1
- xl(n)=xlon0+xtra1(i)*dx
- yl(n)=ylat0+ytra1(i)*dy
- zl(n)=ztra1(i)
-
-
- ! Interpolate PBL height, PV, and tropopause height to each
- ! particle position in order to determine fraction of particles
- ! within the PBL, above tropopause height, and average PV.
- ! Interpolate topography, too, and convert to altitude asl
- !**************************************************************
-
- ix=int(xtra1(i))
- jy=int(ytra1(i))
- ixp=ix+1
- jyp=jy+1
- ddx=xtra1(i)-real(ix)
- ddy=ytra1(i)-real(jy)
- rddx=1.-ddx
- rddy=1.-ddy
- p1=rddx*rddy
- p2=ddx*rddy
- p3=rddx*ddy
- p4=ddx*ddy
-
- ! Topography
- !***********
-
- topo=p1*oro(ix ,jy) &
- + p2*oro(ixp,jy) &
- + p3*oro(ix ,jyp) &
- + p4*oro(ixp,jyp)
- topocenter=topocenter+topo
-
- ! Potential vorticity
- !********************
-
- do il=2,nz
- if (height(il).gt.zl(n)) then
- indz=il-1
- indzp=il
- goto 6
- endif
- end do
-6 continue
-
- dz1=zl(n)-height(indz)
- dz2=height(indzp)-zl(n)
- dz=1./(dz1+dz2)
-
-
- do ind=indz,indzp
- do m=1,2
- indexh=memind(m)
- pv1(m)=p1*pv(ix ,jy ,ind,indexh) &
- +p2*pv(ixp,jy ,ind,indexh) &
- +p3*pv(ix ,jyp,ind,indexh) &
- +p4*pv(ixp,jyp,ind,indexh)
- end do
- pvprof(ind-indz+1)=(pv1(1)*dt2+pv1(2)*dt1)*dtt
- end do
- pvi=(dz1*pvprof(2)+dz2*pvprof(1))*dz
- pvcenter=pvcenter+pvi
- if (yl(n).gt.0.) then
- if (pvi.lt.2.) pvfract=pvfract+1.
- else
- if (pvi.gt.-2.) pvfract=pvfract+1.
- endif
-
-
- ! Tropopause and PBL height
- !**************************
-
- do m=1,2
- indexh=memind(m)
-
- tr(m)=p1*tropopause(ix ,jy ,1,indexh) &
- + p2*tropopause(ixp,jy ,1,indexh) &
- + p3*tropopause(ix ,jyp,1,indexh) &
- + p4*tropopause(ixp,jyp,1,indexh)
-
- hm(m)=p1*hmix(ix ,jy ,1,indexh) &
- + p2*hmix(ixp,jy ,1,indexh) &
- + p3*hmix(ix ,jyp,1,indexh) &
- + p4*hmix(ixp,jyp,1,indexh)
- end do
-
- hmixi=(hm(1)*dt2+hm(2)*dt1)*dtt
- tri=(tr(1)*dt2+tr(2)*dt1)*dtt
- if (zl(n).lt.tri) tropofract=tropofract+1.
- tropocenter=tropocenter+tri+topo
- if (zl(n).lt.hmixi) hmixfract=hmixfract+1.
- zl(n)=zl(n)+topo ! convert to height asl
- hmixcenter=hmixcenter+hmixi
-
-
-20 continue
- end do
-
-
- ! Make statistics for all plumes with n>0 particles
- !**************************************************
-
- if (n.gt.0) then
- topocenter=topocenter/real(n)
- hmixcenter=hmixcenter/real(n)
- pvcenter=pvcenter/real(n)
- tropocenter=tropocenter/real(n)
- hmixfract=100.*hmixfract/real(n)
- pvfract=100.*pvfract/real(n)
- tropofract=100.*tropofract/real(n)
-
- ! Cluster the particle positions
- !*******************************
-
- call clustering(xl,yl,zl,n,xclust,yclust,zclust,fclust,rms, &
- rmsclust,zrms)
-
-
- ! Determine center of mass position on earth and average height
- !**************************************************************
-
- call centerofmass(xl,yl,n,xcenter,ycenter)
- call mean(zl,zcenter,zrmsdist,n)
-
- ! Root mean square distance from center of mass
- !**********************************************
-
- do k=1,n
- dist=distance(yl(k),xl(k),ycenter,xcenter)
- rmsdist=rmsdist+dist*dist
- end do
- if (rmsdist.gt.0.) rmsdist=sqrt(rmsdist/real(n))
- rmsdist=max(rmsdist,0.)
-
- ! Write out results in trajectory data file
- !******************************************
-
- write(unitouttraj,'(i5,i8,2f9.4,4f8.1,f8.2,4f8.1,3f6.1,&
- &5(2f8.3,f7.0,f6.1,f8.1))')&
- &j,itime-(ireleasestart(j)+ireleaseend(j))/2, &
- xcenter,ycenter,zcenter,topocenter,hmixcenter,tropocenter, &
- pvcenter,rmsdist,rms,zrmsdist,zrms,hmixfract,pvfract, &
- tropofract, &
- (xclust(k),yclust(k),zclust(k),fclust(k),rmsclust(k), &
- k=1,ncluster)
- endif
-
-
-10 continue
- end do
-
-
-end subroutine plumetraj
diff --git a/src/point_mod.f90 b/src/point_mod.f90
index 3b075347..764981c6 100644
--- a/src/point_mod.f90
+++ b/src/point_mod.f90
@@ -20,4 +20,116 @@ module point_mod
real,allocatable, dimension (:,:) :: xmass
real,allocatable, dimension (:) :: rho_rel
+ real :: &
+ dx, & ! grid distance in x direction
+ dy, & ! grid distance in y direction
+ xlon0, & ! geographical longitude and
+ ylat0 ! geographical latitude of lower left grid point
+
+contains
+
+subroutine coordtrafo(nxmin1,nymin1)
+
+ !**********************************************************************
+ ! *
+ ! FLEXPART MODEL SUBROUTINE COORDTRAFO *
+ ! *
+ !**********************************************************************
+ ! *
+ ! AUTHOR: G. WOTAWA *
+ ! DATE: 1994-02-07 *
+ ! LAST UPDATE: 1996-05-18 A. STOHL *
+ ! *
+ !**********************************************************************
+ ! *
+ ! DESCRIPTION: This subroutine transforms x and y coordinates of *
+ ! particle release points to grid coordinates. *
+ ! *
+ !**********************************************************************
+
+ use par_mod
+ use com_mod
+
+ implicit none
+ integer,intent(in) :: &
+ nxmin1, & ! nx-1
+ nymin1 ! ny-1
+ integer :: i,j,k
+ real :: yrspc ! small real number relative to x
+
+ if((ipin.eq.3).or.(ipin.eq.4)) return ! Not necessary when using part_ic.nc
+
+ if(numpoint.eq.0) then
+ write(*,*) ' FLEXPART MODEL SUBROUTINE COORDTRAFO: ERROR ! '
+ write(*,*) ' NO PARTICLE RELEASES ARE DEFINED!'
+ write(*,*) ' CHECK FILE RELEASES...'
+ stop
+ endif
+
+ ! TRANSFORM X- AND Y- COORDINATES OF STARTING POINTS TO GRID COORDINATES
+ !***********************************************************************
+
+ do i=1,numpoint
+ xpoint1(i)=(xpoint1(i)-xlon0)/dx
+ xpoint2(i)=(xpoint2(i)-xlon0)/dx
+ ypoint1(i)=(ypoint1(i)-ylat0)/dy
+ ypoint2(i)=(ypoint2(i)-ylat0)/dy
+ end do
+
+15 continue
+
+
+ ! CHECK IF RELEASE POINTS ARE WITHIN DOMAIN
+ !******************************************
+
+ yrspc = spacing(real(nymin1,kind=sp))
+
+ do i=1,numpoint
+ if (sglobal.and.(ypoint1(i).lt.1.e-6)) ypoint1(i)=1.e-6
+ if (nglobal.and.(ypoint2(i).gt.real(nymin1,kind=dp)-1.e-5)) &
+ ypoint2(i)=real(nymin1,kind=dp)-10*yrspc
+ if ((ypoint1(i).lt.1.e-6).or.(ypoint1(i).ge.real(nymin1,kind=dp)-1.e-6) &
+ .or.(ypoint2(i).lt.1.e-6).or.(ypoint2(i).ge.real(nymin1,kind=dp)-yrspc) &
+ .or.((.not.xglobal).and.((xpoint1(i).lt.1.e-6).or. &
+ (xpoint1(i).ge.real(nxmin1,kind=dp)-1.e-6).or.(xpoint2(i).lt.1.e-6).or. &
+ (xpoint2(i).ge.real(nxmin1,kind=dp)-1.e-6)))) then
+ write(*,*) ' NOTICE: RELEASE POINT OUT OF DOMAIN DETECTED.'
+ write(*,*) ' IT IS REMOVED NOW ... '
+ if (i.le.1000) then
+ write(*,*) ' COMMENT: ',compoint(i)
+ else
+ write(*,*) ' COMMENT: ',compoint(1001)
+ endif
+ if (i.lt.numpoint) then
+ do j=i+1,numpoint
+ xpoint1(j-1)=xpoint1(j)
+ ypoint1(j-1)=ypoint1(j)
+ xpoint2(j-1)=xpoint2(j)
+ ypoint2(j-1)=ypoint2(j)
+ zpoint1(j-1)=zpoint1(j)
+ zpoint2(j-1)=zpoint2(j)
+ npart(j-1)=npart(j)
+ kindz(j-1)=kindz(j)
+ ireleasestart(j-1)=ireleasestart(j)
+ ireleaseend(j-1)=ireleaseend(j)
+ if (j.le.1000) compoint(j-1)=compoint(j)
+ do k=1,nspec
+ xmass(j-1,k)=xmass(j,k)
+ end do
+ end do
+ endif
+
+ numpoint=numpoint-1
+ if (numpoint.gt.0) goto 15
+ endif
+ end do
+
+ if(numpoint.eq.0) then
+ write(*,*) ' FLEXPART MODEL SUBROUTINE COORDTRAFO: ERROR ! '
+ write(*,*) ' NO PARTICLE RELEASES ARE DEFINED!'
+ write(*,*) ' CHECK FILE RELEASES...'
+ stop
+ endif
+end subroutine coordtrafo
+
end module point_mod
diff --git a/src/qvsat.f90 b/src/qvsat_mod.f90
similarity index 69%
rename from src/qvsat.f90
rename to src/qvsat_mod.f90
index ccda690a..d353b941 100644
--- a/src/qvsat.f90
+++ b/src/qvsat_mod.f90
@@ -10,8 +10,16 @@
!###### ######
!##################################################################
!##################################################################
+module qvsat_mod
+
+ implicit none
+ private
+
+ public :: f_qvsat, ew
+
+contains
-function f_qvsat( p, t )
+real function f_qvsat( p, t )
!PURPOSE:
!
@@ -36,8 +44,7 @@ function f_qvsat( p, t )
real :: p ! Pressure (Pascal)
real :: t ! Temperature (K)
- real :: f_qvsat ! Saturation water vapor specific humidity (kg/kg)
- real :: f_esl,f_esi,fespt
+ real :: fespt
real,parameter :: rd = 287.0 ! Gas constant for dry air (m**2/(s**2*K))
real,parameter :: rv = 461.0 ! Gas constant for water vapor (m**2/(s**2*K)).
@@ -64,14 +71,12 @@ function f_qvsat( p, t )
end function f_qvsat
-function f_esl( p, t )
-
+real function f_esl( p, t )
+ ! Saturation water vapor pressure over liquid water
implicit none
real :: p ! Pressure (Pascal)
real :: t ! Temperature (K)
- real :: f_esl ! Saturation water vapor pressure over liquid water
-
real :: f
!#######################################################################
@@ -101,14 +106,12 @@ function f_esl( p, t )
return
end function f_esl
-function f_esi( p, t )
-
+real function f_esi( p, t )
+ ! Saturation water vapor pressure over ice (Pa)
implicit none
real :: p ! Pressure (Pascal)
real :: t ! Temperature (K)
- real :: f_esi ! Saturation water vapor pressure over ice (Pa)
-
real :: f
!#######################################################################
@@ -137,3 +140,59 @@ function f_esi( p, t )
return
end function f_esi
+
+real function ew(x,p)
+
+ !****************************************************************
+ !SAETTIGUNGSDAMPFDRUCK UEBER WASSER IN PA. X IN KELVIN.
+ !NACH DER GOFF-GRATCH-FORMEL.
+ !****************************************************************
+
+ implicit none
+
+ real :: x, y, a, p , c, d
+
+ ew=0.
+ if(x.le.0.) stop 'sorry: t not in [k]'
+ ! Formula of Goff and Gratch (after Murray, 1966)
+ ! if (x.lt.273.15) then
+ ! ! Above ice
+ ! a = 273.15/x
+ ! y = -20.947031*a - 3.56654*log(a) - 2.01889049/a
+ ! ew = 5.75185606E10*exp(y)
+ ! else
+ ! ! Above water
+ ! a = 373.15/x
+ ! y = -18.1972839*a + 5.02808*log(a) - 70242.1852*exp(-26.1205253/a) + &
+ ! 58.0691913*exp(-8.03945282*a)
+ ! ew = 7.95357242E10*exp(y)
+ ! endif
+
+ ! ! Formula of Magnus (after Murray, 1966)
+ ! if (x.lt.273.15) then
+ ! ! Above ice
+ ! ew = 6.1078*exp(21.8745584*(x-273.15)/(x-7.66))
+ ! else
+ ! ! Above water
+ ! ew = 6.1078*exp(17.2693882*(x-273.15)/(x-35.86))
+ ! endif
+
+ ! Formula of Buck 1981
+ ! ew = f_qvsat(p,x)
+
+ ! ! Original
+ y=373.16/x
+ a=-7.90298*(y-1.)
+ a=a+(5.02808*0.43429*alog(y))
+ c=(1.-(1./y))*11.344
+ c=-1.+(10.**c)
+ c=-1.3816*c/(10.**7)
+ d=(1.-y)*3.49149
+ d=-1.+(10.**d)
+ d=8.1328*d/(10.**3)
+ y=a+c+d
+ ew=101324.6*(10.**y) ! Saettigungsdampfdruck in Pa
+
+end function ew
+
+end module qvsat_mod
\ No newline at end of file
diff --git a/src/random_mod.f90 b/src/random_mod.f90
index 01ea7ff3..6082ea61 100644
--- a/src/random_mod.f90
+++ b/src/random_mod.f90
@@ -7,62 +7,102 @@ module random_mod
implicit none
+ integer, parameter :: ran1_ntab=32
+ integer, allocatable :: ran1_iv(:,:), ran1_iy(:)
+
+ integer, allocatable :: gasdev_iset(:)
+ real, allocatable :: gasdev_gset(:)
+
+ integer, allocatable :: ran3_iff(:)
+ integer, allocatable :: ran3_inext(:),ran3_inextp(:)
+ integer, allocatable :: ma(:,:)
+
+ integer, allocatable :: iseed1(:), iseed2(:)
+
contains
- function ran1(idum)
+ subroutine allocate_random(num_threads)
implicit none
- integer :: idum
+ integer :: num_threads, i
+
+ allocate(ran1_iv(ran1_ntab,0:num_threads-1),ran1_iy(0:num_threads-1))
+ allocate(gasdev_iset(0:num_threads-1),gasdev_gset(0:num_threads-1))
+ allocate(ran3_iff(0:num_threads-1),ran3_inext(0:num_threads-1),ran3_inextp(0:num_threads-1))
+ allocate(ma(55,0:num_threads-1))
+ allocate(iseed1(0:num_threads-1),iseed2(0:num_threads-1))
+
+ do i=0,num_threads-1
+ iseed1(i) = -7-i
+ iseed2(i) = -88-i
+ end do
+ ran3_iff(0:num_threads-1)=0
+ ran1_iv(:,0:num_threads-1)=0
+ ran1_iy(0:num_threads-1)=0
+ gasdev_iset(0:num_threads-1)=0
+ gasdev_gset(0:num_threads-1)=0
+ end subroutine allocate_random
+
+ subroutine deallocate_random()
+
+ deallocate(ran1_iv,ran1_iy)
+ deallocate(gasdev_iset,gasdev_gset)
+ deallocate(ran3_iff,ran3_inext,ran3_inextp)
+ deallocate(ma)
+ deallocate(iseed1,iseed2)
+ end subroutine deallocate_random
+
+ function ran1(idum,ithread)
+
+ implicit none
+
+ integer :: idum,ithread
real :: ran1
integer,parameter :: ia=16807, im=2147483647, iq=127773, ir=2836
- integer,parameter :: ntab=32, ndiv=1+(im-1)/ntab
+ integer,parameter :: ndiv=1+(im-1)/ran1_ntab
real,parameter :: am=1./im, eps=1.2e-7, rnmx=1.-eps
integer :: j, k
- integer :: iv(ntab) = (/ (0,j=1,ntab) /)
- integer :: iy=0
- if (idum.le.0.or.iy.eq.0) then
+ if (idum.le.0.or.ran1_iy(ithread).eq.0) then
idum=max(-idum,1)
- do j=ntab+8,1,-1
+ do j=ran1_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
+ if (j.le.ran1_ntab) ran1_iv(j,ithread)=idum
enddo
- iy=iv(1)
+ ran1_iy(ithread)=ran1_iv(1,ithread)
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)
+ j=1+ran1_iy(ithread)/ndiv
+ ran1_iy(ithread)=ran1_iv(j,ithread)
+ ran1_iv(j,ithread)=idum
+ ran1=min(am*ran1_iy(ithread),rnmx)
end function ran1
- function gasdev(idum)
+ function gasdev(idum,ithread)
implicit none
- integer :: idum
+ integer :: idum,ithread
real :: gasdev, fac, r, v1, v2
- integer :: iset = 0
- real :: gset = 0.
-
- if (iset.eq.0) then
-1 v1=2.*ran3(idum)-1.
- v2=2.*ran3(idum)-1.
+
+ if (gasdev_iset(ithread).eq.0) then
+1 v1=2.*ran3(idum,ithread)-1.
+ v2=2.*ran3(idum,ithread)-1.
r=v1**2+v2**2
if(r.ge.1.0 .or. r.eq.0.0) go to 1
fac=sqrt(-2.*log(r)/r)
- gset=v1*fac
+ gasdev_gset(ithread)=v1*fac
gasdev=v2*fac
- iset=1
+ gasdev_iset(ithread)=1
else
- gasdev=gset
- iset=0
+ gasdev=gasdev_gset(ithread)
+ gasdev_iset(ithread)=0
endif
end function gasdev
@@ -74,8 +114,8 @@ contains
integer :: idum
real :: random1, random2, fac, v1, v2, r
-1 v1=2.*ran3(idum)-1.
- v2=2.*ran3(idum)-1.
+1 v1=2.*ran3(idum,0)-1.
+ v2=2.*ran3(idum,0)-1.
r=v1**2+v2**2
if(r.ge.1.0 .or. r.eq.0.0) go to 1
fac=sqrt(-2.*log(r)/r)
@@ -90,51 +130,48 @@ contains
end subroutine gasdev1
- function ran3(idum)
+ function ran3(idum,ithread)
implicit none
- integer :: idum
+ integer :: idum,ithread
real :: ran3
integer,parameter :: mbig=1000000000, mseed=161803398, mz=0
real,parameter :: fac=1./mbig
integer :: i,ii,inext,inextp,k
- integer :: mj,mk,ma(55)
-
- save inext,inextp,ma
- integer :: iff = 0
+ integer :: mj,mk
- if(idum.lt.0.or.iff.eq.0)then
- iff=1
+ if(idum.lt.0 .or. ran3_iff(ithread).eq.0)then
+ ran3_iff(ithread)=1
mj=mseed-iabs(idum)
mj=mod(mj,mbig)
- ma(55)=mj
+ ma(55,ithread)=mj
mk=1
do i=1,54
ii=mod(21*i,55)
- ma(ii)=mk
+ ma(ii,ithread)=mk
mk=mj-mk
if(mk.lt.mz)mk=mk+mbig
- mj=ma(ii)
+ mj=ma(ii,ithread)
end do
do k=1,4
do i=1,55
- ma(i)=ma(i)-ma(1+mod(i+30,55))
- if(ma(i).lt.mz)ma(i)=ma(i)+mbig
+ ma(i,ithread)=ma(i,ithread)-ma(1+mod(i+30,55),ithread)
+ if(ma(i,ithread).lt.mz) ma(i,ithread)=ma(i,ithread)+mbig
end do
end do
- inext=0
- inextp=31
+ ran3_inext(ithread)=0
+ ran3_inextp(ithread)=31
idum=1
endif
- inext=inext+1
- if(inext.eq.56)inext=1
- inextp=inextp+1
- if(inextp.eq.56)inextp=1
- mj=ma(inext)-ma(inextp)
+ ran3_inext(ithread)=ran3_inext(ithread)+1
+ if(ran3_inext(ithread).eq.56) ran3_inext(ithread)=1
+ ran3_inextp(ithread)=ran3_inextp(ithread)+1
+ if(ran3_inextp(ithread).eq.56) ran3_inextp(ithread)=1
+ mj=ma(ran3_inext(ithread),ithread)-ma(ran3_inextp(ithread),ithread)
if(mj.lt.mz)mj=mj+mbig
- ma(inext)=mj
+ ma(ran3_inext(ithread),ithread)=mj
ran3=mj*fac
end function ran3
! (C) Copr. 1986-92 Numerical Recipes Software US.
diff --git a/src/readoptions_mod.f90 b/src/readoptions_mod.f90
new file mode 100644
index 00000000..4d44a486
--- /dev/null
+++ b/src/readoptions_mod.f90
@@ -0,0 +1,3334 @@
+! SPDX-FileCopyrightText: FLEXPART 1998-2019, see flexpart_license.txt
+! SPDX-License-Identifier: GPL-3.0-or-later
+
+!*****************************************************************************
+! *
+! L. Bakels 2022: This module contains all subroutines for *
+! reading option files *
+! *
+!*****************************************************************************
+
+module readoptions_mod
+ use par_mod
+ use com_mod
+ use date_mod
+ use point_mod
+ use windfields_mod
+
+ implicit none
+
+contains
+
+subroutine readageclasses
+
+ !*****************************************************************************
+ ! *
+ ! This routine reads the age classes to be used for the current model *
+ ! run. *
+ ! *
+ ! Author: A. Stohl *
+ ! 20 March 2000 *
+ ! HSO, 1 July 2014 *
+ ! Added optional namelist input *
+ ! *
+ !*****************************************************************************
+ ! *
+ ! Variables: *
+ ! *
+ ! Constants: *
+ ! *
+ !*****************************************************************************
+
+ implicit none
+
+ integer :: i
+
+ ! namelist help variables
+ integer :: readerror
+
+ ! namelist declaration
+ namelist /ageclass/ &
+ nageclass, &
+ lage
+
+ nageclass=-1 ! preset to negative value to identify failed namelist input
+
+ ! If age spectra calculation is switched off, set number of age classes
+ ! to 1 and maximum age to a large number
+ !**********************************************************************
+
+ if (lagespectra.ne.1) then
+ nageclass=1
+ lage(nageclass)=999999999
+ return
+ endif
+
+ ! If age spectra claculation is switched on,
+ ! open the AGECLASSSES file and read user options
+ !************************************************
+
+ open(unitageclasses,file=path(1)(1:length(1))//'AGECLASSES',form='formatted',status='old',err=999)
+
+ ! try to read in as a namelist
+ read(unitageclasses,ageclass,iostat=readerror)
+ close(unitageclasses)
+
+ if ((nageclass.lt.0).or.(readerror.ne.0)) then
+ open(unitageclasses,file=path(1)(1:length(1))//'AGECLASSES',status='old',err=999)
+ do i=1,13
+ read(unitageclasses,*)
+ end do
+ read(unitageclasses,*) nageclass
+ read(unitageclasses,*) lage(1)
+ if (nageclass.ge.2) then
+ do i=2,nageclass
+ read(unitageclasses,*) lage(i)
+ end do
+ endif
+ close(unitageclasses)
+ endif
+
+ ! write ageclasses file in namelist format to output directory if requested
+ if (nmlout.and.lroot) then
+ open(unitageclasses,file=path(2)(1:length(2))//'AGECLASSES.namelist',err=1000)
+ write(unitageclasses,nml=ageclass)
+ close(unitageclasses)
+ endif
+
+ if (nageclass.gt.maxageclass) then
+ write(*,*) ' #### FLEXPART MODEL ERROR! NUMBER OF AGE #### '
+ write(*,*) ' #### CLASSES GREATER THAN MAXIMUM ALLOWED. #### '
+ write(*,*) ' #### CHANGE SETTINGS IN FILE AGECLASSES OR #### '
+ write(*,*) ' #### RECOMPILE WITH LARGER MAXAGECLASS IN #### '
+ write(*,*) ' #### FILE PAR_MOD. #### '
+ stop
+ endif
+
+ if (lage(1).le.0) then
+ write(*,*) ' #### FLEXPART MODEL ERROR! AGE OF FIRST #### '
+ write(*,*) ' #### CLASS MUST BE GREATER THAN ZERO. CHANGE #### '
+ write(*,*) ' #### SETTINGS IN FILE AGECLASSES. #### '
+ stop
+ endif
+
+ do i=2,nageclass
+ if (lage(i).le.lage(i-1)) then
+ write(*,*) ' #### FLEXPART MODEL ERROR! AGE CLASSES #### '
+ write(*,*) ' #### MUST BE GIVEN IN TEMPORAL ORDER. #### '
+ write(*,*) ' #### CHANGE SETTINGS IN FILE AGECLASSES. #### '
+ stop
+ endif
+ end do
+
+ return
+
+999 write(*,*) ' #### FLEXPART MODEL ERROR! FILE "AGECLASSES" #### '
+ write(*,*) ' #### CANNOT BE OPENED IN THE DIRECTORY #### '
+ write(*,'(a)') path(1)(1:length(1))
+ stop
+
+1000 write(*,*) ' #### FLEXPART MODEL ERROR! FILE "AGECLASSES" #### '
+ write(*,*) ' #### CANNOT BE OPENED IN THE DIRECTORY #### '
+ write(*,'(a)') path(2)(1:length(2))
+ stop
+end subroutine readageclasses
+
+subroutine readavailable
+
+ !*****************************************************************************
+ ! *
+ ! This routine reads the dates and times for which windfields are *
+ ! available. *
+ ! *
+ ! Authors: A. Stohl *
+ ! *
+ ! 6 February 1994 *
+ ! 8 February 1999, Use of nested fields, A. Stohl *
+ ! *
+ !*****************************************************************************
+ ! *
+ ! Variables: *
+ ! bdate beginning date as Julian date *
+ ! beg beginning date for windfields *
+ ! endl ending date for windfields *
+ ! fname filename of wind field, help variable *
+ ! ideltas [s] duration of modelling period *
+ ! idiff time difference between 2 wind fields *
+ ! idiffnorm normal time difference between 2 wind fields *
+ ! idiffmax [s] maximum allowable time between 2 wind fields *
+ ! jul julian date, help variable *
+ ! numbwf actual number of wind fields *
+ ! wfname(maxwf) file names of needed wind fields *
+ ! wfspec(maxwf) file specifications of wind fields (e.g., if on disc) *
+ ! wftime(maxwf) [s]times of wind fields relative to beginning time *
+ ! wfname1,wfspec1,wftime1 = same as above, but only local (help variables) *
+ ! *
+ ! Constants: *
+ ! maxwf maximum number of wind fields *
+ ! unitavailab unit connected to file AVAILABLE *
+ ! *
+ !*****************************************************************************
+
+ implicit none
+
+ integer :: i,idiff,ldat,ltim,wftime1(maxwf),numbwfn(maxnests),k
+ integer :: wftime1n(maxnests,maxwf),wftimen(maxnests,maxwf)
+ logical :: lwarntd=.true.
+ real(kind=dp) :: jul,beg,endl
+ character(len=255) :: fname,spec,wfname1(maxwf),wfspec1(maxwf)
+ character(len=255) :: wfname1n(maxnests,maxwf)
+ character(len=40) :: wfspec1n(maxnests,maxwf)
+
+
+ ! Windfields are only used, if they are within the modelling period.
+ ! However, 1 additional day at the beginning and at the end is used for
+ ! interpolation. -> Compute beginning and ending date for the windfields.
+ !************************************************************************
+
+ if (ideltas.gt.0) then ! forward trajectories
+ beg=bdate-1._dp
+ endl=bdate+real(ideltas,kind=dp)/86400._dp+real(idiffmax,kind=dp)/ &
+ 86400._dp
+ else ! backward trajectories
+ beg=bdate+real(ideltas,kind=dp)/86400._dp-real(idiffmax,kind=dp)/ &
+ 86400._dp
+ endl=bdate+1._dp
+ endif
+
+ ! Open the wind field availability file and read available wind fields
+ ! within the modelling period.
+ !*********************************************************************
+
+ open(unitavailab,file=path(4)(1:length(4)),status='old', &
+ err=999)
+
+ do i=1,3
+ read(unitavailab,*)
+ end do
+
+ numbwf=0
+100 read(unitavailab,'(i8,1x,i6,2(6x,a255))',end=99) &
+ ldat,ltim,fname,spec
+ jul=juldate(ldat,ltim)
+ if ((jul.ge.beg).and.(jul.le.endl)) then
+ numbwf=numbwf+1
+ if (numbwf.gt.maxwf) then ! check exceedance of dimension
+ write(*,*) 'Number of wind fields needed is too great.'
+ write(*,*) 'Reduce modelling period (file "COMMAND") or'
+ write(*,*) 'reduce number of wind fields (file "AVAILABLE").'
+ stop
+ endif
+
+ wfname1(numbwf)=fname(1:index(fname,' '))
+ wfspec1(numbwf)=spec
+ wftime1(numbwf)=nint((jul-bdate)*86400._dp)
+ endif
+ goto 100 ! next wind field
+
+99 continue
+
+ close(unitavailab)
+
+ ! Open the wind field availability file and read available wind fields
+ ! within the modelling period (nested grids)
+ !*********************************************************************
+
+ do k=1,numbnests
+ !print*,length(numpath+2*(k-1)+1),length(numpath+2*(k-1)+2),length(4),length(3)
+ !print*,path(numpath+2*(k-1)+2)(1:length(numpath+2*(k-1)+2))
+ open(unitavailab,file=path(numpath+2*(k-1)+2) &
+ (1:length(numpath+2*(k-1)+2)),status='old',err=998)
+
+ do i=1,3
+ read(unitavailab,*)
+ end do
+
+ numbwfn(k)=0
+700 read(unitavailab,'(i8,1x,i6,2(6x,a255))',end=699) ldat, &
+ ltim,fname,spec
+ jul=juldate(ldat,ltim)
+ if ((jul.ge.beg).and.(jul.le.endl)) then
+ numbwfn(k)=numbwfn(k)+1
+ if (numbwfn(k).gt.maxwf) then ! check exceedance of dimension
+ write(*,*) 'Number of nested wind fields is too great.'
+ write(*,*) 'Reduce modelling period (file "COMMAND") or'
+ write(*,*) 'reduce number of wind fields (file "AVAILABLE").'
+ stop
+ endif
+
+ wfname1n(k,numbwfn(k))=fname
+ wfspec1n(k,numbwfn(k))=spec
+ wftime1n(k,numbwfn(k))=nint((jul-bdate)*86400._dp)
+ endif
+ goto 700 ! next wind field
+
+699 continue
+
+ close(unitavailab)
+ end do
+
+
+ ! Check wind field times of file AVAILABLE (expected to be in temporal order)
+ !****************************************************************************
+
+ if (numbwf.eq.0) then
+ write(*,*) ' #### FLEXPART MODEL ERROR! NO WIND FIELDS #### '
+ write(*,*) ' #### AVAILABLE FOR SELECTED TIME PERIOD. #### '
+ stop
+ endif
+
+ do i=2,numbwf
+ if (wftime1(i).le.wftime1(i-1)) then
+ write(*,*) 'FLEXPART ERROR: FILE AVAILABLE IS CORRUPT.'
+ write(*,*) 'THE WIND FIELDS ARE NOT IN TEMPORAL ORDER.'
+ write(*,*) 'PLEASE CHECK FIELD ',wfname1(i)
+ stop
+ endif
+ end do
+
+ ! Check wind field times of file AVAILABLE for the nested fields
+ ! (expected to be in temporal order)
+ !***************************************************************
+
+ do k=1,numbnests
+ if (numbwfn(k).eq.0) then
+ write(*,*) '#### FLEXPART MODEL ERROR! NO WIND FIELDS ####'
+ write(*,*) '#### AVAILABLE FOR SELECTED TIME PERIOD. ####'
+ stop
+ endif
+
+ do i=2,numbwfn(k)
+ if (wftime1n(k,i).le.wftime1n(k,i-1)) then
+ write(*,*) 'FLEXPART ERROR: FILE AVAILABLE IS CORRUPT. '
+ write(*,*) 'THE NESTED WIND FIELDS ARE NOT IN TEMPORAL ORDER.'
+ write(*,*) 'PLEASE CHECK FIELD ',wfname1n(k,i)
+ write(*,*) 'AT NESTING LEVEL ',k
+ stop
+ endif
+ end do
+
+ end do
+
+
+ ! For backward trajectories, reverse the order of the windfields
+ !***************************************************************
+
+ if (ideltas.ge.0) then
+ do i=1,numbwf
+ wfname(i)=wfname1(i)
+ wfspec(i)=wfspec1(i)
+ wftime(i)=wftime1(i)
+ end do
+ do k=1,numbnests
+ do i=1,numbwfn(k)
+ wfnamen(k,i)=wfname1n(k,i)
+ wfspecn(k,i)=wfspec1n(k,i)
+ wftimen(k,i)=wftime1n(k,i)
+ end do
+ end do
+ else
+ do i=1,numbwf
+ wfname(numbwf-i+1)=wfname1(i)
+ wfspec(numbwf-i+1)=wfspec1(i)
+ wftime(numbwf-i+1)=wftime1(i)
+ end do
+ do k=1,numbnests
+ do i=1,numbwfn(k)
+ wfnamen(k,numbwfn(k)-i+1)=wfname1n(k,i)
+ wfspecn(k,numbwfn(k)-i+1)=wfspec1n(k,i)
+ wftimen(k,numbwfn(k)-i+1)=wftime1n(k,i)
+ end do
+ end do
+ endif
+
+ ! Check the time difference between the wind fields. If it is big,
+ ! write a warning message. If it is too big, terminate the trajectory.
+ !*********************************************************************
+
+ do i=2,numbwf
+ idiff=abs(wftime(i)-wftime(i-1))
+ if (idiff.gt.idiffmax.and.lroot) then
+ write(*,*) 'FLEXPART WARNING: TIME DIFFERENCE BETWEEN TWO'
+ write(*,*) 'WIND FIELDS IS TOO BIG FOR TRANSPORT CALCULATION.&
+ &'
+ write(*,*) 'THEREFORE, TRAJECTORIES HAVE TO BE SKIPPED.'
+ else if (idiff.gt.idiffnorm.and.lroot.and.lwarntd) then
+ write(*,*) 'FLEXPART WARNING: TIME DIFFERENCE BETWEEN TWO'
+ write(*,*) 'WIND FIELDS IS BIG. THIS MAY CAUSE A DEGRADATION'
+ write(*,*) 'OF SIMULATION QUALITY.'
+ lwarntd=.false. ! only issue this warning once
+ endif
+ end do
+
+ do k=1,numbnests
+ if (numbwfn(k).ne.numbwf) then
+ write(*,*) 'FLEXPART ERROR: THE AVAILABLE FILES FOR THE'
+ write(*,*) 'NESTED WIND FIELDS ARE NOT CONSISTENT WITH'
+ write(*,*) 'THE AVAILABLE FILE OF THE MOTHER DOMAIN. '
+ write(*,*) 'ERROR AT NEST LEVEL: ',k
+ stop
+ endif
+ do i=1,numbwf
+ if (wftimen(k,i).ne.wftime(i)) then
+ write(*,*) 'FLEXPART ERROR: THE AVAILABLE FILES FOR THE'
+ write(*,*) 'NESTED WIND FIELDS ARE NOT CONSISTENT WITH'
+ write(*,*) 'THE AVAILABLE FILE OF THE MOTHER DOMAIN. '
+ write(*,*) 'ERROR AT NEST LEVEL: ',k
+ stop
+ endif
+ end do
+ end do
+
+ ! Reset the times of the wind fields that are kept in memory to no time
+ !**********************************************************************
+
+ do i=1,2
+ memind(i)=i
+ memtime(i)=999999999
+ end do
+
+ return
+
+998 write(*,*) ' #### FLEXPART MODEL ERROR! AVAILABLE FILE #### '
+ write(*,'(a)') ' '//path(numpath+2*(k-1)+2) &
+ (1:length(numpath+2*(k-1)+2))
+ write(*,*) ' #### CANNOT BE OPENED #### '
+ stop
+
+999 write(*,*) ' #### FLEXPART MODEL ERROR! AVAILABLE FILE #### '
+ write(*,'(a)') ' '//path(4)(1:length(4))
+ write(*,*) ' #### CANNOT BE OPENED #### '
+ stop
+end subroutine readavailable
+
+subroutine readcommand
+
+ !*****************************************************************************
+ ! *
+ ! This routine reads the user specifications for the current model run. *
+ ! *
+ ! Author: A. Stohl *
+ ! *
+ ! 18 May 1996 *
+ ! HSO, 1 July 2014 *
+ ! Added optional namelist input *
+ ! *
+ !*****************************************************************************
+ ! *
+ ! Variables: *
+ ! bdate beginning date as Julian date *
+ ! ctl factor by which time step must be smaller than *
+ ! Lagrangian time scale *
+ ! ibdate,ibtime beginnning date and time (YYYYMMDD, HHMISS) *
+ ! ideltas [s] modelling period *
+ ! iedate,ietime ending date and time (YYYYMMDD, HHMISS) *
+ ! ifine reduction factor for vertical wind time step *
+ ! outputforeachrel for forward runs it is possible either to create *
+ ! one outputfield or several for each releasepoint *
+ ! iflux switch to turn on (1)/off (0) flux calculations *
+ ! iout 1 for conc. (residence time for backward runs) output,*
+ ! 2 for mixing ratio output, 3 both, 4 for plume *
+ ! trajectory output, 5 = options 1 and 4 *
+ ! ipin 1 continue simulation with restart.bin file, *
+ ! 2 continue simulaion with dumped particle data, 0 no *
+ ! 3 use self-defined initial conditions in netcdf *
+ ! 4 initial run using option 3, restart from restart.bin*
+ ! ipout 0 no particle dump, 1 every output time, 3 only at end*
+ ! ipoutfac increase particle dump interval by factor (default 1) *
+ ! loutaver [s] concentration output is an average over loutaver *
+ ! seconds *
+ ! loutsample [s] average is computed from samples taken every [s] *
+ ! seconds *
+ ! loutstep [s] time interval of concentration output *
+ ! lsynctime [s] synchronisation time interval for all particles *
+ ! lagespectra switch to turn on (1)/off (0) calculation of age *
+ ! spectra *
+ ! lconvection value of either 0 and 1 indicating mixing by *
+ ! convection *
+ ! = 0 .. no convection *
+ ! + 1 .. parameterisation of mixing by subgrid-scale *
+ ! convection = on *
+ ! lsubgrid switch to turn on (1)/off (0) subgrid topography *
+ ! parameterization *
+ ! method method used to compute the particle pseudovelocities *
+ ! mdomainfill 1 use domain-filling option, 0 not, 2 use strat. O3 *
+ ! *
+ ! Constants: *
+ ! unitcommand unit connected to file COMMAND *
+ ! *
+ !*****************************************************************************
+
+ implicit none
+
+ character(len=50) :: line
+ logical :: old
+ integer :: readerror
+
+ namelist /command/ &
+ ldirect, &
+ ibdate,ibtime, &
+ iedate,ietime, &
+ loutstep, &
+ loutaver, &
+ loutsample, &
+ loutrestart, &
+ lsynctime, &
+ ctl, &
+ ifine, &
+ iout, &
+ ipout, &
+ ipoutfac, &
+ lsubgrid, &
+ lconvection, &
+ lagespectra, &
+ ipin, &
+ ioutputforeachrelease, &
+ iflux, &
+ mdomainfill, &
+ ind_source, &
+ ind_receptor, &
+ mquasilag, &
+ nested_output, &
+ linit_cond, &
+ lnetcdfout, &
+ surf_only, &
+ cblflag, &
+ linversionout, &
+ ohfields_path, &
+ d_trop, &
+ d_strat, &
+ nxshift
+
+ ! Presetting namelist command
+ ldirect=0
+ ibdate=20000101
+ ibtime=0
+ iedate=20000102
+ ietime=0
+ loutstep=10800
+ loutaver=10800
+ loutsample=900
+ loutrestart=-1
+ lsynctime=900
+ ctl=-5.0
+ ifine=4
+ iout=3
+ ipout=0
+ ipoutfac=1
+ lsubgrid=1
+ lconvection=1
+ lagespectra=0
+ ipin=0
+ ioutputforeachrelease=1
+ iflux=1
+ mdomainfill=0
+ ind_source=1
+ ind_receptor=1
+ mquasilag=0
+ nested_output=0
+ linit_cond=0
+ lnetcdfout=0
+ surf_only=0
+ cblflag=0 ! if using old-style COMMAND file, set to 1 here to use mc cbl routine
+ linversionout=0
+ ohfields_path="../../flexin/"
+ nxshift=-9999
+
+ !Af set release-switch
+ WETBKDEP=.false.
+ DRYBKDEP=.false.
+
+ ! Open the command file and read user options
+ ! Namelist input first: try to read as namelist file
+ !**************************************************************************
+ open(unitcommand,file=path(1)(1:length(1))//'COMMAND',status='old',form='formatted',err=999)
+
+ ! try namelist input (default)
+ read(unitcommand,command,iostat=readerror)
+ if (readerror.ne.0) then
+ backspace(unitcommand)
+ read(unitcommand,fmt='(A)') line
+ if (lroot) write(*,*) &
+ 'Invalid line in COMMAND reads: '//trim(line)
+ end if
+
+ close(unitcommand)
+
+ ! distinguish namelist from fixed text input
+ if ((readerror.ne.0).or.(ldirect.eq.0)) then ! parse as text file format
+ if (lroot) write(*,*) 'COMMAND either having unrecognised entries, &
+ &or in old format, please update to namelist format.'
+ stop
+ endif ! input format
+
+ ! write command file in namelist format to output directory if requested
+ if (nmlout.and.lroot) then
+ open(unitcommand,file=path(2)(1:length(2))//'COMMAND.namelist',err=1000)
+ write(unitcommand,nml=command)
+ close(unitcommand)
+ endif
+
+ ifine=max(ifine,1)
+
+ ! Determine how Markov chain is formulated (for w or for w/sigw)
+ !***************************************************************
+ if (cblflag.eq.1) then !---- added by mc to properly set parameters for CBL simulations
+ turbswitch=.true.
+ if (lsynctime>maxtl) lsynctime=maxtl !maxtl defined in com_mod.f90
+ if (ctl.lt.5) then
+ print *,'WARNING: CBL flag active the ratio of TLu/dt has been set to 5'
+ ctl=5.
+ end if
+ if (ifine*ctl.lt.50) then
+ ifine=int(50./ctl)+1
+
+ print *,'WARNING: CBL flag active the ratio of TLW/dt was < 50, ifine has been re-set to',ifine
+ !pause
+ endif
+ print *,'WARNING: CBL flag active the ratio of TLW/dt is ',ctl*ifine
+ print *,'WARNING: CBL flag active lsynctime is ',lsynctime
+ else !added by mc
+ if (ctl.ge.0.1) then
+ turbswitch=.true.
+ else
+ turbswitch=.false.
+ ifine=1
+ endif
+ endif !added by mc
+ fine=1./real(ifine)
+ ctl=1./ctl
+
+ ! Set the switches required for the various options for input/output units
+ !*************************************************************************
+ !AF Set the switches IND_REL and IND_SAMP for the release and sampling
+ !Af switches for the releasefile:
+ !Af IND_REL = 1 : xmass * rho
+ !Af IND_REL = 0 : xmass * 1
+
+ !Af switches for the conccalcfile:
+ !AF IND_SAMP = 0 : xmass * 1
+ !Af IND_SAMP = -1 : xmass / rho
+
+ !AF IND_SOURCE switches between different units for concentrations at the source
+ !Af NOTE that in backward simulations the release of computational particles
+ !Af takes place at the "receptor" and the sampling of particles at the "source".
+ !Af 1 = mass units
+ !Af 2 = mass mixing ratio units
+ !Af IND_RECEPTOR switches between different units for concentrations at the receptor
+ ! 0 = no receptors
+ !Af 1 = mass units
+ !Af 2 = mass mixing ratio units
+ ! 3 = wet deposition in outputfield
+ ! 4 = dry deposition in outputfield
+
+ if ( ldirect .eq. 1 ) then ! FWD-Run
+ !Af set release-switch
+ if (ind_source .eq. 1 ) then !mass
+ ind_rel = 0
+ else ! mass mix
+ ind_rel = 1
+ endif
+ !Af set sampling switch
+ if (ind_receptor .le. 1) then !mass
+ ind_samp = 0
+ else ! mass mix
+ ind_samp = -1
+ endif
+ elseif (ldirect .eq. -1 ) then !BWD-Run
+ !Af set sampling switch
+ if (ind_source .eq. 1 ) then !mass
+ ind_samp = -1
+ else ! mass mix
+ ind_samp = 0
+ endif
+ select case (ind_receptor)
+ case (1) ! 1 .. concentration at receptor
+ ind_rel = 1
+ case (2) ! 2 .. mixing ratio at receptor
+ ind_rel = 0
+ case (3) ! 3 .. wet deposition in outputfield
+ ind_rel = 3
+ if (lroot) then
+ write(*,*) ' #### FLEXPART WET DEPOSITION BACKWARD MODE #### '
+ write(*,*) ' #### Releaseheight is forced to 0 - 20km #### '
+ write(*,*) ' #### Release is performed above ground lev #### '
+ end if
+ WETBKDEP=.true.
+ !allocate(xscav_frac1(maxpart,maxspec))
+ case (4) ! 4 .. dry deposition in outputfield
+ ind_rel = 4
+ if (lroot) then
+ write(*,*) ' #### FLEXPART DRY DEPOSITION BACKWARD MODE #### '
+ write(*,*) ' #### Releaseheight is forced to 0 - 2*href #### '
+ write(*,*) ' #### Release is performed above ground lev #### '
+ end if
+ DRYBKDEP=.true.
+ !allocate(xscav_frac1(maxpart,maxspec))
+ end select
+ endif
+
+ !*************************************************************
+ ! Check whether valid options have been chosen in file COMMAND
+ !*************************************************************
+
+ ! Check options for initial condition output: Switch off for forward runs
+ !************************************************************************
+
+ if (ldirect.eq.1) linit_cond=0
+ if ((linit_cond.lt.0).or.(linit_cond.gt.2)) then
+ write(*,*) ' #### FLEXPART MODEL ERROR! INVALID OPTION #### '
+ write(*,*) ' #### FOR LINIT_COND IN FILE "COMMAND". #### '
+ stop
+ endif
+
+ ! Check input dates
+ !******************
+
+ if (iedate.lt.ibdate) then
+ write(*,*) ' #### FLEXPART MODEL ERROR! BEGINNING DATE #### '
+ write(*,*) ' #### IS LARGER THAN ENDING DATE. CHANGE #### '
+ write(*,*) ' #### EITHER POINT 2 OR POINT 3 IN FILE #### '
+ write(*,*) ' #### "COMMAND". #### '
+ stop
+ else if (iedate.eq.ibdate) then
+ if (ietime.lt.ibtime) then
+ write(*,*) ' #### FLEXPART MODEL ERROR! BEGINNING TIME #### '
+ write(*,*) ' #### IS LARGER THAN ENDING TIME. CHANGE #### '
+ write(*,*) ' #### EITHER POINT 2 OR POINT 3 IN FILE #### '
+ write(*,*) ' #### "COMMAND". #### '
+ stop
+ endif
+ endif
+
+#ifndef USE_NCF
+ if ((loutrestart.ne.-1).or.(ipin.ne.0)) then
+ write(*,*) ' WARNING: restart option set with intervals'
+ write(*,*) ' LOUTRESTART', loutrestart
+ write(*,*) ' not possible when using binary gridded output'
+ write(*,*) ' ==> RESTART FUNCTION SWITCHED OFF!'
+ endif
+ if (ipin.ne.0) then
+ write(*,*) ' ERROR: restart option not possible using binary'
+ write(*,*) ' output.'
+ write(*,*) ' Please only use IPIN>0 when compiling and running using'
+ write(*,*) ' netcdf output. '
+ endif
+#else
+ if ((surf_only.eq.1).or.(linversionout.eq.1)) then
+ write(*,*) ' ERROR: NetCDF output for surface only or for inversions'
+ write(*,*) ' is not yet implemented. Please compile without NetCDF.'
+ stop
+ endif
+#endif
+
+ ! Determine kind of dispersion method
+ !************************************
+
+ if (ctl.gt.0.) then
+ method=1
+ mintime=minstep
+ else
+ method=0
+ mintime=lsynctime
+ endif
+
+ ! Check for netcdf output switch
+ !*******************************
+#ifdef USE_NCF
+ lnetcdfout = 1
+#endif
+ if (iout.ge.8) then
+ lnetcdfout = 1
+ iout = iout - 8
+#ifndef USE_NCF
+ write(*,*) 'ERROR: netcdf output not activated during compile time but used in COMMAND file!'
+ write(*,*) 'Please recompile with netcdf library (`make [...] ncf=yes`) or use standard output format.'
+ stop
+#endif
+ endif
+#ifndef USE_NCF
+ if (ipout.ne.0) then
+ write(*,*) 'ERROR: NETCDF missing! Please recompile with the netcdf'
+ write(*,*) 'library if you want the particle dump or set IPOUT=0.'
+ stop
+ endif
+#endif
+
+ ! Check whether a valid option for gridded model output has been chosen
+ !**********************************************************************
+
+ if (iout.eq.0) then
+ write(*,*) 'WARNING: IOUT set to zero, no gridded information will be written to file'
+ else if ((iout.lt.0).or.(iout.gt.5)) then
+ write(*,*) ' #### FLEXPART MODEL ERROR! FILE COMMAND: #### '
+ write(*,*) ' #### IOUT MUST BE 1, 2, 3, 4 OR 5 FOR #### '
+ write(*,*) ' #### STANDARD FLEXPART OUTPUT OR 9 - 13 #### '
+ write(*,*) ' #### FOR NETCDF OUTPUT #### '
+ stop
+ endif
+
+ !AF check consistency between units and volume mixing ratio
+ if ( ((iout.eq.2).or.(iout.eq.3)).and. &
+ (ind_source.gt.1 .or.ind_receptor.gt.1) ) then
+ write(*,*) ' #### FLEXPART MODEL ERROR! FILE COMMAND: #### '
+ write(*,*) ' #### VOLUME MIXING RATIO ONLY SUPPORTED #### '
+ write(*,*) ' #### FOR MASS UNITS (at the moment) #### '
+ stop
+ endif
+
+
+ ! For quasilag output for each release is forbidden
+ !*****************************************************************************
+
+ if ((ioutputforeachrelease.eq.1).and.(mquasilag.eq.1)) then
+ write(*,*) '#### FLEXPART MODEL ERROR! FILE COMMAND: ####'
+ write(*,*) '#### OUTPUTFOREACHRELEASE AND QUASILAGRANGIAN####'
+ write(*,*) '#### MODE IS NOT POSSIBLE ! ####'
+ stop
+ endif
+
+
+ ! For quasilag backward is forbidden
+ !*****************************************************************************
+
+ if ((ldirect.lt.0).and.(mquasilag.eq.1)) then
+ write(*,*) '#### FLEXPART MODEL ERROR! FILE COMMAND: ####'
+ write(*,*) '#### FOR BACKWARD RUNS, QUASILAGRANGIAN MODE ####'
+ write(*,*) '#### IS NOT POSSIBLE ! ####'
+ stop
+ endif
+
+
+ ! For backward runs one releasefield for all releases makes no sense,
+ ! For quasilag and domainfill ioutputforechrelease is forbidden
+ !*****************************************************************************
+
+ if ((ldirect.lt.0).and.(ioutputforeachrelease.eq.0)) then
+ write(*,*) '#### FLEXPART MODEL ERROR! FILE COMMAND: ####'
+ write(*,*) '#### FOR BACKWARD RUNS, IOUTPUTFOREACHRLEASE ####'
+ write(*,*) '#### MUST BE SET TO ONE! ####'
+ stop
+ endif
+
+
+ ! For backward runs one releasefield for all releases makes no sense,
+ ! and is "forbidden"
+ !*****************************************************************************
+
+ if ((mdomainfill.eq.1).and.(ioutputforeachrelease.eq.1)) then
+ write(*,*) '#### FLEXPART MODEL ERROR! FILE COMMAND: ####'
+ write(*,*) '#### FOR DOMAIN FILLING RUNS OUTPUT FOR ####'
+ write(*,*) '#### EACH RELEASE IS FORBIDDEN ! ####'
+ stop
+ endif
+
+ ! Inversion output format only for backward runs
+ !*****************************************************************************
+
+ if ((linversionout.eq.1).and.(ldirect.eq.1)) then
+ write(*,*) '#### FLEXPART MODEL ERROR! FILE COMMAND: ####'
+ write(*,*) '#### INVERSION OUTPUT FORMAT ONLY FOR ####'
+ write(*,*) '#### BACKWARD RUNS ####'
+ stop
+ endif
+
+
+ ! For domain-filling trajectories, a plume centroid trajectory makes no sense,
+ ! For backward runs, only residence time output (iout=1) or plume trajectories (iout=4),
+ ! or both (iout=5) makes sense; other output options are "forbidden"
+ !*****************************************************************************
+
+ if (ldirect.lt.0) then
+ if ((iout.eq.2).or.(iout.eq.3)) then
+ write(*,*) '#### FLEXPART MODEL ERROR! FILE COMMAND: ####'
+ write(*,*) '#### FOR BACKWARD RUNS, IOUT MUST BE 1,4,OR 5####'
+ stop
+ endif
+ endif
+
+
+ ! For domain-filling trajectories, a plume centroid trajectory makes no sense,
+ ! and is "forbidden"
+ !*****************************************************************************
+
+ if (mdomainfill.ge.1) then
+ if ((iout.eq.4).or.(iout.eq.5)) then
+ write(*,*) '#### FLEXPART MODEL ERROR! FILE COMMAND: ####'
+ write(*,*) '#### FOR DOMAIN-FILLING TRAJECTORY OPTION, ####'
+ write(*,*) '#### IOUT MUST NOT BE SET TO 4 OR 5. ####'
+ stop
+ endif
+ endif
+
+ ! Check whether a valid options for particle dump has been chosen
+ !****************************************************************
+
+ if ((ipout.ne.0).and.(ipout.ne.1).and.(ipout.ne.2).and.(ipout.ne.3)) then
+ write(*,*) ' #### FLEXPART MODEL ERROR! FILE COMMAND: #### '
+ write(*,*) ' #### IPOUT MUST BE 0, 1, 2 OR 3! #### '
+ stop
+ endif
+
+ ! Check whether input and output settings don't contradict
+ !*********************************************************
+ if (((iout.eq.4).or.(iout.eq.5)).and.((ipin.eq.3).or.(ipin.eq.4))) then
+ write(*,*) ' #### FLEXPART MODEL ERROR! FILE COMMAND: #### '
+ write(*,*) ' #### IOUT CANNOT BE 4 or 5 (plume) WHEN #### '
+ write(*,*) ' #### READING FROM part_ic.nc (ipin=4/5) #### '
+ stop
+ endif
+
+ if(lsubgrid.ne.1.and.verbosity.eq.0) then
+ write(*,*) ' ---------------- '
+ write(*,*) ' INFORMATION: SUBGRIDSCALE TERRAIN EFFECT IS'
+ write(*,*) ' NOT PARAMETERIZED DURING THIS SIMULATION. '
+ write(*,*) ' ---------------- '
+ endif
+
+
+ ! Check whether convection scheme is either turned on or off
+ !***********************************************************
+
+ if ((lconvection.ne.0).and.(lconvection.ne.1)) then
+ write(*,*) ' #### FLEXPART MODEL ERROR! FILE COMMAND: #### '
+ write(*,*) ' #### LCONVECTION MUST BE SET TO EITHER 1 OR 0#### '
+ stop
+ endif
+
+
+ ! Check whether synchronisation interval is sufficiently short
+ !*************************************************************
+
+ if (lsynctime.gt.(idiffnorm/2)) then
+ write(*,*) ' #### FLEXPART MODEL ERROR! SYNCHRONISATION #### '
+ write(*,*) ' #### TIME IS TOO LONG. MAKE IT SHORTER. #### '
+ write(*,*) ' #### MINIMUM HAS TO BE: ', idiffnorm/2
+ stop
+ endif
+
+
+ ! Check consistency of the intervals, sampling periods, etc., for model output
+ !*****************************************************************************
+
+ if (loutaver.eq.0) then
+ write(*,*) ' #### FLEXPART MODEL ERROR! TIME AVERAGE OF #### '
+ write(*,*) ' #### CONCENTRATION FIELD OUTPUT MUST NOT BE #### '
+ write(*,*) ' #### ZERO. #### '
+ write(*,*) ' #### CHANGE INPUT IN FILE COMMAND. #### '
+ stop
+ endif
+
+ if (loutaver.gt.loutstep) then
+ write(*,*) ' #### FLEXPART MODEL ERROR! TIME AVERAGE OF #### '
+ write(*,*) ' #### CONCENTRATION FIELD OUTPUT MUST NOT BE #### '
+ write(*,*) ' #### GREATER THAN INTERVAL OF OUTPUT. #### '
+ write(*,*) ' #### CHANGE INPUT IN FILE COMMAND. #### '
+ stop
+ endif
+
+ if (loutsample.gt.loutaver) then
+ write(*,*) ' #### FLEXPART MODEL ERROR! SAMPLING TIME OF #### '
+ write(*,*) ' #### CONCENTRATION FIELD OUTPUT MUST NOT BE #### '
+ write(*,*) ' #### GREATER THAN TIME AVERAGE OF OUTPUT. #### '
+ write(*,*) ' #### CHANGE INPUT IN FILE COMMAND. #### '
+ stop
+ endif
+
+ if (mod(loutaver,lsynctime).ne.0) then
+ write(*,*) ' #### FLEXPART MODEL ERROR! AVERAGING TIME OF #### '
+ write(*,*) ' #### CONCENTRATION FIELD MUST BE A MULTIPLE #### '
+ write(*,*) ' #### OF THE SYNCHRONISATION INTERVAL #### '
+ stop
+ endif
+
+ if ((loutaver/lsynctime).lt.2) then
+ write(*,*) ' #### FLEXPART MODEL ERROR! AVERAGING TIME OF #### '
+ write(*,*) ' #### CONCENTRATION FIELD MUST BE AT LEAST #### '
+ write(*,*) ' #### TWICE THE SYNCHRONISATION INTERVAL #### '
+ stop
+ endif
+
+ if (mod(loutstep,lsynctime).ne.0) then
+ write(*,*) ' #### FLEXPART MODEL ERROR! INTERVAL BETWEEN #### '
+ write(*,*) ' #### CONCENTRATION FIELDS MUST BE A MULTIPLE #### '
+ write(*,*) ' #### OF THE SYNCHRONISATION INTERVAL #### '
+ stop
+ endif
+
+ if ((loutstep/lsynctime).lt.2) then
+ write(*,*) ' #### FLEXPART MODEL ERROR! INTERVAL BETWEEN #### '
+ write(*,*) ' #### CONCENTRATION FIELDS MUST BE AT LEAST #### '
+ write(*,*) ' #### TWICE THE SYNCHRONISATION INTERVAL #### '
+ stop
+ endif
+
+ if (mod(loutsample,lsynctime).ne.0) then
+ write(*,*) ' #### FLEXPART MODEL ERROR! SAMPLING TIME OF #### '
+ write(*,*) ' #### CONCENTRATION FIELD MUST BE A MULTIPLE #### '
+ write(*,*) ' #### OF THE SYNCHRONISATION INTERVAL #### '
+ stop
+ endif
+
+ if ((mquasilag.eq.1).and.(iout.ge.4)) then
+ write(*,*) ' #### FLEXPART MODEL ERROR! CONFLICTING #### '
+ write(*,*) ' #### OPTIONS: IF MQUASILAG=1, PLUME #### '
+ write(*,*) ' #### TRAJECTORY OUTPUT IS IMPOSSIBLE. #### '
+ stop
+ endif
+
+ ! Compute modeling time in seconds and beginning date in Julian date
+ !*******************************************************************
+
+ outstep=real(abs(loutstep))
+ if (ldirect.eq.1) then
+ bdate=juldate(ibdate,ibtime)
+ edate=juldate(iedate,ietime)
+ ideltas=nint((edate-bdate)*86400.)
+ else if (ldirect.eq.-1) then
+ loutaver=-1*loutaver
+ loutstep=-1*loutstep
+ loutsample=-1*loutsample
+ lsynctime=-1*lsynctime
+ bdate=juldate(iedate,ietime)
+ edate=juldate(ibdate,ibtime)
+ ideltas=nint((edate-bdate)*86400.)
+ else
+ write(*,*) ' #### FLEXPART MODEL ERROR! DIRECTION IN #### '
+ write(*,*) ' #### FILE "COMMAND" MUST BE EITHER -1 OR 1. #### '
+ stop
+ endif
+
+ return
+
+999 write(*,*) ' #### FLEXPART MODEL ERROR! FILE "COMMAND" #### '
+ write(*,*) ' #### CANNOT BE OPENED IN THE DIRECTORY #### '
+ write(*,'(a)') path(1)(1:length(1))
+ stop
+
+1000 write(*,*) ' #### FLEXPART MODEL ERROR! FILE "COMMAND" #### '
+ write(*,*) ' #### CANNOT BE OPENED IN THE DIRECTORY #### '
+ write(*,'(a)') path(2)(1:length(2))
+ stop
+end subroutine readcommand
+
+subroutine readdepo
+
+ !*****************************************************************************
+ ! *
+ ! Reads dry deposition parameters needed by the procedure of Wesely (1989). *
+ ! Wesely (1989): Parameterization of surface resistances to gaseous *
+ ! dry deposition in regional-scale numerical models. *
+ ! Atmos. Environ. 23, 1293-1304. *
+ ! *
+ ! *
+ ! AUTHOR: Andreas Stohl, 19 May 1995 *
+ ! *
+ !*****************************************************************************
+ ! *
+ ! Variables: *
+ ! *
+ ! rcl(maxspec,5,9) [s/m] Lower canopy resistance *
+ ! rgs(maxspec,5,9) [s/m] Ground resistance *
+ ! rlu(maxspec,5,9) [s/m] Leaf cuticular resistance *
+ ! rm(maxspec) [s/m] Mesophyll resistance, set in readreleases *
+ ! ri(maxspec) [s/m] Stomatal resistance *
+ ! *
+ ! Constants: *
+ ! *
+ !*****************************************************************************
+
+ implicit none
+
+ ! FOR THIS SUBROUTINE, numclass=9 IS ASSUMED
+ !*******************************************
+
+ real :: rluh(5,numclass),rgssh(5,numclass),rgsoh(5,numclass)
+ real :: rclsh(5,numclass),rcloh(5,numclass)
+ integer :: i,j,ic
+
+
+ ! Read deposition constants related with landuse and seasonal category
+ !*********************************************************************
+ open(unitwesely,file=path(1)(1:length(1))//'surfdepo.t', &
+ status='old',err=999)
+
+ do i=1,16
+ read(unitwesely,*)
+ end do
+ do i=1,5
+ read(unitwesely,*)
+ read(unitwesely,'(8x,13f8.0)') (ri(i,j),j=1,numclass)
+ read(unitwesely,'(8x,13f8.0)') (rluh(i,j),j=1,numclass)
+ read(unitwesely,'(8x,13f8.0)') (rac(i,j),j=1,numclass)
+ read(unitwesely,'(8x,13f8.0)') (rgssh(i,j),j=1,numclass)
+ read(unitwesely,'(8x,13f8.0)') (rgsoh(i,j),j=1,numclass)
+ read(unitwesely,'(8x,13f8.0)') (rclsh(i,j),j=1,numclass)
+ read(unitwesely,'(8x,13f8.0)') (rcloh(i,j),j=1,numclass)
+ end do
+
+ ! TEST
+ ! do 31 i=1,5
+ ! ri(i,13)=ri(i,5)
+ ! rluh(i,13)=rluh(i,5)
+ ! rac(i,13)=rac(i,5)
+ ! rgssh(i,13)=rgssh(i,5)
+ ! rgsoh(i,13)=rgsoh(i,5)
+ ! rclsh(i,13)=rclsh(i,5)
+ ! rcloh(i,13)=rcloh(i,5)
+ !31 continue
+ ! TEST
+ ! Sabine Eckhardt, Dec 06, set resistances of 9999 to 'infinite' (1E25)
+ do i=1,5
+ do j=1,numclass
+ if (ri(i,j).eq.9999.) ri(i,j)=1.E25
+ if (rluh(i,j).eq.9999.) rluh(i,j)=1.E25
+ if (rac(i,j).eq.9999.) rac(i,j)=1.E25
+ if (rgssh(i,j).eq.9999.) rgssh(i,j)=1.E25
+ if (rgsoh(i,j).eq.9999.) rgsoh(i,j)=1.E25
+ if (rclsh(i,j).eq.9999.) rclsh(i,j)=1.E25
+ if (rcloh(i,j).eq.9999.) rcloh(i,j)=1.E25
+ end do
+ end do
+
+
+
+ do i=1,5
+ do j=1,numclass
+ ri(i,j)=max(ri(i,j),0.001)
+ rluh(i,j)=max(rluh(i,j),0.001)
+ rac(i,j)=max(rac(i,j),0.001)
+ rgssh(i,j)=max(rgssh(i,j),0.001)
+ rgsoh(i,j)=max(rgsoh(i,j),0.001)
+ rclsh(i,j)=max(rclsh(i,j),0.001)
+ rcloh(i,j)=max(rcloh(i,j),0.001)
+ end do
+ end do
+ close(unitwesely)
+
+
+ ! Compute additional parameters
+ !******************************
+
+ do ic=1,nspec
+ if (reldiff(ic).gt.0.) then ! gas is dry deposited
+ do i=1,5
+ do j=1,numclass
+ rlu(ic,i,j)=rluh(i,j)/(1.e-5*henry(ic)+f0(ic))
+ rgs(ic,i,j)=1./(henry(ic)/(10.e5*rgssh(i,j))+f0(ic)/ &
+ rgsoh(i,j))
+ rcl(ic,i,j)=1./(henry(ic)/(10.e5*rclsh(i,j))+f0(ic)/ &
+ rcloh(i,j))
+ end do
+ end do
+ endif
+ end do
+
+
+ return
+
+999 write(*,*) '### FLEXPART ERROR! FILE ###'
+ write(*,*) '### surfdepo.t DOES NOT EXIST. ###'
+ stop
+end subroutine readdepo
+
+subroutine readOHfield
+
+ !*****************************************************************************
+ ! *
+ ! Reads the OH field into memory *
+ ! *
+ ! AUTHOR: R.L. Thompson, Nov 2014 *
+ ! *
+ ! UPDATES: *
+ ! 03/2018 SEC: Converted original netCDF files to binary format *
+ !*****************************************************************************
+ ! *
+ ! Variables: *
+ ! *
+ ! path(numpath) contains the path names *
+ ! lonOH(nxOH) longitude of OH fields *
+ ! latOH(nyOH) latitude of OH fields *
+ ! altOH(nzOH) altitude of OH fields *
+ ! etaOH(nzOH) eta-levels of OH fields *
+ ! OH_field(nxOH,nyOH,nzOH,m) OH concentration (molecules/cm3) *
+ ! *
+ ! *
+ !*****************************************************************************
+
+ use oh_mod
+
+ implicit none
+
+ integer :: i,j,k,l,ierr
+ real, dimension(:), allocatable :: etaOH
+
+ ! real, parameter :: gasct=8.314 ! gas constant
+ ! real, parameter :: mct=0.02894 ! kg mol-1
+ ! real, parameter :: g=9.80665 ! m s-2
+ ! real, parameter :: lrate=0.0065 ! K m-1
+ real, parameter :: scalehgt=7000. ! scale height in metres
+
+
+ open(unitOH,file=trim(ohfields_path) &
+ //'OH_FIELDS/OH_variables.bin',status='old', &
+ form='UNFORMATTED', iostat=ierr, convert='little_endian')
+
+ if(ierr.ne.0) then
+ write(*,*) 'Cannot read binary OH fields in ',trim(ohfields_path)//'OH_FIELDS/OH_variables.bin'
+ stop
+ endif
+
+ read(unitOH) nxOH
+ read(unitOH) nyOH
+ read(unitOH) nzOH
+ write(*,*) nxOH,nyOH,nzOH
+
+ ! allocate variables
+ allocate(lonOH(nxOH))
+ allocate(latOH(nyOH))
+ allocate(etaOH(nzOH))
+ allocate(altOH(nzOH))
+ allocate(OH_field(nxOH,nyOH,nzOH,12))
+ allocate(OH_hourly(nxOH,nyOH,nzOH,2))
+
+ read(unitOH) (lonjr(i),i=1,360)
+ read(unitOH) (latjr(i),i=1,180)
+ read(unitOH) (((jrate_average(i,j,k),i=1,360),j=1,180),k=1,12)
+ read(unitOH) (lonOH(i),i=1,nxOH)
+ read(unitOH) (latOH(i),i=1,nyOH)
+ read(unitOH) (lonOH(i),i=1,nxOH)
+
+ read(unitOH) (altOH(i),i=1,nzOH)
+ read(unitOH) ((((OH_field(i,j,k,l),i=1,nxOH),j=1,nyOH),k=1,nzOH),l=1,12)
+ read(unitOH) ((((OH_hourly(i,j,k,l),i=1,nxOH),j=1,nyOH),k=1,nzOH),l=1,2)
+end subroutine readOHfield
+
+subroutine readlanduse
+
+ !*****************************************************************************
+ ! *
+ ! Reads the landuse inventory into memory and relates it to Leaf Area *
+ ! Index and roughness length. *
+ ! *
+ ! AUTHOR: Andreas Stohl, 10 January 1994 *
+ ! *
+ !*****************************************************************************
+ ! *
+ ! Variables: *
+ ! i loop indices *
+ ! landinvent(1200,600,13) area fractions of 13 landuse categories *
+ ! LENGTH(numpath) length of the path names *
+ ! PATH(numpath) contains the path names *
+ ! unitland unit connected with landuse inventory *
+ ! *
+ ! ----- *
+ ! Sabine Eckhardt, Dec 06 - new landuse inventary *
+ ! after *
+ ! Belward, A.S., Estes, J.E., and Kline, K.D., 1999, *
+ ! The IGBP-DIS 1-Km Land-Cover Data Set DISCover: *
+ ! A Project Overview: Photogrammetric Engineering and Remote Sensing, *
+ ! v. 65, no. 9, p. 1013-1020 *
+ ! *
+ ! LANDUSE CATEGORIES: *
+ ! *
+ ! 1 Urban land *
+ ! 2 Agricultural land *
+ ! 3 Range land *
+ ! 4 Deciduous forest *
+ ! 5 Coniferous forest *
+ ! 6 Mixed forest including wetland *
+ ! 7 water, both salt and fresh *
+ ! 8 barren land mostly desert *
+ ! 9 nonforested wetland *
+ ! 10 mixed agricultural and range land *
+ ! 11 rocky open areas with low growing shrubs *
+ ! 12 ice *
+ ! 13 rainforest *
+ ! *
+ !*****************************************************************************
+
+ use drydepo_mod
+
+ implicit none
+
+ integer :: ix,jy,i,k,lu_cat,lu_perc
+ integer(kind=1) :: ilr
+ integer(kind=1) :: ilr_buffer(2160000)
+ integer :: il,irecread
+ real :: rlr, r2lr
+
+
+ ! Read landuse inventory
+ !***********************
+ ! The landuse information is saved in a compressed format and written
+ ! out by records of the length of 1 BYTE. Each grid cell consists of 3
+ ! Bytes, which include 3 landuse categories (val 1-13 and 16 percentage
+ ! categories) So one half byte is used to store the Landusecat the other
+ ! for the percentageclass in 6.25 steps (100/6.25=16)
+ ! e.g.
+ ! 4 3 percentage 4 = 4*6.25 => 25% landuse class 3
+ ! 2 1 percentage 2 = 2*6.25 => 13% landuse class 1
+ ! 1 12 percentage 1 = 1*6.26 => 6.25% landuse class 12
+
+ open(unitland,file=path(1)(1:length(1)) &
+ //'IGBP_int1.dat',status='old', &
+ ! +form='UNFORMATTED', err=998)
+ form='UNFORMATTED', err=998, convert='little_endian')
+ ! print*,unitland
+ read (unitland) (ilr_buffer(i),i=1,2160000)
+ close(unitland)
+
+ irecread=1
+ do ix=1,1200
+ do jy=1,600
+ ! the 3 most abundant landuse categories in the inventory
+ ! first half byte contains the landuse class
+ ! second half byte contains the respective percentage
+ do k=1,3
+ ! 1 byte is read
+ ilr=ilr_buffer(irecread)
+ ! ilr=0
+ irecread=irecread+1
+ ! as only signed integer values exist an unsigned value is constructed
+ if (ilr.lt.0) then
+ il=ilr+256
+ else
+ il=ilr
+ endif
+ ! dividing by 16 has the effect to get rid of the right half of the byte
+ ! so just the left half remains, this corresponds to a shift right of 4
+ ! bits
+ rlr=real(il)/16.
+ lu_cat=int(rlr)
+ ! the left half of the byte is substracted from the whole in order to
+ ! get only the right half of the byte
+ r2lr=rlr-int(rlr)
+ ! shift left by 4
+ lu_perc=r2lr*16.
+ landinvent(ix,jy,k)=lu_cat
+ landinvent(ix,jy,k+3)=lu_perc
+ ! if ((jy.lt.10).and.(ix.lt.10)) write(*,*) 'reading: ' , ix, jy, lu_cat, lu_perc
+ end do
+ end do
+ end do
+
+ ! Read relation landuse,z0
+ !*****************************
+
+ open(unitsurfdata,file=path(1)(1:length(1))//'surfdata.t', &
+ status='old',err=999)
+
+ do i=1,4
+ read(unitsurfdata,*)
+ end do
+ do i=1,numclass
+ read(unitsurfdata,'(45x,f15.3)') z0(i)
+ end do
+ close(unitsurfdata)
+
+ return
+
+ ! Issue error messages
+ !*********************
+
+998 write(*,*) ' #### FLEXPART ERROR! FILE CONTAINING ####'
+ write(*,*) ' #### LANDUSE INVENTORY DOES NOT EXIST ####'
+ stop
+
+999 write(*,*) ' #### FLEXPART ERROR! FILE CONTAINING ####'
+ write(*,*) ' #### RELATION LANDUSE,z0 DOES NOT EXIST ####'
+ stop
+end subroutine readlanduse
+
+subroutine readoutgrid
+
+ !*****************************************************************************
+ ! *
+ ! This routine reads the user specifications for the output grid. *
+ ! *
+ ! Author: A. Stohl *
+ ! *
+ ! 4 June 1996 *
+ ! HSO, 1 July 2014
+ ! Added optional namelist input
+ ! *
+ !*****************************************************************************
+ ! *
+ ! Variables: *
+ ! dxout,dyout grid distance *
+ ! numxgrid,numygrid,numzgrid grid dimensions *
+ ! outlon0,outlat0 lower left corner of grid *
+ ! outheight(maxzgrid) height levels of output grid [m] *
+ ! *
+ ! Constants: *
+ ! unitoutgrid unit connected to file OUTGRID *
+ ! *
+ !*****************************************************************************
+
+ use outg_mod
+
+ implicit none
+
+ integer :: i,j,stat
+ real :: outhelp,xr,xr1,yr,yr1
+ real,parameter :: eps=1.e-4
+
+ ! namelist variables
+ integer, parameter :: maxoutlev=500
+ integer :: readerror
+ real,allocatable, dimension (:) :: outheights
+
+ ! declare namelist
+ namelist /outgrid/ &
+ outlon0,outlat0, &
+ numxgrid,numygrid, &
+ dxout,dyout, &
+ outheights
+
+ ! allocate large array for reading input
+ allocate(outheights(maxoutlev),stat=stat)
+ if (stat.ne.0) write(*,*)'ERROR: could not allocate outheights'
+
+ ! helps identifying failed namelist input
+ dxout=-1.0
+ outheights=-1.0
+
+ ! Open the OUTGRID file and read output grid specifications
+ !**********************************************************
+
+ open(unitoutgrid,file=path(1)(1:length(1))//'OUTGRID',status='old',form='formatted',err=999)
+
+ ! try namelist input
+ read(unitoutgrid,outgrid,iostat=readerror)
+ close(unitoutgrid)
+
+ if ((dxout.le.0).or.(readerror.ne.0)) then
+
+ readerror=1
+
+ open(unitoutgrid,file=path(1)(1:length(1))//'OUTGRID',status='old',err=999)
+
+ call skplin(5,unitoutgrid)
+
+ ! 1. Read horizontal grid specifications
+ !****************************************
+
+ call skplin(3,unitoutgrid)
+ read(unitoutgrid,'(4x,f11.4)') outlon0
+ call skplin(3,unitoutgrid)
+ read(unitoutgrid,'(4x,f11.4)') outlat0
+ call skplin(3,unitoutgrid)
+ read(unitoutgrid,'(4x,i5)') numxgrid
+ call skplin(3,unitoutgrid)
+ read(unitoutgrid,'(4x,i5)') numygrid
+ call skplin(3,unitoutgrid)
+ read(unitoutgrid,'(4x,f12.5)') dxout
+ call skplin(3,unitoutgrid)
+ read(unitoutgrid,'(4x,f12.5)') dyout
+
+ endif
+
+ ! Check validity of output grid (shall be within model domain)
+ !*************************************************************
+
+ xr=outlon0+real(numxgrid)*dxout
+ yr=outlat0+real(numygrid)*dyout
+ xr1=xlon0+real(nxmin1)*dx
+ yr1=ylat0+real(nymin1)*dy
+ if ((outlon0+eps.lt.xlon0).or.(outlat0+eps.lt.ylat0) &
+ .or.(xr.gt.xr1+eps).or.(yr.gt.yr1+eps)) then
+ write(*,*) outlon0,outlat0
+ write(*,*) xr1,yr1,xlon0,ylat0,xr,yr,dxout,dyout
+ write(*,*) ' #### FLEXPART MODEL ERROR! PART OF OUTPUT ####'
+ write(*,*) ' #### GRID IS OUTSIDE MODEL DOMAIN. CHANGE ####'
+ write(*,*) ' #### FILE OUTGRID IN DIRECTORY ####'
+ write(*,'(a)') path(1)(1:length(1))
+ stop
+ endif
+
+ ! 2. Count Vertical levels of output grid
+ !****************************************
+
+ if (readerror.ne.0) then
+ j=0
+100 j=j+1
+ do i=1,3
+ read(unitoutgrid,*,end=99)
+ end do
+ read(unitoutgrid,'(4x,f7.1)',end=99) outhelp
+ if (outhelp.eq.0.) goto 99
+ goto 100
+99 numzgrid=j-1
+ else
+ do i=1,maxoutlev
+ if (outheights(i).lt.0) exit
+ end do
+ numzgrid=i-1
+ end if
+
+ allocate(outheight(numzgrid),stat=stat)
+ if (stat.ne.0) write(*,*)'ERROR: could not allocate outheight'
+ allocate(outheighthalf(numzgrid),stat=stat)
+ if (stat.ne.0) write(*,*)'ERROR: could not allocate outheighthalf'
+
+ ! 2. Vertical levels of output grid
+ !**********************************
+
+ if (readerror.ne.0) then
+
+ rewind(unitoutgrid)
+ call skplin(29,unitoutgrid)
+
+ do j=1,numzgrid
+ do i=1,3
+ read(unitoutgrid,*)
+ end do
+ read(unitoutgrid,'(4x,f7.1)') outhelp
+ outheight(j)=outhelp
+ outheights(j)=outhelp
+ end do
+ close(unitoutgrid)
+
+ else
+
+ do j=1,numzgrid
+ outheight(j)=outheights(j)
+ end do
+
+ endif
+
+ ! write outgrid file in namelist format to output directory if requested
+ if (nmlout.and.lroot) then
+ ! reallocate outheights with actually required dimension for namelist writing
+ deallocate(outheights)
+ allocate(outheights(numzgrid),stat=stat)
+ if (stat.ne.0) write(*,*)'ERROR: could not allocate outheights'
+
+ do j=1,numzgrid
+ outheights(j)=outheight(j)
+ end do
+
+ open(unitoutgrid,file=path(2)(1:length(2))//'OUTGRID.namelist',err=1000)
+ write(unitoutgrid,nml=outgrid)
+ close(unitoutgrid)
+ endif
+
+ ! Check whether vertical levels are specified in ascending order
+ !***************************************************************
+
+ do j=2,numzgrid
+ if (outheight(j).le.outheight(j-1)) then
+ write(*,*) ' #### FLEXPART MODEL ERROR! YOUR SPECIFICATION#### '
+ write(*,*) ' #### OF OUTPUT LEVELS IS CORRUPT AT LEVEL #### '
+ write(*,*) ' #### ',j,' #### '
+ write(*,*) ' #### PLEASE MAKE CHANGES IN FILE OUTGRID. #### '
+ endif
+ end do
+
+ ! Determine the half levels, i.e. middle levels of the output grid
+ !*****************************************************************
+
+ outheighthalf(1)=outheight(1)/2.
+ do j=2,numzgrid
+ outheighthalf(j)=(outheight(j-1)+outheight(j))/2.
+ end do
+
+ xoutshift=xlon0-outlon0
+ youtshift=ylat0-outlat0
+
+ allocate(oroout(0:numxgrid-1,0:numygrid-1),stat=stat)
+ if (stat.ne.0) write(*,*)'ERROR: could not allocate oroout'
+ allocate(area(0:numxgrid-1,0:numygrid-1),stat=stat)
+ if (stat.ne.0) write(*,*)'ERROR: could not allocate area'
+ allocate(volume(0:numxgrid-1,0:numygrid-1,numzgrid),stat=stat)
+ if (stat.ne.0) write(*,*)'ERROR: could not allocate volume'
+ allocate(areaeast(0:numxgrid-1,0:numygrid-1,numzgrid),stat=stat)
+ if (stat.ne.0) write(*,*)'ERROR: could not allocate areaeast'
+ allocate(areanorth(0:numxgrid-1,0:numygrid-1,numzgrid),stat=stat)
+ if (stat.ne.0) write(*,*)'ERROR: could not allocate areanorth'
+ return
+
+999 write(*,*) ' #### FLEXPART MODEL ERROR! FILE "OUTGRID" #### '
+ write(*,*) ' #### CANNOT BE OPENED IN THE DIRECTORY #### '
+ write(*,'(a)') path(1)(1:length(1))
+ stop
+
+1000 write(*,*) ' #### FLEXPART MODEL ERROR! FILE "OUTGRID" #### '
+ write(*,*) ' #### CANNOT BE OPENED IN THE DIRECTORY #### '
+ write(*,'(a)') path(2)(1:length(2))
+ stop
+end subroutine readoutgrid
+
+subroutine readoutgrid_nest
+
+ !*****************************************************************************
+ ! *
+ ! This routine reads the user specifications for the output nest. *
+ ! *
+ ! Author: A. Stohl *
+ ! *
+ ! 4 June 1996 *
+ ! *
+ !*****************************************************************************
+ ! *
+ ! Variables: *
+ ! dxoutn,dyoutn grid distances of output nest *
+ ! numxgridn,numygridn,numzgrid nest dimensions *
+ ! outlon0n,outlat0n lower left corner of nest *
+ ! outheight(maxzgrid) height levels of output grid [m] *
+ ! *
+ ! Constants: *
+ ! unitoutgrid unit connected to file OUTGRID *
+ ! *
+ !*****************************************************************************
+
+ use outg_mod
+
+ implicit none
+
+ integer :: stat
+ real :: xr,xr1,yr,yr1
+ real,parameter :: eps=1.e-4
+
+ integer :: readerror
+
+ ! declare namelist
+ namelist /outgridn/ &
+ outlon0n,outlat0n, &
+ numxgridn,numygridn, &
+ dxoutn,dyoutn
+
+ ! helps identifying failed namelist input
+ dxoutn=-1.0
+
+ ! Open the OUTGRID file and read output grid specifications
+ !**********************************************************
+
+ open(unitoutgrid,file=path(1)(1:length(1))//'OUTGRID_NEST',form='formatted',status='old',err=999)
+
+ ! try namelist input
+ read(unitoutgrid,outgridn,iostat=readerror)
+ close(unitoutgrid)
+
+ if ((dxoutn.le.0).or.(readerror.ne.0)) then
+
+ open(unitoutgrid,file=path(1)(1:length(1))//'OUTGRID_NEST',status='old',err=999)
+ call skplin(5,unitoutgrid)
+
+ ! 1. Read horizontal grid specifications
+ !****************************************
+
+ call skplin(3,unitoutgrid)
+ read(unitoutgrid,'(4x,f11.4)') outlon0n
+ call skplin(3,unitoutgrid)
+ read(unitoutgrid,'(4x,f11.4)') outlat0n
+ call skplin(3,unitoutgrid)
+ read(unitoutgrid,'(4x,i5)') numxgridn
+ call skplin(3,unitoutgrid)
+ read(unitoutgrid,'(4x,i5)') numygridn
+ call skplin(3,unitoutgrid)
+ read(unitoutgrid,'(4x,f12.5)') dxoutn
+ call skplin(3,unitoutgrid)
+ read(unitoutgrid,'(4x,f12.5)') dyoutn
+
+ close(unitoutgrid)
+ endif
+
+ ! write outgrid_nest file in namelist format to output directory if requested
+ if (nmlout.and.lroot) then
+ open(unitoutgrid,file=path(2)(1:length(2))//'OUTGRID_NEST.namelist',err=1000)
+ write(unitoutgrid,nml=outgridn)
+ close(unitoutgrid)
+ endif
+
+ allocate(orooutn(0:numxgridn-1,0:numygridn-1),stat=stat)
+ if (stat.ne.0) write(*,*)'ERROR: could not allocate orooutn'
+ allocate(arean(0:numxgridn-1,0:numygridn-1),stat=stat)
+ if (stat.ne.0) write(*,*)'ERROR: could not allocate arean'
+ allocate(volumen(0:numxgridn-1,0:numygridn-1,numzgrid),stat=stat)
+ if (stat.ne.0) write(*,*)'ERROR: could not allocate volumen'
+
+ ! Check validity of output grid (shall be within model domain)
+ !*************************************************************
+
+ xr=outlon0n+real(numxgridn)*dxoutn
+ yr=outlat0n+real(numygridn)*dyoutn
+ xr1=xlon0+real(nxmin1)*dx
+ yr1=ylat0+real(nymin1)*dy
+ if ((outlon0n+eps.lt.xlon0).or.(outlat0n+eps.lt.ylat0) &
+ .or.(xr.gt.xr1+eps).or.(yr.gt.yr1+eps)) then
+ write(*,*) ' #### FLEXPART MODEL ERROR! PART OF OUTPUT ####'
+ write(*,*) ' #### NEST IS OUTSIDE MODEL DOMAIN. CHANGE ####'
+ write(*,*) ' #### FILE OUTGRID IN DIRECTORY ####'
+ write(*,'(a)') path(1)(1:length(1))
+ stop
+ endif
+
+ xoutshiftn=xlon0-outlon0n
+ youtshiftn=ylat0-outlat0n
+ return
+
+999 write(*,*) ' #### FLEXPART MODEL ERROR! FILE "OUTGRID" #### '
+ write(*,*) ' #### CANNOT BE OPENED IN THE DIRECTORY #### '
+ write(*,'(a)') path(1)(1:length(1))
+ stop
+
+1000 write(*,*) ' #### FLEXPART MODEL ERROR! FILE "OUTGRID" #### '
+ write(*,*) ' #### CANNOT BE OPENED IN THE DIRECTORY #### '
+ write(*,'(a)') path(2)(1:length(2))
+ stop
+end subroutine readoutgrid_nest
+
+subroutine readpaths
+
+ !*****************************************************************************
+ ! *
+ ! Reads the pathnames, where input/output files are expected to be. *
+ ! The file pathnames must be available in the current working directory. *
+ ! *
+ ! Author: A. Stohl *
+ ! *
+ ! 1 February 1994 *
+ ! last modified *
+ ! HS, 7.9.2012 *
+ ! option to give pathnames file as command line option *
+ ! *
+ !*****************************************************************************
+ ! *
+ ! Variables: *
+ ! length(numpath) lengths of the path names *
+ ! path(numpath) pathnames of input/output files *
+ ! *
+ ! Constants: *
+ ! numpath number of pathnames to be read in *
+ ! *
+ !*****************************************************************************
+
+ implicit none
+
+ integer :: i
+ character(256) :: string_test
+ character(1) :: character_test
+
+ ! Read the pathname information stored in unitpath
+ !*************************************************
+
+ open(unitpath,file=trim(pathfile),status='old',err=999)
+
+ do i=1,numpath
+ read(unitpath,'(a)',err=998) path(i)
+ length(i)=index(path(i),' ')-1
+
+
+ string_test = path(i)
+ character_test = string_test(length(i):length(i))
+ !print*, 'character_test, string_test ', character_test, string_test
+ if ((character_test .NE. '/') .AND. (i .LT. 4)) then
+ print*, 'WARNING: path not ending in /'
+ print*, path(i)
+ path(i) = string_test(1:length(i)) // '/'
+ length(i)=length(i)+1
+ print*, 'fix: padded with /'
+ print*, path(i)
+ print*, 'length(i) increased 1'
+ endif
+ end do
+
+ ! Check whether any nested subdomains are to be used
+ !***************************************************
+
+ do i=1,maxnests
+ ! ESO 2016 Added 'end'/'err' in case user forgot '====' at end of file and
+ ! maxnests > numbnests
+ read(unitpath,'(a)', end=30, err=30) path(numpath+2*(i-1)+1)
+ read(unitpath,'(a)', end=30, err=30) path(numpath+2*(i-1)+2)
+ if (path(numpath+2*(i-1)+1)(1:5).eq.'=====') goto 30
+ length(numpath+2*(i-1)+1)=index(path(numpath+2*(i-1)+1),' ')-1
+ length(numpath+2*(i-1)+2)=index(path(numpath+2*(i-1)+2),' ')-1
+ end do
+
+
+ ! Determine number of available nested domains
+ !*********************************************
+
+30 numbnests=i-1
+
+ close(unitpath)
+ return
+
+998 write(*,*) ' #### TRAJECTORY MODEL ERROR! ERROR WHILE #### '
+ write(*,*) ' #### READING FILE PATHNAMES. #### '
+ stop
+
+999 write(*,*) ' #### TRAJECTORY MODEL ERROR! FILE "pathnames"#### '
+ write(*,*) ' #### CANNOT BE OPENED IN THE CURRENT WORKING #### '
+ write(*,*) ' #### DIRECTORY. #### '
+ stop
+end subroutine readpaths
+
+
+subroutine readreceptors
+
+ !*****************************************************************************
+ ! *
+ ! This routine reads the user specifications for the receptor points. *
+ ! *
+ ! Author: A. Stohl *
+ ! 1 August 1996 *
+ ! *
+ ! HSO, 14 August 2013: Added optional namelist input
+ ! PS, 2/2015: access= -> position=
+ ! PS, 6/2015: variable names, simplify code
+ ! PS, 3/2023: remove position=append, makes no sense for new file *
+ ! *
+ !*****************************************************************************
+ ! *
+ ! Variables: *
+ ! receptorarea(maxreceptor) area of dx*dy at location of receptor *
+ ! receptorname(maxreceptor) names of receptors *
+ ! xreceptor,yreceptor coordinates of receptor points *
+ ! *
+ ! Constants: *
+ ! unitreceptor unit connected to file RECEPTORS *
+ ! *
+ !*****************************************************************************
+
+ implicit none
+
+ integer :: j
+ real :: x,y,xm,ym
+ character(len=16) :: receptor
+
+ integer :: ios
+ real :: xlon,ylat ! for namelist input, lon/lat are used instead of x,y
+
+ ! declare namelist
+ namelist /nml_receptors/ receptor, xlon, ylat
+
+!CPS I comment this out - why should we not have receptor output in bwd runs?
+ ! For backward runs, do not allow receptor output. Thus, set number of
+ ! receptors to zero
+ ! if (ldirect.lt.0) then
+ ! numreceptor=0
+ ! return
+ ! endif
+
+
+ ! Open the RECEPTORS file and read output grid specifications
+ !************************************************************
+
+ open (unitreceptor,file=trim(path(1))//'RECEPTORS',form='formatted', &
+ status='old',err=999)
+
+ ! try namelist input
+ read(unitreceptor,nml_receptors,iostat=ios)
+
+ ! prepare namelist output if requested
+ if (nmlout) open(unitreceptorout,file=trim(path(2))// &
+ 'RECEPTORS.namelist',status='new',err=1000)
+
+ if (ios .ne. 0) then ! read as regular text file
+
+ close(unitreceptor)
+ open (unitreceptor,file=trim(path(1))//'RECEPTORS',status='old',err=999)
+
+ call skplin(5,unitreceptor)
+
+ ! Read the names and coordinates of the receptors
+ !************************************************
+
+ j=1
+100 continue
+ read(unitreceptor,*,end=99)
+ read(unitreceptor,*,end=99)
+ read(unitreceptor,*,end=99)
+ read(unitreceptor,'(4x,a16)',end=99) receptor
+ call skplin(3,unitreceptor)
+ read(unitreceptor,'(4x,f11.4)',end=99) xlon
+ call skplin(3,unitreceptor)
+ read(unitreceptor,'(4x,f11.4)',end=99) ylat
+ if (xlon.eq.0. .and. ylat.eq.0. .and. &
+ (receptor .eq. ' ')) then
+ write(*,*) 'WARNING: looks like empty receptor at south pole;'// &
+ ' will be skipped'
+ j=j-1
+ goto 100
+ endif
+ if (j .gt. maxreceptor) then
+ write(*,*) ' #### FLEXPART MODEL ERROR! TOO MANY RECEPTOR #### '
+ write(*,*) ' #### POINTS ARE GIVEN. #### '
+ write(*,*) ' #### MAXIMUM NUMBER IS ',maxreceptor,' #### '
+ write(*,*) ' #### PLEASE MAKE CHANGES IN FILE RECEPTORS #### '
+ endif
+ receptorname(j)=receptor
+ xreceptor(j)=(xlon-xlon0)/dx ! transform to grid coordinates
+ yreceptor(j)=(ylat-ylat0)/dy
+ xm=r_earth*cos(ylat*pi/180.)*dx/180.*pi
+ ym=r_earth*dy/180.*pi
+ receptorarea(j)=xm*ym
+ ! write receptors file in namelist format to output directory if requested
+ if (nmlout) write(unitreceptorout,nml=nml_receptors)
+ goto 100
+
+99 numreceptor=j-1
+
+ else ! continue with namelist input
+
+ j=0
+ do while (ios .eq. 0)
+ j=j+1
+ read(unitreceptor,nml_receptors,iostat=ios)
+ if (ios .eq. 0) then
+ if (j .gt. maxreceptor) then
+ write(*,*) ' #### FLEXPART MODEL ERROR! TOO MANY RECEPTOR #### '
+ write(*,*) ' #### POINTS ARE GIVEN. #### '
+ write(*,*) ' #### MAXIMUM NUMBER IS ',maxreceptor,' #### '
+ write(*,*) ' #### PLEASE MAKE CHANGES IN FILE RECEPTORS #### '
+ endif
+ receptorname(j)=receptor
+ xreceptor(j)=(xlon-xlon0)/dx ! transform to grid coordinates
+ yreceptor(j)=(ylat-ylat0)/dy
+ xm=r_earth*cos(ylat*pi/180.)*dx/180.*pi
+ ym=r_earth*dy/180.*pi
+ receptorarea(j)=xm*ym
+ ! write receptors in namelist format to output directory if requested
+ if (nmlout) write(unitreceptorout,nml=nml_receptors)
+ elseif (ios .gt. 0) then
+ write(*,*) ' ### FLEXPART MODEL ERROR! Error in RECEPTORS namelist ###'
+ stop 'Error in RECEPTORS namelist'
+ endif
+ end do ! end nml receptors reading loop
+
+ numreceptor=j-1
+
+ endif ! end no-nml / nml bloc
+
+ close (unitreceptor)
+ if (nmlout) close (unitreceptorout)
+
+ return
+
+
+999 write(*,*) 'INFORMATION: input file RECEPTORS cannot be opened'
+ write(*,*) 'in directory '//trim(path(1))
+ write(*,*) 'Continuing without RECEPTOR'
+
+ numreceptor=0
+ return
+
+1000 write(*,*) ' #### FLEXPART MODEL ERROR! File "RECEPTORS" #### '
+ write(*,*) ' #### cannot be opened in the directory #### '
+ write(*,'(a)') ' #### '//trim(path(2))
+
+ stop
+
+end subroutine readreceptors
+
+subroutine readreleases
+
+ !*****************************************************************************
+ ! *
+ ! This routine reads the release point specifications for the current *
+ ! model run. Several release points can be used at the same time. *
+ ! *
+ ! Author: A. Stohl *
+ ! *
+ ! 18 May 1996 *
+ ! *
+ ! Update: 29 January 2001 *
+ ! Release altitude can be either in magl or masl *
+ ! HSO, 12 August 2013
+ ! Added optional namelist input
+ ! *
+ !*****************************************************************************
+ ! *
+ ! Variables: *
+ ! decay decay constant of species *
+ ! dquer [um] mean particle diameters *
+ ! dsigma e.g. dsigma=10 or dsigma=0.1 means that 68% of the mass*
+ ! are between 0.1*dquer and 10*dquer *
+ ! ireleasestart, ireleaseend [s] starting time and ending time of each *
+ ! release *
+ ! kindz 1: zpoint is in m agl, 2: zpoint is in m asl, 3: zpoint*
+ ! is in hPa *
+ ! npart number of particles to be released *
+ ! nspec number of species to be released *
+ ! density [kg/m3] density of the particles *
+ ! rm [s/m] Mesophyll resistance *
+ ! species name of species *
+ ! xmass total mass of each species *
+ ! xpoint1,ypoint1 geograf. coordinates of lower left corner of release *
+ ! area *
+ ! xpoint2,ypoint2 geograf. coordinates of upper right corner of release *
+ ! area *
+ ! weta_gas, wetb_gas parameters for below-cloud scavenging (gas) *
+ ! crain_aero, csnow_aero parameters for below-cloud scavenging (aerosol) *
+ ! ccn_aero, in_aero parameters for in-cloud scavenging (aerosol) *
+ ! zpoint1,zpoint2 height range, over which release takes place *
+ ! num_min_discrete if less, release cannot be randomized and happens at *
+ ! time mid-point of release interval *
+ ! lroot true if serial version, or if MPI and root process *
+ ! *
+ !*****************************************************************************
+
+ use point_mod
+ use xmass_mod
+ use drydepo_mod
+
+ implicit none
+
+ integer :: numpartmax,i,j,id1,it1,id2,it2,idum,stat,irel,ispc,nsettle
+ integer,parameter :: num_min_discrete=100
+ real :: releaserate,xdum,cun
+ real(kind=dp) :: jul1,jul2,julm
+ real,parameter :: eps2=1.e-9
+ character(len=50) :: line
+ logical :: old
+
+ ! help variables for namelist reading
+ integer :: numpoints, parts, readerror
+ integer*2 :: zkind
+ integer :: idate1, itime1, idate2, itime2
+ real :: lon1,lon2,lat1,lat2,z1,z2
+ character*40 :: comment
+ integer,parameter :: unitreleasesout=2
+ real,allocatable, dimension (:) :: mass
+ integer,allocatable, dimension (:) :: specnum_rel,specnum_rel2
+ real,allocatable,dimension(:) :: vsh,fracth,schmih
+
+ ! declare namelists
+ namelist /releases_ctrl/ &
+ nspec, &
+ specnum_rel
+
+ namelist /release/ &
+ idate1, itime1, &
+ idate2, itime2, &
+ lon1, lon2, &
+ lat1, lat2, &
+ z1, z2, &
+ zkind, &
+ mass, &
+ parts, &
+ comment
+
+ numpoint=0
+
+ ! allocate with maxspec for first input loop
+ allocate(mass(maxspec),stat=stat)
+ if (stat.ne.0) write(*,*)'ERROR: could not allocate mass'
+ allocate(specnum_rel(maxspec),stat=stat)
+ if (stat.ne.0) write(*,*)'ERROR: could not allocate specnum_rel'
+
+ ! presetting namelist releases_ctrl
+ nspec = -1 ! use negative value to determine failed namelist input
+ specnum_rel = 0
+
+ !sec, read release to find how many releasepoints should be allocated
+ open(unitreleases,file=path(1)(1:length(1))//'RELEASES',status='old',form='formatted',err=999)
+
+ ! check if namelist input provided
+ read(unitreleases,releases_ctrl,iostat=readerror)
+ if (readerror.ne.0) then
+ backspace(unitreleases)
+ read(unitreleases,fmt='(A)') line
+ if (lroot) write(*,*) &
+ 'Invalid line in RELEASES: '//trim(line)
+ !cgz; Check if the number of species in RELEASES_CTRL is larger than the maximum number of species in par_mod
+ if ((lroot) .and. nspec.gt.maxspec) goto 994
+ end if
+
+ ! prepare namelist output if requested
+ if (nmlout.and.lroot) then
+ open(unitreleasesout,file=path(2)(1:length(2))//'RELEASES.namelist',access='append',status='replace',err=1000)
+ endif
+
+ if ((readerror.ne.0).or.(nspec.lt.0)) then
+ if (lroot) write(*,*) 'RELEASE either having unrecognised entries, &
+ &or in old format, please update to namelist format.'
+ stop
+ else
+ if ((ipin.ne.3).and.(ipin.ne.4)) then ! Not necessary to read releases when using part_ic.nc
+ readerror=0
+ do while (readerror.eq.0)
+ idate1=-1
+ read(unitreleases,release,iostat=readerror)
+ if ((idate1.lt.0).or.(readerror.ne.0)) then
+ readerror=1
+ else
+ numpoint=numpoint+1
+ endif
+ end do
+ readerror=0
+ else
+ numpoint=1
+ endif
+ endif
+
+ rewind(unitreleases)
+
+ if (nspec.gt.maxspec) goto 994
+
+ ! allocate arrays of matching size for number of species (namelist output)
+ deallocate(mass)
+ allocate(mass(nspec),stat=stat)
+ if (stat.ne.0) write(*,*)'ERROR: could not allocate mass'
+ allocate(specnum_rel2(nspec),stat=stat)
+ if (stat.ne.0) write(*,*)'ERROR: could not allocate specnum_rel2'
+ specnum_rel2=specnum_rel(1:nspec)
+ deallocate(specnum_rel)
+ ! eso: BUG, crashes here for nspec=12 and maxspec=6,
+ ! TODO: catch error and exit
+ allocate(specnum_rel(nspec),stat=stat)
+ if (stat.ne.0) write(*,*)'ERROR: could not allocate specnum_rel'
+ specnum_rel=specnum_rel2
+ deallocate(specnum_rel2)
+
+ !allocate memory for numpoint releaspoints
+ allocate(ireleasestart(numpoint),stat=stat)
+ if (stat.ne.0) write(*,*)'ERROR: could not allocate ireleasestart'
+ allocate(ireleaseend(numpoint),stat=stat)
+ if (stat.ne.0) write(*,*)'ERROR: could not allocate ireleaseend'
+ allocate(xpoint1(numpoint),stat=stat)
+ if (stat.ne.0) write(*,*)'ERROR: could not allocate xpoint1'
+ allocate(xpoint2(numpoint),stat=stat)
+ if (stat.ne.0) write(*,*)'ERROR: could not allocate xpoint2'
+ allocate(ypoint1(numpoint),stat=stat)
+ if (stat.ne.0) write(*,*)'ERROR: could not allocate ypoint1'
+ allocate(ypoint2(numpoint),stat=stat)
+ if (stat.ne.0) write(*,*)'ERROR: could not allocate ypoint2'
+ allocate(zpoint1(numpoint),stat=stat)
+ if (stat.ne.0) write(*,*)'ERROR: could not allocate zpoint1'
+ allocate(zpoint2(numpoint),stat=stat)
+ if (stat.ne.0) write(*,*)'ERROR: could not allocate zpoint2'
+ allocate(kindz(numpoint),stat=stat)
+ if (stat.ne.0) write(*,*)'ERROR: could not allocate kindz'
+ allocate(xmass(numpoint,maxspec),stat=stat)
+ if (stat.ne.0) write(*,*)'ERROR: could not allocate xmass'
+ allocate(rho_rel(numpoint),stat=stat)
+ if (stat.ne.0) write(*,*)'ERROR: could not allocate rho_rel'
+ allocate(npart(numpoint),stat=stat)
+ if (stat.ne.0) write(*,*)'ERROR: could not allocate npart'
+ allocate(xmasssave(numpoint),stat=stat)
+ if (stat.ne.0) write(*,*)'ERROR: could not allocate xmasssave'
+
+ if (lroot) write (*,*) 'Releasepoints : ', numpoint
+
+ do i=1,numpoint
+ xmasssave(i)=0.
+ end do
+
+ !now save the information
+ DEP=.false.
+ DRYDEP=.false.
+ WETDEP=.false.
+ OHREA=.false.
+ do i=1,maxspec
+ DRYDEPSPEC(i)=.false.
+ WETDEPSPEC(i)=.false.
+ end do
+
+ ! namelist output
+ if (nmlout.and.lroot) then
+ write(unitreleasesout,nml=releases_ctrl)
+ endif
+
+ do i=1,nspec
+ call readspecies(specnum_rel(i),i)
+
+
+ ! Allocate temporary memory necessary for the different diameter bins
+ !********************************************************************
+ allocate(vsh(ndia(i)),fracth(ndia(i)),schmih(ndia(i)))
+
+ ! Molecular weight
+ !*****************
+
+ if (((iout.eq.2).or.(iout.eq.3)).and.(weightmolar(i).lt.0.)) then
+ write(*,*) 'For mixing ratio output, valid molar weight'
+ write(*,*) 'must be specified for all simulated species.'
+ write(*,*) 'Check table SPECIES or choose concentration'
+ write(*,*) 'output instead if molar weight is not known.'
+ stop
+ endif
+
+ ! Radioactive decay
+ !******************
+
+ decay(i)=0.693147/decay(i) !conversion half life to decay constant
+
+
+ ! Dry deposition of gases
+ !************************
+
+ if (reldiff(i).gt.0.) rm(i)=1./(henry(i)/3000.+100.*f0(i)) ! mesophyll resistance
+
+ ! Dry deposition of particles
+ !****************************
+
+ vsetaver(i)=0.
+ cunningham(i)=0.
+ dquer(i)=dquer(i)*1000000. ! Conversion m to um
+ if (density(i).gt.0.) then ! Additional parameters
+ call part0(dquer(i),dsigma(i),density(i),ndia(i),fracth,schmih,cun,vsh)
+ do j=1,ndia(i)
+ fract(i,j)=fracth(j)
+ schmi(i,j)=schmih(j)
+ vset(i,j)=vsh(j)
+ cunningham(i)=cunningham(i)+cun*fract(i,j)
+ vsetaver(i)=vsetaver(i)-vset(i,j)*fract(i,j)
+ end do
+ if (lroot) write(*,*) 'Average settling velocity: ',i,vsetaver(i)
+ endif
+
+ ! Dry deposition for constant deposition velocity
+ !************************************************
+
+ dryvel(i)=dryvel(i)*0.01 ! conversion to m/s
+
+ ! Check if wet deposition or OH reaction shall be calculated
+ !***********************************************************
+
+ ! ESO 04.2016 check for below-cloud scavenging (gas or aerosol)
+ if ((dquer(i).le.0..and.(weta_gas(i).gt.0. .or. wetb_gas(i).gt.0.)) .or. &
+ &(dquer(i).gt.0. .and. (crain_aero(i) .gt. 0. .or. csnow_aero(i).gt.0.))) then
+ WETDEP=.true.
+ WETDEPSPEC(i)=.true.
+ if (lroot) then
+ write (*,*) ' Below-cloud scavenging: ON'
+ ! write (*,*) 'Below-cloud scavenging coefficients: ',weta(i),i
+ end if
+ else
+ if (lroot) write (*,*) ' Below-cloud scavenging: OFF'
+ endif
+
+ ! NIK 31.01.2013 + 10.12.2013 + 15.02.2015
+ if (dquer(i).gt.0..and.(ccn_aero(i).gt.0. .or. in_aero(i).gt.0.)) then
+ WETDEP=.true.
+ WETDEPSPEC(i)=.true.
+ if (lroot) then
+ write (*,*) ' In-cloud scavenging: ON'
+ ! write (*,*) 'In-cloud scavenging coefficients: ',&
+ ! &ccn_aero(i),in_aero(i),i !,wetc_in(i), wetd_in(i),i
+ end if
+ else
+ if (lroot) write (*,*) ' In-cloud scavenging: OFF'
+ endif
+
+ if (ohcconst(i).gt.0.) then
+ OHREA=.true.
+ if (lroot) write (*,*) ' OHreaction switched on: ',ohcconst(i),i
+ endif
+
+ if ((reldiff(i).gt.0.).or.(density(i).gt.0.).or.(dryvel(i).gt.0.)) then
+ DRYDEP=.true.
+ DRYDEPSPEC(i)=.true.
+ endif
+
+ deallocate(vsh,fracth,schmih)
+ end do ! end loop over species
+
+ if (WETDEP.or.DRYDEP) DEP=.true.
+
+ ! Not necessary to read releases when using part_ic.nc
+ !*****************************************************
+ if ((ipin.eq.3).or.(ipin.eq.4)) then
+ maxpointspec_act=1
+ return
+ endif
+
+ ! Read specifications for each release point
+ !*******************************************
+ numpoints=numpoint
+ numpoint=0
+ numpartmax=0
+ releaserate=0.
+101 numpoint=numpoint+1
+
+ if (numpoint.gt.numpoints) goto 250
+ zkind = 1
+ mass = 0
+ parts = 0
+ comment = ' '
+ read(unitreleases,release,iostat=readerror)
+ id1=idate1
+ it1=itime1
+ id2=idate2
+ it2=itime2
+ xpoint1(numpoint)=lon1
+ xpoint2(numpoint)=lon2
+ ypoint1(numpoint)=lat1
+ ypoint2(numpoint)=lat2
+ zpoint1(numpoint)=z1
+ zpoint2(numpoint)=z2
+ kindz(numpoint)=zkind
+ do i=1,nspec
+ xmass(numpoint,i)=mass(i)
+ end do
+ npart(numpoint)=parts
+ compoint(min(1001,numpoint))=comment
+
+! namelist output
+ if (nmlout.and.lroot) then
+ write(unitreleasesout,nml=release)
+ endif
+
+ ! If a release point contains no particles, stop and issue error message
+ !***********************************************************************
+
+ if (npart(numpoint).eq.0) then
+ write(*,*) 'FLEXPART MODEL ERROR'
+ write(*,*) 'RELEASES file is corrupt.'
+ write(*,*) 'At least for one release point, there are zero'
+ write(*,*) 'particles released. Make changes to RELEASES.'
+ stop
+ endif
+
+ ! If FLEXPART is run for backward deposition force zpoint
+ !*********************************************************************
+ if (WETBKDEP) then
+ zpoint1(numpoint)=0.
+ zpoint2(numpoint)=20000.
+ kindz(numpoint)=1
+ endif
+ if (DRYBKDEP) then
+ zpoint1(numpoint)=0.
+ zpoint2(numpoint)=2.*href
+ kindz(numpoint)=1
+ endif
+
+
+ ! Check whether x coordinates of release point are within model domain
+ !*********************************************************************
+
+ if (xpoint1(numpoint).lt.xlon0) &
+ xpoint1(numpoint)=xpoint1(numpoint)+360.
+ if (xpoint1(numpoint).gt.xlon0+(nxmin1)*dx) &
+ xpoint1(numpoint)=xpoint1(numpoint)-360.
+ if (xpoint2(numpoint).lt.xlon0) &
+ xpoint2(numpoint)=xpoint2(numpoint)+360.
+ if (xpoint2(numpoint).gt.xlon0+(nxmin1)*dx) &
+ xpoint2(numpoint)=xpoint2(numpoint)-360.
+
+ ! Determine relative beginning and ending times of particle release
+ !******************************************************************
+
+ jul1=juldate(id1,it1)
+ jul2=juldate(id2,it2)
+ julm=(jul1+jul2)/2.
+ if (jul1.gt.jul2) then
+ write(*,*) 'FLEXPART MODEL ERROR'
+ write(*,*) 'Release stops before it begins.'
+ write(*,*) 'Make changes to file RELEASES.'
+ stop
+ endif
+ if (mdomainfill.eq.0) then ! no domain filling
+ if (ldirect.eq.1) then
+ if (((jul1.lt.bdate).or.(jul2.gt.edate)).and.(ipin.eq.0)) then
+ write(*,*) 'FLEXPART MODEL ERROR'
+ write(*,*) 'Release starts before simulation begins or ends'
+ write(*,*) 'after simulation stops.'
+ write(*,*) 'Make files COMMAND and RELEASES consistent.'
+ stop
+ endif
+ if (npart(numpoint).gt.num_min_discrete) then
+ ireleasestart(numpoint)=int((jul1-bdate)*86400.)
+ ireleaseend(numpoint)=int((jul2-bdate)*86400.)
+ else
+ ireleasestart(numpoint)=int((julm-bdate)*86400.)
+ ireleaseend(numpoint)=int((julm-bdate)*86400.)
+ endif
+ else if (ldirect.eq.-1) then
+ if (((jul1.lt.edate).or.(jul2.gt.bdate)).and.(ipin.eq.0)) then
+ write(*,*) 'FLEXPART MODEL ERROR'
+ write(*,*) 'Release starts before simulation begins or ends'
+ write(*,*) 'after simulation stops.'
+ write(*,*) 'Make files COMMAND and RELEASES consistent.'
+ stop
+ endif
+ if (npart(numpoint).gt.num_min_discrete) then
+ ireleasestart(numpoint)=int((jul1-bdate)*86400.)
+ ireleaseend(numpoint)=int((jul2-bdate)*86400.)
+ else
+ ireleasestart(numpoint)=int((julm-bdate)*86400.)
+ ireleaseend(numpoint)=int((julm-bdate)*86400.)
+ endif
+ endif
+ endif
+
+
+ ! Determine the release rate (particles per second) and total number
+ ! of particles released during the simulation
+ !*******************************************************************
+
+ if (ireleasestart(numpoint).ne.ireleaseend(numpoint)) then
+ releaserate=releaserate+real(npart(numpoint))/ &
+ real(ireleaseend(numpoint)-ireleasestart(numpoint))
+ else
+ releaserate=99999999
+ endif
+ numpartmax=numpartmax+npart(numpoint)
+ goto 101
+
+250 close(unitreleases)
+
+ if (nmlout.and.lroot) then
+ close(unitreleasesout)
+ endif
+
+ !if (lroot) write (*,*) 'Particles allocated (maxpart) : ',maxpart
+ if (lroot) write (*,*) 'Particles released (numpartmax): ',numpartmax
+ numpoint=numpoint-1
+
+ if (ioutputforeachrelease.eq.1) then
+ maxpointspec_act=numpoint
+ else
+ maxpointspec_act=1
+ endif
+
+ ! Disable settling if more than 1 species at any release point
+ ! or if MQUASILAG and more than one species
+ !*************************************************************
+
+ if (mquasilag.ne.0) then
+ if (nspec.gt.1) lsettling=.false.
+ else
+ do irel=1,numpoint
+ nsettle=0
+ do ispc=1,nspec
+ if (xmass(irel,ispc).gt.eps2) nsettle=nsettle+1
+ end do
+ if (nsettle.gt.1) lsettling=.false.
+ end do
+ end if
+
+ if (lroot) then
+ if (.not.lsettling) then
+ write(*,*) 'WARNING: more than 1 species per release point, settling &
+ &disabled'
+ end if
+ end if
+
+ ! Check, whether the total number of particles may exceed totally allowed
+ ! number of particles at some time during the simulation
+ !************************************************************************
+
+ ! if (releaserate.gt. &
+ ! 0.99*real(maxpart)/real(lage(nageclass))) then
+ ! if (numpartmax.gt.maxpart.and.lroot) then
+ ! write(*,*) '#####################################################'
+ ! write(*,*) '#### FLEXPART MODEL SUBROUTINE READRELEASES: ####'
+ ! write(*,*) '#### ####'
+ ! write(*,*) '####WARNING - TOTAL NUMBER OF PARTICLES SPECIFIED####'
+ ! write(*,*) '#### IN FILE "RELEASES" MAY AT SOME POINT DURING ####'
+ ! write(*,*) '#### THE SIMULATION EXCEED THE MAXIMUM ALLOWED ####'
+ ! write(*,*) '#### NUMBER (MAXPART).IF RELEASES DO NOT OVERLAP,####'
+ ! write(*,*) '#### FLEXPART CAN POSSIBLY COMPLETE SUCCESSFULLY.####'
+ ! write(*,*) '#### HOWEVER, FLEXPART MAY HAVE TO STOP ####'
+ ! write(*,*) '#### AT SOME TIME DURING THE SIMULATION. PLEASE ####'
+ ! write(*,*) '#### MAKE SURE THAT YOUR SETTINGS ARE CORRECT. ####'
+ ! write(*,*) '#####################################################'
+ ! write(*,*) 'Maximum release rate may be: ',releaserate, &
+ ! ' particles per second'
+ ! write(*,*) 'Maximum allowed release rate is: ', &
+ ! real(maxpart)/real(lage(nageclass)),' particles per second'
+ ! write(*,*) &
+ ! 'Total number of particles released during the simulation is: ', &
+ ! numpartmax
+ ! write(*,*) 'Maximum allowed number of particles is: ',maxpart
+ ! endif
+ ! endif
+
+
+ if (lroot) then
+ write(*,FMT='(A,ES14.7)') ' Total mass released:', sum(xmass(1:numpoint,1:nspec))
+ end if
+
+ return
+
+994 write(*,*) '#####################################################'
+ write(*,*) '#### FLEXPART MODEL SUBROUTINE READRELEASES: ####'
+ write(*,*) '#### ####'
+ write(*,*) '#### ERROR - MAXIMUM NUMBER OF EMITTED SPECIES IS####'
+ write(*,*) '#### TOO LARGE. PLEASE REDUCE NUMBER OF SPECIES. ####'
+ write(*,*) '#####################################################'
+ stop
+
+998 write(*,*) '#####################################################'
+ write(*,*) '#### FLEXPART MODEL SUBROUTINE READRELEASES: ####'
+ write(*,*) '#### ####'
+ write(*,*) '#### FATAL ERROR - FILE "RELEASES" IS ####'
+ write(*,*) '#### CORRUPT. PLEASE CHECK YOUR INPUTS FOR ####'
+ write(*,*) '#### MISTAKES OR GET A NEW "RELEASES"- ####'
+ write(*,*) '#### FILE ... ####'
+ write(*,*) '#####################################################'
+ stop
+
+
+999 write(*,*) '#####################################################'
+ write(*,*) ' FLEXPART MODEL SUBROUTINE READRELEASES: '
+ write(*,*)
+ write(*,*) 'FATAL ERROR - FILE CONTAINING PARTICLE RELEASE POINTS'
+ write(*,*) 'POINTS IS NOT AVAILABLE OR YOU ARE NOT'
+ write(*,*) 'PERMITTED FOR ANY ACCESS'
+ write(*,*) '#####################################################'
+ stop
+
+1000 write(*,*) ' #### FLEXPART MODEL ERROR! FILE "RELEASES" #### '
+ write(*,*) ' #### CANNOT BE OPENED IN THE DIRECTORY #### '
+ write(*,'(a)') path(2)(1:length(2))
+ stop
+end subroutine readreleases
+
+subroutine readspecies(id_spec,pos_spec)
+
+ !*****************************************************************************
+ ! *
+ ! This routine reads names and physical constants of chemical species/ *
+ ! radionuclides given in the parameter pos_spec *
+ ! *
+ ! Author: A. Stohl *
+ ! *
+ ! 11 July 1996 *
+ ! *
+ ! Changes: *
+ ! N. Kristiansen, 31.01.2013: Including parameters for in-cloud scavenging *
+ ! *
+ ! HSO, 13 August 2013
+ ! added optional namelist input
+ ! *
+ !*****************************************************************************
+ ! *
+ ! Variables: *
+ ! decaytime(maxtable) half time for radiological decay *
+ ! specname(maxtable) names of chemical species, radionuclides *
+ ! weta_gas, wetb_gas Parameters for below-cloud scavenging of gasses *
+ ! crain_aero,csnow_aero Parameters for below-cloud scavenging of aerosols *
+ ! ccn_aero,in_aero Parameters for in-cloud scavenging of aerosols *
+ ! ohcconst OH reaction rate constant C *
+ ! ohdconst OH reaction rate constant D *
+ ! ohnconst OH reaction rate constant n *
+ ! id_spec SPECIES number as referenced in RELEASE file *
+ ! id_pos position where SPECIES data shall be stored *
+ ! ni Number of diameter classes of particles * *
+ ! Constants: *
+ ! *
+ !*****************************************************************************
+
+ implicit none
+
+ integer :: i, pos_spec,j
+ integer :: idow,ihour,id_spec
+ character(len=3) :: aspecnumb
+ logical :: spec_found
+
+ character(len=16) :: pspecies
+ character(len=50) :: line
+ real :: pdecay, pweta_gas, pwetb_gas, preldiff, phenry, pf0, pdensity, pdquer
+ real :: pdsigma, pdryvel, pweightmolar, pohcconst, pohdconst, pohnconst
+ real :: pcrain_aero, pcsnow_aero, pccn_aero, pin_aero
+ real :: parea_dow(7), parea_hour(24), ppoint_dow(7), ppoint_hour(24)
+ integer :: pndia
+ integer :: readerror
+ integer :: pshape,porient
+ ! Daria Tatsii: species shape properties
+ real ::pla,pia,psa,f,e,paspectratio
+ real :: la(maxspec),ia(maxspec),sa(maxspec) ! Axes
+
+ ! declare namelist
+ namelist /species_params/ &
+ pspecies, pdecay, pweta_gas, pwetb_gas, &
+ pcrain_aero, pcsnow_aero, pccn_aero, pin_aero, &
+ preldiff, phenry, pf0, pdensity, pdquer, &
+ pdsigma, pndia, pdryvel, pweightmolar, pohcconst, pohdconst, pohnconst, &
+ parea_dow, parea_hour, ppoint_dow, ppoint_hour, &
+ pshape, paspectratio, pla, pia, psa, porient
+
+ pspecies="" ! read failure indicator value
+ pdecay=-999.9
+ pweta_gas=-9.9E-09
+ pwetb_gas=0.0
+ pcrain_aero=-9.9E-09
+ pcsnow_aero=-9.9E-09
+ pccn_aero=-9.9E-09
+ pin_aero=-9.9E-09
+ preldiff=-9.9
+ phenry=0.0
+ pf0=0.0
+ pdensity=-9.9E09
+ pdquer=0.0
+ pdsigma=0.0
+ pndia=1
+ pdryvel=-9.99
+ pohcconst=-9.99
+ pohdconst=-9.9E-09
+ pohnconst=2.0
+ pweightmolar=-999.9
+ parea_dow=-999.9
+ parea_hour=-999.9
+ ppoint_dow=-999.9
+ ppoint_hour=-999.9
+ pshape=0 ! 0 for sphere, 1 for other shapes
+ paspectratio=-1.
+ pla=-1. ! longest axis in micrometer
+ pia=-1. ! Intermediate axis
+ psa=-1. ! Smallest axis
+ porient=0 ! 0 for horizontal, 1 for random
+
+
+ do j=1,24 ! initialize everything to no variation
+ parea_hour(j)=1.
+ ppoint_hour(j)=1.
+ area_hour(pos_spec,j)=1.
+ point_hour(pos_spec,j)=1.
+ end do
+ do j=1,7
+ parea_dow(j)=1.
+ ppoint_dow(j)=1.
+ area_dow(pos_spec,j)=1.
+ point_dow(pos_spec,j)=1.
+ end do
+
+ ! Open the SPECIES file and read species names and properties
+ !************************************************************
+ specnum(pos_spec)=id_spec
+ write(aspecnumb,'(i3.3)') specnum(pos_spec)
+ open(unitspecies,file=path(1)(1:length(1))//'SPECIES/SPECIES_'//aspecnumb,status='old',form='formatted',err=998)
+ write(*,*) 'reading SPECIES',specnum(pos_spec)
+
+ ASSSPEC=.FALSE.
+
+ ! try namelist input
+ read(unitspecies,species_params,iostat=readerror)
+ !CGZ add check on which line of species file problem occurs
+ if (readerror.ne.0) then
+ backspace(unitspecies)
+ read(unitspecies,fmt='(A)') line
+ if (lroot) write(*,*) &
+ 'Invalid line in species: '//trim(line)
+ end if
+ close(unitspecies)
+
+ if ((len(trim(pspecies)).eq.0).or.(readerror.ne.0)) then ! no namelist found
+ if (lroot) write(*,*) "SPECIES file not in NAMELIST format, attempting to &
+ &read as fixed format"
+
+ readerror=1
+
+ open(unitspecies,file=path(1)(1:length(1))//'SPECIES/SPECIES_'//aspecnumb,status='old',err=998)
+
+ do i=1,6
+ read(unitspecies,*)
+ end do
+
+ read(unitspecies,'(a10)',end=22) species(pos_spec)
+ ! write(*,*) species(pos_spec)
+ read(unitspecies,'(f18.1)',end=22) decay(pos_spec)
+ ! write(*,*) decay(pos_spec)
+ read(unitspecies,'(e18.1)',end=22) weta_gas(pos_spec)
+ ! write(*,*) weta_gas(pos_spec)
+ read(unitspecies,'(f18.2)',end=22) wetb_gas(pos_spec)
+ ! write(*,*) wetb_gas(pos_spec)
+ read(unitspecies,'(e18.1)',end=22) crain_aero(pos_spec)
+ ! write(*,*) crain_aero(pos_spec)
+ read(unitspecies,'(f18.2)',end=22) csnow_aero(pos_spec)
+ ! write(*,*) csnow_aero(pos_spec)
+ !*** NIK 31.01.2013: including in-cloud scavening parameters
+ read(unitspecies,'(e18.1)',end=22) ccn_aero(pos_spec)
+ ! write(*,*) ccn_aero(pos_spec)
+ read(unitspecies,'(f18.2)',end=22) in_aero(pos_spec)
+ ! write(*,*) in_aero(pos_spec)
+ read(unitspecies,'(f18.1)',end=22) reldiff(pos_spec)
+ ! write(*,*) reldiff(pos_spec)
+ read(unitspecies,'(e18.1)',end=22) henry(pos_spec)
+ ! write(*,*) henry(pos_spec)
+ read(unitspecies,'(f18.1)',end=22) f0(pos_spec)
+ ! write(*,*) f0(pos_spec)
+ read(unitspecies,'(e18.1)',end=22) density(pos_spec)
+ ! write(*,*) density(pos_spec)
+ read(unitspecies,'(e18.1)',end=22) dquer(pos_spec)
+ ! write(*,*) 'dquer(pos_spec):', dquer(pos_spec)
+ read(unitspecies,'(e18.1)',end=22) dsigma(pos_spec)
+ ! write(*,*) dsigma(pos_spec)
+ read(unitspecies,'(i16)',end=22) ndia(pos_spec)
+ ! write(*,*) ndia(pos_spec)
+ read(unitspecies,'(f18.2)',end=22) dryvel(pos_spec)
+ ! write(*,*) dryvel(pos_spec)
+ read(unitspecies,'(f18.2)',end=22) weightmolar(pos_spec)
+ ! write(*,*) weightmolar(pos_spec)
+ read(unitspecies,'(e18.2)',end=22) ohcconst(pos_spec)
+ ! write(*,*) ohcconst(pos_spec)
+ read(unitspecies,'(f8.2)',end=22) ohdconst(pos_spec)
+ ! write(*,*) ohdconst(pos_spec)
+ read(unitspecies,'(f8.2)',end=22) ohnconst(pos_spec)
+ ! write(*,*) ohnconst(pos_spec)
+
+ ! Read in daily and day-of-week variation of emissions, if available
+ !*******************************************************************
+
+ read(unitspecies,*,end=22)
+ do j=1,24 ! 24 hours, starting with 0-1 local time
+ read(unitspecies,*) ihour,area_hour(pos_spec,j),point_hour(pos_spec,j)
+ end do
+ read(unitspecies,*)
+ do j=1,7 ! 7 days of the week, starting with Monday
+ read(unitspecies,*) idow,area_dow(pos_spec,j),point_dow(pos_spec,j)
+ end do
+
+ pspecies=species(pos_spec)
+ pdecay=decay(pos_spec)
+ pweta_gas=weta_gas(pos_spec)
+ pwetb_gas=wetb_gas(pos_spec)
+ pcrain_aero=crain_aero(pos_spec)
+ pcsnow_aero=csnow_aero(pos_spec)
+ pccn_aero=ccn_aero(pos_spec)
+ pin_aero=in_aero(pos_spec)
+ preldiff=reldiff(pos_spec)
+ phenry=henry(pos_spec)
+ pf0=f0(pos_spec)
+ pdensity=density(pos_spec)
+ pdquer=dquer(pos_spec)
+ pdsigma=dsigma(pos_spec)
+ pndia=ndia(pos_spec)
+ pdryvel=dryvel(pos_spec)
+ pweightmolar=weightmolar(pos_spec)
+ pohcconst=ohcconst(pos_spec)
+ pohdconst=ohdconst(pos_spec)
+ pohnconst=ohnconst(pos_spec)
+
+
+ do j=1,24 ! 24 hours, starting with 0-1 local time
+ parea_hour(j)=area_hour(pos_spec,j)
+ ppoint_hour(j)=point_hour(pos_spec,j)
+ end do
+ do j=1,7 ! 7 days of the week, starting with Monday
+ parea_dow(j)=area_dow(pos_spec,j)
+ ppoint_dow(j)=point_dow(pos_spec,j)
+ end do
+
+ else ! namelist available
+
+ species(pos_spec)=pspecies
+ decay(pos_spec)=pdecay
+ weta_gas(pos_spec)=pweta_gas
+ wetb_gas(pos_spec)=pwetb_gas
+ crain_aero(pos_spec)=pcrain_aero
+ csnow_aero(pos_spec)=pcsnow_aero
+ ccn_aero(pos_spec)=pccn_aero
+ in_aero(pos_spec)=pin_aero
+ reldiff(pos_spec)=preldiff
+ henry(pos_spec)=phenry
+ f0(pos_spec)=pf0
+ density(pos_spec)=pdensity
+ dquer(pos_spec)=pdquer
+ dsigma(pos_spec)=pdsigma
+ ndia(pos_spec)=pndia
+ dryvel(pos_spec)=pdryvel
+ weightmolar(pos_spec)=pweightmolar
+ ohcconst(pos_spec)=pohcconst
+ ohdconst(pos_spec)=pohdconst
+ ohnconst(pos_spec)=pohnconst
+ shape(pos_spec)=pshape
+ orient(pos_spec)=porient
+
+
+ ! Daria Tatsii 2023: compute particle shape dimensions
+ if (shape(pos_spec).ge.1) then ! Compute shape according to given axes
+ select case (shape(pos_spec))
+ case (1)
+ write(*,*) "Particle shape USER-DEFINED for particle", id_spec
+ if ((psa.le.0.0).or.(pia.le.0.0).or.(pla.le.0.0)) then
+ write(*,*) "#### ERROR: Shape=1 (user-defined) is chosen, but no valid axes are provided."
+ write(*,*) "#### SPECIES file requires SA, IA, and LA parameter greater than zero."
+ stop
+ endif
+ write(*,*) "SA,IA,LA:",psa,pia,pla
+ case (2) ! Cylinders (fibers) !
+ if (paspectratio.le.0.0) then
+ write(*,*) "#### ERROR: Shape=2 cylinder is chosen, but no valid apect ratio is provided."
+ write(*,*) "#### SPECIES file requires ASPECTRATIO parameter greater than zero."
+ stop
+ endif
+ psa=(((dquer(pos_spec)**3.0)*2.0)/ &
+ (3.0*paspectratio))**(1.0/3.0)
+ pia=psa
+ pla=psa*paspectratio
+ write(*,*) "Particle shape CYLINDER for particle", id_spec
+ write(*,*) "SA,IA,LA:",psa,pia,pla
+ case (3) ! Cubes !
+ write(*,*) "Particle shape CUBE for particle", id_spec
+ psa=((dquer(pos_spec)**3)*pi/6.0)**(1.0/3.0)
+ pia=(2.0**0.5)*psa
+ pla=(3.0**0.5)*psa
+ if ((psa.le.0.0).or.(pia.le.0.0).or.(pla.le.0.0)) then
+ write(*,*) "#### ERROR: Shape=3 (user-defined) is chosen, but no valid axes are provided."
+ write(*,*) "#### SPECIES file requires SA, IA, and LA parameter greater than zero."
+ stop
+ endif
+ write(*,*) "SA,IA,LA:",psa,pia,pla
+ case (4) ! Tetrahedrons !
+ write(*,*) "Particle shape TETRAHEDRON for particle", id_spec
+ pla=((dquer(pos_spec)**3)*pi*2**(0.5))**(1.0/3.0)
+ pia=pla*((3.0/4.0)**(0.5))
+ psa=pla*((2.0/3.0)**(0.5))
+ if ((psa.le.0.0).or.(pia.le.0.0).or.(pla.le.0.0)) then
+ write(*,*) "#### ERROR: Shape=4 (user-defined) is chosen, but no valid axes are provided."
+ write(*,*) "#### SPECIES file requires SA, IA, and LA parameter greater than zero."
+ stop
+ endif
+ write(*,*) "SA,IA,LA:",psa,pia,pla
+ case (5) ! Octahedrons !
+ write(*,*) "Particle shape OCTAHEDRON for particle", id_spec
+ psa=dquer(pos_spec)*(pi/(2.0*2.0**(0.5)))**3
+ pia=psa
+ pla=psa*(2.0**(0.5))
+ if ((psa.le.0.0).or.(pia.le.0.0).or.(pla.le.0.0)) then
+ write(*,*) "#### ERROR: Shape=5 (user-defined) is chosen, but no valid axes are provided."
+ write(*,*) "#### SPECIES file requires SA, IA, and LA parameter greater than zero."
+ stop
+ endif
+ write(*,*) "SA,IA,LA:",psa,pia,pla
+ case (6) ! Ellipsoids !
+ write(*,*) "Particle shape ELLIPSOID for particle", id_spec
+ psa=dquer(pos_spec)/(2.0**(1.0/3.0))
+ pia=psa
+ pla=2*pia
+ if ((psa.le.0.0).or.(pia.le.0.0).or.(pla.le.0.0)) then
+ write(*,*) "#### ERROR: Shape=6 (user-defined) is chosen, but no valid axes are provided."
+ write(*,*) "#### SPECIES file requires SA, IA, and LA parameter greater than zero."
+ stop
+ endif
+ write(*,*) "SA,IA,LA:",psa,pia,pla
+ end select
+
+ ! When using the shape option, dquer is the sphere equivalent diameter
+ f=psa/pia
+ e=pia/pla
+ Fn(pos_spec)=f*f*e*((dquer(pos_spec))**3)/(psa*pia*pla) ! Newton's regime
+ Fs(pos_spec)=f*e**(1.3)*(dquer(pos_spec)**3/(psa*pia*pla)) ! Stokes' regime
+ else ! Spheres
+ write(*,*) "Particle shape SPHERE for particle", id_spec
+ endif
+
+ do j=1,24 ! 24 hours, starting with 0-1 local time
+ area_hour(pos_spec,j)=parea_hour(j)
+ point_hour(pos_spec,j)=ppoint_hour(j)
+ end do
+ do j=1,7 ! 7 days of the week, starting with Monday
+ area_dow(pos_spec,j)=parea_dow(j)
+ point_dow(pos_spec,j)=ppoint_dow(j)
+ end do
+ endif
+
+ i=pos_spec
+
+ !NIK 16.02.2015
+ ! Check scavenging parameters given in SPECIES file
+
+ if (lroot) then
+ ! ZHG 2016.04.07 Start of changes
+ write(*,*) ' '
+ if (dquer(pos_spec) .gt.0) write(*,'(a,i3,a,a,a)') ' SPECIES: ', &
+ id_spec,' ', species(pos_spec),' (AEROSOL) '
+ if (dquer(pos_spec) .le.0) write(*,'(a,i3,a,a,a)') ' SPECIES: ', &
+ id_spec,' ', species(pos_spec),' (GAS) '
+
+ ! Particles
+ !**********
+ if (dquer(pos_spec).gt.0) then
+ if (ccn_aero(pos_spec) .gt. 0) then
+ write(*,'(a,f5.2)') ' Particle CCN efficiency (CCNeff):', ccn_aero(pos_spec)
+ else
+ write(*,'(a)') ' Particle CCN efficiency (CCNeff): OFF'
+ endif
+ if (in_aero(pos_spec) .gt. 0) then
+ write(*,'(a,f5.2)') ' Particle IN efficiency (INeff) :', in_aero(pos_spec)
+ else
+ write(*,'(a)') ' Particle IN efficiency (INeff) : OFF'
+ endif
+ if (crain_aero(pos_spec) .gt. 0) then
+ write(*,'(a,f5.2)') ' Particle Rain efficiency (Crain) :', crain_aero(pos_spec)
+ else
+ write(*,'(a)') ' Particle Rain efficiency (Crain) : OFF'
+ endif
+ if (csnow_aero(pos_spec) .gt. 0) then
+ write(*,'(a,f5.2)') ' Particle Snow efficiency (Csnow) :', csnow_aero(pos_spec)
+ else
+ write(*,'(a)') ' Particle Snow efficiency (Csnow) : OFF'
+ end if
+ if (density(pos_spec) .gt. 0) then
+ write(*,'(a)') ' Dry deposition is turned : ON'
+ if (reldiff(pos_spec).gt.0) then
+ stop 'density>0 (SPECIES is a particle) implies reldiff <=0 '
+ endif
+ else
+ if (reldiff(pos_spec).le.0) then
+ stop 'density<=0 (SPECIES is a gas) implies reldiff >0 '
+ endif
+ write(*,'(a)') ' Dry deposition is (density<0) : OFF'
+ end if
+ if (crain_aero(pos_spec).gt.10.0 .or. csnow_aero(pos_spec).gt.10.0 .or. &
+ &ccn_aero(pos_spec).gt.1.0 .or. in_aero(pos_spec).gt.1.0) then
+ write(*,*) '*******************************************'
+ write(*,*) ' WARNING: Particle Scavenging parameter likely out of range '
+ write(*,*) ' Likely range for Crain 0.0-10'
+ write(*,*) ' Likely range for Csnow 0.0-10'
+ write(*,*) ' Physical range for CCNeff 0.0-1'
+ write(*,*) ' Physical range for INeff 0.0-1'
+ write(*,*) '*******************************************'
+ end if
+ else
+ ! Gas
+ !****
+ if (weta_gas(pos_spec) .gt. 0 .and. wetb_gas(pos_spec).gt.0) then
+ write(*,*) ' Wet removal for gases is turned: ON'
+ write(*,*) ' Gas below-cloud scavenging parameter A ', &
+ &weta_gas(pos_spec)
+ write(*,'(a,f5.2)') ' Gas below-cloud scavenging parameter B ', &
+ &wetb_gas(pos_spec)
+ else
+ write(*,*) ' Wet removal for gases is turned: OFF '
+ end if
+ if (reldiff(i).gt.0.) then
+ write(*,*) ' Dry deposition for gases is turned: ON '
+ else
+ write(*,*) ' Dry deposition for gases is turned: OFF '
+ end if
+ if (weta_gas(pos_spec).gt.0.) then !if wet deposition is turned on
+ if (weta_gas(pos_spec).gt.1E-04 .or. weta_gas(pos_spec).lt.1E-09 .or. &
+ &wetb_gas(pos_spec).gt.0.8 .or. wetb_gas(pos_spec).lt.0.4) then
+ write(*,*) '*******************************************'
+ write(*,*) ' WARNING: Gas below-cloud scavengig is out of likely range'
+ write(*,*) ' Likely range for A is 1E-04 to 1E-08'
+ write(*,*) ' Likely range for B is 0.60 to 0.80 '
+ write(*,*) '*******************************************'
+ end if
+ endif
+
+ if (((weta_gas(pos_spec).gt.0).or.(wetb_gas(pos_spec).gt.0)).and.&
+ &(henry(pos_spec).le.0)) then
+ if (dquer(pos_spec).le.0) goto 996 ! no particle, no henry set
+ endif
+ end if
+ end if
+
+ if (ndia(pos_spec).gt.maxndia) then
+ write(*,*) 'NDIA in SPECIES file', pos_spec, 'set to', ndia(pos_spec), 'larger than maxndia', &
+ maxndia, 'set in par_mod.f90'
+ endif
+ ! if (dsigma(i).eq.0.) dsigma(i)=1.0001 ! avoid floating exception
+ if (dquer(i).gt.0 .and. dsigma(i).le.1.) then !dsigma(i)=1.0001 ! avoid floating exception
+ !write(*,*) '#### FLEXPART MODEL ERROR! ####'
+ write(*,*) '#### FLEXPART MODEL WARNING ####'
+ write(*,*) '#### in SPECIES_',aspecnumb, ' ####'
+ write(*,*) '#### from v10.4 dsigma has to be larger than 1 ####'
+ write(*,*) '#### to adapt older SPECIES files, ####'
+ write(*,*) '#### if dsigma was < 1 ####'
+ write(*,*) '#### use the reciprocal of the old dsigma ####'
+ if (.not.debug_mode) then
+ stop
+ else
+ write(*,*) 'debug mode: continue'
+ endif
+ endif
+
+ if ((reldiff(i).gt.0.).and.(density(i).gt.0.)) then
+ write(*,*) '#### FLEXPART MODEL ERROR! FILE "SPECIES" ####'
+ write(*,*) '#### IS CORRUPT. SPECIES CANNOT BE BOTH ####'
+ write(*,*) '#### PARTICLE AND GAS. ####'
+ write(*,*) '#### SPECIES NUMBER',aspecnumb
+ stop
+ endif
+20 continue
+
+
+22 close(unitspecies)
+
+! namelist output if requested
+ if (nmlout.and.lroot) then
+ open(unitspecies,file=path(2)(1:length(2))//'SPECIES_'//aspecnumb//'.namelist',access='append',status='replace',err=1000)
+ write(unitspecies,nml=species_params)
+ close(unitspecies)
+ endif
+
+ return
+
+996 write(*,*) '#####################################################'
+ write(*,*) '#### FLEXPART MODEL ERROR! #### '
+ write(*,*) '#### WET DEPOSITION SWITCHED ON, BUT NO HENRYS #### '
+ write(*,*) '#### CONSTANT IS SET ####'
+ write(*,*) '#### PLEASE MODIFY SPECIES DESCR. FILE! #### '
+ write(*,*) '#####################################################'
+ stop
+
+
+997 write(*,*) '#####################################################'
+ write(*,*) '#### FLEXPART MODEL ERROR! #### '
+ write(*,*) '#### THE ASSSOCIATED SPECIES HAS TO BE DEFINED #### '
+ write(*,*) '#### BEFORE THE ONE WHICH POINTS AT IT #### '
+ write(*,*) '#### PLEASE CHANGE ORDER IN RELEASES OR ADD #### '
+ write(*,*) '#### THE ASSOCIATED SPECIES IN RELEASES #### '
+ write(*,*) '#####################################################'
+ stop
+
+
+998 write(*,*) '#####################################################'
+ write(*,*) '#### FLEXPART MODEL ERROR! #### '
+ write(*,*) '#### THE SPECIES FILE FOR SPECIES ', id_spec
+ write(*,*) '#### CANNOT BE FOUND: CREATE FILE'
+ write(*,*) '#### ',path(1)(1:length(1)),'SPECIES/SPECIES_',aspecnumb
+ write(*,*) '#####################################################'
+ stop
+
+1000 write(*,*) ' #### FLEXPART MODEL ERROR! FILE "SPECIES_',aspecnumb,'.namelist'
+ write(*,*) ' #### CANNOT BE OPENED IN THE DIRECTORY #### '
+ write(*,'(a)') path(2)(1:length(2))
+ stop
+end subroutine readspecies
+
+subroutine readpartoptions
+
+ !*****************************************************************************
+ ! *
+ ! This routine reads the age classes to be used for the current model *
+ ! run. *
+ ! *
+ ! Author: A. Stohl *
+ ! 20 March 2000 *
+ ! HSO, 1 July 2014 *
+ ! Added optional namelist input *
+ ! *
+ !*****************************************************************************
+ ! *
+ ! Variables: *
+ ! *
+ ! Constants: *
+ ! *
+ !*****************************************************************************
+
+ implicit none
+
+ integer :: i,np
+
+ ! namelist help variables
+ integer :: readerror
+
+ logical :: &
+ longitude=.false., &
+ longitude_average=.false., &
+ latitude=.false., &
+ latitude_average=.false., &
+ height=.false., &
+ height_average=.false., &
+ pv=.false., &
+ pv_average=.false., &
+ qv=.false., &
+ qv_average=.false., &
+ density=.false., &
+ density_average=.false., &
+ temperature=.false., &
+ temperature_average=.false., &
+ pressure=.false., &
+ pressure_average=.false., &
+ mixingheight=.false., &
+ mixingheight_average=.false., &
+ tropopause=.false., &
+ tropopause_average=.false., &
+ topography=.false., &
+ topography_average=.false., &
+ mass=.false., &
+ mass_average=.false., &
+ u=.false., &
+ u_average=.false., &
+ v=.false., &
+ v_average=.false., &
+ w=.false., &
+ w_average=.false., &
+ vsettling=.false., &
+ vsettling_average=.false., &
+ wetdeposition=.false., &
+ drydeposition=.false.
+
+ ! namelist declaration
+ namelist /partoptions/ &
+ longitude, &
+ longitude_average, &
+ latitude, &
+ latitude_average, &
+ height, &
+ height_average, &
+ pv, &
+ pv_average, &
+ qv, &
+ qv_average, &
+ density, &
+ density_average, &
+ temperature, &
+ temperature_average, &
+ pressure, &
+ pressure_average, &
+ mixingheight, &
+ mixingheight_average, &
+ tropopause, &
+ tropopause_average, &
+ topography, &
+ topography_average, &
+ mass, &
+ mass_average, &
+ u, &
+ u_average, &
+ v, &
+ v_average, &
+ w, &
+ w_average, &
+ vsettling, &
+ vsettling_average, &
+ wetdeposition, &
+ drydeposition
+
+ ! If age spectra claculation is switched on,
+ ! open the AGECLASSSES file and read user options
+ !************************************************
+
+ open(unitpartoptions,file=path(1)(1:length(1))//'PARTOPTIONS',form='formatted',status='old',err=9999)
+
+ ! try to read in as a namelist
+ read(unitpartoptions,partoptions,iostat=readerror)
+ close(unitpartoptions)
+
+ if (readerror.ne.0) then
+ write(*,*) 'Namelist error in PARTOPTIONS file', trim(path(1)(1:length(1))//'PARTOPTIONS')
+ stop
+ endif
+ allocate( partopt(num_partopt) )
+ ! Save values in particle options derived type
+ !*********************************************
+ partopt(1)%long_name='longitude'
+ partopt(1)%name='LO'
+ partopt(1)%print=longitude
+
+ partopt(2)%long_name='longitude_average'
+ partopt(2)%name='lo'
+ partopt(2)%print=longitude_average
+ partopt(2)%average=.true.
+
+ partopt(3)%long_name='latitude'
+ partopt(3)%name='LA'
+ partopt(3)%print=latitude
+
+ partopt(4)%long_name='latitude_average'
+ partopt(4)%name='la'
+ partopt(4)%print=latitude_average
+ partopt(4)%average=.true.
+
+ partopt(5)%long_name='height'
+ partopt(5)%name='ZZ'
+ partopt(5)%print=height
+
+ partopt(6)%long_name='height_average'
+ partopt(6)%name='zz'
+ partopt(6)%print=height_average
+ partopt(6)%average=.true.
+
+ partopt(7)%long_name='pv'
+ partopt(7)%name='PV'
+ partopt(7)%print=pv
+
+ partopt(8)%long_name='pv_average'
+ partopt(8)%name='pv'
+ partopt(8)%print=pv_average
+ partopt(8)%average=.true.
+
+ partopt(9)%long_name='qv'
+ partopt(9)%name='QV'
+ partopt(9)%print=qv
+
+ partopt(10)%long_name='qv_average'
+ partopt(10)%name='qv'
+ partopt(10)%print=qv_average
+ partopt(10)%average=.true.
+
+ partopt(11)%long_name='density'
+ partopt(11)%name='RH'
+ partopt(11)%print=density
+
+ partopt(12)%long_name='density_average'
+ partopt(12)%name='rh'
+ partopt(12)%print=density_average
+ partopt(12)%average=.true.
+
+ partopt(13)%long_name='temperature'
+ partopt(13)%name='TT'
+ partopt(13)%print=temperature
+
+ partopt(14)%long_name='temperature_average'
+ partopt(14)%name='tt'
+ partopt(14)%print=temperature_average
+ partopt(14)%average=.true.
+
+ partopt(15)%long_name='pressure'
+ partopt(15)%name='PR'
+ partopt(15)%print=pressure
+
+ partopt(16)%long_name='pressure_average'
+ partopt(16)%name='pr'
+ partopt(16)%print=pressure_average
+ partopt(16)%average=.true.
+
+ partopt(17)%long_name='mixingheight'
+ partopt(17)%name='HM'
+ partopt(17)%print=mixingheight
+
+ partopt(18)%long_name='mixingheight_average'
+ partopt(18)%name='hm'
+ partopt(18)%print=mixingheight_average
+ partopt(18)%average=.true.
+
+ partopt(19)%long_name='tropopause'
+ partopt(19)%name='TR'
+ partopt(19)%print=tropopause
+
+ partopt(20)%long_name='tropopause_average'
+ partopt(20)%name='tr'
+ partopt(20)%print=tropopause_average
+ partopt(20)%average=.true.
+
+ partopt(21)%long_name='topography'
+ partopt(21)%name='TO'
+ partopt(21)%print=topography
+
+ partopt(22)%long_name='topography_average'
+ partopt(22)%name='to'
+ partopt(22)%print=topography_average
+ partopt(22)%average=.true.
+
+ partopt(23)%long_name='mass'
+ partopt(23)%name='MA'
+ partopt(23)%print=mass
+
+ partopt(24)%long_name='mass_average'
+ partopt(24)%name='ma'
+ partopt(24)%print=mass_average
+ partopt(24)%average=.true.
+
+ partopt(25)%long_name='u'
+ partopt(25)%name='UU'
+ partopt(25)%print=u
+
+ partopt(26)%long_name='u_average'
+ partopt(26)%name='uu'
+ partopt(26)%print=u_average
+ partopt(26)%average=.true.
+
+ partopt(27)%long_name='v'
+ partopt(27)%name='VV'
+ partopt(27)%print=v
+
+ partopt(28)%long_name='v_average'
+ partopt(28)%name='vv'
+ partopt(28)%print=v_average
+ partopt(28)%average=.true.
+
+ partopt(29)%long_name='w'
+ partopt(29)%name='WW'
+ partopt(29)%print=w
+
+ partopt(30)%long_name='w_average'
+ partopt(30)%name='ww'
+ partopt(30)%print=w_average
+ partopt(30)%average=.true.
+
+ partopt(31)%long_name='vsettling'
+ partopt(31)%name='VS'
+ partopt(31)%print=vsettling
+
+ partopt(32)%long_name='vsettling_average'
+ partopt(32)%name='vs'
+ partopt(32)%print=vsettling_average
+ partopt(32)%average=.true.
+
+ partopt(33)%long_name='wetdeposition'
+ partopt(33)%name='WD'
+ partopt(33)%print=wetdeposition
+
+ partopt(34)%long_name='drydeposition'
+ partopt(34)%name='DD'
+ partopt(34)%print=drydeposition
+ ! Numbers are assigned to the averaged fields for proper
+ ! allocation and reading in particle_mod and output_mod
+ !******************************************************
+ n_average=0
+ do np=1,num_partopt
+ if (partopt(np)%average .and. partopt(np)%print) then
+ n_average=n_average+1
+ partopt(np)%i_average = n_average
+ if ((partopt(np)%name.eq.'MA') .or. (partopt(np)%name.eq.'ma')) then
+ n_average=n_average + (maxspec-1)
+ endif
+ endif
+ end do
+
+ ! write partoptions file in namelist format to output directory if requested
+ if (nmlout.and.lroot) then
+ open(unitpartoptions,file=path(2)(1:length(2))//'PARTOPTIONS.namelist',err=10000)
+ write(unitpartoptions,nml=partoptions)
+ close(unitpartoptions)
+ endif
+
+
+ ! Restart files, when using in combination with averaged particle output,
+ ! need to be synchronised to prevent false averages in the first step of
+ ! the new run
+ !************************************************************************
+ if ((ipout.ne.0).and.(n_average.gt.0).and.(loutrestart.ne.-1)) then
+ if (mod(loutrestart,ipoutfac*loutstep).ne.0) then
+ write(*,*) '### FLEXPART MODEL ERROR! FILE COMMAND: ###'
+ write(*,*) '### LOUTRESTART NEEDS TO BE DIVISABLE BY ###'
+ write(*,*) '### LOUTSTEP*IPOUTFAC. ###'
+ stop
+ endif
+ endif
+
+ return
+
+9999 write(*,*) ' #### FLEXPART MODEL ERROR! FILE "PARTOPTIONS" #### '
+ write(*,*) ' #### CANNOT BE OPENED IN THE DIRECTORY #### '
+ write(*,'(a)') path(1)(1:length(1))
+ stop
+
+10000 write(*,*) ' #### FLEXPART MODEL ERROR! FILE "PARTOPTIONS" #### '
+ write(*,*) ' #### CANNOT BE OPENED IN THE DIRECTORY #### '
+ write(*,'(a)') path(2)(1:length(2))
+ stop
+end subroutine readpartoptions
+
+subroutine skplin(nlines,iunit)
+ ! i i
+ !*****************************************************************************
+ ! *
+ ! This routine reads nlines from unit iunit and discards them *
+ ! *
+ ! Authors: Petra Seibert *
+ ! *
+ ! 31 Dec 1998 *
+ ! *
+ !*****************************************************************************
+ ! *
+ ! Variables: *
+ ! *
+ ! iunit unit number from which lines are to be skipped *
+ ! nlines number of lines to be skipped *
+ ! *
+ !*****************************************************************************
+
+ implicit none
+
+ integer :: i,iunit, nlines
+
+ do i=1,nlines
+ read(iunit,*)
+ end do
+
+end subroutine skplin
+
+end module readoptions_mod
diff --git a/src/redist.f90 b/src/redist.f90
deleted file mode 100644
index fa8f85c5..00000000
--- a/src/redist.f90
+++ /dev/null
@@ -1,238 +0,0 @@
-! SPDX-FileCopyrightText: FLEXPART 1998-2019, see flexpart_license.txt
-! SPDX-License-Identifier: GPL-3.0-or-later
-
-subroutine redist (ipart,ktop,ipconv)
-
- !**************************************************************************
- ! Do the redistribution of particles due to convection
- ! This subroutine is called for each particle which is assigned
- ! a new vertical position randomly, based on the convective redistribution
- ! matrix
- !**************************************************************************
-
- ! Petra Seibert, Feb 2001, Apr 2001, May 2001, Jan 2002, Nov 2002 and
- ! Andreas Frank, Nov 2002
-
- ! Caroline Forster: November 2004 - February 2005
-
- use par_mod
- use com_mod
- use conv_mod
- use random_mod
-
- implicit none
-
- real,parameter :: const=r_air/ga
- integer :: ipart, ktop,ipconv
- integer :: k, kz, levnew, levold
- real,save :: uvzlev(nuvzmax)
- real :: wsub(nuvzmax)
- real :: totlevmass, wsubpart
- real :: temp_levold,temp_levold1
- real :: sub_levold,sub_levold1
- real :: pint, pold, rn, tv, tvold, dlevfrac
- real :: ew,ztold,ffraction
- real :: tv1, tv2, dlogp, dz, dz1, dz2
- integer :: iseed = -88
-
-
-
- ! ipart ... number of particle to be treated
-
- ipconv=1
-
- ! determine height of the eta half-levels (uvzlev)
- ! do that only once for each grid column
- ! i.e. when ktop.eq.1
- !**************************************************************
-
- if (ktop .le. 1) then
-
- tvold=tt2conv*(1.+0.378*ew(td2conv)/psconv)
- pold=psconv
- uvzlev(1)=0.
-
- pint = phconv(2)
- ! determine next virtual temperatures
- tv1 = tconv(1)*(1.+0.608*qconv(1))
- tv2 = tconv(2)*(1.+0.608*qconv(2))
- ! interpolate virtual temperature to half-level
- tv = tv1 + (tv2-tv1)*(pconv(1)-phconv(2))/(pconv(1)-pconv(2))
- if (abs(tv-tvold).gt.0.2) then
- uvzlev(2) = uvzlev(1) + &
- const*log(pold/pint)* &
- (tv-tvold)/log(tv/tvold)
- else
- uvzlev(2) = uvzlev(1)+ &
- const*log(pold/pint)*tv
- endif
- tvold=tv
- tv1=tv2
- pold=pint
-
- ! integrate profile (calculation of height agl of eta layers) as required
- do kz = 3, nconvtop+1
- ! note that variables defined in calcmatrix.f (pconv,tconv,qconv)
- ! start at the first real ECMWF model level whereas kz and
- ! thus uvzlev(kz) starts at the surface. uvzlev is defined at the
- ! half-levels (between the tconv, qconv etc. values !)
- ! Thus, uvzlev(kz) is the lower boundary of the tconv(kz) cell.
- pint = phconv(kz)
- ! determine next virtual temperatures
- tv2 = tconv(kz)*(1.+0.608*qconv(kz))
- ! interpolate virtual temperature to half-level
- tv = tv1 + (tv2-tv1)*(pconv(kz-1)-phconv(kz))/ &
- (pconv(kz-1)-pconv(kz))
- if (abs(tv-tvold).gt.0.2) then
- uvzlev(kz) = uvzlev(kz-1) + &
- const*log(pold/pint)* &
- (tv-tvold)/log(tv/tvold)
- else
- uvzlev(kz) = uvzlev(kz-1)+ &
- const*log(pold/pint)*tv
- endif
- tvold=tv
- tv1=tv2
- pold=pint
-
- end do
-
- ktop = 2
-
- endif ! (if ktop .le. 1) then
-
- ! determine vertical grid position of particle in the eta system
- !****************************************************************
-
- ztold = ztra1(abs(ipart))
- ! find old particle grid position
- do kz = 2, nconvtop
- if (uvzlev(kz) .ge. ztold ) then
- levold = kz-1
- goto 30
- endif
- end do
-
- ! Particle is above the potentially convective domain. Skip it.
- goto 90
-
-30 continue
-
- ! now redistribute particles
- !****************************
-
- ! Choose a random number and find corresponding level of destination
- ! Random numbers to be evenly distributed in [0,1]
-
- rn = ran3(iseed)
-
- ! initialize levnew
-
- levnew = levold
-
- ffraction = 0.
- totlevmass=dpr(levold)/ga
- do k = 1,nconvtop
- ! for backward runs use the transposed matrix
- if (ldirect.eq.1) then
- ffraction=ffraction+fmassfrac(levold,k) &
- /totlevmass
- else
- ffraction=ffraction+fmassfrac(k,levold) &
- /totlevmass
- endif
- if (rn.le.ffraction) then
- levnew=k
- ! avoid division by zero or a too small number
- ! if division by zero or a too small number happens the
- ! particle is assigned to the center of the grid cell
- if (ffraction.gt.1.e-20) then
- if (ldirect.eq.1) then
- dlevfrac = (ffraction-rn) / fmassfrac(levold,k) * totlevmass
- else
- dlevfrac = (ffraction-rn) / fmassfrac(k,levold) * totlevmass
- endif
- else
- dlevfrac = 0.5
- endif
- goto 40
- endif
- end do
-
-40 continue
-
- ! now assign new position to particle
-
- if (levnew.le.nconvtop) then
- if (levnew.eq.levold) then
- ztra1(abs(ipart)) = ztold
- else
- dlogp = (1.-dlevfrac)* &
- (log(phconv(levnew+1))-log(phconv(levnew)))
- pint = log(phconv(levnew))+dlogp
- dz1 = pint - log(phconv(levnew))
- dz2 = log(phconv(levnew+1)) - pint
- dz = dz1 + dz2
- ztra1(abs(ipart)) = (uvzlev(levnew)*dz2+uvzlev(levnew+1)*dz1)/dz
- if (ztra1(abs(ipart)).lt.0.) &
- ztra1(abs(ipart))=-1.*ztra1(abs(ipart))
- if (ipconv.gt.0) ipconv=-1
- endif
- endif
-
- ! displace particle according to compensating subsidence
- ! this is done to those particles, that were not redistributed
- ! by the matrix
- !**************************************************************
-
- if (levnew.le.nconvtop.and.levnew.eq.levold) then
-
- ztold = ztra1(abs(ipart))
-
- ! determine compensating vertical velocity at the levels
- ! above and below the particel position
- ! increase compensating subsidence by the fraction that
- ! is displaced by convection to this level
-
- if (levold.gt.1) then
- temp_levold = tconv(levold-1) + &
- (tconv(levold)-tconv(levold-1)) &
- *(pconv(levold-1)-phconv(levold))/ &
- (pconv(levold-1)-pconv(levold))
- sub_levold = sub(levold)/(1.-sub(levold)/dpr(levold)*ga)
- wsub(levold)=-1.*sub_levold*r_air*temp_levold/(phconv(levold))
- else
- wsub(levold)=0.
- endif
-
- temp_levold1 = tconv(levold) + &
- (tconv(levold+1)-tconv(levold)) &
- *(pconv(levold)-phconv(levold+1))/ &
- (pconv(levold)-pconv(levold+1))
- sub_levold1 = sub(levold+1)/(1.-sub(levold+1)/dpr(levold+1)*ga)
- wsub(levold+1)=-1.*sub_levold1*r_air*temp_levold1/ &
- (phconv(levold+1))
-
- ! interpolate wsub to the vertical particle position
-
- dz1 = ztold - uvzlev(levold)
- dz2 = uvzlev(levold+1) - ztold
- dz = dz1 + dz2
-
- wsubpart = (dz2*wsub(levold)+dz1*wsub(levold+1))/dz
- ztra1(abs(ipart)) = ztold+wsubpart*real(lsynctime)
- if (ztra1(abs(ipart)).lt.0.) then
- ztra1(abs(ipart))=-1.*ztra1(abs(ipart))
- endif
-
- endif !(levnew.le.nconvtop.and.levnew.eq.levold)
-
- ! Maximum altitude .5 meter below uppermost model level
- !*******************************************************
-
- 90 continue
-
- if (ztra1(abs(ipart)) .gt. height(nz)-0.5) &
- ztra1(abs(ipart)) = height(nz)-0.5
-
-end subroutine redist
diff --git a/src/FLEXPART_MPI.f90 b/src/redundant/FLEXPART_MPI.f90
similarity index 96%
rename from src/FLEXPART_MPI.f90
rename to src/redundant/FLEXPART_MPI.f90
index 15a9b877..4b7e21bb 100644
--- a/src/FLEXPART_MPI.f90
+++ b/src/redundant/FLEXPART_MPI.f90
@@ -51,13 +51,13 @@ program flexpart
integer(selected_int_kind(16)), dimension(maxspec) :: tot_b=0, &
& tot_i=0
+ write(*,*) 'Flexpart has started'
! Initialize mpi
!*********************
call mpif_init
if (mp_measure_time) call mpif_mtime('flexpart',0)
-
! Generate a large number of random numbers
!******************************************
@@ -101,6 +101,7 @@ program flexpart
!*******************************************************
print*,'Welcome to FLEXPART ', trim(flexversion)
print*,'FLEXPART is free software released under the GNU General Public License.'
+ call system_clock(count_clock0, count_rate, count_max)
endif
if (inline_options(1:1).eq.'-') then
@@ -132,7 +133,7 @@ program flexpart
if (verbosity.gt.1) then !show clock info
!print*,'length(4)',length(4)
!count=0,count_rate=1000
- call system_clock(count_clock0, count_rate, count_max)
+ call system_clock(count_clock0, count_rate, count_max)
!WRITE(*,*) 'SYSTEM_CLOCK',count, count_rate, count_max
!WRITE(*,*) 'SYSTEM_CLOCK, count_clock0', count_clock0
!WRITE(*,*) 'SYSTEM_CLOCK, count_rate', count_rate
@@ -463,6 +464,14 @@ program flexpart
call timemanager(metdata_format)
+ if (verbosity.gt.1) then
+ CALL SYSTEM_CLOCK(count_clock, count_rate, count_max)
+ if (lroot) then
+ WRITE(*,*) 'END ROOT CLOCK ',(count_clock - count_clock0)/real(count_rate)
+ else
+ WRITE(*,*) 'END CLOCK ',(count_clock - count_clock0)/real(count_rate)
+ end if
+ end if
! NIK 16.02.2005
if (mp_partgroup_pid.ge.0) then ! Skip for readwind process
@@ -485,7 +494,8 @@ program flexpart
! & tot_inc_count(i)
write(*,*) '**********************************************'
end do
-
+ CALL SYSTEM_CLOCK(count_clock, count_rate, count_max)
+ WRITE(*,*) 'Time elapsed: ',(count_clock - count_clock0)/real(count_rate)
write(*,*) 'CONGRATULATIONS: YOU HAVE SUCCESSFULLY COMPLETED A FLE&
&XPART MODEL RUN!'
end if
diff --git a/src/advance.f90 b/src/redundant/advance.f90
similarity index 70%
rename from src/advance.f90
rename to src/redundant/advance.f90
index 9764e48a..d289a0c2 100644
--- a/src/advance.f90
+++ b/src/redundant/advance.f90
@@ -2,7 +2,7 @@
! SPDX-License-Identifier: GPL-3.0-or-later
subroutine advance(itime,nrelpoint,ldt,up,vp,wp, &
- usigold,vsigold,wsigold,nstop,xt,yt,zt,prob,icbt)
+ usigold,vsigold,wsigold,nstop,xt,yt,zt,zteta,prob,icbt,pp)
! i i i/oi/oi/o
! i/o i/o i/o o i/oi/oi/o i/o i/o
!*****************************************************************************
@@ -85,57 +85,93 @@ subroutine advance(itime,nrelpoint,ldt,up,vp,wp, &
use hanna_mod
use cmapf_mod
use random_mod, only: ran3
+ use coordinates_ecmwf
+ use particle_mod
- implicit none
+ ! openmp change
+ use omp_lib, only: OMP_GET_THREAD_NUM
+ ! openmp change end
- real(kind=dp) :: xt,yt
- real :: zt,xts,yts,weight
- integer :: itime,itimec,nstop,ldt,i,j,k,nrand,loop,memindnext,mind
- integer :: ngr,nix,njy,ks,nsp,nrelpoint
- real :: dz,dz1,dz2,xlon,ylat,xpol,ypol,gridsize
- real :: ru,rv,rw,dt,ux,vy,cosfact,xtn,ytn,tropop
- real :: prob(maxspec),up,vp,wp,dxsave,dysave,dawsave
- real :: dcwsave
- real :: usigold,vsigold,wsigold,r,rs
- real :: uold,vold,wold,vdepo(maxspec)
- real :: h1(2)
- !real uprof(nzmax),vprof(nzmax),wprof(nzmax)
- !real usigprof(nzmax),vsigprof(nzmax),wsigprof(nzmax)
- !real rhoprof(nzmax),rhogradprof(nzmax)
- real :: rhoa,rhograd,delz,dtf,rhoaux,dtftlw,uxscale,wpscale
- integer(kind=2) :: icbt
- real,parameter :: eps=nxmax/3.e5,eps2=1.e-9,eps3=tiny(1.0)
- real :: ptot_lhh,Q_lhh,phi_lhh,ath,bth !modified by mc
- real :: old_wp_buf,dcas,dcas1,del_test !added by mc
- integer :: i_well,jj,flagrein !test well mixed: modified by mc
-
-
- !!! CHANGE: TEST OF THE WELL-MIXED CRITERION
- ! integer,parameter :: iclass=10
- ! real(kind=dp) :: zacc,tacc,t(iclass),th(0:iclass),hsave
- ! logical dump
- ! save zacc,tacc,t,th,hsave,dump
- !!! CHANGE
-
- integer :: idummy = -7
- real :: settling = 0.
-
-
- !!! CHANGE: TEST OF THE WELL-MIXED CRITERION
- !if (idummy.eq.-7) then
- !open(550,file='WELLMIXEDTEST')
- !do 17 i=0,iclass
- !7 th(i)=real(i)/real(iclass)
- !endif
- !!! CHANGE
-
-
- nstop=0
+ implicit none
+ real, parameter :: &
+ eps=nxmax/3.e5, &
+ eps2=1.e-9, &
+ eps3=tiny(1.0), &
+ eps_eta=1.e-4
+ integer, intent(in) :: &
+ itime, & ! time index
+ nrelpoint, & ! particle index
+ pp ! temporary, will be removed
+ logical, intent(inout) :: &
+ nstop ! flag to stop particle if it leaves the domain
+ integer, intent(inout) :: &
+ ldt ! next timestep
+ integer(kind=2), intent(inout) :: &
+ icbt ! flag for forbidden state particle
+ integer :: &
+ itimec, &
+ i,j,k, & ! loop variables
+ nrand, & ! random number used for turbulence
+ loop, & ! loop variable for time in the PBL
+ memindnext, & ! seems useless
+ mind, & ! windfield index
+ ngr, & ! temporary new grid index of moved particle
+ ! nix,njy, & ! nexted grid indices Moved to interpol_mod
+ ks,nsp, & ! loop variables for vertical levels
+ flagrein, & ! flag used in CBL scheme
+ thread, & ! number of openmp threads (probably can be removed)
+ idummy = -7 ! used in random number routines
+ real, intent(inout) :: &
+ zt, & ! z particle position in meters, want to keep this local to advance in future
+ zteta, & ! z particle position in eta coordinates
+ up,vp,wp, & ! random turbulence velocities
+ usigold,vsigold,wsigold ! old mesoscale wind fluctuations
+ real(kind=dp), intent(inout) :: &
+ xt, yt ! particle positions on grid
+ real :: &
+ xts,yts, & ! local 'real' copy of the particle position
+ ! xtn,ytn, & ! nested particle position Moved to interpol_mod
+ weight, & ! transition above the tropopause
+ dz,dz1,dz2, & ! values used for interpolating between vertical levels
+ xlon,ylat,xpol,ypol, & ! temporarily storing new particle positions
+ gridsize,cosfact, & ! used to compute new positions of particles
+ ru,rv,rw, & ! used for computing turbulence
+ dt, & ! real(ldt)
+ ux,vy, & ! random turbulent velocities above PBL
+ tropop, & ! height of troposphere
+ prob(maxspec), & ! dry deposition ground absorption probability
+ dxsave,dysave, & ! accumulated displacement in long and lat
+ dawsave,dcwsave, & ! accumulated displacement in wind directions
+ uold,vold,wold,woldeta, & !
+ r,rs, & ! mesoscale related
+ vdepo(maxspec), & ! deposition velocities for all species
+ h1(2), & ! mixing height
+ rhoa, & ! air density, used in CBL
+ rhograd, & ! vertical gradient of the air density, used in CBL
+ delz, & ! change in vertical position due to turbulence
+ dtf,rhoaux,dtftlw,ath,bth, & ! CBL related
+ ptot_lhh,Q_lhh,phi_lhh, & ! CBL related
+ old_wp_buf,dcas,dcas1, & ! CBL related
+ del_test, & ! CBL related
+ uxscale,wpscale, & ! factor used in calculating turbulent perturbations above PBL
+ ztemp, & ! temporarily storing z position
+ settling = 0. ! settling velo
+
+ !type(particle) :: part
+ ! openmp change
+ save idummy
+!$OMP THREADPRIVATE(idummy)
+!$ if (idummy.eq.-7) then
+!$ thread = OMP_GET_THREAD_NUM()
+!$ idummy = idummy - thread
+!$ endif
+ ! openmp change end
+
+ nstop=.false.
do i=1,nmixz
indzindicator(i)=.true.
end do
-
-
+
if (DRYDEP) then ! reset probability for deposition
do ks=1,nspec
depoindicator(ks)=.true.
@@ -152,7 +188,6 @@ subroutine advance(itime,nrelpoint,ldt,up,vp,wp, &
nrand=int(ran3(idummy)*real(maxrand-1))+1
-
! Determine whether lat/long grid or polarstereographic projection
! is to be used
! Furthermore, determine which nesting level to be used
@@ -168,13 +203,11 @@ subroutine advance(itime,nrelpoint,ldt,up,vp,wp, &
if ((xt.gt.xln(j)+eps).and.(xt.lt.xrn(j)-eps).and. &
(yt.gt.yln(j)+eps).and.(yt.lt.yrn(j)-eps)) then
ngrid=j
- goto 23
+ exit
endif
end do
-23 continue
endif
-
!***************************
! Interpolate necessary data
!***************************
@@ -186,100 +219,37 @@ subroutine advance(itime,nrelpoint,ldt,up,vp,wp, &
endif
! Determine nested grid coordinates
- !**********************************
-
- if (ngrid.gt.0) then
- xtn=(xt-xln(ngrid))*xresoln(ngrid)
- ytn=(yt-yln(ngrid))*yresoln(ngrid)
- ix=int(xtn)
- jy=int(ytn)
- nix=nint(xtn)
- njy=nint(ytn)
- else
- ix=int(xt)
- jy=int(yt)
- nix=nint(xt)
- njy=nint(yt)
- endif
- ixp=ix+1
- jyp=jy+1
-
-
- ! Determine the lower left corner and its distance to the current position
- !*************************************************************************
-
- ddx=xt-real(ix)
- ddy=yt-real(jy)
- rddx=1.-ddx
- rddy=1.-ddy
- p1=rddx*rddy
- p2=ddx*rddy
- p3=rddx*ddy
- p4=ddx*ddy
-
- ! Calculate variables for time interpolation
+ ! Determine the lower left corner and its distance to the current position
+ ! Calculate variables for time interpolation
!*******************************************
-
- dt1=real(itime-memtime(1))
- dt2=real(memtime(2)-itime)
- dtt=1./(dt1+dt2)
-
-! eso: Temporary fix for particle exactly at north pole
- if (jyp >= nymax) then
- ! write(*,*) 'WARNING: advance.f90 jyp >= nymax. xt,yt:',xt,yt
- jyp=jyp-1
- end if
+ call initialise_interpol_mod(itime,real(xt),real(yt),zt,zteta)
! Compute maximum mixing height around particle position
!*******************************************************
+
+ ! Convert z(eta) to z(m) for the turbulence scheme, w(m/s)
+ ! is computed in verttransform_ecmwf.f90
- h=0.
- if (ngrid.le.0) then
- do k=1,2
- mind=memind(k) ! eso: compatibility with 3-field version
- if (interpolhmix) then
- h1(k)=p1*hmix(ix ,jy ,1,mind) &
- + p2*hmix(ixp,jy ,1,mind) &
- + p3*hmix(ix ,jyp,1,mind) &
- + p4*hmix(ixp,jyp,1,mind)
- else
- do j=jy,jyp
- do i=ix,ixp
- if (hmix(i,j,1,mind).gt.h) h=hmix(i,j,1,mind)
- end do
- end do
- endif
- end do
- tropop=tropopause(nix,njy,1,1)
- else
- do k=1,2
- mind=memind(k)
- do j=jy,jyp
- do i=ix,ixp
- if (hmixn(i,j,1,mind,ngrid).gt.h) h=hmixn(i,j,1,mind,ngrid)
- end do
- end do
- end do
- tropop=tropopausen(nix,njy,1,1,ngrid)
+ if (wind_coord_type.eq.'ETA') then
+ if (.not. part(pp)%etaupdate) call zeta_to_z(itime,xt,yt,zteta,zt)
endif
- if (interpolhmix) h=(h1(1)*dt2+h1(2)*dt1)*dtt
+ ! Compute the height of the troposphere and the PBL at the x-y location of the particle
+ call interpol_htropo_hmix(tropop,h)
zeta=zt/h
-
-
!*************************************************************
! If particle is in the PBL, interpolate once and then make a
! time loop until end of interval is reached
!*************************************************************
-
+ ! In the PBL we use meters instead of eta coordinates for the vertical transport
if (zeta.le.1.) then
! BEGIN TIME LOOP
!================
-
loop=0
-100 loop=loop+1
+ pbl_loop : do
+ loop=loop+1
if (method.eq.1) then
ldt=min(ldt,abs(lsynctime-itimec+itime))
itimec=itimec+ldt*ldirect
@@ -291,44 +261,24 @@ subroutine advance(itime,nrelpoint,ldt,up,vp,wp, &
zeta=zt/h
-
if (loop.eq.1) then
if (ngrid.le.0) then
xts=real(xt)
yts=real(yt)
- call interpol_all(itime,xts,yts,zt)
+ call interpol_all(itime,xts,yts,zt,zteta)
else
call interpol_all_nests(itime,xtn,ytn,zt)
endif
else
-
-
- ! Determine the level below the current position for u,v,rho
- !***********************************************************
-
- do i=2,nz
- if (height(i).gt.zt) then
- indz=i-1
- indzp=i
- goto 6
- endif
- end do
-6 continue
-
- ! If one of the levels necessary is not yet available,
- ! calculate it
- !*****************************************************
-
- do i=indz,indzp
- if (indzindicator(i)) then
- if (ngrid.le.0) then
- call interpol_misslev(i)
- else
- call interpol_misslev_nests(i)
- endif
- endif
- end do
+ ! Determine the level below the current position for u,v,rho
+ !***********************************************************
+ call find_z_level(zt,zteta) ! Not sure if zteta levels are necessary here
+
+ ! If one of the levels necessary is not yet available,
+ ! calculate it
+ !*****************************************************
+ call interpol_misslev()
endif
@@ -338,17 +288,7 @@ subroutine advance(itime,nrelpoint,ldt,up,vp,wp, &
! Vertical distance to the level below and above current position
! both in terms of (u,v) and (w) fields
!****************************************************************
-
- dz=1./(height(indzp)-height(indz))
- dz1=(zt-height(indz))*dz
- dz2=(height(indzp)-zt)*dz
-
- u=dz1*uprof(indzp)+dz2*uprof(indz)
- v=dz1*vprof(indzp)+dz2*vprof(indz)
- w=dz1*wprof(indzp)+dz2*wprof(indz)
- rhoa=dz1*rhoprof(indzp)+dz2*rhoprof(indz)
- rhograd=dz1*rhogradprof(indzp)+dz2*rhogradprof(indz)
-
+ call interpol_mixinglayer(zt,zteta,rhoa,rhograd)
! Compute the turbulent disturbances
! Determine the sigmas and the timescales
@@ -360,7 +300,6 @@ subroutine advance(itime,nrelpoint,ldt,up,vp,wp, &
call hanna1(zt)
endif
-
!*****************************************
! Determine the new diffusivity velocities
!*****************************************
@@ -402,6 +341,7 @@ subroutine advance(itime,nrelpoint,ldt,up,vp,wp, &
if (dtftlw.lt..5) then
!*************************************************************
!************** CBL options added by mc see routine cblf90 ***
+ ! LB needs to be checked if this works with openmp
if (cblflag.eq.1) then !modified by mc
if (-h/ol.gt.5) then !modified by mc
!if (ol.lt.0.) then !modified by mc
@@ -540,6 +480,7 @@ subroutine advance(itime,nrelpoint,ldt,up,vp,wp, &
dysave=dysave+v*dt
dawsave=dawsave+up*dt
dcwsave=dcwsave+vp*dt
+ ! How can I change the w to w(eta) efficiently?
zt=zt+w*dt*real(ldirect)
! HSO/AL: Particle managed to go over highest level -> interpolation error in goto 700
@@ -547,34 +488,10 @@ subroutine advance(itime,nrelpoint,ldt,up,vp,wp, &
if (zt.ge.height(nz)) zt=height(nz)-100.*eps
if (zt.gt.h) then
+ if (wind_coord_type.eq.'ETA') call z_to_zeta(itime,xt,yt,zt,zteta)
if (itimec.eq.itime+lsynctime) goto 99
goto 700 ! complete the current interval above PBL
endif
-
-
- !!! CHANGE: TEST OF THE WELL-MIXED CRITERION
- !!! These lines may be switched on to test the well-mixed criterion
- !if (zt.le.h) then
- ! zacc=zacc+zt/h*dt
- ! hsave=hsave+h*dt
- ! tacc=tacc+dt
- ! do 67 i=1,iclass
- ! if ((zt/h.gt.th(i-1)).and.(zt/h.le.th(i)))
- ! + t(i)=t(i)+dt
- !7 continue
- !endif
- !if ((mod(itime,10800).eq.0).and.dump) then
- ! dump=.false.
- ! write(550,'(i6,12f10.3)') itime,hsave/tacc,zacc/tacc,
- ! + (t(i)/tacc*real(iclass),i=1,iclass)
- ! zacc=0.
- ! tacc=0.
- ! do 68 i=1,iclass
- !8 t(i)=0.
- ! hsave=0.
- !endif
- !if (mod(itime,10800).ne.0) dump=.true.
- !!! CHANGE
! Determine probability of deposition
!************************************
@@ -592,37 +509,34 @@ subroutine advance(itime,nrelpoint,ldt,up,vp,wp, &
! correction by Petra Seibert, 10 April 2001
! this formulation means that prob(n) = 1 - f(0)*...*f(n)
! where f(n) is the exponential term
- prob(ks)=1.+(prob(ks)-1.)* &
- exp(-vdepo(ks)*abs(dt)/(2.*href))
+ prob(ks)=1.+(prob(ks)-1.)* &
+ exp(-vdepo(ks)*abs(dt)/(2.*href))
+ !if (pp.eq.535) write(*,*) 'advance1', ks,dtt,p1,vdep(ix,jy,ks,1)
endif
end do
endif
if (zt.lt.0.) zt=min(h-eps2,-1.*zt) ! if particle below ground -> reflection
+
if (itimec.eq.(itime+lsynctime)) then
- usig=0.5*(usigprof(indzp)+usigprof(indz))
- vsig=0.5*(vsigprof(indzp)+vsigprof(indz))
- wsig=0.5*(wsigprof(indzp)+wsigprof(indz))
+ call interpol_average()
+ ! Converting the z position that changed through turbulence motions to eta coords
+ if (wind_coord_type.eq.'ETA') call z_to_zeta(itime,xt,yt,zt,zteta)
goto 99 ! finished
endif
- goto 100
+ end do pbl_loop
! END TIME LOOP
!==============
-
-
endif
-
-
!**********************************************************
! For all particles that are outside the PBL, make a single
! time step. Only horizontal turbulent disturbances are
! calculated. Vertical disturbances are reset.
!**********************************************************
-
! Interpolate the wind
!*********************
@@ -630,12 +544,11 @@ subroutine advance(itime,nrelpoint,ldt,up,vp,wp, &
if (ngrid.le.0) then
xts=real(xt)
yts=real(yt)
- call interpol_wind(itime,xts,yts,zt)
+ call interpol_wind(itime,xts,yts,zt,zteta,pp)
else
call interpol_wind_nests(itime,xtn,ytn,zt)
endif
-
! Compute everything for above the PBL
! Assume constant, uncorrelated, turbulent perturbations
@@ -682,7 +595,7 @@ subroutine advance(itime,nrelpoint,ldt,up,vp,wp, &
! If particle represents only a single species, add gravitational settling
! velocity. The settling velocity is zero for gases
!*************************************************************************
-
+ ! Does not work in eta coordinates yet
if (mdomainfill.eq.0) then
if (lsettling) then
do nsp=1,nspec
@@ -691,9 +604,11 @@ subroutine advance(itime,nrelpoint,ldt,up,vp,wp, &
if (nsp.gt.nspec) then
nsp=nspec
end if
+ ! LB needs to be checked if this works with openmp and change to eta coords
if (density(nsp).gt.0.) then
call get_settling(itime,real(xt),real(yt),zt,nsp,settling) !bugfix
w=w+settling
+ zt=zt+settling*dt*real(ldirect)
end if
endif
end if
@@ -701,11 +616,29 @@ subroutine advance(itime,nrelpoint,ldt,up,vp,wp, &
! Calculate position at time step itime+lsynctime
!************************************************
-
dxsave=dxsave+(u+ux)*dt
dysave=dysave+(v+vy)*dt
- zt=zt+(w+wp)*dt*real(ldirect)
- if (zt.lt.0.) zt=min(h-eps2,-1.*zt) ! if particle below ground -> reflection
+
+ select case (wind_coord_type)
+ case ('ETA')
+ zt=zt+(wp)*dt*real(ldirect)
+ if (zt.lt.0.) zt=min(h-eps2,-1.*zt) ! if particle below ground -> reflection
+ call z_to_zeta(itime,xt,yt,zt,zteta)
+ zteta=zteta+(weta)*dt*real(ldirect)
+ part(pp)%etaupdate=.false.
+ if (zteta.ge.1.) zteta=1.-(zteta-1.)
+ if (zteta.eq.1.) zteta=zteta-eps_eta
+ case ('METER')
+ zt=zt+(w+wp)*dt*real(ldirect)
+ if (zt.lt.0.) zt=min(h-eps2,-1.*zt)
+ case default
+ zt=zt+(w+wp)*dt*real(ldirect)
+ if (zt.lt.0.) zt=min(h-eps2,-1.*zt)
+ end select
+
+
+ ! if (zteta.ge.uvheight(2)) zteta=uvheight(2) -(zteta - uvheight(2))
+
99 continue
@@ -730,14 +663,27 @@ subroutine advance(itime,nrelpoint,ldt,up,vp,wp, &
if (nrand+2.gt.maxrand) nrand=1
usigold=r*usigold+rs*rannumb(nrand)*usig*turbmesoscale
vsigold=r*vsigold+rs*rannumb(nrand+1)*vsig*turbmesoscale
- wsigold=r*wsigold+rs*rannumb(nrand+2)*wsig*turbmesoscale
-
dxsave=dxsave+usigold*real(lsynctime)
dysave=dysave+vsigold*real(lsynctime)
- zt=zt+wsigold*real(lsynctime)
- if (zt.lt.0.) zt=-1.*zt ! if particle below ground -> refletion
-
+ select case (wind_coord_type)
+ case ('ETA')
+ wsigold=r*wsigold+rs*rannumb(nrand+2)*wsigeta*turbmesoscale
+ zteta=zteta+wsigold*real(lsynctime)
+ part(pp)%etaupdate=.false.
+ if (zteta.ge.1.) zteta=1.-(zteta-1.)
+ if (zteta.eq.1.) zteta=zteta-eps_eta
+
+ case ('METER')
+ wsigold=r*wsigold+rs*rannumb(nrand+2)*wsig*turbmesoscale
+ zt=zt+wsigold*real(lsynctime)
+ if (zt.lt.0.) zt=-1.*zt ! if particle below ground -> refletion
+
+ case default
+ wsigold=r*wsigold+rs*rannumb(nrand+2)*wsig*turbmesoscale
+ zt=zt+wsigold*real(lsynctime)
+ if (zt.lt.0.) zt=-1.*zt ! if particle below ground -> refletion
+ end select
!*************************************************************
! Transform along and cross wind components to xy coordinates,
! add them to u and v, transform u,v to grid units/second
@@ -752,8 +698,8 @@ subroutine advance(itime,nrelpoint,ldt,up,vp,wp, &
xt=xt+real(dxsave*cosfact*real(ldirect),kind=dp)
yt=yt+real(dysave*dyconst*real(ldirect),kind=dp)
else if (ngrid.eq.-1) then ! around north pole
- xlon=xlon0+xt*dx !comment by mc: compute old particle position
- ylat=ylat0+yt*dy
+ xlon=xlon0+real(xt)*dx !comment by mc: compute old particle position
+ ylat=ylat0+real(yt)*dy
call cll2xy(northpolemap,ylat,xlon,xpol,ypol) !convert old particle position in polar stereographic
gridsize=1000.*cgszll(northpolemap,ylat,xlon) !calculate size in m of grid element in polar stereographic coordinate
dxsave=dxsave/gridsize !increment from meter to grdi unit
@@ -761,11 +707,11 @@ subroutine advance(itime,nrelpoint,ldt,up,vp,wp, &
xpol=xpol+dxsave*real(ldirect) !position in grid unit polar stereographic
ypol=ypol+dysave*real(ldirect)
call cxy2ll(northpolemap,xpol,ypol,ylat,xlon) !convert to lat long coordinate
- xt=(xlon-xlon0)/dx !convert to grid units in lat long coordinate, comment by mc
- yt=(ylat-ylat0)/dy
+ xt=real((xlon-xlon0)/dx,kind=dp) !convert to grid units in lat long coordinate, comment by mc
+ yt=real((ylat-ylat0)/dy,kind=dp)
else if (ngrid.eq.-2) then ! around south pole
- xlon=xlon0+xt*dx
- ylat=ylat0+yt*dy
+ xlon=xlon0+real(xt)*dx
+ ylat=ylat0+real(yt)*dy
call cll2xy(southpolemap,ylat,xlon,xpol,ypol)
gridsize=1000.*cgszll(southpolemap,ylat,xlon)
dxsave=dxsave/gridsize
@@ -773,19 +719,17 @@ subroutine advance(itime,nrelpoint,ldt,up,vp,wp, &
xpol=xpol+dxsave*real(ldirect)
ypol=ypol+dysave*real(ldirect)
call cxy2ll(southpolemap,xpol,ypol,ylat,xlon)
- xt=(xlon-xlon0)/dx
- yt=(ylat-ylat0)/dy
+ xt=real((xlon-xlon0)/dx,kind=dp)
+ yt=real((ylat-ylat0)/dy,kind=dp)
endif
-
! If global data are available, use cyclic boundary condition
!************************************************************
-
if (xglobal) then
- if (xt.ge.real(nxmin1)) xt=xt-real(nxmin1)
- if (xt.lt.0.) xt=xt+real(nxmin1)
- if (xt.le.eps) xt=eps
- if (abs(xt-real(nxmin1)).le.eps) xt=real(nxmin1)-eps
+ if (xt.ge.real(nxmin1,kind=dp)) xt=xt-real(nxmin1,kind=dp)
+ if (xt.lt.0.) xt=xt+real(nxmin1,kind=dp)
+ if (xt.le.real(eps,kind=dp)) xt=real(eps,kind=dp)
+ if (abs(xt-real(nxmin1)).le.eps) xt=real(nxmin1-eps,kind=dp)
endif
! HSO/AL: Prevent particles from disappearing at the pole
@@ -794,9 +738,9 @@ subroutine advance(itime,nrelpoint,ldt,up,vp,wp, &
if ( yt.lt.0. ) then
xt=mod(xt+180.,360.)
yt=-yt
- else if ( yt.gt.real(nymin1) ) then
+ else if ( yt.gt.real(nymin1,kind=dp) ) then
xt=mod(xt+180.,360.)
- yt=2*real(nymin1)-yt
+ yt=2.*real(nymin1,kind=dp)-yt
endif
! Check position: If trajectory outside model domain, terminate it
@@ -804,16 +748,24 @@ subroutine advance(itime,nrelpoint,ldt,up,vp,wp, &
if ((xt.lt.0.).or.(xt.ge.real(nxmin1)).or.(yt.lt.0.).or. &
(yt.gt.real(nymin1))) then
- nstop=3
+ nstop=.true.
return
endif
! If particle above highest model level, set it back into the domain
!*******************************************************************
-
- if (zt.ge.height(nz)) zt=height(nz)-100.*eps
-
-
+ select case (wind_coord_type)
+ case ('ETA')
+ if (zteta.le.uvheight(nz)) then
+ zteta=uvheight(nz)+eps_eta
+ part(pp)%etaupdate=.false.
+ endif
+ case ('METER')
+ if (zt.ge.height(nz)) zt=height(nz)-100.*eps
+ case default
+ if (zt.ge.height(nz)) zt=height(nz)-100.*eps
+ end select
+
!************************************************************************
! Now we could finish, as this was done in FLEXPART versions up to 4.0.
! However, truncation errors of the advection can be significantly
@@ -849,36 +801,31 @@ subroutine advance(itime,nrelpoint,ldt,up,vp,wp, &
if ((xt.gt.xln(j)+eps).and.(xt.lt.xrn(j)-eps).and. &
(yt.gt.yln(j)+eps).and.(yt.lt.yrn(j)-eps)) then
ngr=j
- goto 43
+ exit
endif
end do
-43 continue
endif
if (ngr.ne.ngrid) return
! Determine nested grid coordinates
!**********************************
-
- if (ngrid.gt.0) then
- xtn=(xt-xln(ngrid))*xresoln(ngrid)
- ytn=(yt-yln(ngrid))*yresoln(ngrid)
- ix=int(xtn)
- jy=int(ytn)
- else
- ix=int(xt)
- jy=int(yt)
- endif
- ixp=ix+1
- jyp=jy+1
-
+ call determine_grid_coordinates(real(xt),real(yt))
! Memorize the old wind
!**********************
uold=u
vold=v
- wold=w
+
+ select case (wind_coord_type)
+ case ('ETA')
+ woldeta=weta
+ case ('METER')
+ wold=w
+ case default
+ wold=w
+ end select
! Interpolate wind at new position and time
!******************************************
@@ -886,7 +833,7 @@ subroutine advance(itime,nrelpoint,ldt,up,vp,wp, &
if (ngrid.le.0) then
xts=real(xt)
yts=real(yt)
- call interpol_wind_short(itime+ldt*ldirect,xts,yts,zt)
+ call interpol_wind_short(itime+ldt*ldirect,xts,yts,zt,zteta)
else
call interpol_wind_short_nests(itime+ldt*ldirect,xtn,ytn,zt)
endif
@@ -900,8 +847,22 @@ subroutine advance(itime,nrelpoint,ldt,up,vp,wp, &
nsp=nspec
end if
if (density(nsp).gt.0.) then
- call get_settling(itime+ldt,real(xt),real(yt),zt,nsp,settling) !bugfix
- w=w+settling
+ select case (wind_coord_type)
+
+ case ('ETA')
+ call zeta_to_z(itime,xt,yt,zteta,zt)
+ call get_settling(itime+ldt,real(xt),real(yt),zt,nsp,settling) !bugfix
+ call z_to_zeta(itime,xt,yt,zt+settling*real(ldt*ldirect),ztemp)
+ weta=weta+(ztemp-zteta)/real(ldt*ldirect)
+
+ case ('METER')
+ call get_settling(itime+ldt,real(xt),real(yt),zt,nsp,settling) !bugfix
+ w=w+settling
+
+ case default
+ call get_settling(itime+ldt,real(xt),real(yt),zt,nsp,settling) !bugfix
+ w=w+settling
+ end select
end if
endif
end if
@@ -913,21 +874,35 @@ subroutine advance(itime,nrelpoint,ldt,up,vp,wp, &
u=(u-uold)/2.
v=(v-vold)/2.
- w=(w-wold)/2.
+ select case (wind_coord_type)
+ case ('ETA')
+ weta=(weta-woldeta)/2.
+ zteta=zteta+weta*real(ldt*ldirect)
+ part(pp)%etaupdate=.false.
+ if (zteta.ge.1.) zteta=1.-(zteta-1.)
+ if (zteta.eq.1.) zteta=zteta-eps_eta
+
+ case ('METER')
+ w=(w-wold)/2.
+ zt=zt+w*real(ldt*ldirect)
+ if (zt.lt.0.) zt=min(h-eps2,-1.*zt) ! if particle below ground -> reflection
+
+ case default
+ w=(w-wold)/2.
+ zt=zt+w*real(ldt*ldirect)
+ if (zt.lt.0.) zt=min(h-eps2,-1.*zt)
+ end select
! Finally, correct the old position
!**********************************
-
- zt=zt+w*real(ldt*ldirect)
- if (zt.lt.0.) zt=min(h-eps2,-1.*zt) ! if particle below ground -> reflection
if (ngrid.ge.0) then
- cosfact=dxconst/cos((yt*dy+ylat0)*pi180)
+ cosfact=dxconst/cos((real(yt)*dy+ylat0)*pi180)
xt=xt+real(u*cosfact*real(ldt*ldirect),kind=dp)
yt=yt+real(v*dyconst*real(ldt*ldirect),kind=dp)
else if (ngrid.eq.-1) then ! around north pole
- xlon=xlon0+xt*dx
- ylat=ylat0+yt*dy
+ xlon=xlon0+real(xt)*dx
+ ylat=ylat0+real(yt)*dy
call cll2xy(northpolemap,ylat,xlon,xpol,ypol)
gridsize=1000.*cgszll(northpolemap,ylat,xlon)
u=u/gridsize
@@ -935,11 +910,11 @@ subroutine advance(itime,nrelpoint,ldt,up,vp,wp, &
xpol=xpol+u*real(ldt*ldirect)
ypol=ypol+v*real(ldt*ldirect)
call cxy2ll(northpolemap,xpol,ypol,ylat,xlon)
- xt=(xlon-xlon0)/dx
- yt=(ylat-ylat0)/dy
+ xt=real((xlon-xlon0)/dx,kind=dp)
+ yt=real((ylat-ylat0)/dy,kind=dp)
else if (ngrid.eq.-2) then ! around south pole
- xlon=xlon0+xt*dx
- ylat=ylat0+yt*dy
+ xlon=xlon0+real(xt)*dx
+ ylat=ylat0+real(yt)*dy
call cll2xy(southpolemap,ylat,xlon,xpol,ypol)
gridsize=1000.*cgszll(southpolemap,ylat,xlon)
u=u/gridsize
@@ -947,45 +922,51 @@ subroutine advance(itime,nrelpoint,ldt,up,vp,wp, &
xpol=xpol+u*real(ldt*ldirect)
ypol=ypol+v*real(ldt*ldirect)
call cxy2ll(southpolemap,xpol,ypol,ylat,xlon)
- xt=(xlon-xlon0)/dx
- yt=(ylat-ylat0)/dy
+ xt=real((xlon-xlon0)/dx,kind=dp)
+ yt=real((ylat-ylat0)/dy,kind=dp)
endif
! If global data are available, use cyclic boundary condition
!************************************************************
if (xglobal) then
- if (xt.ge.real(nxmin1)) xt=xt-real(nxmin1)
- if (xt.lt.0.) xt=xt+real(nxmin1)
- if (xt.le.eps) xt=eps
- if (abs(xt-real(nxmin1)).le.eps) xt=real(nxmin1)-eps
+ if (xt.ge.real(nxmin1,kind=dp)) xt=xt-real(nxmin1,kind=dp)
+ if (xt.lt.0.) xt=xt+real(nxmin1,kind=dp)
+ if (xt.le.eps) xt=real(eps,kind=dp)
+ if (abs(xt-real(nxmin1,kind=dp)).le.eps) xt=real(nxmin1-eps,kind=dp)
endif
! HSO/AL: Prevent particles from disappearing at the pole
!******************************************************************
-
if ( yt.lt.0. ) then
xt=mod(xt+180.,360.)
yt=-yt
- else if ( yt.gt.real(nymin1) ) then
+ else if ( yt.gt.real(nymin1,kind=dp) ) then
xt=mod(xt+180.,360.)
- yt=2*real(nymin1)-yt
+ yt=2.*real(nymin1,kind=dp)-yt
endif
! Check position: If trajectory outside model domain, terminate it
!*****************************************************************
-
- if ((xt.lt.0.).or.(xt.ge.real(nxmin1)).or.(yt.lt.0.).or. &
- (yt.gt.real(nymin1))) then
- nstop=3
+ if ((xt.lt.0.).or.(xt.ge.real(nxmin1,kind=dp)).or.(yt.lt.0.).or. &
+ (yt.gt.real(nymin1,kind=dp))) then
+ nstop=.true.
return
endif
! If particle above highest model level, set it back into the domain
!*******************************************************************
-
- if (zt.ge.height(nz)) zt=height(nz)-100.*eps
-
+ select case (wind_coord_type)
+ case ('ETA')
+ if (zteta.le.uvheight(nz)) then
+ zteta=uvheight(nz)+eps_eta
+ part(pp)%etaupdate=.false.
+ endif
+ case ('METER')
+ if (zt.ge.height(nz)) zt=height(nz)-100.*eps
+ case default
+ if (zt.ge.height(nz)) zt=height(nz)-100.*eps
+ end select
end subroutine advance
diff --git a/src/assignland.f90 b/src/redundant/assignland.f90
similarity index 99%
rename from src/assignland.f90
rename to src/redundant/assignland.f90
index 00c10075..7c452613 100644
--- a/src/assignland.f90
+++ b/src/redundant/assignland.f90
@@ -33,6 +33,7 @@ subroutine assignland
use par_mod
use com_mod
+ use windfields_mod
implicit none
diff --git a/src/boundcond_domainfill.f90 b/src/redundant/boundcond_domainfill.f90
similarity index 60%
rename from src/boundcond_domainfill.f90
rename to src/redundant/boundcond_domainfill.f90
index 6dcd6548..a793e394 100644
--- a/src/boundcond_domainfill.f90
+++ b/src/redundant/boundcond_domainfill.f90
@@ -29,6 +29,8 @@ subroutine boundcond_domainfill(itime,loutend)
use par_mod
use com_mod
use random_mod, only: ran1
+ use particle_mod
+ use coordinates_ecmwf
implicit none
@@ -61,15 +63,14 @@ subroutine boundcond_domainfill(itime,loutend)
!********************************************************************
do i=1,numpart
- if (itra1(i).eq.itime) then
- if ((ytra1(i).gt.real(ny_sn(2))).or. &
- (ytra1(i).lt.real(ny_sn(1)))) itra1(i)=-999999999
- if (((.not.xglobal).or.(nx_we(2).ne.(nx-2))).and. &
- ((xtra1(i).lt.real(nx_we(1))).or. &
- (xtra1(i).gt.real(nx_we(2))))) itra1(i)=-999999999
- endif
- if (itra1(i).ne.-999999999) numactiveparticles= &
- numactiveparticles+1
+ if (.not. part(i)%alive) cycle
+
+ if ((part(i)%ylat.gt.real(ny_sn(2))).or. &
+ (part(i)%ylat.lt.real(ny_sn(1)))) call terminate_particle(i)
+ if (((.not.xglobal).or.(nx_we(2).ne.(nx-2))).and. &
+ ((part(i)%xlon.lt.real(nx_we(1))).or. &
+ (part(i)%xlon.gt.real(nx_we(2))))) call terminate_particle(i)
+ if (part(i)%alive) numactiveparticles = numactiveparticles+1
end do
@@ -80,11 +81,6 @@ subroutine boundcond_domainfill(itime,loutend)
dt2=real(memtime(2)-itime)
dtt=1./(dt1+dt2)
- ! Initialize auxiliary variable used to search for vacant storage space
- !**********************************************************************
-
- minpart=1
-
!***************************************
! Western and eastern boundary condition
!***************************************
@@ -110,8 +106,6 @@ subroutine boundcond_domainfill(itime,loutend)
if (j.eq.1) then
deltaz=(zcolumn_we(k,jy,2)+zcolumn_we(k,jy,1))/2.
else if (j.eq.numcolumn_we(k,jy)) then
- ! deltaz=height(nz)-(zcolumn_we(k,jy,j-1)+
- ! + zcolumn_we(k,jy,j))/2.
! In order to avoid taking a very high column for very many particles,
! use the deltaz from one particle below instead
deltaz=(zcolumn_we(k,jy,j)-zcolumn_we(k,jy,j-2))/2.
@@ -135,10 +129,9 @@ subroutine boundcond_domainfill(itime,loutend)
if (height(i).gt.zcolumn_we(k,jy,j)) then
indz=i-1
indzp=i
- goto 6
+ exit
endif
end do
-6 continue
! Vertical distance to the level below and above current position
!****************************************************************
@@ -205,115 +198,95 @@ subroutine boundcond_domainfill(itime,loutend)
endif
do m=1,mmass
- do ipart=minpart,maxpart
-
- ! If a vacant storage space is found, attribute everything to this array element
- !*****************************************************************************
-
- if (itra1(ipart).ne.itime) then
+ call get_new_part_index(ipart)
+ call spawn_particle(itime, ipart)
! Assign particle positions
!**************************
- xtra1(ipart)=real(nx_we(k))
- if (jy.eq.ny_sn(1)) then
- ytra1(ipart)=real(jy)+0.5*ran1(idummy)
- else if (jy.eq.ny_sn(2)) then
- ytra1(ipart)=real(jy)-0.5*ran1(idummy)
- else
- ytra1(ipart)=real(jy)+(ran1(idummy)-.5)
- endif
- if (j.eq.1) then
- ztra1(ipart)=zcolumn_we(k,jy,1)+(zcolumn_we(k,jy,2)- &
- zcolumn_we(k,jy,1))/4.
- else if (j.eq.numcolumn_we(k,jy)) then
- ztra1(ipart)=(2.*zcolumn_we(k,jy,j)+ &
- zcolumn_we(k,jy,j-1)+height(nz))/4.
- else
- ztra1(ipart)=zcolumn_we(k,jy,j-1)+ran1(idummy)* &
- (zcolumn_we(k,jy,j+1)-zcolumn_we(k,jy,j-1))
- endif
+ call set_xlon(ipart,real(nx_we(k),kind=dp))
+ if (jy.eq.ny_sn(1)) then
+ call set_ylat(ipart,real(real(jy)+0.5*ran1(idummy),kind=dp))
+ else if (jy.eq.ny_sn(2)) then
+ call set_ylat(ipart,real(real(jy)-0.5*ran1(idummy),kind=dp))
+ else
+ call set_ylat(ipart,real(real(jy)+(ran1(idummy)-.5),kind=dp))
+ endif
+ if (j.eq.1) then
+ call set_z(ipart,zcolumn_we(k,jy,1)+(zcolumn_we(k,jy,2)- &
+ zcolumn_we(k,jy,1))/4.)
+ else if (j.eq.numcolumn_we(k,jy)) then
+ call set_z(ipart,(2.*zcolumn_we(k,jy,j)+ &
+ zcolumn_we(k,jy,j-1)+height(nz))/4.)
+ else
+ call set_z(ipart,zcolumn_we(k,jy,j-1)+ran1(idummy)* &
+ (zcolumn_we(k,jy,j+1)-zcolumn_we(k,jy,j-1)))
+ endif
+
+ call update_z_to_zeta(itime, ipart)
! Interpolate PV to the particle position
!****************************************
- ixm=int(xtra1(ipart))
- jym=int(ytra1(ipart))
- ixp=ixm+1
- jyp=jym+1
- ddx=xtra1(ipart)-real(ixm)
- ddy=ytra1(ipart)-real(jym)
- rddx=1.-ddx
- rddy=1.-ddy
- p1=rddx*rddy
- p2=ddx*rddy
- p3=rddx*ddy
- p4=ddx*ddy
- do i=2,nz
- if (height(i).gt.ztra1(ipart)) then
- indzm=i-1
- indzp=i
- goto 26
- endif
- end do
-26 continue
- dz1=ztra1(ipart)-height(indzm)
- dz2=height(indzp)-ztra1(ipart)
- dz=1./(dz1+dz2)
- do mm=1,2
- indexh=memind(mm)
- do in=1,2
- indzh=indzm+in-1
- y1(in)=p1*pv(ixm,jym,indzh,indexh) &
- +p2*pv(ixp,jym,indzh,indexh) &
- +p3*pv(ixm,jyp,indzh,indexh) &
- +p4*pv(ixp,jyp,indzh,indexh)
- end do
- yh1(mm)=(dz2*y1(1)+dz1*y1(2))*dz
- end do
- pvpart=(yh1(1)*dt2+yh1(2)*dt1)*dtt
- ylat=ylat0+ytra1(ipart)*dy
- if (ylat.lt.0.) pvpart=-1.*pvpart
+ ixm=int(part(ipart)%xlon)
+ jym=int(part(ipart)%ylat)
+ ixp=ixm+1
+ jyp=jym+1
+ ddx=part(ipart)%xlon-real(ixm)
+ ddy=part(ipart)%ylat-real(jym)
+ rddx=1.-ddx
+ rddy=1.-ddy
+ p1=rddx*rddy
+ p2=ddx*rddy
+ p3=rddx*ddy
+ p4=ddx*ddy
+ do i=2,nz
+ if (real(height(i),kind=dp).gt.part(ipart)%z) then
+ indzm=i-1
+ indzp=i
+ exit
+ endif
+ end do
+ dz1=real(part(ipart)%z)-height(indzm)
+ dz2=height(indzp)-real(part(ipart)%z)
+ dz=1./(dz1+dz2)
+ do mm=1,2
+ indexh=memind(mm)
+ do in=1,2
+ indzh=indzm+in-1
+ y1(in)=p1*pv(ixm,jym,indzh,indexh) &
+ +p2*pv(ixp,jym,indzh,indexh) &
+ +p3*pv(ixm,jyp,indzh,indexh) &
+ +p4*pv(ixp,jyp,indzh,indexh)
+ end do
+ yh1(mm)=(dz2*y1(1)+dz1*y1(2))*dz
+ end do
+ pvpart=(yh1(1)*dt2+yh1(2)*dt1)*dtt
+ ylat=ylat0+part(ipart)%ylat*dy
+ if (ylat.lt.0.) pvpart=-1.*pvpart
! For domain-filling option 2 (stratospheric O3), do the rest only in the stratosphere
!*****************************************************************************
- if (((ztra1(ipart).gt.3000.).and. &
- (pvpart.gt.pvcrit)).or.(mdomainfill.eq.1)) then
- nclass(ipart)=min(int(ran1(idummy)* &
- real(nclassunc))+1,nclassunc)
- numactiveparticles=numactiveparticles+1
- numparticlecount=numparticlecount+1
- npoint(ipart)=numparticlecount
- idt(ipart)=mintime
- itra1(ipart)=itime
- itramem(ipart)=itra1(ipart)
- itrasplit(ipart)=itra1(ipart)+ldirect*itsplit
- xmass1(ipart,1)=xmassperparticle
- if (mdomainfill.eq.2) xmass1(ipart,1)= &
- xmass1(ipart,1)*pvpart*48./29.*ozonescale/10.**9
- else
- goto 71
- endif
-
-
- ! Increase numpart, if necessary
- !*******************************
-
- numpart=max(numpart,ipart)
- goto 73 ! Storage space has been found, stop searching
- endif
- end do
- if (ipart.gt.maxpart) &
- stop 'boundcond_domainfill.f: too many particles required'
-73 minpart=ipart+1
-71 continue
- end do
-
-
- end do
- end do
- end do
+ if (((part(ipart)%z.gt.3000.).and. &
+ (pvpart.gt.pvcrit)).or.(mdomainfill.eq.1)) then
+ part(ipart)%nclass=min(int(ran1(idummy)* &
+ real(nclassunc))+1,nclassunc)
+ numactiveparticles=numactiveparticles+1
+ numparticlecount=numparticlecount+1
+ part(ipart)%npoint=numparticlecount
+ part(ipart)%idt=mintime
+ part(ipart)%tstart=itime
+ part(ipart)%mass(1)=xmassperparticle
+ if (mdomainfill.eq.2) part(ipart)%mass(1)= &
+ part(ipart)%mass(1)*pvpart*48./29.*ozonescale/10.**9
+ else
+ stop 'boundcond_domainfill error: look into original to understand what should happen here'
+ endif
+ end do ! particles
+ end do ! release locations in column
+ end do ! western and eastern boundary
+ end do ! south to north
!*****************************************
@@ -368,10 +341,9 @@ subroutine boundcond_domainfill(itime,loutend)
if (height(i).gt.zcolumn_sn(k,ix,j)) then
indz=i-1
indzp=i
- goto 16
+ exit
endif
end do
-16 continue
! Vertical distance to the level below and above current position
!****************************************************************
@@ -437,124 +409,92 @@ subroutine boundcond_domainfill(itime,loutend)
endif
do m=1,mmass
- do ipart=minpart,maxpart
-
- ! If a vacant storage space is found, attribute everything to this array element
- !*****************************************************************************
-
- if (itra1(ipart).ne.itime) then
-
+ call get_new_part_index(ipart)
+ call spawn_particle(itime, ipart)
+
! Assign particle positions
!**************************
+ call set_ylat(ipart,real(ny_sn(k),kind=dp))
+ if (ix.eq.nx_we(1)) then
+ call set_xlon(ipart,real(real(ix)+0.5*ran1(idummy),kind=dp))
+ else if (ix.eq.nx_we(2)) then
+ call set_xlon(ipart,real(real(ix)-0.5*ran1(idummy),kind=dp))
+ else
+ call set_xlon(ipart,real(real(ix)+(ran1(idummy)-.5),kind=dp))
+ endif
+ if (j.eq.1) then
+ call set_z(ipart,zcolumn_sn(k,ix,1)+(zcolumn_sn(k,ix,2)- &
+ zcolumn_sn(k,ix,1))/4.)
+ else if (j.eq.numcolumn_sn(k,ix)) then
+ call set_z(ipart,(2.*zcolumn_sn(k,ix,j)+ &
+ zcolumn_sn(k,ix,j-1)+height(nz))/4.)
+ else
+ call set_z(ipart,zcolumn_sn(k,ix,j-1)+ran1(idummy)* &
+ (zcolumn_sn(k,ix,j+1)-zcolumn_sn(k,ix,j-1)))
+ endif
- ytra1(ipart)=real(ny_sn(k))
- if (ix.eq.nx_we(1)) then
- xtra1(ipart)=real(ix)+0.5*ran1(idummy)
- else if (ix.eq.nx_we(2)) then
- xtra1(ipart)=real(ix)-0.5*ran1(idummy)
- else
- xtra1(ipart)=real(ix)+(ran1(idummy)-.5)
- endif
- if (j.eq.1) then
- ztra1(ipart)=zcolumn_sn(k,ix,1)+(zcolumn_sn(k,ix,2)- &
- zcolumn_sn(k,ix,1))/4.
- else if (j.eq.numcolumn_sn(k,ix)) then
- ztra1(ipart)=(2.*zcolumn_sn(k,ix,j)+ &
- zcolumn_sn(k,ix,j-1)+height(nz))/4.
- else
- ztra1(ipart)=zcolumn_sn(k,ix,j-1)+ran1(idummy)* &
- (zcolumn_sn(k,ix,j+1)-zcolumn_sn(k,ix,j-1))
- endif
-
+ call update_z_to_zeta(itime, ipart)
! Interpolate PV to the particle position
!****************************************
- ixm=int(xtra1(ipart))
- jym=int(ytra1(ipart))
- ixp=ixm+1
- jyp=jym+1
- ddx=xtra1(ipart)-real(ixm)
- ddy=ytra1(ipart)-real(jym)
- rddx=1.-ddx
- rddy=1.-ddy
- p1=rddx*rddy
- p2=ddx*rddy
- p3=rddx*ddy
- p4=ddx*ddy
- do i=2,nz
- if (height(i).gt.ztra1(ipart)) then
- indzm=i-1
- indzp=i
- goto 126
- endif
- end do
-126 continue
- dz1=ztra1(ipart)-height(indzm)
- dz2=height(indzp)-ztra1(ipart)
- dz=1./(dz1+dz2)
- do mm=1,2
- indexh=memind(mm)
- do in=1,2
- indzh=indzm+in-1
- y1(in)=p1*pv(ixm,jym,indzh,indexh) &
- +p2*pv(ixp,jym,indzh,indexh) &
- +p3*pv(ixm,jyp,indzh,indexh) &
- +p4*pv(ixp,jyp,indzh,indexh)
- end do
- yh1(mm)=(dz2*y1(1)+dz1*y1(2))*dz
- end do
- pvpart=(yh1(1)*dt2+yh1(2)*dt1)*dtt
- if (ylat.lt.0.) pvpart=-1.*pvpart
-
-
- ! For domain-filling option 2 (stratospheric O3), do the rest only in the stratosphere
- !*****************************************************************************
-
- if (((ztra1(ipart).gt.3000.).and. &
- (pvpart.gt.pvcrit)).or.(mdomainfill.eq.1)) then
- nclass(ipart)=min(int(ran1(idummy)* &
- real(nclassunc))+1,nclassunc)
- numactiveparticles=numactiveparticles+1
- numparticlecount=numparticlecount+1
- npoint(ipart)=numparticlecount
- idt(ipart)=mintime
- itra1(ipart)=itime
- itramem(ipart)=itra1(ipart)
- itrasplit(ipart)=itra1(ipart)+ldirect*itsplit
- xmass1(ipart,1)=xmassperparticle
- if (mdomainfill.eq.2) xmass1(ipart,1)= &
- xmass1(ipart,1)*pvpart*48./29.*ozonescale/10.**9
- else
- goto 171
- endif
-
-
- ! Increase numpart, if necessary
- !*******************************
- numpart=max(numpart,ipart)
- goto 173 ! Storage space has been found, stop searching
+ ixm=int(part(ipart)%xlon)
+ jym=int(part(ipart)%ylat)
+ ixp=ixm+1
+ jyp=jym+1
+ ddx=part(ipart)%xlon-real(ixm)
+ ddy=part(ipart)%ylat-real(jym)
+ rddx=1.-ddx
+ rddy=1.-ddy
+ p1=rddx*rddy
+ p2=ddx*rddy
+ p3=rddx*ddy
+ p4=ddx*ddy
+ do i=2,nz
+ if (real(height(i),kind=dp).gt.part(ipart)%z) then
+ indzm=i-1
+ indzp=i
+ exit
endif
end do
- if (ipart.gt.maxpart) &
- stop 'boundcond_domainfill.f: too many particles required'
-173 minpart=ipart+1
-171 continue
- end do
-
-
- end do
- end do
- end do
+ dz1=real(part(ipart)%z)-height(indzm)
+ dz2=height(indzp)-real(part(ipart)%z)
+ dz=1./(dz1+dz2)
+ do mm=1,2
+ indexh=memind(mm)
+ do in=1,2
+ indzh=indzm+in-1
+ y1(in)=p1*pv(ixm,jym,indzh,indexh) &
+ +p2*pv(ixp,jym,indzh,indexh) &
+ +p3*pv(ixm,jyp,indzh,indexh) &
+ +p4*pv(ixp,jyp,indzh,indexh)
+ end do
+ yh1(mm)=(dz2*y1(1)+dz1*y1(2))*dz
+ end do
+ pvpart=(yh1(1)*dt2+yh1(2)*dt1)*dtt
+ if (ylat.lt.0.) pvpart=-1.*pvpart
- xm=0.
- do i=1,numpart
- if (itra1(i).eq.itime) xm=xm+xmass1(i,1)
- end do
-
- !write(*,*) itime,numactiveparticles,numparticlecount,numpart,
- ! +xm,accmasst,xm+accmasst
+ ! For domain-filling option 2 (stratospheric O3), do the rest only in the stratosphere
+ !*****************************************************************************
+ if (((part(ipart)%z.gt.3000.).and. &
+ (pvpart.gt.pvcrit)).or.(mdomainfill.eq.1)) then
+ part(ipart)%nclass=min(int(ran1(idummy)* &
+ real(nclassunc))+1,nclassunc)
+ numactiveparticles=numactiveparticles+1
+ numparticlecount=numparticlecount+1
+ part(ipart)%npoint=numparticlecount
+ part(ipart)%idt=mintime
+ part(ipart)%mass(1)=xmassperparticle
+ if (mdomainfill.eq.2) part(ipart)%mass(1)= &
+ part(ipart)%mass(1)*pvpart*48./29.*ozonescale/10.**9
+ else
+ stop 'boundcond_domainfill error: look into original to understand what should happen here'
+ endif
+ end do ! particles
+ end do ! releases per column
+ end do ! east west
+ end do ! north south
! If particles shall be dumped, then accumulated masses at the domain boundaries
! must be dumped, too, to be used for later runs
diff --git a/src/boundcond_domainfill_mpi.f90 b/src/redundant/boundcond_domainfill_mpi.f90
similarity index 100%
rename from src/boundcond_domainfill_mpi.f90
rename to src/redundant/boundcond_domainfill_mpi.f90
diff --git a/src/calcfluxes.f90 b/src/redundant/calcfluxes.f90
similarity index 83%
rename from src/calcfluxes.f90
rename to src/redundant/calcfluxes.f90
index c75078b1..f7f18392 100644
--- a/src/calcfluxes.f90
+++ b/src/redundant/calcfluxes.f90
@@ -1,7 +1,7 @@
! SPDX-FileCopyrightText: FLEXPART 1998-2019, see flexpart_license.txt
! SPDX-License-Identifier: GPL-3.0-or-later
-subroutine calcfluxes(nage,jpart,xold,yold,zold)
+subroutine calcfluxes(itime,nage,jpart,xold,yold,zold)
! i i i i i
!*****************************************************************************
! *
@@ -29,10 +29,12 @@ subroutine calcfluxes(nage,jpart,xold,yold,zold)
use outg_mod
use par_mod
use com_mod
+ use particle_mod
+ use coordinates_ecmwf
implicit none
- integer :: jpart,nage,ixave,jyave,kz,kzave,kp
+ integer :: itime,jpart,nage,ixave,jyave,kz,kzave,kp
integer :: k,k1,k2,ix,ix1,ix2,ixs,jy,jy1,jy2
real :: xold,yold,zold,xmean,ymean
@@ -41,20 +43,20 @@ subroutine calcfluxes(nage,jpart,xold,yold,zold)
!****************************
if ((ioutputforeachrelease.eq.1).and.(mdomainfill.eq.0)) then
- kp=npoint(jpart)
+ kp=part(jpart)%npoint
else
kp=1
endif
-
- xmean=(xold+xtra1(jpart))/2.
- ymean=(yold+ytra1(jpart))/2.
+ call update_zeta_to_z(itime,jpart)
+ xmean=(xold+part(jpart)%xlon)/2.
+ ymean=(yold+part(jpart)%ylat)/2.
ixave=int((xmean*dx+xoutshift)/dxout)
jyave=int((ymean*dy+youtshift)/dyout)
do kz=1,numzgrid ! determine height of cell
- if (outheight(kz).gt.ztra1(jpart)) goto 16
+ if (outheight(kz).gt.part(jpart)%z) exit
end do
-16 kzave=kz
+ kzave=kz
! Determine vertical fluxes
@@ -63,24 +65,24 @@ subroutine calcfluxes(nage,jpart,xold,yold,zold)
if ((ixave.ge.0).and.(jyave.ge.0).and.(ixave.le.numxgrid-1).and. &
(jyave.le.numygrid-1)) then
do kz=1,numzgrid ! determine height of cell
- if (outheighthalf(kz).gt.zold) goto 11
+ if (outheighthalf(kz).gt.zold) exit
end do
-11 k1=min(numzgrid,kz)
+ k1=min(numzgrid,kz)
do kz=1,numzgrid ! determine height of cell
- if (outheighthalf(kz).gt.ztra1(jpart)) goto 21
+ if (outheighthalf(kz).gt.part(jpart)%z) exit
end do
-21 k2=min(numzgrid,kz)
+ k2=min(numzgrid,kz)
do k=1,nspec
do kz=k1,k2-1
flux(5,ixave,jyave,kz,k,kp,nage)= &
flux(5,ixave,jyave,kz,k,kp,nage)+ &
- xmass1(jpart,k)
+ part(jpart)%mass(k)
end do
do kz=k2,k1-1
flux(6,ixave,jyave,kz,k,kp,nage)= &
flux(6,ixave,jyave,kz,k,kp,nage)+ &
- xmass1(jpart,k)
+ part(jpart)%mass(k)
end do
end do
endif
@@ -94,22 +96,22 @@ subroutine calcfluxes(nage,jpart,xold,yold,zold)
! 1) Particle does not cross domain boundary
- if (abs(xold-xtra1(jpart)).lt.real(nx)/2.) then
+ if (abs(xold-part(jpart)%xlon).lt.real(nx)/2.) then
ix1=int((xold*dx+xoutshift)/dxout+0.5)
- ix2=int((xtra1(jpart)*dx+xoutshift)/dxout+0.5)
+ ix2=int((part(jpart)%xlon*dx+xoutshift)/dxout+0.5)
do k=1,nspec
do ix=ix1,ix2-1
if ((ix.ge.0).and.(ix.le.numxgrid-1)) then
flux(1,ix,jyave,kzave,k,kp,nage)= &
flux(1,ix,jyave,kzave,k,kp,nage) &
- +xmass1(jpart,k)
+ +part(jpart)%mass(k)
endif
end do
do ix=ix2,ix1-1
if ((ix.ge.0).and.(ix.le.numxgrid-1)) then
flux(2,ix,jyave,kzave,k,kp,nage)= &
flux(2,ix,jyave,kzave,k,kp,nage) &
- +xmass1(jpart,k)
+ +part(jpart)%mass(k)
endif
end do
end do
@@ -121,17 +123,17 @@ subroutine calcfluxes(nage,jpart,xold,yold,zold)
else
ixs=int(((real(nxmin1)-1.e5)*dx+xoutshift)/dxout)
if ((ixs.ge.0).and.(ixs.le.numxgrid-1)) then
- if (xold.gt.xtra1(jpart)) then ! west-east flux
+ if (xold.gt.part(jpart)%xlon) then ! west-east flux
do k=1,nspec
flux(1,ixs,jyave,kzave,k,kp,nage)= &
flux(1,ixs,jyave,kzave,k,kp,nage) &
- +xmass1(jpart,k)
+ +part(jpart)%mass(k)
end do
else ! east-west flux
do k=1,nspec
flux(2,ixs,jyave,kzave,k,kp,nage)= &
flux(2,ixs,jyave,kzave,k,kp,nage) &
- +xmass1(jpart,k)
+ +part(jpart)%mass(k)
end do
endif
endif
@@ -145,21 +147,21 @@ subroutine calcfluxes(nage,jpart,xold,yold,zold)
if ((kzave.le.numzgrid).and.(ixave.ge.0).and. &
(ixave.le.numxgrid-1)) then
jy1=int((yold*dy+youtshift)/dyout+0.5)
- jy2=int((ytra1(jpart)*dy+youtshift)/dyout+0.5)
+ jy2=int((part(jpart)%ylat*dy+youtshift)/dyout+0.5)
do k=1,nspec
do jy=jy1,jy2-1
if ((jy.ge.0).and.(jy.le.numygrid-1)) then
flux(3,ixave,jy,kzave,k,kp,nage)= &
flux(3,ixave,jy,kzave,k,kp,nage) &
- +xmass1(jpart,k)
+ +part(jpart)%mass(k)
endif
end do
do jy=jy2,jy1-1
if ((jy.ge.0).and.(jy.le.numygrid-1)) then
flux(4,ixave,jy,kzave,k,kp,nage)= &
flux(4,ixave,jy,kzave,k,kp,nage) &
- +xmass1(jpart,k)
+ +part(jpart)%mass(k)
endif
end do
end do
diff --git a/src/calcmatrix.f90 b/src/redundant/calcmatrix.f90
similarity index 67%
rename from src/calcmatrix.f90
rename to src/redundant/calcmatrix.f90
index 5c6246e2..1b3c4b72 100644
--- a/src/calcmatrix.f90
+++ b/src/redundant/calcmatrix.f90
@@ -67,23 +67,35 @@ subroutine calcmatrix(lconv,delt,cbmf,metdata_format)
phconv(1) = psconv
! Emanuel subroutine needs pressure in hPa, therefore convert all pressures
- do kuvz = 2,nuvz
- k = kuvz-1
- if (metdata_format.eq.GRIBFILE_CENTRE_ECMWF) then
- pconv(k) = (akz(kuvz) + bkz(kuvz)*psconv)
- phconv(kuvz) = (akm(kuvz) + bkm(kuvz)*psconv)
- else
- phconv(kuvz) = 0.5*(pconv(kuvz)+pconv(k))
- endif
- dpr(k) = phconv(k) - phconv(kuvz)
- qsconv(k) = f_qvsat( pconv(k), tconv(k) )
+ ! do kuvz = 2,nuvz
+ ! k = kuvz-1
+ ! if (metdata_format.eq.GRIBFILE_CENTRE_ECMWF) then
+ ! pconv(k) = (akz(kuvz) + bkz(kuvz)*psconv)
+ ! phconv(kuvz) = (akm(kuvz) + bkm(kuvz)*psconv)
+ ! else
+ ! phconv(kuvz) = 0.5*(pconv(kuvz)+pconv(k))
+ ! endif
+ ! dpr(k) = phconv(k) - phconv(kuvz)
+ ! qsconv(k) = f_qvsat( pconv(k), tconv(k) )
! initialize mass fractions
- do kk=1,nconvlev
- fmassfrac(k,kk)=0.
- end do
+ ! do kk=1,nconvlev
+ ! fmassfrac(k,kk)=0.
+ ! end do
+ ! end do
+ ! LB 04.05.2021, replace above with array operations
+ if (metdata_format.eq.GRIBFILE_CENTRE_ECMWF) then
+ pconv(1:nuvz-1) = (akz(2:nuvz) + bkz(2:nuvz)*psconv)
+ phconv(2:nuvz) = (akm(2:nuvz) + bkm(2:nuvz)*psconv)
+ else
+ phconv(2:nuvz) = 0.5*(pconv(2:nuvz)+pconv(1:nuvz-1))
+ endif
+ dpr(1:nuvz-1) = phconv(1:nuvz-1) - phconv(2:nuvz)
+ do k = 1,nuvz-1
+ qsconv(k) = f_qvsat( pconv(k), tconv(k) )
end do
-
+ fmassfrac(1:nuvz-1,1:nconvlev)=0.
+ ! LB end
!note that Emanuel says it is important
!a. to set this =0. every grid point
@@ -92,47 +104,58 @@ subroutine calcmatrix(lconv,delt,cbmf,metdata_format)
! CALL CONVECTION
!******************
- cbmfold = cbmf
+ cbmfold = cbmf
! Convert pressures to hPa, as required by Emanuel scheme
!********************************************************
!!$ do k=1,nconvlev !old
- do k=1,nconvlev+1 !bugfix
- pconv_hpa(k)=pconv(k)/100.
- phconv_hpa(k)=phconv(k)/100.
- end do
- phconv_hpa(nconvlev+1)=phconv(nconvlev+1)/100.
- call convect(nconvlevmax, nconvlev, delt, iflag, &
- precip, wd, tprime, qprime, cbmf)
+ ! do k=1,nconvlev+1 !bugfix
+ ! pconv_hpa(k)=pconv(k)/100.
+ ! phconv_hpa(k)=phconv(k)/100.
+ ! end do
+ ! phconv_hpa(nconvlev+1)=phconv(nconvlev+1)/100.
+ ! LB 04.05.2021, replace above with array operations
+ pconv_hpa(1:nconvlev+1)=pconv(1:nconvlev+1)/100.
+ phconv_hpa(1:nconvlev+1)=phconv(1:nconvlev+1)/100.
+ ! LB end
+
+ call convect(nconvlevmax, nconvlev, delt, iflag, &
+ precip, wd, tprime, qprime, cbmf)
! do not update fmassfrac and cloudbase massflux
! if no convection takes place or
! if a CFL criterion is violated in convect43c.f
- if (iflag .ne. 1 .and. iflag .ne. 4) then
- cbmf=cbmfold
- goto 200
- endif
+ if (iflag .ne. 1 .and. iflag .ne. 4) then
+ cbmf=cbmfold
+ goto 200
+ endif
! do not update fmassfrac and cloudbase massflux
! if the old and the new cloud base mass
! fluxes are zero
- if (cbmf.le.0..and.cbmfold.le.0.) then
- cbmf=cbmfold
- goto 200
- endif
+ if (cbmf.le.0..and.cbmfold.le.0.) then
+ cbmf=cbmfold
+ goto 200
+ endif
! Update fmassfrac
! account for mass displaced from level k to level k
- lconv = .true.
- do k=1,nconvtop
- rlevmass = dpr(k)/ga
- summe = 0.
- do kk=1,nconvtop
- fmassfrac(k,kk) = delt*fmass(k,kk)
- summe = summe + fmassfrac(k,kk)
- end do
- fmassfrac(k,k)=fmassfrac(k,k) + rlevmass - summe
+ lconv = .true.
+ do k=1,nconvtop
+ rlevmass = dpr(k)/ga
+ summe = 0.
+ do kk=1,nconvtop
+ fmassfrac(k,kk) = delt*fmass(k,kk)
+ summe = summe + fmassfrac(k,kk)
end do
+ fmassfrac(k,k)=fmassfrac(k,k) + rlevmass - summe
+ end do
+ ! LB 04.05.2021, replace above with array operations (not the problem)
+ ! fmassfrac(1:nconvtop,1:nconvtop) = delt*fmass(1:nconvtop,1:nconvtop)
+ ! do k=1, nconvtop
+ ! fmassfrac(k, k) = fmassfrac(k, k) + dpr(k)/ga - sum(fmassfrac(k, 1:nconvtop))
+ ! end do
+ ! LB end
200 continue
diff --git a/src/calcpar_nests.f90 b/src/redundant/calcpar_nests.f90
similarity index 100%
rename from src/calcpar_nests.f90
rename to src/redundant/calcpar_nests.f90
diff --git a/src/redundant/calcpv.f90 b/src/redundant/calcpv.f90
new file mode 100644
index 00000000..7cb453f4
--- /dev/null
+++ b/src/redundant/calcpv.f90
@@ -0,0 +1,579 @@
+! SPDX-FileCopyrightText: FLEXPART 1998-2019, see flexpart_license.txt
+! SPDX-License-Identifier: GPL-3.0-or-later
+
+subroutine calcpv(n,uuh,vvh,pvh)
+ ! i i i o
+ !*****************************************************************************
+ ! *
+ ! Calculation of potential vorticity on 3-d grid. *
+ ! *
+ ! Author: P. James *
+ ! 3 February 2000 *
+ ! *
+ ! Adaptation to FLEXPART, A. Stohl, 1 May 2000 *
+ ! *
+ !*****************************************************************************
+ ! *
+ ! Variables: *
+ ! n temporal index for meteorological fields (1 to 2) *
+ ! *
+ ! Constants: *
+ ! *
+ !*****************************************************************************
+
+ use par_mod
+ use com_mod
+ use windfields_mod
+
+ implicit none
+
+ integer :: n,ix,jy,i,j,k,kl,ii,jj,klvrp,klvrm,klpt,kup,kdn,kch
+ integer :: jyvp,jyvm,ixvp,ixvm,jumpx,jumpy,jux,juy,ivrm,ivrp,ivr
+ integer :: nlck
+ real :: vx(2),uy(2),phi,tanphi,cosphi,dvdx,dudy,f
+ real :: theta,thetap,thetam,dthetadp,dt1,dt2,dt
+ real :: pvavr,ppml(0:nxmax-1,0:nymax-1,nuvzmax),ppmk(0:nxmax-1,0:nymax-1,nuvzmax)
+ real :: thup,thdn
+ real,parameter :: eps=1.e-5, p0=101325
+ real :: uuh(0:nxmax-1,0:nymax-1,nuvzmax)
+ real :: vvh(0:nxmax-1,0:nymax-1,nuvzmax)
+ real :: pvh(0:nxmax-1,0:nymax-1,nuvzmax)
+
+ ! Set number of levels to check for adjacent theta
+ nlck=nuvz/3
+ !
+ ! Loop over entire grid
+ !**********************
+ do kl=1,nuvz
+ do jy=0,nymin1
+ do ix=0,nxmin1
+ ppml(ix,jy,kl)=akz(kl)+bkz(kl)*ps(ix,jy,1,n)
+ enddo
+ enddo
+ enddo
+
+! ppmk(:,:,1:nuvz)=(100000./ppml(:,:,1:nuvz))**kappa
+ ppmk(0:nxmin1,0:nymin1,1:nuvz)=(100000./ppml(0:nxmin1,0:nymin1,1:nuvz))**kappa
+!$OMP PARALLEL PRIVATE(jy,ix,kl,phi,f,tanphi,cosphi,jyvp,jyvm,jumpy,juy, &
+!$OMP ixvp,ixvm,jumpx,ivrp,ivrm,jux,theta,klvrp,klvrm,klpt,thetap,thetam,dthetadp, &
+!$OMP ii,i,ivr,kdn,kch,kup,thdn,thup,dt1,dt2,dt,vx,k,dvdx, &
+!$OMP jj,j,uy,dudy)
+!$OMP DO
+ do jy=0,nymin1
+ if (sglobal.and.jy.eq.0) goto 10
+ if (nglobal.and.jy.eq.nymin1) goto 10
+ phi = (ylat0 + jy * dy) * pi / 180.
+ f = 0.00014585 * sin(phi)
+ tanphi = tan(phi)
+ cosphi = cos(phi)
+ ! Provide a virtual jy+1 and jy-1 in case we are on domain edge (Lat)
+ jyvp=jy+1
+ jyvm=jy-1
+ if (jy.eq.0) jyvm=0
+ if (jy.eq.nymin1) jyvp=nymin1
+ ! Define absolute gap length
+ jumpy=2
+ if (jy.eq.0.or.jy.eq.nymin1) jumpy=1
+ if (sglobal.and.jy.eq.1) then
+ jyvm=1
+ jumpy=1
+ end if
+ if (nglobal.and.jy.eq.ny-2) then
+ jyvp=ny-2
+ jumpy=1
+ end if
+ juy=jumpy
+ !
+ do ix=0,nxmin1
+ ! Provide a virtual ix+1 and ix-1 in case we are on domain edge (Long)
+ ixvp=ix+1
+ ixvm=ix-1
+ jumpx=2
+ if (xglobal) then
+ ivrp=ixvp
+ ivrm=ixvm
+ if (ixvm.lt.0) ivrm=ixvm+nxmin1
+ if (ixvp.ge.nx) ivrp=ixvp-nx+1
+ else
+ if (ix.eq.0) ixvm=0
+ if (ix.eq.nxmin1) ixvp=nxmin1
+ ivrp=ixvp
+ ivrm=ixvm
+ ! Define absolute gap length
+ if (ix.eq.0.or.ix.eq.nxmin1) jumpx=1
+ end if
+ jux=jumpx
+ !
+ ! Loop over the vertical
+ !***********************
+
+ do kl=1,nuvz
+ theta=tth(ix,jy,kl,n)*ppmk(ix,jy,kl)
+ klvrp=kl+1
+ klvrm=kl-1
+ klpt=kl
+ ! If top or bottom level, dthetadp is evaluated between the current
+ ! level and the level inside, otherwise between level+1 and level-1
+ !
+ if (klvrp.gt.nuvz) klvrp=nuvz
+ if (klvrm.lt.1) klvrm=1
+ thetap=tth(ix,jy,klvrp,n)*ppmk(ix,jy,klvrp)
+ thetam=tth(ix,jy,klvrm,n)*ppmk(ix,jy,klvrm)
+ dthetadp=(thetap-thetam)/(ppml(ix,jy,klvrp)-ppml(ix,jy,klvrm))
+
+ ! Compute vertical position at pot. temperature surface on subgrid
+ ! and the wind at that position
+ !*****************************************************************
+ ! a) in x direction
+ ii=0
+ do i=ixvm,ixvp,jumpx
+ ivr=i
+ if (xglobal) then
+ if (i.lt.0) ivr=ivr+nxmin1
+ if (i.ge.nx) ivr=ivr-nx+1
+ end if
+ ii=ii+1
+ ! Search adjacent levels for current theta value
+ ! Spiral out from current level for efficiency
+ kup=klpt-1
+ kdn=klpt
+ kch=0
+40 continue
+ ! Upward branch
+ kup=kup+1
+ if (kch.ge.nlck) goto 21 ! No more levels to check,
+ ! ! and no values found
+ if (kup.ge.nuvz) goto 41
+ kch=kch+1
+ k=kup
+ thdn=tth(ivr,jy,k,n)*ppmk(ivr,jy,k)
+ thup=tth(ivr,jy,k+1,n)*ppmk(ivr,jy,k+1)
+
+
+ if (((thdn.ge.theta).and.(thup.le.theta)).or. &
+ ((thdn.le.theta).and.(thup.ge.theta))) then
+ dt1=abs(theta-thdn)
+ dt2=abs(theta-thup)
+ dt=dt1+dt2
+ if (dt.lt.eps) then ! Avoid division by zero error
+ dt1=0.5 ! G.W., 10.4.1996
+ dt2=0.5
+ dt=1.0
+ endif
+ vx(ii)=(vvh(ivr,jy,k)*dt2+vvh(ivr,jy,k+1)*dt1)/dt
+ goto 20
+ endif
+41 continue
+ ! Downward branch
+ kdn=kdn-1
+ if (kdn.lt.1) goto 40
+ kch=kch+1
+ k=kdn
+ thdn=tth(ivr,jy,k,n)*ppmk(ivr,jy,k)
+ thup=tth(ivr,jy,k+1,n)*ppmk(ivr,jy,k+1)
+
+ if (((thdn.ge.theta).and.(thup.le.theta)).or. &
+ ((thdn.le.theta).and.(thup.ge.theta))) then
+ dt1=abs(theta-thdn)
+ dt2=abs(theta-thup)
+ dt=dt1+dt2
+ if (dt.lt.eps) then ! Avoid division by zero error
+ dt1=0.5 ! G.W., 10.4.1996
+ dt2=0.5
+ dt=1.0
+ endif
+ vx(ii)=(vvh(ivr,jy,k)*dt2+vvh(ivr,jy,k+1)*dt1)/dt
+ goto 20
+ endif
+ goto 40
+ ! This section used when no values were found
+21 continue
+ ! Must use vv at current level and long. jux becomes smaller by 1
+ vx(ii)=vvh(ix,jy,kl)
+ jux=jux-1
+ ! Otherwise OK
+20 continue
+ end do
+ if (jux.gt.0) then
+ dvdx=(vx(2)-vx(1))/real(jux)/(dx*pi/180.)
+ else
+ dvdx=vvh(ivrp,jy,kl)-vvh(ivrm,jy,kl)
+ dvdx=dvdx/real(jumpx)/(dx*pi/180.)
+ ! Only happens if no equivalent theta value
+ ! can be found on either side, hence must use values
+ ! from either side, same pressure level.
+ end if
+
+ ! b) in y direction
+
+ jj=0
+ do j=jyvm,jyvp,jumpy
+ jj=jj+1
+ ! Search adjacent levels for current theta value
+ ! Spiral out from current level for efficiency
+ kup=klpt-1
+ kdn=klpt
+ kch=0
+70 continue
+ ! Upward branch
+ kup=kup+1
+ if (kch.ge.nlck) goto 51 ! No more levels to check,
+ ! ! and no values found
+ if (kup.ge.nuvz) goto 71
+ kch=kch+1
+ k=kup
+ thdn=tth(ix,j,k,n)*ppmk(ix,j,k)
+ thup=tth(ix,j,k+1,n)*ppmk(ix,j,k+1)
+ if (((thdn.ge.theta).and.(thup.le.theta)).or. &
+ ((thdn.le.theta).and.(thup.ge.theta))) then
+ dt1=abs(theta-thdn)
+ dt2=abs(theta-thup)
+ dt=dt1+dt2
+ if (dt.lt.eps) then ! Avoid division by zero error
+ dt1=0.5 ! G.W., 10.4.1996
+ dt2=0.5
+ dt=1.0
+ endif
+ uy(jj)=(uuh(ix,j,k)*dt2+uuh(ix,j,k+1)*dt1)/dt
+ goto 50
+ endif
+71 continue
+ ! Downward branch
+ kdn=kdn-1
+ if (kdn.lt.1) goto 70
+ kch=kch+1
+ k=kdn
+ thdn=tth(ix,j,k,n)*ppmk(ix,j,k)
+ thup=tth(ix,j,k+1,n)*ppmk(ix,j,k+1)
+ if (((thdn.ge.theta).and.(thup.le.theta)).or. &
+ ((thdn.le.theta).and.(thup.ge.theta))) then
+ dt1=abs(theta-thdn)
+ dt2=abs(theta-thup)
+ dt=dt1+dt2
+ if (dt.lt.eps) then ! Avoid division by zero error
+ dt1=0.5 ! G.W., 10.4.1996
+ dt2=0.5
+ dt=1.0
+ endif
+ uy(jj)=(uuh(ix,j,k)*dt2+uuh(ix,j,k+1)*dt1)/dt
+ goto 50
+ endif
+ goto 70
+ ! This section used when no values were found
+51 continue
+ ! Must use uu at current level and lat. juy becomes smaller by 1
+ uy(jj)=uuh(ix,jy,kl)
+ juy=juy-1
+ ! Otherwise OK
+50 continue
+ end do
+ if (juy.gt.0) then
+ dudy=(uy(2)-uy(1))/real(juy)/(dy*pi/180.)
+ else
+ dudy=uuh(ix,jyvp,kl)-uuh(ix,jyvm,kl)
+ dudy=dudy/real(jumpy)/(dy*pi/180.)
+ end if
+ !
+ pvh(ix,jy,kl)=dthetadp*(f+(dvdx/cosphi-dudy &
+ +uuh(ix,jy,kl)*tanphi)/r_earth)*(-1.e6)*9.81
+
+
+ !
+ ! Resest jux and juy
+ jux=jumpx
+ juy=jumpy
+ end do
+ end do
+10 continue
+ end do
+!$OMP END DO
+!$OMP END PARALLEL
+ !
+ ! Fill in missing PV values on poles, if present
+ ! Use mean PV of surrounding latitude ring
+ !
+ if (sglobal) then
+ do kl=1,nuvz
+ pvavr=0.
+ do ix=0,nxmin1
+ pvavr=pvavr+pvh(ix,1,kl)
+ end do
+ pvavr=pvavr/real(nx)
+ jy=0
+ do ix=0,nxmin1
+ pvh(ix,jy,kl)=pvavr
+ end do
+ end do
+ end if
+ if (nglobal) then
+ do kl=1,nuvz
+ pvavr=0.
+ do ix=0,nxmin1
+ pvavr=pvavr+pvh(ix,ny-2,kl)
+ end do
+ pvavr=pvavr/real(nx)
+ jy=nymin1
+ do ix=0,nxmin1
+ pvh(ix,jy,kl)=pvavr
+ end do
+ end do
+ end if
+
+end subroutine calcpv
+
+subroutine calcpv_nests(l,n,uuhn,vvhn,pvhn)
+ ! i i i i o
+ !*****************************************************************************
+ ! *
+ ! Calculation of potential vorticity on 3-d nested grid *
+ ! *
+ ! Author: P. James *
+ ! 22 February 2000 *
+ ! *
+ !*****************************************************************************
+ ! *
+ ! Variables: *
+ ! n temporal index for meteorological fields (1 to 2) *
+ ! l index of current nest *
+ ! *
+ ! Constants: *
+ ! *
+ !*****************************************************************************
+
+ use par_mod
+ use com_mod
+ use windfields_mod
+
+ implicit none
+
+ integer :: n,ix,jy,i,j,k,kl,ii,jj,klvrp,klvrm,klpt,kup,kdn,kch
+ integer :: jyvp,jyvm,ixvp,ixvm,jumpx,jumpy,jux,juy,ivrm,ivrp,ivr
+ integer :: nlck,l
+ real :: vx(2),uy(2),phi,tanphi,cosphi,dvdx,dudy,f
+ real :: theta,thetap,thetam,dthetadp,dt1,dt2,dt
+ real :: ppml(0:nxmaxn-1,0:nymaxn-1,nuvzmax),ppmk(0:nxmaxn-1,0:nymaxn-1,nuvzmax)
+ real :: thup,thdn
+ real,parameter :: eps=1.e-5,p0=101325
+ real :: uuhn(0:nxmaxn-1,0:nymaxn-1,nuvzmax,maxnests)
+ real :: vvhn(0:nxmaxn-1,0:nymaxn-1,nuvzmax,maxnests)
+ real :: pvhn(0:nxmaxn-1,0:nymaxn-1,nuvzmax,maxnests)
+
+ ! Set number of levels to check for adjacent theta
+ nlck=nuvz/3
+ !
+ ! Loop over entire grid
+ !**********************
+ do kl=1,nuvz
+ do jy=0,nyn(l)-1
+ do ix=0,nxn(l)-1
+ ppml(ix,jy,kl)=akz(kl)+bkz(kl)*psn(ix,jy,1,n,l)
+ enddo
+ enddo
+ enddo
+ ! ppmk=(100000./ppml)**kappa
+ ppmk(0:nxn(l)-1,0:nyn(l)-1,1:nuvz)=(100000./ppml(0:nxn(l)-1,0:nyn(l)-1,1:nuvz))**kappa
+
+ do jy=0,nyn(l)-1
+ phi = (ylat0n(l) + jy * dyn(l)) * pi / 180.
+ f = 0.00014585 * sin(phi)
+ tanphi = tan(phi)
+ cosphi = cos(phi)
+ ! Provide a virtual jy+1 and jy-1 in case we are on domain edge (Lat)
+ jyvp=jy+1
+ jyvm=jy-1
+ if (jy.eq.0) jyvm=0
+ if (jy.eq.nyn(l)-1) jyvp=nyn(l)-1
+ ! Define absolute gap length
+ jumpy=2
+ if (jy.eq.0.or.jy.eq.nyn(l)-1) jumpy=1
+ juy=jumpy
+ !
+ do ix=0,nxn(l)-1
+ ! Provide a virtual ix+1 and ix-1 in case we are on domain edge (Long)
+ ixvp=ix+1
+ ixvm=ix-1
+ jumpx=2
+ if (ix.eq.0) ixvm=0
+ if (ix.eq.nxn(l)-1) ixvp=nxn(l)-1
+ ivrp=ixvp
+ ivrm=ixvm
+ ! Define absolute gap length
+ if (ix.eq.0.or.ix.eq.nxn(l)-1) jumpx=1
+ jux=jumpx
+ !
+ ! Loop over the vertical
+ !***********************
+
+ do kl=1,nuvz
+ theta=tthn(ix,jy,kl,n,l)*ppmk(ix,jy,kl)
+ klvrp=kl+1
+ klvrm=kl-1
+ klpt=kl
+ ! If top or bottom level, dthetadp is evaluated between the current
+ ! level and the level inside, otherwise between level+1 and level-1
+ !
+ if (klvrp.gt.nuvz) klvrp=nuvz
+ if (klvrm.lt.1) klvrm=1
+ thetap=tthn(ix,jy,klvrp,n,l)*ppmk(ix,jy,klvrp)
+ thetam=tthn(ix,jy,klvrm,n,l)*ppmk(ix,jy,klvrm)
+ dthetadp=(thetap-thetam)/(ppml(ix,jy,klvrp)-ppml(ix,jy,klvrm))
+
+ ! Compute vertical position at pot. temperature surface on subgrid
+ ! and the wind at that position
+ !*****************************************************************
+ ! a) in x direction
+ ii=0
+ do i=ixvm,ixvp,jumpx
+ ivr=i
+ ii=ii+1
+ ! Search adjacent levels for current theta value
+ ! Spiral out from current level for efficiency
+ kup=klpt-1
+ kdn=klpt
+ kch=0
+40 continue
+ ! Upward branch
+ kup=kup+1
+ if (kch.ge.nlck) goto 21 ! No more levels to check,
+ ! ! and no values found
+ if (kup.ge.nuvz) goto 41
+ kch=kch+1
+ k=kup
+ thdn=tthn(ivr,jy,k,n,l)*ppmk(ivr,jy,k)
+ thup=tthn(ivr,jy,k+1,n,l)*ppmk(ivr,jy,k+1)
+
+ if (((thdn.ge.theta).and.(thup.le.theta)).or. &
+ ((thdn.le.theta).and.(thup.ge.theta))) then
+ dt1=abs(theta-thdn)
+ dt2=abs(theta-thup)
+ dt=dt1+dt2
+ if (dt.lt.eps) then ! Avoid division by zero error
+ dt1=0.5 ! G.W., 10.4.1996
+ dt2=0.5
+ dt=1.0
+ endif
+ vx(ii)=(vvhn(ivr,jy,k,l)*dt2+vvhn(ivr,jy,k+1,l)*dt1)/dt
+ goto 20
+ endif
+41 continue
+ ! Downward branch
+ kdn=kdn-1
+ if (kdn.lt.1) goto 40
+ kch=kch+1
+ k=kdn
+ thdn=tthn(ivr,jy,k,n,l)*ppmk(ivr,jy,k)
+ thup=tthn(ivr,jy,k+1,n,l)*ppmk(ivr,jy,k+1)
+ if (((thdn.ge.theta).and.(thup.le.theta)).or. &
+ ((thdn.le.theta).and.(thup.ge.theta))) then
+ dt1=abs(theta-thdn)
+ dt2=abs(theta-thup)
+ dt=dt1+dt2
+ if (dt.lt.eps) then ! Avoid division by zero error
+ dt1=0.5 ! G.W., 10.4.1996
+ dt2=0.5
+ dt=1.0
+ endif
+ vx(ii)=(vvhn(ivr,jy,k,l)*dt2+vvhn(ivr,jy,k+1,l)*dt1)/dt
+ goto 20
+ endif
+ goto 40
+ ! This section used when no values were found
+21 continue
+ ! Must use vv at current level and long. jux becomes smaller by 1
+ vx(ii)=vvhn(ix,jy,kl,l)
+ jux=jux-1
+ ! Otherwise OK
+20 continue
+ end do
+ if (jux.gt.0) then
+ dvdx=(vx(2)-vx(1))/real(jux)/(dxn(l)*pi/180.)
+ else
+ dvdx=vvhn(ivrp,jy,kl,l)-vvhn(ivrm,jy,kl,l)
+ dvdx=dvdx/real(jumpx)/(dxn(l)*pi/180.)
+ ! Only happens if no equivalent theta value
+ ! can be found on either side, hence must use values
+ ! from either side, same pressure level.
+ end if
+
+ ! b) in y direction
+
+ jj=0
+ do j=jyvm,jyvp,jumpy
+ jj=jj+1
+ ! Search adjacent levels for current theta value
+ ! Spiral out from current level for efficiency
+ kup=klpt-1
+ kdn=klpt
+ kch=0
+70 continue
+ ! Upward branch
+ kup=kup+1
+ if (kch.ge.nlck) goto 51 ! No more levels to check,
+ ! ! and no values found
+ if (kup.ge.nuvz) goto 71
+ kch=kch+1
+ k=kup
+ thdn=tthn(ix,j,k,n,l)*ppmk(ix,j,k)
+ thup=tthn(ix,j,k+1,n,l)*ppmk(ix,j,k+1)
+ if (((thdn.ge.theta).and.(thup.le.theta)).or. &
+ ((thdn.le.theta).and.(thup.ge.theta))) then
+ dt1=abs(theta-thdn)
+ dt2=abs(theta-thup)
+ dt=dt1+dt2
+ if (dt.lt.eps) then ! Avoid division by zero error
+ dt1=0.5 ! G.W., 10.4.1996
+ dt2=0.5
+ dt=1.0
+ endif
+ uy(jj)=(uuhn(ix,j,k,l)*dt2+uuhn(ix,j,k+1,l)*dt1)/dt
+ goto 50
+ endif
+71 continue
+ ! Downward branch
+ kdn=kdn-1
+ if (kdn.lt.1) goto 70
+ kch=kch+1
+ k=kdn
+ thdn=tthn(ix,j,k,n,l)*ppmk(ix,j,k)
+ thup=tthn(ix,j,k+1,n,l)*ppmk(ix,j,k+1)
+ if (((thdn.ge.theta).and.(thup.le.theta)).or. &
+ ((thdn.le.theta).and.(thup.ge.theta))) then
+ dt1=abs(theta-thdn)
+ dt2=abs(theta-thup)
+ dt=dt1+dt2
+ if (dt.lt.eps) then ! Avoid division by zero error
+ dt1=0.5 ! G.W., 10.4.1996
+ dt2=0.5
+ dt=1.0
+ endif
+ uy(jj)=(uuhn(ix,j,k,l)*dt2+uuhn(ix,j,k+1,l)*dt1)/dt
+ goto 50
+ endif
+ goto 70
+ ! This section used when no values were found
+51 continue
+ ! Must use uu at current level and lat. juy becomes smaller by 1
+ uy(jj)=uuhn(ix,jy,kl,l)
+ juy=juy-1
+ ! Otherwise OK
+50 continue
+ end do
+ if (juy.gt.0) then
+ dudy=(uy(2)-uy(1))/real(juy)/(dyn(l)*pi/180.)
+ else
+ dudy=uuhn(ix,jyvp,kl,l)-uuhn(ix,jyvm,kl,l)
+ dudy=dudy/real(jumpy)/(dyn(l)*pi/180.)
+ end if
+ !
+ pvhn(ix,jy,kl,l)=dthetadp*(f+(dvdx/cosphi-dudy &
+ +uuhn(ix,jy,kl,l)*tanphi)/r_earth)*(-1.e6)*9.81
+
+ !
+ ! Resest jux and juy
+ jux=jumpx
+ juy=jumpy
+ end do
+ end do
+ end do
+ !
+end subroutine calcpv_nests
\ No newline at end of file
diff --git a/src/calcpv_nests.f90 b/src/redundant/calcpv_nests.f90
similarity index 100%
rename from src/calcpv_nests.f90
rename to src/redundant/calcpv_nests.f90
diff --git a/src/caldate.f90 b/src/redundant/caldate.f90
similarity index 100%
rename from src/caldate.f90
rename to src/redundant/caldate.f90
diff --git a/src/centerofmass.f90 b/src/redundant/centerofmass.f90
similarity index 100%
rename from src/centerofmass.f90
rename to src/redundant/centerofmass.f90
diff --git a/src/clustering.f90 b/src/redundant/clustering.f90
similarity index 89%
rename from src/clustering.f90
rename to src/redundant/clustering.f90
index 23436433..8e4137b9 100644
--- a/src/clustering.f90
+++ b/src/redundant/clustering.f90
@@ -1,7 +1,7 @@
! SPDX-FileCopyrightText: FLEXPART 1998-2019, see flexpart_license.txt
! SPDX-License-Identifier: GPL-3.0-or-later
-subroutine clustering(xl,yl,zl,n,xclust,yclust,zclust,fclust,rms, &
+subroutine clustering(n,xclust,yclust,zclust,fclust,rms, &
rmsclust,zrms)
! i i i i o o o o o
! o o
@@ -37,11 +37,12 @@ subroutine clustering(xl,yl,zl,n,xclust,yclust,zclust,fclust,rms, &
!*****************************************************************************
use par_mod
+ use particle_mod
implicit none
- integer :: n,i,j,l,nclust(maxpart),numb(ncluster),ncl
- real :: xl(n),yl(n),zl(n),xclust(ncluster),yclust(ncluster),x,y,z
+ integer :: n,i,j,l,numb(ncluster),ncl
+ real :: xclust(ncluster),yclust(ncluster),x,y,z
real :: zclust(ncluster),distance2,distances,distancemin,rms,rmsold
real :: xav(ncluster),yav(ncluster),zav(ncluster),fclust(ncluster)
real :: rmsclust(ncluster)
@@ -57,8 +58,8 @@ subroutine clustering(xl,yl,zl,n,xclust,yclust,zclust,fclust,rms, &
do i=1,n
nclust(i)=i
- xl(i)=xl(i)*pi180
- yl(i)=yl(i)*pi180
+ xplum(i)=xplum(i)*pi180
+ yplum(i)=yplum(i)*pi180
end do
@@ -67,8 +68,8 @@ subroutine clustering(xl,yl,zl,n,xclust,yclust,zclust,fclust,rms, &
do j=1,ncluster
zclust(j)=0.
- xclust(j)=xl(j*n/ncluster)
- yclust(j)=yl(j*n/ncluster)
+ xclust(j)=xplum(j*n/ncluster)
+ yclust(j)=yplum(j*n/ncluster)
end do
@@ -85,7 +86,7 @@ subroutine clustering(xl,yl,zl,n,xclust,yclust,zclust,fclust,rms, &
do i=1,n
distancemin=10.**10.
do j=1,ncluster
- distances=distance2(yl(i),xl(i),yclust(j),xclust(j))
+ distances=distance2(yplum(i),xplum(i),yclust(j),xclust(j))
if (distances.lt.distancemin) then
distancemin=distances
ncl=j
@@ -110,7 +111,7 @@ subroutine clustering(xl,yl,zl,n,xclust,yclust,zclust,fclust,rms, &
do i=1,n
numb(nclust(i))=numb(nclust(i))+1
- distances=distance2(yl(i),xl(i), &
+ distances=distance2(yplum(i),xplum(i), &
yclust(nclust(i)),xclust(nclust(i)))
! rms is the total rms of all particles
@@ -123,9 +124,9 @@ subroutine clustering(xl,yl,zl,n,xclust,yclust,zclust,fclust,rms, &
! Calculate Cartesian 3D coordinates from longitude and latitude
!***************************************************************
- x = cos(yl(i))*sin(xl(i))
- y = -1.*cos(yl(i))*cos(xl(i))
- z = sin(yl(i))
+ x = cos(yplum(i))*sin(xplum(i))
+ y = -1.*cos(yplum(i))*cos(xplum(i))
+ z = sin(yplum(i))
xav(nclust(i))=xav(nclust(i))+x
yav(nclust(i))=yav(nclust(i))+y
zav(nclust(i))=zav(nclust(i))+z
@@ -156,20 +157,18 @@ subroutine clustering(xl,yl,zl,n,xclust,yclust,zclust,fclust,rms, &
! Leave the loop if the RMS distance decreases only slightly between 2 iterations
!*****************************************************************************
- if ((l.gt.1).and.(abs(rms-rmsold)/rmsold.lt.0.005)) goto 99
+ if ((l.gt.1).and.(abs(rms-rmsold)/rmsold.lt.0.005)) exit
rmsold=rms
end do
-99 continue
-
! Convert longitude and latitude from radians to degrees
!*******************************************************
do i=1,n
- xl(i)=xl(i)/pi180
- yl(i)=yl(i)/pi180
- zclust(nclust(i))=zclust(nclust(i))+zl(i)
+ xplum(i)=xplum(i)/pi180
+ yplum(i)=yplum(i)/pi180
+ zclust(nclust(i))=zclust(nclust(i))+zplum(i)
end do
do j=1,ncluster
@@ -184,7 +183,7 @@ subroutine clustering(xl,yl,zl,n,xclust,yclust,zclust,fclust,rms, &
zrms=0.
do i=1,n
- zdist=zl(i)-zclust(nclust(i))
+ zdist=zplum(i)-zclust(nclust(i))
zrms=zrms+zdist*zdist
end do
if (zrms.gt.0.) zrms=sqrt(zrms/real(n))
diff --git a/src/conccalc.f90 b/src/redundant/conccalc.f90
similarity index 63%
rename from src/conccalc.f90
rename to src/redundant/conccalc.f90
index 9f7618e7..36ff6cb6 100644
--- a/src/conccalc.f90
+++ b/src/redundant/conccalc.f90
@@ -30,34 +30,38 @@ subroutine conccalc(itime,weight)
use outg_mod
use par_mod
use com_mod
+ use omp_lib, only: OMP_GET_THREAD_NUM
+ use interpol_mod, only: interpol_density,ix,jy,ixp,jyp,ddx,ddy
+ use coordinates_ecmwf
+ use particle_mod
implicit none
- integer :: itime,itage,i,ix,jy,ixp,jyp,kz,ks,n,nage
+ integer,intent(in) :: itime
+ real,intent(in) :: weight
+ integer :: itage,i,kz,ks,n,nage
integer :: il,ind,indz,indzp,nrelpointer
- real :: rddx,rddy,p1,p2,p3,p4,dz1,dz2,dz
- real :: weight,hx,hy,hz,h,xd,yd,zd,xkern,r2,c(maxspec),ddx,ddy
- real :: rhoprof(2),rhoi
+ real :: hx,hy,hz,h,xd,yd,zd,xkern,r2,c(maxspec)
+ real :: rhoi
real :: xl,yl,wx,wy,w
real,parameter :: factor=.596831, hxmax=6.0, hymax=4.0, hzmax=150.
-! integer xscav_count
+ ! integer xscav_count
! For forward simulations, make a loop over the number of species;
! for backward simulations, make an additional loop over the
! releasepoints
!***************************************************************************
-! xscav_count=0
+ ! xscav_count=0
do i=1,numpart
- if (itra1(i).ne.itime) goto 20
+ if (.not.part(i)%alive) cycle
! Determine age class of the particle
- itage=abs(itra1(i)-itramem(i))
+ itage=abs(itime-part(i)%tstart)
do nage=1,nageclass
- if (itage.lt.lage(nage)) goto 33
+ if (itage.lt.lage(nage)) exit
end do
-33 continue
-! if (xscav_frac1(i,1).lt.0) xscav_count=xscav_count+1
+ ! if (xscav_frac1(i,1).lt.0) xscav_count=xscav_count+1
! For special runs, interpolate the air density to the particle position
!************************************************************************
@@ -78,52 +82,11 @@ subroutine conccalc(itime,weight)
!Af ind_samp is defined in readcommand.f
if ( ind_samp .eq. -1 ) then
-
- ix=int(xtra1(i))
- jy=int(ytra1(i))
- ixp=ix+1
- jyp=jy+1
- ddx=xtra1(i)-real(ix)
- ddy=ytra1(i)-real(jy)
- rddx=1.-ddx
- rddy=1.-ddy
- p1=rddx*rddy
- p2=ddx*rddy
- p3=rddx*ddy
- p4=ddx*ddy
-
-! eso: Temporary fix for particle exactly at north pole
- if (jyp >= nymax) then
- ! write(*,*) 'WARNING: conccalc.f90 jyp >= nymax'
- jyp=jyp-1
- end if
-
- do il=2,nz
- if (height(il).gt.ztra1(i)) then
- indz=il-1
- indzp=il
- goto 6
- endif
- end do
-6 continue
-
- dz1=ztra1(i)-height(indz)
- dz2=height(indzp)-ztra1(i)
- dz=1./(dz1+dz2)
-
- ! Take density from 2nd wind field in memory (accurate enough, no time interpolation needed)
- !*****************************************************************************
- do ind=indz,indzp
- rhoprof(ind-indz+1)=p1*rho(ix ,jy ,ind,memind(2)) &
- +p2*rho(ixp,jy ,ind,2) &
- +p3*rho(ix ,jyp,ind,2) &
- +p4*rho(ixp,jyp,ind,2)
- end do
- rhoi=(dz1*rhoprof(2)+dz2*rhoprof(1))*dz
- elseif (ind_samp.eq.0) then
+ call update_zeta_to_z(itime,i)
+ call interpol_density(i,rhoi)
+ elseif (ind_samp.eq.0) then
rhoi = 1.
- endif
-
+ endif
!****************************************************************************
! 1. Evaluate grid concentrations using a uniform kernel of bandwidths dx, dy
@@ -139,13 +102,13 @@ subroutine conccalc(itime,weight)
if ((ioutputforeachrelease.eq.0).or.(mdomainfill.eq.1)) then
nrelpointer=1
else
- nrelpointer=npoint(i)
+ nrelpointer=part(i)%npoint
endif
do kz=1,numzgrid ! determine height of cell
- if (outheight(kz).gt.ztra1(i)) goto 21
+ if (outheight(kz).gt.part(i)%z) exit
end do
-21 continue
+
if (kz.le.numzgrid) then ! inside output domain
@@ -153,8 +116,8 @@ subroutine conccalc(itime,weight)
! Do everything for mother domain
!********************************
- xl=(xtra1(i)*dx+xoutshift)/dxout
- yl=(ytra1(i)*dy+youtshift)/dyout
+ xl=(part(i)%xlon*dx+xoutshift)/dxout
+ yl=(part(i)%ylat*dy+youtshift)/dyout
ix=int(xl)
if (xl.lt.0.) ix=ix-1
jy=int(yl)
@@ -176,21 +139,21 @@ subroutine conccalc(itime,weight)
(jy.le.numygrid-1)) then
if (DRYBKDEP.or.WETBKDEP) then
do ks=1,nspec
- gridunc(ix,jy,kz,ks,nrelpointer,nclass(i),nage)= &
- gridunc(ix,jy,kz,ks,nrelpointer,nclass(i),nage)+ &
- xmass1(i,ks)/rhoi*weight*max(xscav_frac1(i,ks),0.0)
+ gridunc(ix,jy,kz,ks,nrelpointer,part(i)%nclass,nage)= &
+ gridunc(ix,jy,kz,ks,nrelpointer,part(i)%nclass,nage)+ &
+ part(i)%mass(ks)/rhoi*weight*max(xscav_frac1(i,ks),0.0)
end do
else
if (lparticlecountoutput) then
do ks=1,nspec
- gridunc(ix,jy,kz,ks,nrelpointer,nclass(i),nage)= &
- gridunc(ix,jy,kz,ks,nrelpointer,nclass(i),nage)+1
+ gridunc(ix,jy,kz,ks,nrelpointer,part(i)%nclass,nage)= &
+ gridunc(ix,jy,kz,ks,nrelpointer,part(i)%nclass,nage)+1
end do
else
do ks=1,nspec
- gridunc(ix,jy,kz,ks,nrelpointer,nclass(i),nage)= &
- gridunc(ix,jy,kz,ks,nrelpointer,nclass(i),nage)+ &
- xmass1(i,ks)/rhoi*weight
+ gridunc(ix,jy,kz,ks,nrelpointer,part(i)%nclass,nage)= &
+ gridunc(ix,jy,kz,ks,nrelpointer,part(i)%nclass,nage)+ &
+ part(i)%mass(ks)/rhoi*weight
end do
end if
endif
@@ -225,15 +188,15 @@ subroutine conccalc(itime,weight)
w=wx*wy
if (DRYBKDEP.or.WETBKDEP) then
do ks=1,nspec
- gridunc(ix,jy,kz,ks,nrelpointer,nclass(i),nage)= &
- gridunc(ix,jy,kz,ks,nrelpointer,nclass(i),nage)+ &
- xmass1(i,ks)/rhoi*w*weight*max(xscav_frac1(i,ks),0.0)
+ gridunc(ix,jy,kz,ks,nrelpointer,part(i)%nclass,nage)= &
+ gridunc(ix,jy,kz,ks,nrelpointer,part(i)%nclass,nage)+ &
+ part(i)%mass(ks)/rhoi*w*weight*max(xscav_frac1(i,ks),0.0)
end do
else
do ks=1,nspec
- gridunc(ix,jy,kz,ks,nrelpointer,nclass(i),nage)= &
- gridunc(ix,jy,kz,ks,nrelpointer,nclass(i),nage)+ &
- xmass1(i,ks)/rhoi*weight*w
+ gridunc(ix,jy,kz,ks,nrelpointer,part(i)%nclass,nage)= &
+ gridunc(ix,jy,kz,ks,nrelpointer,part(i)%nclass,nage)+ &
+ part(i)%mass(ks)/rhoi*weight*w
end do
endif
endif
@@ -242,15 +205,15 @@ subroutine conccalc(itime,weight)
w=wx*(1.-wy)
if (DRYBKDEP.or.WETBKDEP) then
do ks=1,nspec
- gridunc(ix,jyp,kz,ks,nrelpointer,nclass(i),nage)= &
- gridunc(ix,jyp,kz,ks,nrelpointer,nclass(i),nage)+ &
- xmass1(i,ks)/rhoi*weight*w*max(xscav_frac1(i,ks),0.0)
+ gridunc(ix,jyp,kz,ks,nrelpointer,part(i)%nclass,nage)= &
+ gridunc(ix,jyp,kz,ks,nrelpointer,part(i)%nclass,nage)+ &
+ part(i)%mass(ks)/rhoi*weight*w*max(xscav_frac1(i,ks),0.0)
end do
else
do ks=1,nspec
- gridunc(ix,jyp,kz,ks,nrelpointer,nclass(i),nage)= &
- gridunc(ix,jyp,kz,ks,nrelpointer,nclass(i),nage)+ &
- xmass1(i,ks)/rhoi*weight*w
+ gridunc(ix,jyp,kz,ks,nrelpointer,part(i)%nclass,nage)= &
+ gridunc(ix,jyp,kz,ks,nrelpointer,part(i)%nclass,nage)+ &
+ part(i)%mass(ks)/rhoi*weight*w
end do
endif
endif
@@ -262,15 +225,15 @@ subroutine conccalc(itime,weight)
w=(1.-wx)*(1.-wy)
if (DRYBKDEP.or.WETBKDEP) then
do ks=1,nspec
- gridunc(ixp,jyp,kz,ks,nrelpointer,nclass(i),nage)= &
- gridunc(ixp,jyp,kz,ks,nrelpointer,nclass(i),nage)+ &
- xmass1(i,ks)/rhoi*w*weight*max(xscav_frac1(i,ks),0.0)
+ gridunc(ixp,jyp,kz,ks,nrelpointer,part(i)%nclass,nage)= &
+ gridunc(ixp,jyp,kz,ks,nrelpointer,part(i)%nclass,nage)+ &
+ part(i)%mass(ks)/rhoi*w*weight*max(xscav_frac1(i,ks),0.0)
end do
else
do ks=1,nspec
- gridunc(ixp,jyp,kz,ks,nrelpointer,nclass(i),nage)= &
- gridunc(ixp,jyp,kz,ks,nrelpointer,nclass(i),nage)+ &
- xmass1(i,ks)/rhoi*weight*w
+ gridunc(ixp,jyp,kz,ks,nrelpointer,part(i)%nclass,nage)= &
+ gridunc(ixp,jyp,kz,ks,nrelpointer,part(i)%nclass,nage)+ &
+ part(i)%mass(ks)/rhoi*weight*w
end do
endif
endif
@@ -279,15 +242,15 @@ subroutine conccalc(itime,weight)
w=(1.-wx)*wy
if (DRYBKDEP.or.WETBKDEP) then
do ks=1,nspec
- gridunc(ixp,jy,kz,ks,nrelpointer,nclass(i),nage)= &
- gridunc(ixp,jy,kz,ks,nrelpointer,nclass(i),nage)+ &
- xmass1(i,ks)/rhoi*weight*w*max(xscav_frac1(i,ks),0.0)
+ gridunc(ixp,jy,kz,ks,nrelpointer,part(i)%nclass,nage)= &
+ gridunc(ixp,jy,kz,ks,nrelpointer,part(i)%nclass,nage)+ &
+ part(i)%mass(ks)/rhoi*weight*w*max(xscav_frac1(i,ks),0.0)
end do
else
do ks=1,nspec
- gridunc(ixp,jy,kz,ks,nrelpointer,nclass(i),nage)= &
- gridunc(ixp,jy,kz,ks,nrelpointer,nclass(i),nage)+ &
- xmass1(i,ks)/rhoi*weight*w
+ gridunc(ixp,jy,kz,ks,nrelpointer,part(i)%nclass,nage)= &
+ gridunc(ixp,jy,kz,ks,nrelpointer,part(i)%nclass,nage)+ &
+ part(i)%mass(ks)/rhoi*weight*w
end do
endif
endif
@@ -299,8 +262,8 @@ subroutine conccalc(itime,weight)
!************************************
if (nested_output.eq.1) then
- xl=(xtra1(i)*dx+xoutshiftn)/dxoutn
- yl=(ytra1(i)*dy+youtshiftn)/dyoutn
+ xl=(part(i)%xlon*dx+xoutshiftn)/dxoutn
+ yl=(part(i)%ylat*dy+youtshiftn)/dyoutn
ix=int(xl)
if (xl.lt.0.) ix=ix-1
jy=int(yl)
@@ -316,26 +279,26 @@ subroutine conccalc(itime,weight)
if ((itage.lt.10800).or.(xl.lt.0.5).or.(yl.lt.0.5).or. &
(xl.gt.real(numxgridn-1)-0.5).or. &
(yl.gt.real(numygridn-1)-0.5).or.((.not.lusekerneloutput))) then
-! no kernel, direct attribution to grid cell
+ ! no kernel, direct attribution to grid cell
if ((ix.ge.0).and.(jy.ge.0).and.(ix.le.numxgridn-1).and. &
(jy.le.numygridn-1)) then
if (DRYBKDEP.or.WETBKDEP) then
do ks=1,nspec
- griduncn(ix,jy,kz,ks,nrelpointer,nclass(i),nage)= &
- griduncn(ix,jy,kz,ks,nrelpointer,nclass(i),nage)+ &
- xmass1(i,ks)/rhoi*weight*max(xscav_frac1(i,ks),0.0)
+ griduncn(ix,jy,kz,ks,nrelpointer,part(i)%nclass,nage)= &
+ griduncn(ix,jy,kz,ks,nrelpointer,part(i)%nclass,nage)+ &
+ part(i)%mass(ks)/rhoi*weight*max(xscav_frac1(i,ks),0.0)
end do
else
if (lparticlecountoutput) then
do ks=1,nspec
- griduncn(ix,jy,kz,ks,nrelpointer,nclass(i),nage)= &
- griduncn(ix,jy,kz,ks,nrelpointer,nclass(i),nage)+1
+ griduncn(ix,jy,kz,ks,nrelpointer,part(i)%nclass,nage)= &
+ griduncn(ix,jy,kz,ks,nrelpointer,part(i)%nclass,nage)+1
end do
else
do ks=1,nspec
- griduncn(ix,jy,kz,ks,nrelpointer,nclass(i),nage)= &
- griduncn(ix,jy,kz,ks,nrelpointer,nclass(i),nage)+ &
- xmass1(i,ks)/rhoi*weight
+ griduncn(ix,jy,kz,ks,nrelpointer,part(i)%nclass,nage)= &
+ griduncn(ix,jy,kz,ks,nrelpointer,part(i)%nclass,nage)+ &
+ part(i)%mass(ks)/rhoi*weight
end do
endif
endif
@@ -370,15 +333,15 @@ subroutine conccalc(itime,weight)
w=wx*wy
if (DRYBKDEP.or.WETBKDEP) then
do ks=1,nspec
- griduncn(ix,jy,kz,ks,nrelpointer,nclass(i),nage)= &
- griduncn(ix,jy,kz,ks,nrelpointer,nclass(i),nage)+ &
- xmass1(i,ks)/rhoi*weight*w*max(xscav_frac1(i,ks),0.0)
+ griduncn(ix,jy,kz,ks,nrelpointer,part(i)%nclass,nage)= &
+ griduncn(ix,jy,kz,ks,nrelpointer,part(i)%nclass,nage)+ &
+ part(i)%mass(ks)/rhoi*weight*w*max(xscav_frac1(i,ks),0.0)
end do
else
do ks=1,nspec
- griduncn(ix,jy,kz,ks,nrelpointer,nclass(i),nage)= &
- griduncn(ix,jy,kz,ks,nrelpointer,nclass(i),nage)+ &
- xmass1(i,ks)/rhoi*weight*w
+ griduncn(ix,jy,kz,ks,nrelpointer,part(i)%nclass,nage)= &
+ griduncn(ix,jy,kz,ks,nrelpointer,part(i)%nclass,nage)+ &
+ part(i)%mass(ks)/rhoi*weight*w
end do
endif
endif
@@ -387,15 +350,15 @@ subroutine conccalc(itime,weight)
w=wx*(1.-wy)
if (DRYBKDEP.or.WETBKDEP) then
do ks=1,nspec
- griduncn(ix,jyp,kz,ks,nrelpointer,nclass(i),nage)= &
- griduncn(ix,jyp,kz,ks,nrelpointer,nclass(i),nage)+ &
- xmass1(i,ks)/rhoi*weight*w*max(xscav_frac1(i,ks),0.0)
+ griduncn(ix,jyp,kz,ks,nrelpointer,part(i)%nclass,nage)= &
+ griduncn(ix,jyp,kz,ks,nrelpointer,part(i)%nclass,nage)+ &
+ part(i)%mass(ks)/rhoi*weight*w*max(xscav_frac1(i,ks),0.0)
end do
else
do ks=1,nspec
- griduncn(ix,jyp,kz,ks,nrelpointer,nclass(i),nage)= &
- griduncn(ix,jyp,kz,ks,nrelpointer,nclass(i),nage)+ &
- xmass1(i,ks)/rhoi*weight*w
+ griduncn(ix,jyp,kz,ks,nrelpointer,part(i)%nclass,nage)= &
+ griduncn(ix,jyp,kz,ks,nrelpointer,part(i)%nclass,nage)+ &
+ part(i)%mass(ks)/rhoi*weight*w
end do
endif
endif
@@ -407,15 +370,15 @@ subroutine conccalc(itime,weight)
w=(1.-wx)*(1.-wy)
if (DRYBKDEP.or.WETBKDEP) then
do ks=1,nspec
- griduncn(ixp,jyp,kz,ks,nrelpointer,nclass(i),nage)= &
- griduncn(ixp,jyp,kz,ks,nrelpointer,nclass(i),nage)+ &
- xmass1(i,ks)/rhoi*weight*w*max(xscav_frac1(i,ks),0.0)
+ griduncn(ixp,jyp,kz,ks,nrelpointer,part(i)%nclass,nage)= &
+ griduncn(ixp,jyp,kz,ks,nrelpointer,part(i)%nclass,nage)+ &
+ part(i)%mass(ks)/rhoi*weight*w*max(xscav_frac1(i,ks),0.0)
end do
else
do ks=1,nspec
- griduncn(ixp,jyp,kz,ks,nrelpointer,nclass(i),nage)= &
- griduncn(ixp,jyp,kz,ks,nrelpointer,nclass(i),nage)+ &
- xmass1(i,ks)/rhoi*weight*w
+ griduncn(ixp,jyp,kz,ks,nrelpointer,part(i)%nclass,nage)= &
+ griduncn(ixp,jyp,kz,ks,nrelpointer,part(i)%nclass,nage)+ &
+ part(i)%mass(ks)/rhoi*weight*w
end do
endif
endif
@@ -424,15 +387,15 @@ subroutine conccalc(itime,weight)
w=(1.-wx)*wy
if (DRYBKDEP.or.WETBKDEP) then
do ks=1,nspec
- griduncn(ixp,jy,kz,ks,nrelpointer,nclass(i),nage)= &
- griduncn(ixp,jy,kz,ks,nrelpointer,nclass(i),nage)+ &
- xmass1(i,ks)/rhoi*weight*w*max(xscav_frac1(i,ks),0.0)
+ griduncn(ixp,jy,kz,ks,nrelpointer,part(i)%nclass,nage)= &
+ griduncn(ixp,jy,kz,ks,nrelpointer,part(i)%nclass,nage)+ &
+ part(i)%mass(ks)/rhoi*weight*w*max(xscav_frac1(i,ks),0.0)
end do
else
do ks=1,nspec
- griduncn(ixp,jy,kz,ks,nrelpointer,nclass(i),nage)= &
- griduncn(ixp,jy,kz,ks,nrelpointer,nclass(i),nage)+ &
- xmass1(i,ks)/rhoi*weight*w
+ griduncn(ixp,jy,kz,ks,nrelpointer,part(i)%nclass,nage)= &
+ griduncn(ixp,jy,kz,ks,nrelpointer,part(i)%nclass,nage)+ &
+ part(i)%mass(ks)/rhoi*weight*w
end do
endif
endif
@@ -440,9 +403,8 @@ subroutine conccalc(itime,weight)
endif
endif
endif
-20 continue
end do
-! write(*,*) 'xscav count:',xscav_count
+ ! write(*,*) 'xscav count:',xscav_count
!***********************************************************************
! 2. Evaluate concentrations at receptor points, using the kernel method
@@ -464,32 +426,31 @@ subroutine conccalc(itime,weight)
do i=1,numpart
- if (itra1(i).ne.itime) goto 40
- itage=abs(itra1(i)-itramem(i))
+ if (.not. part(i)%alive) cycle
+ itage=abs(itime-part(i)%tstart)
hz=min(50.+0.3*sqrt(real(itage)),hzmax)
- zd=ztra1(i)/hz
- if (zd.gt.1.) goto 40 ! save computing time, leave loop
+ zd=part(i)%z/hz
+ if (zd.gt.1.) cycle ! save computing time, leave loop
hx=min((0.29+2.222e-3*sqrt(real(itage)))*dx+ &
real(itage)*1.2e-5,hxmax) ! 80 km/day
- xd=(xtra1(i)-xreceptor(n))/hx
- if (xd*xd.gt.1.) goto 40 ! save computing time, leave loop
+ xd=(part(i)%xlon-xreceptor(n))/hx
+ if (xd*xd.gt.1.) cycle ! save computing time, leave loop
hy=min((0.18+1.389e-3*sqrt(real(itage)))*dy+ &
real(itage)*7.5e-6,hymax) ! 80 km/day
- yd=(ytra1(i)-yreceptor(n))/hy
- if (yd*yd.gt.1.) goto 40 ! save computing time, leave loop
+ yd=(part(i)%ylat-yreceptor(n))/hy
+ if (yd*yd.gt.1.) cycle ! save computing time, leave loop
h=hx*hy*hz
r2=xd*xd+yd*yd+zd*zd
if (r2.lt.1.) then
xkern=factor*(1.-r2)
do ks=1,nspec
- c(ks)=c(ks)+xmass1(i,ks)*xkern/h
+ c(ks)=c(ks)+part(i)%mass(ks)*xkern/h
end do
endif
-40 continue
end do
do ks=1,nspec
diff --git a/src/conccalc_mpi.f90 b/src/redundant/conccalc_mpi.f90
similarity index 100%
rename from src/conccalc_mpi.f90
rename to src/redundant/conccalc_mpi.f90
diff --git a/src/concoutput.f90 b/src/redundant/concoutput.f90
similarity index 100%
rename from src/concoutput.f90
rename to src/redundant/concoutput.f90
diff --git a/src/concoutput_inversion.f90 b/src/redundant/concoutput_inversion.f90
similarity index 100%
rename from src/concoutput_inversion.f90
rename to src/redundant/concoutput_inversion.f90
diff --git a/src/concoutput_inversion_nest.f90 b/src/redundant/concoutput_inversion_nest.f90
similarity index 100%
rename from src/concoutput_inversion_nest.f90
rename to src/redundant/concoutput_inversion_nest.f90
diff --git a/src/concoutput_mpi.f90 b/src/redundant/concoutput_mpi.f90
similarity index 100%
rename from src/concoutput_mpi.f90
rename to src/redundant/concoutput_mpi.f90
diff --git a/src/concoutput_nest.f90 b/src/redundant/concoutput_nest.f90
similarity index 100%
rename from src/concoutput_nest.f90
rename to src/redundant/concoutput_nest.f90
diff --git a/src/concoutput_nest_mpi.f90 b/src/redundant/concoutput_nest_mpi.f90
similarity index 100%
rename from src/concoutput_nest_mpi.f90
rename to src/redundant/concoutput_nest_mpi.f90
diff --git a/src/concoutput_surf.f90 b/src/redundant/concoutput_surf.f90
similarity index 100%
rename from src/concoutput_surf.f90
rename to src/redundant/concoutput_surf.f90
diff --git a/src/concoutput_surf_mpi.f90 b/src/redundant/concoutput_surf_mpi.f90
similarity index 100%
rename from src/concoutput_surf_mpi.f90
rename to src/redundant/concoutput_surf_mpi.f90
diff --git a/src/concoutput_surf_nest.f90 b/src/redundant/concoutput_surf_nest.f90
similarity index 100%
rename from src/concoutput_surf_nest.f90
rename to src/redundant/concoutput_surf_nest.f90
diff --git a/src/concoutput_surf_nest_mpi.f90 b/src/redundant/concoutput_surf_nest_mpi.f90
similarity index 100%
rename from src/concoutput_surf_nest_mpi.f90
rename to src/redundant/concoutput_surf_nest_mpi.f90
diff --git a/src/convect43c.f90 b/src/redundant/convect43c.f90
similarity index 61%
rename from src/convect43c.f90
rename to src/redundant/convect43c.f90
index 8db8f43d..3adbedfb 100644
--- a/src/convect43c.f90
+++ b/src/redundant/convect43c.f90
@@ -212,8 +212,8 @@
! *** be the first model level at which T is defined above ***
! *** the surface layer) ***
!
- INTEGER,PARAMETER :: IPBL=0
- INTEGER,PARAMETER :: MINORIG=1
+ INTEGER,PARAMETER :: IPBL=0
+ INTEGER,PARAMETER :: MINORIG=1
!
!------------------------------------------------------------------------------
!
@@ -244,20 +244,20 @@
! *** (THEIR STANDARD VALUES ARE 0.20 AND 0.1, RESPECTIVELY) ***
! *** (DAMP MUST BE LESS THAN 1) ***
!
- REAL,PARAMETER :: ELCRIT=.0011
- REAL,PARAMETER :: TLCRIT=-55.0
- REAL,PARAMETER :: ENTP=1.5
- REAL,PARAMETER :: SIGD=0.05
- REAL,PARAMETER :: SIGS=0.12
- REAL,PARAMETER :: OMTRAIN=50.0
- REAL,PARAMETER :: OMTSNOW=5.5
- REAL,PARAMETER :: COEFFR=1.0
- REAL,PARAMETER :: COEFFS=0.8
- REAL,PARAMETER :: CU=0.7
- REAL,PARAMETER :: BETA=10.0
- REAL,PARAMETER :: DTMAX=0.9
- REAL,PARAMETER :: ALPHA=0.025 !original 0.2
- REAL,PARAMETER :: DAMP=0.1
+ REAL,PARAMETER :: ELCRIT=.0011
+ REAL,PARAMETER :: TLCRIT=-55.0
+ REAL,PARAMETER :: ENTP=1.5
+ REAL,PARAMETER :: SIGD=0.05
+ REAL,PARAMETER :: SIGS=0.12
+ REAL,PARAMETER :: OMTRAIN=50.0
+ REAL,PARAMETER :: OMTSNOW=5.5
+ REAL,PARAMETER :: COEFFR=1.0
+ REAL,PARAMETER :: COEFFS=0.8
+ REAL,PARAMETER :: CU=0.7
+ REAL,PARAMETER :: BETA=10.0
+ REAL,PARAMETER :: DTMAX=0.9
+ REAL,PARAMETER :: ALPHA=0.025 !original 0.2
+ REAL,PARAMETER :: DAMP=0.1
!
! *** ASSIGN VALUES OF THERMODYNAMIC CONSTANTS, ***
! *** GRAVITY, AND LIQUID WATER DENSITY. ***
@@ -287,29 +287,29 @@
! *** INITIALIZE OUTPUT ARRAYS AND PARAMETERS ***
!
- DO I=1,NL+1
- FT(I)=0.0
- FQ(I)=0.0
- FDOWN(I)=0.0
- SUB(I)=0.0
- FUP(I)=0.0
- M(I)=0.0
- MP(I)=0.0
- DO J=1,NL+1
- FMASS(I,J)=0.0
- MENT(I,J)=0.0
- END DO
- END DO
- DO I=1,NL+1
- RDCP=(RD*(1.-QCONV(I))+QCONV(I)*RV)/ &
- (CPD*(1.-QCONV(I))+QCONV(I)*CPV)
- TH(I)=TCONV(I)*(1000.0/PCONV_HPA(I))**RDCP
- END DO
- PRECIP=0.0
- WD=0.0
- TPRIME=0.0
- QPRIME=0.0
- IFLAG=0
+ ! LB 04.05.2021, array operations
+ FT(:NL+1)=0.0
+ FQ(:NL+1)=0.0
+ FDOWN(:NL+1)=0.0
+ SUB(:NL+1)=0.0
+ FUP(:NL+1)=0.0
+ M(:NL+1)=0.0
+ MP(:NL+1)=0.0
+ FMASS(:NL+1,:NL+1)=0.0
+ MENT(:NL+1,:NL+1)=0.0
+ ! DO I=1,NL+1
+ ! RDCP=(RD*(1.-QCONV(I))+QCONV(I)*RV)/ &
+ ! (CPD*(1.-QCONV(I))+QCONV(I)*CPV)
+ ! TH(I)=TCONV(I)*(1000.0/PCONV_HPA(I))**RDCP
+ ! END DO
+ ! LB 04.05.2021, below is not mentioned anywhere, so I commented it
+ ! TH(:NL+1)=TCONV(:NL+1)*(1000.0/PCONV_HPA(:NL+1))** &
+ ! (RD*(1.-QCONV(:NL+1))+QCONV(:NL+1)*RV)/ (CPD*(1.-QCONV(:NL+1))+QCONV(:NL+1)*CPV)
+ PRECIP=0.0
+ WD=0.0
+ TPRIME=0.0
+ QPRIME=0.0
+ IFLAG=0
!
! IF(IPBL.NE.0)THEN
!
@@ -390,85 +390,88 @@
!
! *** CALCULATE ARRAYS OF GEOPOTENTIAL, HEAT CAPACITY AND STATIC ENERGY
!
- GZ(1)=0.0
- CPN(1)=CPD*(1.-QCONV(1))+QCONV(1)*CPV
- H(1)=TCONV(1)*CPN(1)
- LV(1)=LV0-CPVMCL*(TCONV(1)-273.15)
- HM(1)=LV(1)*QCONV(1)
- TV(1)=TCONV(1)*(1.+QCONV(1)*EPSI-QCONV(1))
- AHMIN=1.0E12
- IHMIN=NL
- DO I=2,NL+1
- TVX=TCONV(I)*(1.+QCONV(I)*EPSI-QCONV(I))
- TVY=TCONV(I-1)*(1.+QCONV(I-1)*EPSI-QCONV(I-1))
- GZ(I)=GZ(I-1)+0.5*RD*(TVX+TVY)*(PCONV_HPA(I-1)-PCONV_HPA(I))/ &
- PHCONV_HPA(I)
- CPN(I)=CPD*(1.-QCONV(I))+CPV*QCONV(I)
- H(I)=TCONV(I)*CPN(I)+GZ(I)
- LV(I)=LV0-CPVMCL*(TCONV(I)-273.15)
- HM(I)=(CPD*(1.-QCONV(I))+CL*QCONV(I))*(TCONV(I)-TCONV(1))+ &
- LV(I)*QCONV(I)+GZ(I)
- TV(I)=TCONV(I)*(1.+QCONV(I)*EPSI-QCONV(I))
- !
- ! *** Find level of minimum moist static energy ***
- !
- IF(I.GE.MINORIG.AND.HM(I).LT.AHMIN.AND.HM(I).LT.HM(I-1))THEN
- AHMIN=HM(I)
- IHMIN=I
- END IF
- END DO
- IHMIN=MIN(IHMIN, NL-1)
+ GZ(1)=0.0
+ CPN(1)=CPD*(1.-QCONV(1))+QCONV(1)*CPV
+ H(1)=TCONV(1)*CPN(1)
+ LV(1)=LV0-CPVMCL*(TCONV(1)-273.15)
+ HM(1)=LV(1)*QCONV(1)
+ TV(1)=TCONV(1)*(1.+QCONV(1)*EPSI-QCONV(1))
+ AHMIN=1.0E12
+ IHMIN=NL
+
+ DO I=2,NL+1
+ TVX=TCONV(I)*(1.+QCONV(I)*EPSI-QCONV(I))
+ TVY=TCONV(I-1)*(1.+QCONV(I-1)*EPSI-QCONV(I-1))
+ GZ(I)=GZ(I-1)+0.5*RD*(TVX+TVY)*(PCONV_HPA(I-1)-PCONV_HPA(I))/ &
+ PHCONV_HPA(I)
+ CPN(I)=CPD*(1.-QCONV(I))+CPV*QCONV(I)
+ H(I)=TCONV(I)*CPN(I)+GZ(I)
+ LV(I)=LV0-CPVMCL*(TCONV(I)-273.15)
+ HM(I)=(CPD*(1.-QCONV(I))+CL*QCONV(I))*(TCONV(I)-TCONV(1))+ &
+ LV(I)*QCONV(I)+GZ(I)
+ TV(I)=TCONV(I)*(1.+QCONV(I)*EPSI-QCONV(I))
+!
+! *** Find level of minimum moist static energy ***
+!
+ IF(I.GE.MINORIG.AND.HM(I).LT.AHMIN.AND.HM(I).LT.HM(I-1))THEN
+ AHMIN=HM(I)
+ IHMIN=I
+ END IF
+ END DO
+ IHMIN=MIN(IHMIN, NL-1)
!
! *** Find that model level below the level of minimum moist ***
! *** static energy that has the maximum value of moist static energy ***
!
- AHMAX=0.0
+ AHMAX=0.0
! *** bug fixed: need to assign an initial value to NK
! HSO, 05.08.2009
- NK=MINORIG
- DO I=MINORIG,IHMIN
- IF(HM(I).GT.AHMAX)THEN
+ NK=MINORIG
+ DO I=MINORIG,IHMIN
+ IF(HM(I).GT.AHMAX)THEN
NK=I
AHMAX=HM(I)
- END IF
- END DO
+ END IF
+ END DO
+ ! LB 04.05.2021, replace above with array operations (maxloc not working)
+ ! NK=MINORIG+maxloc(HM(MINORIG:IHMIN))-1
+
!
! *** CHECK WHETHER PARCEL LEVEL TEMPERATURE AND SPECIFIC HUMIDITY ***
! *** ARE REASONABLE ***
! *** Skip convection if HM increases monotonically upward ***
!
- IF(TCONV(NK).LT.250.0.OR.QCONV(NK).LE.0.0.OR.IHMIN.EQ.(NL-1)) &
- THEN
- IFLAG=0
- CBMF=0.0
- RETURN
- END IF
+ IF(TCONV(NK).LT.250.0.OR.QCONV(NK).LE.0.0.OR.IHMIN.EQ.(NL-1)) THEN
+ IFLAG=0
+ CBMF=0.0
+ RETURN
+ END IF
!
! *** CALCULATE LIFTED CONDENSATION LEVEL OF AIR AT PARCEL ORIGIN LEVEL ***
! *** (WITHIN 0.2% OF FORMULA OF BOLTON, MON. WEA. REV.,1980) ***
!
- RH=QCONV(NK)/QSCONV(NK)
- CHI=TCONV(NK)/(1669.0-122.0*RH-TCONV(NK))
- PLCL=PCONV_HPA(NK)*(RH**CHI)
- IF(PLCL.LT.200.0.OR.PLCL.GE.2000.0)THEN
- IFLAG=2
- CBMF=0.0
- RETURN
- END IF
+ RH=QCONV(NK)/QSCONV(NK)
+ CHI=TCONV(NK)/(1669.0-122.0*RH-TCONV(NK))
+ PLCL=PCONV_HPA(NK)*(RH**CHI)
+ IF(PLCL.LT.200.0.OR.PLCL.GE.2000.0)THEN
+ IFLAG=2
+ CBMF=0.0
+ RETURN
+ END IF
!
! *** CALCULATE FIRST LEVEL ABOVE LCL (=ICB) ***
!
- ICB=NL-1
- DO I=NK+1,NL
- IF(PCONV_HPA(I).LT.PLCL)THEN
+ ICB=NL-1
+ DO I=NK+1,NL
+ IF(PCONV_HPA(I).LT.PLCL)THEN
ICB=MIN(ICB,I)
- END IF
- END DO
- IF(ICB.GE.(NL-1))THEN
- IFLAG=3
- CBMF=0.0
- RETURN
END IF
+ END DO
+ IF(ICB.GE.(NL-1))THEN
+ IFLAG=3
+ CBMF=0.0
+ RETURN
+ END IF
!
! *** FIND TEMPERATURE UP THROUGH ICB AND TEST FOR INSTABILITY ***
!
@@ -476,131 +479,170 @@
! *** TEMPERATURE, THE ACTUAL TEMPERATURE AND THE ADIABATIC ***
! *** LIQUID WATER CONTENT ***
!
- CALL TLIFT(GZ,ICB,NK,TVP,TP,CLW,ND,NL,1)
- DO I=NK,ICB
- TVP(I)=TVP(I)-TP(I)*QCONV(NK)
- END DO
+ CALL TLIFT(GZ,ICB,NK,TVP,TP,CLW,ND,NL,1)
+ ! DO I=NK,ICB
+ ! TVP(I)=TVP(I)-TP(I)*QCONV(NK)
+ ! END DO
+ ! LB 04.05.2021, replace above with array operations
+ TVP(NK:ICB)=TVP(NK:ICB)-TP(NK:ICB)*QCONV(NK)
!
! *** If there was no convection at last time step and parcel ***
! *** is stable at ICB then skip rest of calculation ***
!
- IF(CBMF.EQ.0.0.AND.TVP(ICB).LE.(TV(ICB)-DTMAX))THEN
- IFLAG=0
- RETURN
- END IF
+ IF(CBMF.EQ.0.0.AND.TVP(ICB).LE.(TV(ICB)-DTMAX))THEN
+ IFLAG=0
+ RETURN
+ END IF
!
! *** IF THIS POINT IS REACHED, MOIST CONVECTIVE ADJUSTMENT IS NECESSARY ***
!
- IF(IFLAG.NE.4)IFLAG=1
+ IF(IFLAG.NE.4)IFLAG=1
!
! *** FIND THE REST OF THE LIFTED PARCEL TEMPERATURES ***
!
- CALL TLIFT(GZ,ICB,NK,TVP,TP,CLW,ND,NL,2)
+ CALL TLIFT(GZ,ICB,NK,TVP,TP,CLW,ND,NL,2)
!
! *** SET THE PRECIPITATION EFFICIENCIES AND THE FRACTION OF ***
! *** PRECIPITATION FALLING OUTSIDE OF CLOUD ***
! *** THESE MAY BE FUNCTIONS OF TP(I), PCONV_HPA(I) AND CLW(I) ***
!
- DO I=1,NK
- EP(I)=0.0
- SIGP(I)=SIGS
- END DO
- DO I=NK+1,NL
- TCA=TP(I)-273.15
- IF(TCA.GE.0.0)THEN
+ ! DO I=1,NK
+ ! EP(I)=0.0
+ ! SIGP(I)=SIGS
+ ! END DO
+ ! LB 04.05.2021, replace above with array operations, sigp combined with below (NL)
+ EP(1:NK)=0.0
+ SIGP(1:NL)=SIGS
+
+ DO I=NK+1,NL
+ TCA=TP(I)-273.15
+ IF(TCA.GE.0.0)THEN
ELACRIT=ELCRIT
- ELSE
+ ELSE
ELACRIT=ELCRIT*(1.0-TCA/TLCRIT)
- END IF
- ELACRIT=MAX(ELACRIT,0.0)
- EPMAX=0.999
- EP(I)=EPMAX*(1.0-ELACRIT/MAX(CLW(I),1.0E-8))
- EP(I)=MAX(EP(I),0.0)
- EP(I)=MIN(EP(I),EPMAX)
- SIGP(I)=SIGS
- END DO
+ END IF
+ ELACRIT=MAX(ELACRIT,0.0)
+ EPMAX=0.999
+ EP(I)=EPMAX*(1.0-ELACRIT/MAX(CLW(I),1.0E-8))
+ EP(I)=MAX(EP(I),0.0)
+ EP(I)=MIN(EP(I),EPMAX)
+ SIGP(I)=SIGS
+ END DO
+ ! LB 04.05.2021, replace above with array operations
+ ! (this makes it less readable, and not any faster)
+ ! PROBLEM 1 is within the statement below
+ ! EPMAX=0.999
+ ! where ((TP(NK+1:NL)-273.15).ge.0.0)
+ ! EP(NK+1:NL)=EPMAX*(1.0-max(ELCRIT, 0.0)/MAX(CLW(NK+1:NL),1.0E-8))
+ ! elsewhere
+ ! EP(NK+1:NL)=EPMAX*(1.0-max(ELCRIT*(1.0-TCA/TLCRIT), 0.0)/MAX(CLW(NK+1:NL),1.0E-8))
+ ! end where
+ ! where (EP(NK+1:NL).lt.0.0)
+ ! EP(NK+1:NL)=0.0
+ ! elsewhere (EP(NK+1:NL).gt.EPMAX)
+ ! EP(NK+1:NL)=EPMAX
+ ! end where
+
!
! *** CALCULATE VIRTUAL TEMPERATURE AND LIFTED PARCEL ***
! *** VIRTUAL TEMPERATURE ***
- !
- DO I=ICB+1,NL
- TVP(I)=TVP(I)-TP(I)*QCONV(NK)
- END DO
- TVP(NL+1)=TVP(NL)-(GZ(NL+1)-GZ(NL))/CPD
+ ! !
+ ! DO I=ICB+1,NL
+ ! TVP(I)=TVP(I)-TP(I)*QCONV(NK)
+ ! END DO
+ ! LB 04.05.2021, replace above with array operations
+ TVP(ICB+1:NL)=TVP(ICB+1:NL)-TP(ICB+1:NL)*QCONV(NK)
+ TVP(NL+1)=TVP(NL)-(GZ(NL+1)-GZ(NL))/CPD
!
! *** NOW INITIALIZE VARIOUS ARRAYS USED IN THE COMPUTATIONS ***
!
- DO I=1,NL+1
- HP(I)=H(I)
- NENT(I)=0
- WATER(I)=0.0
- EVAP(I)=0.0
- WT(I)=OMTSNOW
- LVCP(I)=LV(I)/CPN(I)
- DO J=1,NL+1
- QENT(I,J)=QCONV(J)
- ELIJ(I,J)=0.0
- SIJ(I,J)=0.0
- END DO
- END DO
- QP(1)=QCONV(1)
- DO I=2,NL+1
- QP(I)=QCONV(I-1)
- END DO
+ ! DO I=1,NL+1
+ ! HP(I)=H(I)
+ ! NENT(I)=0
+ ! WATER(I)=0.0
+ ! EVAP(I)=0.0
+ ! WT(I)=OMTSNOW
+ ! LVCP(I)=LV(I)/CPN(I)
+ ! DO J=1,NL+1
+ ! QENT(I,J)=QCONV(J)
+ ! ELIJ(I,J)=0.0
+ ! SIJ(I,J)=0.0
+ ! END DO
+ ! END DO
+ ! LB 04.05.2021, replace above with array operations
+ HP(:NL+1)=H(:NL+1)
+ NENT(:NL+1)=0
+ WATER(:NL+1)=0.0
+ EVAP(:NL+1)=0.0
+ WT(:NL+1)=OMTSNOW
+ LVCP(:NL+1)=LV(:NL+1)/CPN(:NL+1)
+ ELIJ(:NL+1,:NL+1)=0.0
+ SIJ(:NL+1,:NL+1)=0.0
+ DO I=1,NL+1
+ QENT(I,:NL+1)=QCONV(:NL+1)
+ END DO
+ QP(1)=QCONV(1)
+ QP(2:NL+1)=QCONV(:NL)
+
!
! *** FIND THE FIRST MODEL LEVEL (INB1) ABOVE THE PARCEL'S ***
! *** HIGHEST LEVEL OF NEUTRAL BUOYANCY ***
! *** AND THE HIGHEST LEVEL OF POSITIVE CAPE (INB) ***
!
- CAPE=0.0
- CAPEM=0.0
- INB=ICB+1
- INB1=INB
- BYP=0.0
- DO I=ICB+1,NL-1
- BY=(TVP(I)-TV(I))*(PHCONV_HPA(I)-PHCONV_HPA(I+1))/PCONV_HPA(I)
- CAPE=CAPE+BY
- IF(BY.GE.0.0)INB1=I+1
- IF(CAPE.GT.0.0)THEN
+ CAPE=0.0
+ CAPEM=0.0
+ INB=ICB+1
+ INB1=INB
+ BYP=0.0
+ DO I=ICB+1,NL-1
+ BY=(TVP(I)-TV(I))*(PHCONV_HPA(I)-PHCONV_HPA(I+1))/PCONV_HPA(I)
+ CAPE=CAPE+BY
+ IF(BY.GE.0.0)INB1=I+1
+ IF(CAPE.GT.0.0)THEN
INB=I+1
BYP=(TVP(I+1)-TV(I+1))*(PHCONV_HPA(I+1)-PHCONV_HPA(I+2))/ &
PCONV_HPA(I+1)
CAPEM=CAPE
- END IF
- END DO
- INB=MAX(INB,INB1)
- CAPE=CAPEM+BYP
- DEFRAC=CAPEM-CAPE
- DEFRAC=MAX(DEFRAC,0.001)
- FRAC=-CAPE/DEFRAC
- FRAC=MIN(FRAC,1.0)
- FRAC=MAX(FRAC,0.0)
+ END IF
+ END DO
+ INB=MAX(INB,INB1)
+ CAPE=CAPEM+BYP
+ DEFRAC=CAPEM-CAPE
+ DEFRAC=MAX(DEFRAC,0.001)
+ FRAC=-CAPE/DEFRAC
+ FRAC=MIN(FRAC,1.0)
+ FRAC=MAX(FRAC,0.0)
!
! *** CALCULATE LIQUID WATER STATIC ENERGY OF LIFTED PARCEL ***
- !
- DO I=ICB,INB
- HP(I)=H(NK)+(LV(I)+(CPD-CPV)*TCONV(I))*EP(I)*CLW(I)
- END DO
+ !
+ ! DO I=ICB,INB
+ ! HP(I)=H(NK)+(LV(I)+(CPD-CPV)*TCONV(I))*EP(I)*CLW(I)
+ ! END DO
+ ! LB 04.05.2021, replace above with array operations
+ HP(ICB:INB)=H(NK)+(LV(ICB:INB)+(CPD-CPV)*TCONV(ICB:INB))*EP(ICB:INB)*CLW(ICB:INB)
!
! *** CALCULATE CLOUD BASE MASS FLUX AND RATES OF MIXING, M(I), ***
! *** AT EACH MODEL LEVEL ***
!
- DBOSUM=0.0
+
!
! *** INTERPOLATE DIFFERENCE BETWEEN LIFTED PARCEL AND ***
! *** ENVIRONMENTAL TEMPERATURES TO LIFTED CONDENSATION LEVEL ***
!
- TVPPLCL=TVP(ICB-1)-RD*TVP(ICB-1)*(PCONV_HPA(ICB-1)-PLCL)/ &
- (CPN(ICB-1)*PCONV_HPA(ICB-1))
- TVAPLCL=TV(ICB)+(TVP(ICB)-TVP(ICB+1))*(PLCL-PCONV_HPA(ICB))/ &
- (PCONV_HPA(ICB)-PCONV_HPA(ICB+1))
- DTPBL=0.0
- DO I=NK,ICB-1
- DTPBL=DTPBL+(TVP(I)-TV(I))*(PHCONV_HPA(I)-PHCONV_HPA(I+1))
- END DO
- DTPBL=DTPBL/(PHCONV_HPA(NK)-PHCONV_HPA(ICB))
- DTMIN=TVPPLCL-TVAPLCL+DTMAX+DTPBL
- DTMA=DTMIN
+ TVPPLCL=TVP(ICB-1)-RD*TVP(ICB-1)*(PCONV_HPA(ICB-1)-PLCL)/ &
+ (CPN(ICB-1)*PCONV_HPA(ICB-1))
+ TVAPLCL=TV(ICB)+(TVP(ICB)-TVP(ICB+1))*(PLCL-PCONV_HPA(ICB))/ &
+ (PCONV_HPA(ICB)-PCONV_HPA(ICB+1))
+ DTPBL=0.0
+ ! DO I=NK,ICB-1
+ ! DTPBL=DTPBL+(TVP(I)-TV(I))*(PHCONV_HPA(I)-PHCONV_HPA(I+1))
+ ! END DO
+ ! DTPBL=DTPBL/(PHCONV_HPA(NK)-PHCONV_HPA(ICB))
+ ! LB 04.05.2021, replace above with array operations
+ DTPBL=sum((TVP(NK:ICB-1)-TV(NK:ICB-1))*(PHCONV_HPA(NK:ICB-1)-PHCONV_HPA(NK+1:ICB)))/ &
+ (PHCONV_HPA(NK)-PHCONV_HPA(ICB))
+ DTMIN=TVPPLCL-TVAPLCL+DTMAX+DTPBL
+ DTMA=DTMIN
!
! *** ADJUST CLOUD BASE MASS FLUX ***
!
@@ -614,31 +656,40 @@
! *** If cloud base mass flux is zero, skip rest of calculation ***
!
IF(CBMF.EQ.0.0.AND.CBMFOLD.EQ.0.0)THEN
- RETURN
+ RETURN
END IF
!
! *** CALCULATE RATES OF MIXING, M(I) ***
!
+ ! DBOSUM=0.0
+ ! M(ICB)=0.0
+ ! DO I=ICB+1,INB
+ ! K=MIN(I,INB1)
+ ! DBO=ABS(TV(K)-TVP(K))+ &
+ ! ENTP*0.02*(PHCONV_HPA(K)-PHCONV_HPA(K+1))
+ ! DBOSUM=DBOSUM+DBO
+ ! M(I)=CBMF*DBO
+ ! END DO
+ ! DO I=ICB+1,INB
+ ! M(I)=M(I)/DBOSUM
+ ! END DO
+ ! LB 04.05.2021, replace above with array operations
M(ICB)=0.0
- DO I=ICB+1,INB
- K=MIN(I,INB1)
- DBO=ABS(TV(K)-TVP(K))+ &
- ENTP*0.02*(PHCONV_HPA(K)-PHCONV_HPA(K+1))
- DBOSUM=DBOSUM+DBO
- M(I)=CBMF*DBO
- END DO
- DO I=ICB+1,INB
- M(I)=M(I)/DBOSUM
- END DO
+ M(ICB+1:INB1)=ABS(TV(ICB+1:INB1)-TVP(ICB+1:INB1))+ &
+ ENTP*0.02*(PHCONV_HPA(ICB+1:INB1)-PHCONV_HPA(ICB+2:INB1+1))
+ M(INB1:INB)=ABS(TV(INB1)-TVP(INB1))+ &
+ ENTP*0.02*(PHCONV_HPA(INB1)-PHCONV_HPA(INB1+1))
+ M(ICB+1:INB)=CBMF*M(ICB+1:INB)/sum(M(ICB+1:INB))
+
!
! *** CALCULATE ENTRAINED AIR MASS FLUX (MENT), TOTAL WATER MIXING ***
! *** RATIO (QENT), TOTAL CONDENSED WATER (ELIJ), AND MIXING ***
! *** FRACTION (SIJ) ***
!
- DO I=ICB+1,INB
- QTI=QCONV(NK)-EP(I)*CLW(I)
- DO J=ICB,INB
+ DO I=ICB+1,INB
+ QTI=QCONV(NK)-EP(I)*CLW(I)
+ DO J=ICB,INB
BF2=1.+LV(J)*LV(J)*QSCONV(J)/(RV*TCONV(J)*TCONV(J)*CPD)
ANUM=H(J)-HP(I)+(CPV-CPD)*TCONV(J)*(QTI-QCONV(J))
DENOM=H(I)-HP(I)+(CPD-CPV)*(QCONV(I)-QTI)*TCONV(J)
@@ -651,120 +702,175 @@
CWAT=CLW(J)*(1.-EP(J))
STEMP=SIJ(I,J)
IF((STEMP.LT.0.0.OR.STEMP.GT.1.0.OR. &
- ALTEM.GT.CWAT).AND.J.GT.I)THEN
- ANUM=ANUM-LV(J)*(QTI-QSCONV(J)-CWAT*BF2)
- DENOM=DENOM+LV(J)*(QCONV(I)-QTI)
- IF(ABS(DENOM).LT.0.01)DENOM=0.01
- SIJ(I,J)=ANUM/DENOM
- ALTEM=SIJ(I,J)*QCONV(I)+(1.-SIJ(I,J))*QTI-QSCONV(J)
- ALTEM=ALTEM-(BF2-1.)*CWAT
+ ALTEM.GT.CWAT).AND.J.GT.I)THEN
+ ANUM=ANUM-LV(J)*(QTI-QSCONV(J)-CWAT*BF2)
+ DENOM=DENOM+LV(J)*(QCONV(I)-QTI)
+ IF(ABS(DENOM).LT.0.01)DENOM=0.01
+ SIJ(I,J)=ANUM/DENOM
+ ALTEM=SIJ(I,J)*QCONV(I)+(1.-SIJ(I,J))*QTI-QSCONV(J)
+ ALTEM=ALTEM-(BF2-1.)*CWAT
END IF
IF(SIJ(I,J).GT.0.0.AND.SIJ(I,J).LT.0.9)THEN
- QENT(I,J)=SIJ(I,J)*QCONV(I)+(1.-SIJ(I,J))*QTI
- ELIJ(I,J)=ALTEM
- ELIJ(I,J)=MAX(0.0,ELIJ(I,J))
- MENT(I,J)=M(I)/(1.-SIJ(I,J))
- NENT(I)=NENT(I)+1
+ QENT(I,J)=SIJ(I,J)*QCONV(I)+(1.-SIJ(I,J))*QTI
+ ELIJ(I,J)=ALTEM
+ ELIJ(I,J)=MAX(0.0,ELIJ(I,J))
+ MENT(I,J)=M(I)/(1.-SIJ(I,J))
+ NENT(I)=NENT(I)+1
END IF
SIJ(I,J)=MAX(0.0,SIJ(I,J))
SIJ(I,J)=MIN(1.0,SIJ(I,J))
- END DO
+ END DO
!
! *** IF NO AIR CAN ENTRAIN AT LEVEL I ASSUME THAT UPDRAFT DETRAINS ***
! *** AT THAT LEVEL AND CALCULATE DETRAINED AIR FLUX AND PROPERTIES ***
!
- IF(NENT(I).EQ.0)THEN
+ IF(NENT(I).EQ.0)THEN
MENT(I,I)=M(I)
QENT(I,I)=QCONV(NK)-EP(I)*CLW(I)
ELIJ(I,I)=CLW(I)
SIJ(I,I)=1.0
- END IF
- END DO
- SIJ(INB,INB)=1.0
+ END IF
+ END DO
+ SIJ(INB,INB)=1.0
+ ! LB 04.05.2021, Attempt to array the loop above: PROBLEM 2 is here
+ ! DO J=ICB,INB
+ ! BF2=1.+LV(J)*LV(J)*QSCONV(J)/(RV*TCONV(J)*TCONV(J)*CPD)
+ ! CWAT=CLW(J)*(1.-EP(J))
+ ! DO I=ICB+1,INB
+ ! QTI=QCONV(NK)-EP(I)*CLW(I)
+ ! ANUM=H(J)-HP(I)+(CPV-CPD)*TCONV(J)*(QTI-QCONV(J))
+ ! DENOM=H(I)-HP(I)+(CPD-CPV)*(QCONV(I)-QTI)*TCONV(J)
+ ! DEI=DENOM
+ ! IF(I.EQ.J)THEN
+ ! SIJ(I,I)=1.0
+ ! ELSE IF(ABS(DENOM).LT.0.01)THEN
+ ! SIJ(I,J)=ANUM/0.01
+ ! ELSE
+ ! SIJ(I,J)=ANUM/DENOM
+ ! END IF
+ ! ALTEM=(SIJ(I,J)*QCONV(I)+(1.-SIJ(I,J))*QTI-QSCONV(J))/BF2
+ ! IF((SIJ(I,J).LT.0.0.OR.SIJ(I,J).GT.1.0.OR. &
+ ! ALTEM.GT.CWAT).AND.J.GT.I)THEN
+ ! ANUM=ANUM-LV(J)*(QTI-QSCONV(J)-CWAT*BF2)
+ ! DENOM=DENOM+LV(J)*(QCONV(I)-QTI)
+ ! IF(ABS(DENOM).LT.0.01)DENOM=0.01
+ ! SIJ(I,J)=ANUM/DENOM
+ ! ALTEM=SIJ(I,J)*QCONV(I)+(1.-SIJ(I,J))*QTI-QSCONV(J)
+ ! ALTEM=ALTEM-(BF2-1.)*CWAT
+ ! END IF
+ ! IF(SIJ(I,J).GT.0.0.AND.SIJ(I,J).LT.0.9)THEN
+ ! QENT(I,J)=SIJ(I,J)*QCONV(I)+(1.-SIJ(I,J))*QTI
+ ! ELIJ(I,J)=ALTEM
+ ! ELIJ(I,J)=MAX(0.0,ELIJ(I,J))
+ ! MENT(I,J)=M(I)/(1.-SIJ(I,J))
+ ! NENT(I)=NENT(I)+1
+ ! END IF
+ ! SIJ(I,J)=MAX(0.0,SIJ(I,J))
+ ! SIJ(I,J)=MIN(1.0,SIJ(I,J))
+ ! END DO
+ ! END DO
+ ! !
+ ! ! *** IF NO AIR CAN ENTRAIN AT LEVEL I ASSUME THAT UPDRAFT DETRAINS ***
+ ! ! *** AT THAT LEVEL AND CALCULATE DETRAINED AIR FLUX AND PROPERTIES ***
+ ! !
+ ! do I=ICB+1,INB
+ ! IF(NENT(I).EQ.0)THEN
+ ! MENT(I,I)=M(I)
+ ! QENT(I,I)=QCONV(NK)-EP(I)*CLW(I)
+ ! ELIJ(I,I)=CLW(I)
+ ! SIJ(I,I)=1.0
+ ! END IF
+ ! END DO
+ ! SIJ(INB,INB)=1.0
+
+
!
! *** NORMALIZE ENTRAINED AIR MASS FLUXES TO REPRESENT EQUAL ***
! *** PROBABILITIES OF MIXING ***
!
- DO I=ICB+1,INB
+ ! LB 04.05.2021, depending on how often NENT.ne.0, reversing the loop could
+ ! speed it up...
+ DO I=ICB+1,INB
IF(NENT(I).NE.0)THEN
- QP1=QCONV(NK)-EP(I)*CLW(I)
- ANUM=H(I)-HP(I)-LV(I)*(QP1-QSCONV(I))
- DENOM=H(I)-HP(I)+LV(I)*(QCONV(I)-QP1)
- IF(ABS(DENOM).LT.0.01)DENOM=0.01
- SCRIT=ANUM/DENOM
- ALT=QP1-QSCONV(I)+SCRIT*(QCONV(I)-QP1)
- IF(ALT.LT.0.0)SCRIT=1.0
- SCRIT=MAX(SCRIT,0.0)
- ASIJ=0.0
- SMIN=1.0
- DO J=ICB,INB
- IF(SIJ(I,J).GT.0.0.AND.SIJ(I,J).LT.0.9)THEN
- IF(J.GT.I)THEN
- SMID=MIN(SIJ(I,J),SCRIT)
- SJMAX=SMID
- SJMIN=SMID
- IF(SMID.LT.SMIN.AND.SIJ(I,J+1).LT.SMID)THEN
- SMIN=SMID
- SJMAX=MIN(SIJ(I,J+1),SIJ(I,J),SCRIT)
- SJMIN=MAX(SIJ(I,J-1),SIJ(I,J))
- SJMIN=MIN(SJMIN,SCRIT)
+ QP1=QCONV(NK)-EP(I)*CLW(I)
+ ANUM=H(I)-HP(I)-LV(I)*(QP1-QSCONV(I))
+ DENOM=H(I)-HP(I)+LV(I)*(QCONV(I)-QP1)
+ IF(ABS(DENOM).LT.0.01)DENOM=0.01
+ SCRIT=ANUM/DENOM
+ ALT=QP1-QSCONV(I)+SCRIT*(QCONV(I)-QP1)
+ IF(ALT.LT.0.0)SCRIT=1.0
+ SCRIT=MAX(SCRIT,0.0)
+ ASIJ=0.0
+ SMIN=1.0
+ DO J=ICB,INB
+ IF(SIJ(I,J).GT.0.0.AND.SIJ(I,J).LT.0.9)THEN
+ IF(J.GT.I)THEN
+ SMID=MIN(SIJ(I,J),SCRIT)
+ SJMAX=SMID
+ SJMIN=SMID
+ IF(SMID.LT.SMIN.AND.SIJ(I,J+1).LT.SMID)THEN
+ SMIN=SMID
+ SJMAX=MIN(SIJ(I,J+1),SIJ(I,J),SCRIT)
+ SJMIN=MAX(SIJ(I,J-1),SIJ(I,J))
+ SJMIN=MIN(SJMIN,SCRIT)
+ END IF
+ ELSE
+ SJMAX=MAX(SIJ(I,J+1),SCRIT)
+ SMID=MAX(SIJ(I,J),SCRIT)
+ SJMIN=0.0
+ IF(J.GT.1)SJMIN=SIJ(I,J-1)
+ SJMIN=MAX(SJMIN,SCRIT)
+ END IF
+ DELP=ABS(SJMAX-SMID)
+ DELM=ABS(SJMIN-SMID)
+ ASIJ=ASIJ+(DELP+DELM)*(PHCONV_HPA(J)-PHCONV_HPA(J+1))
+ MENT(I,J)=MENT(I,J)*(DELP+DELM)* &
+ (PHCONV_HPA(J)-PHCONV_HPA(J+1))
END IF
- ELSE
- SJMAX=MAX(SIJ(I,J+1),SCRIT)
- SMID=MAX(SIJ(I,J),SCRIT)
- SJMIN=0.0
- IF(J.GT.1)SJMIN=SIJ(I,J-1)
- SJMIN=MAX(SJMIN,SCRIT)
- END IF
- DELP=ABS(SJMAX-SMID)
- DELM=ABS(SJMIN-SMID)
- ASIJ=ASIJ+(DELP+DELM)*(PHCONV_HPA(J)-PHCONV_HPA(J+1))
- MENT(I,J)=MENT(I,J)*(DELP+DELM)* &
- (PHCONV_HPA(J)-PHCONV_HPA(J+1))
+ END DO
+ ASIJ=MAX(1.0E-21,ASIJ)
+ ASIJ=1.0/ASIJ
+ DO J=ICB,INB
+ MENT(I,J)=MENT(I,J)*ASIJ
+ END DO
+ BSUM=0.0
+ DO J=ICB,INB
+ BSUM=BSUM+MENT(I,J)
+ END DO
+ IF(BSUM.LT.1.0E-18)THEN
+ NENT(I)=0
+ MENT(I,I)=M(I)
+ QENT(I,I)=QCONV(NK)-EP(I)*CLW(I)
+ ELIJ(I,I)=CLW(I)
+ SIJ(I,I)=1.0
END IF
- END DO
- ASIJ=MAX(1.0E-21,ASIJ)
- ASIJ=1.0/ASIJ
- DO J=ICB,INB
- MENT(I,J)=MENT(I,J)*ASIJ
- END DO
- BSUM=0.0
- DO J=ICB,INB
- BSUM=BSUM+MENT(I,J)
- END DO
- IF(BSUM.LT.1.0E-18)THEN
- NENT(I)=0
- MENT(I,I)=M(I)
- QENT(I,I)=QCONV(NK)-EP(I)*CLW(I)
- ELIJ(I,I)=CLW(I)
- SIJ(I,I)=1.0
- END IF
END IF
- END DO
+ END DO
+
!
! *** CHECK WHETHER EP(INB)=0, IF SO, SKIP PRECIPITATING ***
! *** DOWNDRAFT CALCULATION ***
!
- IF(EP(INB).LT.0.0001)GOTO 405
+ IF(EP(INB).LT.0.0001)GOTO 405
!
! *** INTEGRATE LIQUID WATER EQUATION TO FIND CONDENSED WATER ***
! *** AND CONDENSED WATER FLUX ***
!
- JTT=2
+ JTT=2
!
! *** BEGIN DOWNDRAFT LOOP ***
!
- DO I=INB,1,-1
+ DO I=INB,1,-1
!
! *** CALCULATE DETRAINED PRECIPITATION ***
!
WDTRAIN=G*EP(I)*M(I)*CLW(I)
IF(I.GT.1)THEN
- DO J=1,I-1
- AWAT=ELIJ(J,I)-(1.-EP(I))*CLW(I)
- AWAT=MAX(0.0,AWAT)
- WDTRAIN=WDTRAIN+G*AWAT*MENT(J,I)
- END DO
+ DO J=1,I-1
+ AWAT=ELIJ(J,I)-(1.-EP(I))*CLW(I)
+ AWAT=MAX(0.0,AWAT)
+ WDTRAIN=WDTRAIN+G*AWAT*MENT(J,I)
+ END DO
END IF
!
! *** FIND RAIN WATER AND EVAPORATION USING PROVISIONAL ***
@@ -779,8 +885,8 @@
! *** Value of terminal velocity and coefficient of evaporation for rain ***
!
IF(TCONV(I).GT.273.0)THEN
- COEFF=COEFFR
- WT(I)=OMTRAIN
+ COEFF=COEFFR
+ WT(I)=OMTRAIN
END IF
QSM=0.5*(QCONV(I)+QP(I+1))
AFAC=COEFF*PHCONV_HPA(I)*(QSCONV(I)-QSM)/ &
@@ -812,20 +918,20 @@
! *** FORCE MP TO DECREASE LINEARLY TO ZERO ***
! *** BETWEEN ABOUT 950 MB AND THE SURFACE ***
!
- IF(PCONV_HPA(I).GT.(0.949*PCONV_HPA(1)))THEN
- JTT=MAX(JTT,I)
- MP(I)=MP(JTT)*(PCONV_HPA(1)-PCONV_HPA(I))/(PCONV_HPA(1)- &
- PCONV_HPA(JTT))
- END IF
- 360 CONTINUE
+ IF(PCONV_HPA(I).GT.(0.949*PCONV_HPA(1)))THEN
+ JTT=MAX(JTT,I)
+ MP(I)=MP(JTT)*(PCONV_HPA(1)-PCONV_HPA(I))/(PCONV_HPA(1)- &
+ PCONV_HPA(JTT))
+ END IF
+360 CONTINUE
!
! *** FIND MIXING RATIO OF PRECIPITATING DOWNDRAFT ***
!
IF(I.EQ.INB)GOTO 400
IF(I.EQ.1)THEN
- QSTM=QSCONV(1)
+ QSTM=QSCONV(1)
ELSE
- QSTM=QSCONV(I-1)
+ QSTM=QSCONV(I-1)
END IF
IF(MP(I).GT.MP(I+1))THEN
RAT=MP(I+1)/MP(I)
@@ -840,13 +946,13 @@
QP(I)=MIN(QP(I),QSTM)
QP(I)=MAX(QP(I),0.0)
400 CONTINUE
- END DO
+ END DO
!
! *** CALCULATE SURFACE PRECIPITATION IN MM/DAY ***
!
- PRECIP=PRECIP+WT(1)*SIGD*WATER(1)*3600.*24000./(ROWL*G)
+ PRECIP=PRECIP+WT(1)*SIGD*WATER(1)*3600.*24000./(ROWL*G)
!
- 405 CONTINUE
+405 CONTINUE
!
! *** CALCULATE DOWNDRAFT VELOCITY SCALE AND SURFACE TEMPERATURE AND ***
! *** WATER VAPOR FLUCTUATIONS ***
@@ -858,26 +964,31 @@
! *** CALCULATE TENDENCIES OF LOWEST LEVEL POTENTIAL TEMPERATURE ***
! *** AND MIXING RATIO ***
!
- DPINV=0.01/(PHCONV_HPA(1)-PHCONV_HPA(2))
- AM=0.0
- IF(NK.EQ.1)THEN
- DO K=2,INB
- AM=AM+M(K)
- END DO
- END IF
+
+ DPINV=0.01/(PHCONV_HPA(1)-PHCONV_HPA(2))
+ AM=0.0
+ IF(NK.EQ.1)THEN
+ ! DO K=2,INB
+ ! AM=AM+M(K)
+ ! END DO
+ ! LB 04.05.2021, replace above with array operations
+ AM = sum(M(2:INB))
+ END IF
! save saturated upward mass flux for first level
- FUP(1)=AM
- IF((2.*G*DPINV*AM).GE.DELTI)IFLAG=4
- FT(1)=FT(1)+G*DPINV*AM*(TCONV(2)-TCONV(1)+(GZ(2)-GZ(1))/CPN(1))
- FT(1)=FT(1)-LVCP(1)*SIGD*EVAP(1)
- FT(1)=FT(1)+SIGD*WT(2)*(CL-CPD)*WATER(2)*(TCONV(2)- &
- TCONV(1))*DPINV/CPN(1)
- FQ(1)=FQ(1)+G*MP(2)*(QP(2)-QCONV(1))* &
- DPINV+SIGD*EVAP(1)
- FQ(1)=FQ(1)+G*AM*(QCONV(2)-QCONV(1))*DPINV
- DO J=2,INB
- FQ(1)=FQ(1)+G*DPINV*MENT(J,1)*(QENT(J,1)-QCONV(1))
- END DO
+ FUP(1)=AM
+ IF((2.*G*DPINV*AM).GE.DELTI)IFLAG=4
+ FT(1)=FT(1)+G*DPINV*AM*(TCONV(2)-TCONV(1)+(GZ(2)-GZ(1))/CPN(1))
+ FT(1)=FT(1)-LVCP(1)*SIGD*EVAP(1)
+ FT(1)=FT(1)+SIGD*WT(2)*(CL-CPD)*WATER(2)*(TCONV(2)- &
+ TCONV(1))*DPINV/CPN(1)
+ FQ(1)=FQ(1)+G*MP(2)*(QP(2)-QCONV(1))* &
+ DPINV+SIGD*EVAP(1)
+ FQ(1)=FQ(1)+G*AM*(QCONV(2)-QCONV(1))*DPINV
+ ! DO J=2,INB
+ ! FQ(1)=FQ(1)+G*DPINV*MENT(J,1)*(QENT(J,1)-QCONV(1))
+ ! END DO
+ ! LB 04.05.2021, replace above with array operations
+ FQ(1)=FQ(1)+G*DPINV*sum(MENT(2:INB,1)*(QENT(2:INB,1)-QCONV(1)))
!
! *** CALCULATE TENDENCIES OF POTENTIAL TEMPERATURE AND MIXING RATIO ***
! *** AT LEVELS ABOVE THE LOWEST LEVEL ***
@@ -885,29 +996,35 @@
! *** FIRST FIND THE NET SATURATED UPDRAFT AND DOWNDRAFT MASS FLUXES ***
! *** THROUGH EACH LEVEL ***
!
- DO I=2,INB
+ DO I=2,INB
DPINV=0.01/(PHCONV_HPA(I)-PHCONV_HPA(I+1))
CPINV=1.0/CPN(I)
AMP1=0.0
AD=0.0
IF(I.GE.NK)THEN
- DO K=I+1,INB+1
- AMP1=AMP1+M(K)
- END DO
+ ! DO K=I+1,INB+1
+ ! AMP1=AMP1+M(K)
+ ! END DO
+ ! LB 04.05.2021, replace above with array operations
+ AMP1 = sum(M(I+1:INB+1))
END IF
- DO K=1,I
- DO J=I+1,INB+1
- AMP1=AMP1+MENT(K,J)
- END DO
- END DO
+ ! DO K=1,I
+ ! DO J=I+1,INB+1
+ ! AMP1=AMP1+MENT(K,J)
+ ! END DO
+ ! END DO
+ ! LB 04.05.2021, replace above with array operations
+ AMP1 = AMP1 + sum(MENT(1:I,I+1:INB+1))
! save saturated upward mass flux
FUP(I)=AMP1
IF((2.*G*DPINV*AMP1).GE.DELTI)IFLAG=4
- DO K=1,I-1
- DO J=I,INB
- AD=AD+MENT(J,K)
- END DO
- END DO
+ ! DO K=1,I-1
+ ! DO J=I,INB
+ ! AD=AD+MENT(J,K)
+ ! END DO
+ ! END DO
+ ! LB 04.05.2021, replace above with array operations
+ AD = sum(MENT(I:INB,1:I-1))
! save saturated downward mass flux
FDOWN(I)=AD
FT(I)=FT(I)+G*DPINV*(AMP1*(TCONV(I+1)-TCONV(I)+(GZ(I+1)-GZ(I))* &
@@ -920,43 +1037,51 @@
FQ(I)=FQ(I)+G*DPINV*(AMP1*(QCONV(I+1)-QCONV(I))- &
AD*(QCONV(I)-QCONV(I-1)))
DO K=1,I-1
- AWAT=ELIJ(K,I)-(1.-EP(I))*CLW(I)
- AWAT=MAX(AWAT,0.0)
- FQ(I)=FQ(I)+G*DPINV*MENT(K,I)*(QENT(K,I)-AWAT-QCONV(I))
- END DO
- DO K=I,INB
- FQ(I)=FQ(I)+G*DPINV*MENT(K,I)*(QENT(K,I)-QCONV(I))
+ AWAT=ELIJ(K,I)-(1.-EP(I))*CLW(I)
+ AWAT=MAX(AWAT,0.0)
+ FQ(I)=FQ(I)+G*DPINV*MENT(K,I)*(QENT(K,I)-AWAT-QCONV(I))
END DO
+ ! DO K=I,INB
+ ! FQ(I)=FQ(I)+G*DPINV*MENT(K,I)*(QENT(K,I)-QCONV(I))
+ ! END DO
+ ! LB 04.05.2021, replace above with array operations
+ FQ(I)=FQ(I)+G*DPINV*sum(MENT(I:INB,I)*(QENT(I:INB,I)-QCONV(I)))
FQ(I)=FQ(I)+SIGD*EVAP(I)+G*(MP(I+1)* &
(QP(I+1)-QCONV(I))-MP(I)*(QP(I)-QCONV(I-1)))*DPINV
- END DO
+ END DO
!
! *** Adjust tendencies at top of convection layer to reflect ***
! *** actual position of the level zero CAPE ***
!
- FQOLD=FQ(INB)
- FQ(INB)=FQ(INB)*(1.-FRAC)
- FQ(INB-1)=FQ(INB-1)+FRAC*FQOLD*((PHCONV_HPA(INB)- &
- PHCONV_HPA(INB+1))/ &
- (PHCONV_HPA(INB-1)-PHCONV_HPA(INB)))*LV(INB)/LV(INB-1)
- FTOLD=FT(INB)
- FT(INB)=FT(INB)*(1.-FRAC)
- FT(INB-1)=FT(INB-1)+FRAC*FTOLD*((PHCONV_HPA(INB)- &
- PHCONV_HPA(INB+1))/ &
- (PHCONV_HPA(INB-1)-PHCONV_HPA(INB)))*CPN(INB)/CPN(INB-1)
- !
- ! *** Very slightly adjust tendencies to force exact ***
- ! *** enthalpy, momentum and tracer conservation ***
- !
- ENTS=0.0
- DO I=1,INB
- ENTS=ENTS+(CPN(I)*FT(I)+LV(I)*FQ(I))* &
- (PHCONV_HPA(I)-PHCONV_HPA(I+1))
- END DO
- ENTS=ENTS/(PHCONV_HPA(1)-PHCONV_HPA(INB+1))
- DO I=1,INB
- FT(I)=FT(I)-ENTS/CPN(I)
- END DO
+ FQOLD=FQ(INB)
+ FQ(INB)=FQ(INB)*(1.-FRAC)
+ FQ(INB-1)=FQ(INB-1)+FRAC*FQOLD*((PHCONV_HPA(INB)- &
+ PHCONV_HPA(INB+1))/ &
+ (PHCONV_HPA(INB-1)-PHCONV_HPA(INB)))*LV(INB)/LV(INB-1)
+ FTOLD=FT(INB)
+ FT(INB)=FT(INB)*(1.-FRAC)
+ FT(INB-1)=FT(INB-1)+FRAC*FTOLD*((PHCONV_HPA(INB)- &
+ PHCONV_HPA(INB+1))/ &
+ (PHCONV_HPA(INB-1)-PHCONV_HPA(INB)))*CPN(INB)/CPN(INB-1)
+!
+! *** Very slightly adjust tendencies to force exact ***
+! *** enthalpy, momentum and tracer conservation ***
+!
+ ENTS=0.0
+ ! DO I=1,INB
+ ! ENTS=ENTS+(CPN(I)*FT(I)+LV(I)*FQ(I))* &
+ ! (PHCONV_HPA(I)-PHCONV_HPA(I+1))
+ ! END DO
+ ! LB 04.05.2021, replace above with array operations
+ ENTS = sum((CPN(1:INB)*FT(1:INB)+LV(1:INB)*FQ(1:INB))* &
+ (PHCONV_HPA(1:INB)-PHCONV_HPA(2:INB+1)))
+
+ ENTS=ENTS/(PHCONV_HPA(1)-PHCONV_HPA(INB+1))
+ ! DO I=1,INB
+ ! FT(I)=FT(I)-ENTS/CPN(I)
+ ! END DO
+ ! LB 04.05.2021, replace above with array operations
+ FT(1:INB)=FT(1:INB) - ENTS/CPN(1:INB)
! ************************************************
! **** DETERMINE MASS DISPLACEMENT MATRIX
@@ -972,23 +1097,34 @@
! NCONVTOP IS THE TOP LEVEL AT WHICH CONVECTIVE MASS FLUXES ARE DIAGNOSED
! EPSILON IS A SMALL NUMBER
- SUB(1)=0.
- NCONVTOP=1
- do i=1,INB+1
- do j=1,INB+1
- if (j.eq.NK) then
- FMASS(j,i)=FMASS(j,i)+M(i)
- endif
- FMASS(j,i)=FMASS(j,i)+MENT(j,i)
- IF (FMASS(J,I).GT.EPSILON) NCONVTOP=MAX(NCONVTOP,I,J)
- end do
- if (i.gt.1) then
- SUB(i)=FUP(i-1)-FDOWN(i)
- endif
- end do
- NCONVTOP=NCONVTOP+1
-
- RETURN
+ ! SUB(1)=0.
+ ! NCONVTOP=1
+ ! do i=1,INB+1
+ ! do j=1,INB+1
+ ! if (j.eq.NK) then
+ ! FMASS(j,i)=FMASS(j,i)+M(i)
+ ! endif
+ ! FMASS(j,i)=FMASS(j,i)+MENT(j,i)
+ ! IF (FMASS(J,I).GT.EPSILON) NCONVTOP=MAX(NCONVTOP,I,J)
+ ! end do
+ ! if (i.gt.1) then
+ ! SUB(i)=FUP(i-1)-FDOWN(i)
+ ! endif
+ ! end do
+ ! NCONVTOP=NCONVTOP+1
+ ! LB 04.05.2021, replace above with array operations
+ FMASS(NK, :INB+1) = FMASS(NK,:INB+1)+M(:INB+1)
+ FMASS(:INB+1,:INB+1) = FMASS(:INB+1,:INB+1)+MENT(:INB+1,:INB+1)
+ SUB(1) = 0.
+ SUB(2:INB+1) = FUP(1:INB) - FDOWN(2:INB+1)
+ NCONVTOP=1
+ do i=1,INB+1
+ do j=1,INB+1
+ if (FMASS(j,i).gt.EPSILON) NCONVTOP=MAX(NCONVTOP,i,j)
+ end do
+ end do
+ NCONVTOP=NCONVTOP+1
+ RETURN
!
END SUBROUTINE CONVECT
!
@@ -1017,56 +1153,60 @@ SUBROUTINE TLIFT(GZ,ICB,NK,TVP,TPK,CLW,ND,NL,KK)
!
!====>End Module TLIFT File convect.f
- REAL :: GZ(ND),TPK(ND),CLW(ND)
- REAL :: TVP(ND)
+ REAL :: GZ(ND),TPK(ND),CLW(ND)
+ REAL :: TVP(ND)
!
! *** ASSIGN VALUES OF THERMODYNAMIC CONSTANTS ***
!
- REAL,PARAMETER :: CPD=1005.7
- REAL,PARAMETER :: CPV=1870.0
- REAL,PARAMETER :: CL=2500.0
- REAL,PARAMETER :: RV=461.5
- REAL,PARAMETER :: RD=287.04
- REAL,PARAMETER :: LV0=2.501E6
+ REAL,PARAMETER :: CPD=1005.7
+ REAL,PARAMETER :: CPV=1870.0
+ REAL,PARAMETER :: CL=2500.0
+ REAL,PARAMETER :: RV=461.5
+ REAL,PARAMETER :: RD=287.04
+ REAL,PARAMETER :: LV0=2.501E6
!
- REAL,PARAMETER :: CPVMCL=CL-CPV
- REAL,PARAMETER :: EPS0=RD/RV
- REAL,PARAMETER :: EPSI=1./EPS0
+ REAL,PARAMETER :: CPVMCL=CL-CPV
+ REAL,PARAMETER :: EPS0=RD/RV
+ REAL,PARAMETER :: EPSI=1./EPS0
!
! *** CALCULATE CERTAIN PARCEL QUANTITIES, INCLUDING STATIC ENERGY ***
!
- AH0=(CPD*(1.-QCONV(NK))+CL*QCONV(NK))*TCONV(NK)+QCONV(NK)* &
- (LV0-CPVMCL*( &
- TCONV(NK)-273.15))+GZ(NK)
- CPP=CPD*(1.-QCONV(NK))+QCONV(NK)*CPV
- CPINV=1./CPP
+ AH0=(CPD*(1.-QCONV(NK))+CL*QCONV(NK))*TCONV(NK)+QCONV(NK)* &
+ (LV0-CPVMCL*( &
+ TCONV(NK)-273.15))+GZ(NK)
+ CPP=CPD*(1.-QCONV(NK))+QCONV(NK)*CPV
+ CPINV=1./CPP
!
- IF(KK.EQ.1)THEN
+ IF(KK.EQ.1)THEN
!
! *** CALCULATE LIFTED PARCEL QUANTITIES BELOW CLOUD BASE ***
!
- DO I=1,ICB-1
- CLW(I)=0.0
- END DO
- DO I=NK,ICB-1
- TPK(I)=TCONV(NK)-(GZ(I)-GZ(NK))*CPINV
- TVP(I)=TPK(I)*(1.+QCONV(NK)*EPSI)
- END DO
- END IF
+ ! DO I=1,ICB-1
+ ! CLW(I)=0.0
+ ! END DO
+ ! DO I=NK,ICB-1
+ ! TPK(I)=TCONV(NK)-(GZ(I)-GZ(NK))*CPINV
+ ! TVP(I)=TPK(I)*(1.+QCONV(NK)*EPSI)
+ ! END DO
+ ! LB 04.05.2021, replace above with array operations
+ CLW(1:ICB-1) = 0.0
+ TPK(NK:ICB-1)=TCONV(NK)-(GZ(NK:ICB-1)-GZ(NK))*CPINV
+ TVP(NK:ICB-1)=TPK(NK:ICB-1)*(1.+QCONV(NK)*EPSI)
+ END IF
!
! *** FIND LIFTED PARCEL QUANTITIES ABOVE CLOUD BASE ***
!
- NST=ICB
- NSB=ICB
- IF(KK.EQ.2)THEN
- NST=NL
- NSB=ICB+1
- END IF
- DO I=NSB,NST
- TG=TCONV(I)
- QG=QSCONV(I)
- ALV=LV0-CPVMCL*(TCONV(I)-273.15)
- DO J=1,2
+ NST=ICB
+ NSB=ICB
+ IF(KK.EQ.2)THEN
+ NST=NL
+ NSB=ICB+1
+ END IF
+ DO I=NSB,NST
+ TG=TCONV(I)
+ QG=QSCONV(I)
+ ALV=LV0-CPVMCL*(TCONV(I)-273.15)
+ DO J=1,2
S=CPD+ALV*ALV*QG/(RV*TCONV(I)*TCONV(I))
S=1./S
AHG=CPD*TG+(CL-CPD)*QCONV(NK)*TCONV(I)+ALV*QG+GZ(I)
@@ -1075,18 +1215,18 @@ SUBROUTINE TLIFT(GZ,ICB,NK,TVP,TPK,CLW,ND,NL,KK)
TC=TG-273.15
DENOM=243.5+TC
IF(TC.GE.0.0)THEN
- ES=6.112*EXP(17.67*TC/DENOM)
+ ES=6.112*EXP(17.67*TC/DENOM)
ELSE
- ES=EXP(23.33086-6111.72784/TG+0.15215*LOG(TG))
+ ES=EXP(23.33086-6111.72784/TG+0.15215*LOG(TG))
END IF
QG=EPS0*ES/(PCONV_HPA(I)-ES*(1.-EPS0))
- END DO
- ALV=LV0-CPVMCL*(TCONV(I)-273.15)
- TPK(I)=(AH0-(CL-CPD)*QCONV(NK)*TCONV(I)-GZ(I)-ALV*QG)/CPD
- CLW(I)=QCONV(NK)-QG
- CLW(I)=MAX(0.0,CLW(I))
- RG=QG/(1.-QCONV(NK))
- TVP(I)=TPK(I)*(1.+RG*EPSI)
END DO
- RETURN
+ ALV=LV0-CPVMCL*(TCONV(I)-273.15)
+ TPK(I)=(AH0-(CL-CPD)*QCONV(NK)*TCONV(I)-GZ(I)-ALV*QG)/CPD
+ CLW(I)=QCONV(NK)-QG
+ CLW(I)=MAX(0.0,CLW(I))
+ RG=QG/(1.-QCONV(NK))
+ TVP(I)=TPK(I)*(1.+RG*EPSI)
+ END DO
+ RETURN
END SUBROUTINE TLIFT
diff --git a/src/convmix.f90 b/src/redundant/convmix.f90
similarity index 68%
rename from src/convmix.f90
rename to src/redundant/convmix.f90
index 586e5670..b8853149 100644
--- a/src/convmix.f90
+++ b/src/redundant/convmix.f90
@@ -23,19 +23,20 @@ subroutine convmix(itime,metdata_format)
! - Merged convmix and convmix_gfs into one routine using if-then
! for meteo-type dependent code
!**************************************************************
-
+ use omp_lib
use flux_mod
use par_mod
use com_mod
use conv_mod
use class_gribfile
+ use particle_mod
implicit none
integer :: igr,igrold, ipart, itime, ix, j, inest
integer :: ipconv
integer :: jy, kpart, ktop, ngrid,kz
- integer :: igrid(maxpart), ipoint(maxpart), igridn(maxpart,maxnests)
+ integer,allocatable :: igrid(:), ipoint(:), igridn(:,:)
integer :: metdata_format
! itime [s] current time
@@ -51,10 +52,13 @@ subroutine convmix(itime,metdata_format)
integer :: itage,nage
real,parameter :: eps=nxmax/3.e5
+ ! OMP changes
+ integer :: cnt,kk
+ integer,allocatable,dimension(:) :: frst
+ double precision :: tmarray(2)
+ integer :: conv_cnt, thread, part_cnt
- !monitoring variables
- !real sumconv,sumall
-
+ integer :: totpart,alivepart
! Calculate auxiliary variables for time interpolation
!*****************************************************
@@ -66,13 +70,17 @@ subroutine convmix(itime,metdata_format)
mind2=memind(2)
delt=real(abs(lsynctime))
-
lconv = .false.
! if no particles are present return after initialization
!********************************************************
+ call get_alive_part_num(alivepart)
+ if (alivepart.le.0 ) return
- if (numpart.le.0) return
+ call get_total_part_num(totpart)
+ allocate( igrid(totpart) )
+ allocate( ipoint(totpart) )
+ allocate( igridn(totpart,maxnests) )
! Assign igrid and igridn, which are pseudo grid numbers indicating particles
! that are outside the part of the grid under consideration
@@ -81,40 +89,41 @@ subroutine convmix(itime,metdata_format)
! igrid shall be -1
! Also, initialize index vector ipoint
!************************************************************************
-
+!$OMP PARALLEL private(ipart, j, x, y, ngrid, xtn, ytn, ix, jy)
+!$OMP DO
do ipart=1,numpart
igrid(ipart)=-1
do j=numbnests,1,-1
igridn(ipart,j)=-1
end do
ipoint(ipart)=ipart
- ! do not consider particles that are (yet) not part of simulation
- if (itra1(ipart).ne.itime) goto 20
- x = xtra1(ipart)
- y = ytra1(ipart)
+ ! do not consider particles that are not (yet) part of simulation
+ if (.not. part(ipart)%alive) cycle
+ x = part(ipart)%xlon
+ y = part(ipart)%ylat
! Determine which nesting level to be used
!**********************************************************
ngrid=0
if (metdata_format.eq.GRIBFILE_CENTRE_ECMWF) then
- do j=numbnests,1,-1
- if ( x.gt.xln(j)+eps .and. x.lt.xrn(j)-eps .and. &
- y.gt.yln(j)+eps .and. y.lt.yrn(j)-eps ) then
- ngrid=j
- goto 23
- endif
- end do
+ do j=numbnests,1,-1
+ if ( x.gt.xln(j)+eps .and. x.lt.xrn(j)-eps .and. &
+ y.gt.yln(j)+eps .and. y.lt.yrn(j)-eps ) then
+ ngrid=j
+ exit
+ endif
+ end do
else
do j=numbnests,1,-1
if ( x.gt.xln(j) .and. x.lt.xrn(j) .and. &
y.gt.yln(j) .and. y.lt.yrn(j) ) then
ngrid=j
- goto 23
+ exit
endif
end do
endif
- 23 continue
+ ! 23 continue
! Determine nested grid coordinates
!**********************************
@@ -125,16 +134,18 @@ subroutine convmix(itime,metdata_format)
ytn=(y-yln(ngrid))*yresoln(ngrid)
ix=nint(xtn)
jy=nint(ytn)
- igridn(ipart,ngrid) = 1 + jy*nxn(ngrid) + ix
+ ! igridn(ipart,ngrid) = 1 + jy*nxn(ngrid) + ix
+ igridn(ipart,ngrid) = 1 + ix*nyn(ngrid) + jy
else if(ngrid.eq.0) then
! mother grid
ix=nint(x)
jy=nint(y)
- igrid(ipart) = 1 + jy*nx + ix
+ !igrid(ipart) = 1 + jy*nx + ix
+ igrid(ipart) = 1 + ix*ny + jy
endif
-
- 20 continue
end do
+!$OMP END DO
+!$OMP END PARALLEL
! sumall = 0.
! sumconv = 0.
@@ -154,72 +165,94 @@ subroutine convmix(itime,metdata_format)
! Now visit all grid columns where particles are present
! by going through the sorted particles
- igrold = -1
+ !LB changes following the CTM version
+ allocate(frst(nx*(ny+1)+1))
+ frst(1) = 1
+ cnt = 2
+ igrold = igrid(1)
do kpart=1,numpart
- igr = igrid(kpart)
- if (igr .eq. -1) goto 50
- ipart = ipoint(kpart)
- ! sumall = sumall + 1
- if (igr .ne. igrold) then
- ! we are in a new grid column
- jy = (igr-1)/nx
- ix = igr - jy*nx - 1
+ if (igrold.ne.igrid(kpart)) then
+ frst(cnt) = kpart
+ igrold=igrid(kpart)
+ cnt=cnt+1
+ endif
+ end do
+ frst(cnt) = numpart+1
+
+ conv_cnt = 0
+ part_cnt = 0
+
+
+!$OMP PARALLEL PRIVATE(kk,jy,ix,thread,tmarray,j,kz,ktop,lconv,kpart,ipart,ztold,nage,ipconv) REDUCTION(+:conv_cnt,part_cnt)
+!$ thread = OMP_GET_THREAD_NUM()
+
+!$OMP DO SCHEDULE(static)
+ do kk=1,cnt-1
+ if (igrid(frst(kk)).eq.-1) cycle
+
+ ix = (igrid(frst(kk))-1)/ny
+ jy = igrid(frst(kk)) - ix*ny - 1
+ ! jy = (igrid(frst(kk))-1)/nx
+ ! ix = igrid(frst(kk)) - jy*nx - 1
! Interpolate all meteorological data needed for the convection scheme
- psconv=(ps(ix,jy,1,mind1)*dt2+ps(ix,jy,1,mind2)*dt1)*dtt
- tt2conv=(tt2(ix,jy,1,mind1)*dt2+tt2(ix,jy,1,mind2)*dt1)*dtt
- td2conv=(td2(ix,jy,1,mind1)*dt2+td2(ix,jy,1,mind2)*dt1)*dtt
-!!$ do kz=1,nconvlev+1 !old
- if (metdata_format.eq.GRIBFILE_CENTRE_ECMWF) then
- do kz=1,nuvz-1 !bugfix
+ psconv=(ps(ix,jy,1,mind1)*dt2+ps(ix,jy,1,mind2)*dt1)*dtt
+ tt2conv=(tt2(ix,jy,1,mind1)*dt2+tt2(ix,jy,1,mind2)*dt1)*dtt
+ td2conv=(td2(ix,jy,1,mind1)*dt2+td2(ix,jy,1,mind2)*dt1)*dtt
+
+ if (metdata_format.eq.GRIBFILE_CENTRE_ECMWF) then
+ do kz=1,nuvz-1 !bugfix
tconv(kz)=(tth(ix,jy,kz+1,mind1)*dt2+ &
tth(ix,jy,kz+1,mind2)*dt1)*dtt
qconv(kz)=(qvh(ix,jy,kz+1,mind1)*dt2+ &
qvh(ix,jy,kz+1,mind2)*dt1)*dtt
end do
- else
- do kz=1,nuvz-1 !bugfix
- pconv(kz)=(pplev(ix,jy,kz,mind1)*dt2+ &
- pplev(ix,jy,kz,mind2)*dt1)*dtt
- tconv(kz)=(tt(ix,jy,kz,mind1)*dt2+ &
- tt(ix,jy,kz,mind2)*dt1)*dtt
- qconv(kz)=(qv(ix,jy,kz,mind1)*dt2+ &
- qv(ix,jy,kz,mind2)*dt1)*dtt
- end do
- end if
+ else
+ do kz=1,nuvz-1 !bugfix
+ pconv(kz)=(pplev(ix,jy,kz,mind1)*dt2+ &
+ pplev(ix,jy,kz,mind2)*dt1)*dtt
+ tconv(kz)=(tt(ix,jy,kz,mind1)*dt2+ &
+ tt(ix,jy,kz,mind2)*dt1)*dtt
+ qconv(kz)=(qv(ix,jy,kz,mind1)*dt2+ &
+ qv(ix,jy,kz,mind2)*dt1)*dtt
+ end do
+ end if
! Calculate translocation matrix
- call calcmatrix(lconv,delt,cbaseflux(ix,jy),metdata_format)
- igrold = igr
- ktop = 0
- endif
-
+ call calcmatrix(lconv,delt,cbaseflux(ix,jy),metdata_format)
+
! treat particle only if column has convection
if (lconv .eqv. .true.) then
+ ktop = 0
! assign new vertical position to particle
-
- ztold=ztra1(ipart)
- call redist(ipart,ktop,ipconv)
+ !LB th ctm version has a do loop, let's see if that changes anything
+ do kpart=frst(kk), frst(kk+1)-1
+ ipart = ipoint(kpart)
+ ztold=part(ipart)%z
+ call redist(itime,ipart,ktop,ipconv)
! if (ipconv.le.0) sumconv = sumconv+1
! Calculate the gross fluxes across layer interfaces
!***************************************************
- if (iflux.eq.1) then
- itage=abs(itra1(ipart)-itramem(ipart))
- do nage=1,nageclass
- if (itage.lt.lage(nage)) goto 37
- end do
- 37 continue
+ if (iflux.eq.1) then
+ itage=abs(itime-part(ipart)%tstart)
+ do nage=1,nageclass
+ if ((itage.lt.lage(nage)).or.(.not.part(ipart)%alive)) exit
+ end do
- if (nage.le.nageclass) &
- call calcfluxes(nage,ipart,real(xtra1(ipart)), &
- real(ytra1(ipart)),ztold)
- endif
+ if (nage.le.nageclass) &
+ call calcfluxes(itime,nage,ipart,real(part(ipart)%xlon), &
+ real(part(ipart)%ylat),ztold)
+ endif
+ enddo
endif !(lconv .eqv. .true)
- 50 continue
end do
+!$OMP END DO
+!$OMP END PARALLEL
+
+ deallocate(frst)
!*****************************************************************************
@@ -241,7 +274,7 @@ subroutine convmix(itime,metdata_format)
igrold = -1
do kpart=1,numpart
igr = igrid(kpart)
- if (igr .eq. -1) goto 60
+ if (igr .eq. -1) cycle
ipart = ipoint(kpart)
! sumall = sumall + 1
if (igr .ne. igrold) then
@@ -274,29 +307,26 @@ subroutine convmix(itime,metdata_format)
! treat particle only if column has convection
if (lconv .eqv. .true.) then
! assign new vertical position to particle
- ztold=ztra1(ipart)
- call redist(ipart,ktop,ipconv)
+ ztold=part(ipart)%z
+ call redist(itime,ipart,ktop,ipconv)
! if (ipconv.le.0) sumconv = sumconv+1
! Calculate the gross fluxes across layer interfaces
!***************************************************
if (iflux.eq.1) then
- itage=abs(itra1(ipart)-itramem(ipart))
+ itage=abs(itime-part(ipart)%tstart)
do nage=1,nageclass
- if (itage.lt.lage(nage)) goto 47
+ if ((itage.lt.lage(nage)).or.(.not.part(ipart)%alive)) exit
end do
- 47 continue
if (nage.le.nageclass) &
- call calcfluxes(nage,ipart,real(xtra1(ipart)), &
- real(ytra1(ipart)),ztold)
+ call calcfluxes(itime,nage,ipart,real(part(ipart)%xlon), &
+ real(part(ipart)%ylat),ztold)
endif
endif !(lconv .eqv. .true.)
-
-60 continue
end do
end do
!--------------------------------------------------------------------------
@@ -311,5 +341,9 @@ subroutine convmix(itime,metdata_format)
! & sumconv
! write(*,*)'############################################'
+ deallocate( igrid )
+ deallocate( ipoint )
+ deallocate( igridn )
+
return
end subroutine convmix
diff --git a/src/coordtrafo.f90 b/src/redundant/coordtrafo.f90
similarity index 100%
rename from src/coordtrafo.f90
rename to src/redundant/coordtrafo.f90
diff --git a/src/detectformat.f90 b/src/redundant/detectformat.f90
similarity index 100%
rename from src/detectformat.f90
rename to src/redundant/detectformat.f90
diff --git a/src/distance.f90 b/src/redundant/distance.f90
similarity index 100%
rename from src/distance.f90
rename to src/redundant/distance.f90
diff --git a/src/distance2.f90 b/src/redundant/distance2.f90
similarity index 100%
rename from src/distance2.f90
rename to src/redundant/distance2.f90
diff --git a/src/redundant/domainfill.f90 b/src/redundant/domainfill.f90
new file mode 100644
index 00000000..45509e21
--- /dev/null
+++ b/src/redundant/domainfill.f90
@@ -0,0 +1,931 @@
+! SPDX-FileCopyrightText: FLEXPART 1998-2019, see flexpart_license.txt
+! SPDX-License-Identifier: GPL-3.0-or-later
+
+subroutine init_domainfill
+ !
+ !*****************************************************************************
+ ! *
+ ! Initializes particles equally distributed over the first release location *
+ ! specified in file RELEASES. This box is assumed to be the domain for doing *
+ ! domain-filling trajectory calculations. *
+ ! All particles carry the same amount of mass which alltogether comprises the*
+ ! mass of air within the box. *
+ ! *
+ ! Author: A. Stohl *
+ ! *
+ ! 15 October 2002 *
+ ! *
+ !*****************************************************************************
+ ! *
+ ! Variables: *
+ ! *
+ ! numparticlecount consecutively counts the number of particles released *
+ ! nx_we(2) grid indices for western and eastern boundary of domain- *
+ ! filling trajectory calculations *
+ ! ny_sn(2) grid indices for southern and northern boundary of domain- *
+ ! filling trajectory calculations *
+ ! *
+ !*****************************************************************************
+
+ use point_mod
+ use par_mod
+ use com_mod
+ use windfields_mod
+ use random_mod
+ use interpol_mod
+ use coordinates_ecmwf
+ use particle_mod
+
+ implicit none
+
+ integer :: j,kz,lix,ljy,ncolumn,numparttot
+ real :: gridarea(0:nymax-1),pp(nzmax),ylat,ylatp,ylatm,hzone
+ real :: cosfactm,cosfactp,deltacol,dz1,dz2,dz,pnew,fractus
+ real,parameter :: pih=pi/180.
+ real :: colmass(0:nxmax-1,0:nymax-1),colmasstotal,zposition
+
+ integer :: ixm,jym,indzm,in,indzh,i,jj,ii
+ real :: pvpart,y1(2)
+
+ integer :: idummy = -11
+
+ real :: frac,psint,zzlev,zzlev2,ttemp
+
+ logical :: deall
+ ! Determine the release region (only full grid cells), over which particles
+ ! shall be initialized
+ ! Use 2 fields for west/east and south/north boundary
+ !**************************************************************************
+
+ nx_we(1)=max(int(xpoint1(1)),0)
+ nx_we(2)=min((int(xpoint2(1))+1),nxmin1)
+ ny_sn(1)=max(int(ypoint1(1)),0)
+ ny_sn(2)=min((int(ypoint2(1))+1),nymin1)
+
+ ! For global simulations (both global wind data and global domain-filling),
+ ! set a switch, such that no boundary conditions are used
+ !**************************************************************************
+ if (xglobal.and.sglobal.and.nglobal) then
+ if ((nx_we(1).eq.0).and.(nx_we(2).eq.nxmin1).and. &
+ (ny_sn(1).eq.0).and.(ny_sn(2).eq.nymin1)) then
+ gdomainfill=.true.
+ else
+ gdomainfill=.false.
+ endif
+ endif
+
+ ! Exit here if resuming a run from particle dump
+ !***********************************************
+ if (gdomainfill.and.ipin.ne.0) return
+
+
+ ! Do not release particles twice (i.e., not at both in the leftmost and rightmost
+ ! grid cell) for a global domain
+ !*****************************************************************************
+ if (xglobal) nx_we(2)=min(nx_we(2),nx-2)
+
+
+ ! Calculate area of grid cell with formula M=2*pi*R*h*dx/360,
+ ! see Netz, Formeln der Mathematik, 5. Auflage (1983), p.90
+ !************************************************************
+
+ do ljy=ny_sn(1),ny_sn(2) ! loop about latitudes
+ ylat=ylat0+real(ljy)*dy
+ ylatp=ylat+0.5*dy
+ ylatm=ylat-0.5*dy
+ if ((ylatm.lt.0).and.(ylatp.gt.0.)) then
+ hzone=1./dyconst
+ else
+ cosfactp=cos(ylatp*pih)*r_earth
+ cosfactm=cos(ylatm*pih)*r_earth
+ if (cosfactp.lt.cosfactm) then
+ hzone=sqrt(r_earth**2-cosfactp**2)- &
+ sqrt(r_earth**2-cosfactm**2)
+ else
+ hzone=sqrt(r_earth**2-cosfactm**2)- &
+ sqrt(r_earth**2-cosfactp**2)
+ endif
+ endif
+ gridarea(ljy)=2.*pi*r_earth*hzone*dx/360.
+ end do
+
+ ! Do the same for the south pole
+
+ if (sglobal) then
+ ylat=ylat0
+ ylatp=ylat+0.5*dy
+ ylatm=ylat
+ cosfactm=0.
+ cosfactp=cos(ylatp*pih)*r_earth
+ hzone=sqrt(r_earth**2-cosfactm**2)- &
+ sqrt(r_earth**2-cosfactp**2)
+ gridarea(0)=2.*pi*r_earth*hzone*dx/360.
+ endif
+
+ ! Do the same for the north pole
+
+ if (nglobal) then
+ ylat=ylat0+real(nymin1)*dy
+ ylatp=ylat
+ ylatm=ylat-0.5*dy
+ cosfactp=0.
+ cosfactm=cos(ylatm*pih)*r_earth
+ hzone=sqrt(r_earth**2-cosfactp**2)- &
+ sqrt(r_earth**2-cosfactm**2)
+ gridarea(nymin1)=2.*pi*r_earth*hzone*dx/360.
+ endif
+
+
+ ! Calculate total mass of each grid column and of the whole atmosphere
+ !*********************************************************************
+
+ colmasstotal=0.
+ do ljy=ny_sn(1),ny_sn(2) ! loop about latitudes
+ do lix=nx_we(1),nx_we(2) ! loop about longitudes
+ pp(1)=rho(lix,ljy,1,1)*r_air*tt(lix,ljy,1,1)
+ pp(nz)=rho(lix,ljy,nz,1)*r_air*tt(lix,ljy,nz,1)
+ colmass(lix,ljy)=(pp(1)-pp(nz))/ga*gridarea(ljy)
+ colmasstotal=colmasstotal+colmass(lix,ljy)
+ end do
+ end do
+
+ write(*,*) 'Atm. mass: ',colmasstotal
+
+ ! Allocate memory for storing the particles
+ !******************************************
+ call allocate_particles(npart(1))
+
+ if (ipin.eq.0) numpart=0
+
+ ! Determine the particle positions
+ !*********************************
+
+ numparttot=0
+ numcolumn=0
+ do ljy=ny_sn(1),ny_sn(2) ! loop about latitudes
+ ylat=ylat0+real(ljy)*dy
+ do lix=nx_we(1),nx_we(2) ! loop about longitudes
+ ncolumn=nint(0.999*real(npart(1))*colmass(lix,ljy)/ &
+ colmasstotal)
+ if (ncolumn.eq.0) cycle
+ if (ncolumn.gt.numcolumn) numcolumn=ncolumn
+
+ ! Calculate pressure at the altitudes of model surfaces, using the air density
+ ! information, which is stored as a 3-d field
+ !*****************************************************************************
+
+ do kz=1,nz
+ pp(kz)=rho(lix,ljy,kz,1)*r_air*tt(lix,ljy,kz,1)
+ end do
+
+
+ deltacol=(pp(1)-pp(nz))/real(ncolumn)
+ pnew=pp(1)+deltacol/2.
+ jj=0
+ do j=1,ncolumn
+ jj=jj+1
+
+
+ ! For columns with many particles (i.e. around the equator), distribute
+ ! the particles equally, for columns with few particles (i.e. around the
+ ! poles), distribute the particles randomly
+ !***********************************************************************
+
+
+ if (ncolumn.gt.20) then
+ pnew=pnew-deltacol
+ else
+ pnew=pp(1)-ran1(idummy)*(pp(1)-pp(nz))
+ endif
+
+ do kz=1,nz-1
+ if ((pp(kz).ge.pnew).and.(pp(kz+1).lt.pnew)) then
+ dz1=pp(kz)-pnew
+ dz2=pnew-pp(kz+1)
+ dz=1./(dz1+dz2)
+
+ ! Assign particle position
+ !*************************
+ ! Do the following steps only if particles are not read in from previous model run
+ !*****************************************************************************
+ if (ipin.eq.0) then
+ ! First spawn the particle into existence
+ !****************************************
+ call spawn_particle(0,numpart+jj)
+ call set_xlon(numpart+jj,real(real(lix)-0.5+ran1(idummy),kind=dp))
+ if (lix.eq.0) call set_xlon(numpart+jj,real(ran1(idummy),kind=dp))
+ if (lix.eq.nxmin1) &
+ call set_xlon(numpart+jj,real(real(nxmin1)-ran1(idummy),kind=dp))
+ call set_ylat(numpart+jj,real(real(ljy)-0.5+ran1(idummy),kind=dp))
+ call set_z(numpart+jj,(height(kz)*dz2+height(kz+1)*dz1)*dz)
+ if (real(part(numpart+jj)%z).gt.height(nz)-0.5) &
+ call set_z(numpart+jj,height(nz)-0.5)
+
+ call update_z_to_zeta(0, numpart+jj)
+
+ ! Interpolate PV to the particle position
+ !****************************************
+ ixm=int(part(numpart+jj)%xlon)
+ jym=int(part(numpart+jj)%ylat)
+ ixp=ixm+1
+ jyp=jym+1
+ ddx=part(numpart+jj)%xlon-real(ixm)
+ ddy=part(numpart+jj)%ylat-real(jym)
+ rddx=1.-ddx
+ rddy=1.-ddy
+ p1=rddx*rddy
+ p2=ddx*rddy
+ p3=rddx*ddy
+ p4=ddx*ddy
+
+ !***************************************************************************
+
+ do i=2,nz
+ if (real(height(i),kind=dp).gt.part(numpart+jj)%z) then
+ indzm=i-1
+ indzp=i
+ exit
+ endif
+ end do
+ dz1=real(part(numpart+jj)%z)-height(indzm)
+ dz2=height(indzp)-real(part(numpart+jj)%z)
+ dz=1./(dz1+dz2)
+ do in=1,2
+ indzh=indzm+in-1
+ y1(in)=p1*pv(ixm,jym,indzh,1) &
+ +p2*pv(ixp,jym,indzh,1) &
+ +p3*pv(ixm,jyp,indzh,1) &
+ +p4*pv(ixp,jyp,indzh,1)
+ end do
+ pvpart=(dz2*y1(1)+dz1*y1(2))*dz
+ if (ylat.lt.0.) pvpart=-1.*pvpart
+
+
+ ! For domain-filling option 2 (stratospheric O3), do the rest only in the stratosphere
+ !*****************************************************************************
+
+ if (((part(numpart+jj)%z.gt.3000.).and. &
+ (pvpart.gt.pvcrit)).or.(mdomainfill.eq.1)) then
+
+ ! Assign certain properties to the particle
+ !******************************************
+ part(numpart+jj)%nclass=min(int(ran1(idummy)* &
+ real(nclassunc))+1,nclassunc)
+ numparticlecount=numparticlecount+1
+ part(numpart+jj)%npoint=numparticlecount
+ part(numpart+jj)%idt=mintime
+ part(numpart+jj)%mass(1)=colmass(lix,ljy)/real(ncolumn)
+ if (mdomainfill.eq.2) part(numpart+jj)%mass(1)= &
+ part(numpart+jj)%mass(1)*pvpart*48./29.*ozonescale/10.**9
+ else
+ jj=jj-1
+ endif
+ endif
+ endif
+ end do
+ end do
+ numparttot=numparttot+ncolumn
+ if (ipin.eq.0) numpart=numpart+jj
+ end do
+ end do
+
+
+ ! Check whether numpart is really smaller than maxpart
+ !*****************************************************
+
+ ! ! ESO :TODO: this warning need to be moved further up, else out-of-bounds error earlier
+ ! if (numpart.gt.maxpart) then
+ ! write(*,*) 'numpart too large: change source in init_atm_mass.f'
+ ! write(*,*) 'numpart: ',numpart,' maxpart: ',maxpart
+ ! endif
+
+
+ xmassperparticle=colmasstotal/real(numparttot)
+
+
+ ! Make sure that all particles are within domain
+ !***********************************************
+
+ do j=1,numpart
+ if ((part(j)%xlon.lt.0.).or.(part(j)%xlon.ge.real(nxmin1,kind=dp)).or. &
+ (part(j)%ylat.lt.0.).or.(part(j)%ylat.ge.real(nymin1,kind=dp))) then
+ call terminate_particle(j)
+ endif
+ end do
+
+ ! For boundary conditions, we need fewer particle release heights per column,
+ ! because otherwise it takes too long until enough mass has accumulated to
+ ! release a particle at the boundary (would take dx/u seconds), leading to
+ ! relatively large position errors of the order of one grid distance.
+ ! It's better to release fewer particles per column, but to do so more often.
+ ! Thus, use on the order of nz starting heights per column.
+ ! We thus repeat the above to determine fewer starting heights, that are
+ ! used furtheron in subroutine boundcond_domainfill.f.
+ !****************************************************************************
+
+ fractus=real(numcolumn)/real(nz)
+ write(*,*) 'Total number of particles at model start: ',numpart
+ write(*,*) 'Maximum number of particles per column: ',numcolumn
+ write(*,*) 'If ',fractus,' <1, better use more particles'
+ fractus=sqrt(max(fractus,1.))/2.
+
+ do ljy=ny_sn(1),ny_sn(2) ! loop about latitudes
+ do lix=nx_we(1),nx_we(2) ! loop about longitudes
+ ncolumn=nint(0.999/fractus*real(npart(1))*colmass(lix,ljy) &
+ /colmasstotal)
+ if (ncolumn.gt.maxcolumn) stop 'maxcolumn too small'
+ if (ncolumn.eq.0) cycle
+
+
+ ! Memorize how many particles per column shall be used for all boundaries
+ ! This is further used in subroutine boundcond_domainfill.f
+ ! Use 2 fields for west/east and south/north boundary
+ !************************************************************************
+
+ if (lix.eq.nx_we(1)) numcolumn_we(1,ljy)=ncolumn
+ if (lix.eq.nx_we(2)) numcolumn_we(2,ljy)=ncolumn
+ if (ljy.eq.ny_sn(1)) numcolumn_sn(1,lix)=ncolumn
+ if (ljy.eq.ny_sn(2)) numcolumn_sn(2,lix)=ncolumn
+
+ ! Calculate pressure at the altitudes of model surfaces, using the air density
+ ! information, which is stored as a 3-d field
+ !*****************************************************************************
+
+ do kz=1,nz
+ pp(kz)=rho(lix,ljy,kz,1)*r_air*tt(lix,ljy,kz,1)
+ end do
+
+ ! Determine the reference starting altitudes
+ !*******************************************
+
+ deltacol=(pp(1)-pp(nz))/real(ncolumn)
+ pnew=pp(1)+deltacol/2.
+ do j=1,ncolumn
+ pnew=pnew-deltacol
+ do kz=1,nz-1
+ if ((pp(kz).ge.pnew).and.(pp(kz+1).lt.pnew)) then
+ dz1=pp(kz)-pnew
+ dz2=pnew-pp(kz+1)
+ dz=1./(dz1+dz2)
+ zposition=(height(kz)*dz2+height(kz+1)*dz1)*dz
+ if (zposition.gt.height(nz)-0.5) zposition=height(nz)-0.5
+
+ ! Memorize vertical positions where particles are introduced
+ ! This is further used in subroutine boundcond_domainfill.f
+ !***********************************************************
+
+ if (lix.eq.nx_we(1)) zcolumn_we(1,ljy,j)=zposition
+ if (lix.eq.nx_we(2)) zcolumn_we(2,ljy,j)=zposition
+ if (ljy.eq.ny_sn(1)) zcolumn_sn(1,lix,j)=zposition
+ if (ljy.eq.ny_sn(2)) zcolumn_sn(2,lix,j)=zposition
+
+ ! Initialize mass that has accumulated at boundary to zero
+ !*********************************************************
+
+ acc_mass_we(1,ljy,j)=0.
+ acc_mass_we(2,ljy,j)=0.
+ acc_mass_sn(1,ljy,j)=0.
+ acc_mass_sn(2,ljy,j)=0.
+ endif
+ end do
+ end do
+ end do
+ end do
+
+ ! If there were more particles allocated than used,
+ ! Deallocate unused memory and update numpart
+ !**************************************************
+ deall=.false.
+ do i=numpart, 1, -1
+ if (.not. part(i)%alive) then
+ deall=.true.
+ numpart = numpart - 1
+ else
+ exit
+ endif
+ end do
+
+ if (deall) call deallocate_particle(numpart) !Deallocates everything above numpart (F2008)
+
+
+ ! If particles shall be read in to continue an existing run,
+ ! then the accumulated masses at the domain boundaries must be read in, too.
+ ! This overrides any previous calculations.
+ !***************************************************************************
+
+ if ((ipin.eq.1).and.(.not.gdomainfill)) then
+ open(unitboundcond,file=path(2)(1:length(2))//'boundcond.bin', &
+ form='unformatted')
+ read(unitboundcond) numcolumn_we,numcolumn_sn, &
+ zcolumn_we,zcolumn_sn,acc_mass_we,acc_mass_sn
+ close(unitboundcond)
+ endif
+end subroutine init_domainfill
+
+subroutine boundcond_domainfill(itime,loutend)
+ ! i i
+ !*****************************************************************************
+ ! *
+ ! Particles are created by this subroutine continuously throughout the *
+ ! simulation at the boundaries of the domain-filling box. *
+ ! All particles carry the same amount of mass which alltogether comprises the*
+ ! mass of air within the box, which remains (more or less) constant. *
+ ! *
+ ! Author: A. Stohl *
+ ! *
+ ! 16 October 2002 *
+ ! *
+ !*****************************************************************************
+ ! *
+ ! Variables: *
+ ! *
+ ! nx_we(2) grid indices for western and eastern boundary of domain- *
+ ! filling trajectory calculations *
+ ! ny_sn(2) grid indices for southern and northern boundary of domain- *
+ ! filling trajectory calculations *
+ ! *
+ !*****************************************************************************
+
+ use point_mod
+ use par_mod
+ use com_mod
+ use random_mod, only: ran1
+ use particle_mod
+ use coordinates_ecmwf
+
+ implicit none
+
+ real :: dz,dz1,dz2,dt1,dt2,dtt,ylat,xm,cosfact,accmasst
+ integer :: itime,in,indz,indzp,i,loutend
+ integer :: j,k,ix,jy,m,indzh,indexh,minpart,ipart,mmass
+ integer :: numactiveparticles
+
+ real :: windl(2),rhol(2)
+ real :: windhl(2),rhohl(2)
+ real :: windx,rhox
+ real :: deltaz,boundarea,fluxofmass
+
+ integer :: ixm,ixp,jym,jyp,indzm,mm
+ real :: pvpart,ddx,ddy,rddx,rddy,p1,p2,p3,p4,y1(2),yh1(2)
+
+ integer :: idummy = -11
+
+
+ ! If domain-filling is global, no boundary conditions are needed
+ !***************************************************************
+
+ if (gdomainfill) return
+
+ accmasst=0.
+ numactiveparticles=0
+
+ ! Terminate trajectories that have left the domain, if domain-filling
+ ! trajectory calculation domain is not global
+ !********************************************************************
+
+ do i=1,numpart
+ if (.not. part(i)%alive) cycle
+
+ if ((part(i)%ylat.gt.real(ny_sn(2))).or. &
+ (part(i)%ylat.lt.real(ny_sn(1)))) call terminate_particle(i)
+ if (((.not.xglobal).or.(nx_we(2).ne.(nx-2))).and. &
+ ((part(i)%xlon.lt.real(nx_we(1))).or. &
+ (part(i)%xlon.gt.real(nx_we(2))))) call terminate_particle(i)
+ if (part(i)%alive) numactiveparticles = numactiveparticles+1
+ end do
+
+
+ ! Determine auxiliary variables for time interpolation
+ !*****************************************************
+
+ dt1=real(itime-memtime(1))
+ dt2=real(memtime(2)-itime)
+ dtt=1./(dt1+dt2)
+
+ !***************************************
+ ! Western and eastern boundary condition
+ !***************************************
+
+ ! Loop from south to north
+ !*************************
+
+ do jy=ny_sn(1),ny_sn(2)
+
+ ! Loop over western (index 1) and eastern (index 2) boundary
+ !***********************************************************
+
+ do k=1,2
+
+ ! Loop over all release locations in a column
+ !********************************************
+
+ do j=1,numcolumn_we(k,jy)
+
+ ! Determine, for each release location, the area of the corresponding boundary
+ !*****************************************************************************
+
+ if (j.eq.1) then
+ deltaz=(zcolumn_we(k,jy,2)+zcolumn_we(k,jy,1))/2.
+ else if (j.eq.numcolumn_we(k,jy)) then
+ ! In order to avoid taking a very high column for very many particles,
+ ! use the deltaz from one particle below instead
+ deltaz=(zcolumn_we(k,jy,j)-zcolumn_we(k,jy,j-2))/2.
+ else
+ deltaz=(zcolumn_we(k,jy,j+1)-zcolumn_we(k,jy,j-1))/2.
+ endif
+ if ((jy.eq.ny_sn(1)).or.(jy.eq.ny_sn(2))) then
+ boundarea=deltaz*111198.5/2.*dy
+ else
+ boundarea=deltaz*111198.5*dy
+ endif
+
+
+ ! Interpolate the wind velocity and density to the release location
+ !******************************************************************
+
+ ! Determine the model level below the release position
+ !*****************************************************
+
+ do i=2,nz
+ if (height(i).gt.zcolumn_we(k,jy,j)) then
+ indz=i-1
+ indzp=i
+ exit
+ endif
+ end do
+
+ ! Vertical distance to the level below and above current position
+ !****************************************************************
+
+ dz1=zcolumn_we(k,jy,j)-height(indz)
+ dz2=height(indzp)-zcolumn_we(k,jy,j)
+ dz=1./(dz1+dz2)
+
+ ! Vertical and temporal interpolation
+ !************************************
+
+ do m=1,2
+ indexh=memind(m)
+ do in=1,2
+ indzh=indz+in-1
+ windl(in)=uu(nx_we(k),jy,indzh,indexh)
+ rhol(in)=rho(nx_we(k),jy,indzh,indexh)
+ end do
+
+ windhl(m)=(dz2*windl(1)+dz1*windl(2))*dz
+ rhohl(m)=(dz2*rhol(1)+dz1*rhol(2))*dz
+ end do
+
+ windx=(windhl(1)*dt2+windhl(2)*dt1)*dtt
+ rhox=(rhohl(1)*dt2+rhohl(2)*dt1)*dtt
+
+ ! Calculate mass flux
+ !********************
+
+ fluxofmass=windx*rhox*boundarea*real(lsynctime)
+
+
+ ! If the mass flux is directed into the domain, add it to previous mass fluxes;
+ ! if it is out of the domain, set accumulated mass flux to zero
+ !******************************************************************************
+
+ if (k.eq.1) then
+ if (fluxofmass.ge.0.) then
+ acc_mass_we(k,jy,j)=acc_mass_we(k,jy,j)+fluxofmass
+ else
+ acc_mass_we(k,jy,j)=0.
+ endif
+ else
+ if (fluxofmass.le.0.) then
+ acc_mass_we(k,jy,j)=acc_mass_we(k,jy,j)+abs(fluxofmass)
+ else
+ acc_mass_we(k,jy,j)=0.
+ endif
+ endif
+ accmasst=accmasst+acc_mass_we(k,jy,j)
+
+ ! If the accumulated mass exceeds half the mass that each particle shall carry,
+ ! one (or more) particle(s) is (are) released and the accumulated mass is
+ ! reduced by the mass of this (these) particle(s)
+ !******************************************************************************
+
+ if (acc_mass_we(k,jy,j).ge.xmassperparticle/2.) then
+ mmass=int((acc_mass_we(k,jy,j)+xmassperparticle/2.)/ &
+ xmassperparticle)
+ acc_mass_we(k,jy,j)=acc_mass_we(k,jy,j)- &
+ real(mmass)*xmassperparticle
+ else
+ mmass=0
+ endif
+
+ do m=1,mmass
+ call get_new_part_index(ipart)
+ call spawn_particle(itime, ipart)
+
+ ! Assign particle positions
+ !**************************
+
+ call set_xlon(ipart,real(nx_we(k),kind=dp))
+ if (jy.eq.ny_sn(1)) then
+ call set_ylat(ipart,real(real(jy)+0.5*ran1(idummy),kind=dp))
+ else if (jy.eq.ny_sn(2)) then
+ call set_ylat(ipart,real(real(jy)-0.5*ran1(idummy),kind=dp))
+ else
+ call set_ylat(ipart,real(real(jy)+(ran1(idummy)-.5),kind=dp))
+ endif
+ if (j.eq.1) then
+ call set_z(ipart,zcolumn_we(k,jy,1)+(zcolumn_we(k,jy,2)- &
+ zcolumn_we(k,jy,1))/4.)
+ else if (j.eq.numcolumn_we(k,jy)) then
+ call set_z(ipart,(2.*zcolumn_we(k,jy,j)+ &
+ zcolumn_we(k,jy,j-1)+height(nz))/4.)
+ else
+ call set_z(ipart,zcolumn_we(k,jy,j-1)+ran1(idummy)* &
+ (zcolumn_we(k,jy,j+1)-zcolumn_we(k,jy,j-1)))
+ endif
+
+ call update_z_to_zeta(itime, ipart)
+
+ ! Interpolate PV to the particle position
+ !****************************************
+ ixm=int(part(ipart)%xlon)
+ jym=int(part(ipart)%ylat)
+ ixp=ixm+1
+ jyp=jym+1
+ ddx=part(ipart)%xlon-real(ixm)
+ ddy=part(ipart)%ylat-real(jym)
+ rddx=1.-ddx
+ rddy=1.-ddy
+ p1=rddx*rddy
+ p2=ddx*rddy
+ p3=rddx*ddy
+ p4=ddx*ddy
+ do i=2,nz
+ if (real(height(i),kind=dp).gt.part(ipart)%z) then
+ indzm=i-1
+ indzp=i
+ exit
+ endif
+ end do
+ dz1=real(part(ipart)%z)-height(indzm)
+ dz2=height(indzp)-real(part(ipart)%z)
+ dz=1./(dz1+dz2)
+ do mm=1,2
+ indexh=memind(mm)
+ do in=1,2
+ indzh=indzm+in-1
+ y1(in)=p1*pv(ixm,jym,indzh,indexh) &
+ +p2*pv(ixp,jym,indzh,indexh) &
+ +p3*pv(ixm,jyp,indzh,indexh) &
+ +p4*pv(ixp,jyp,indzh,indexh)
+ end do
+ yh1(mm)=(dz2*y1(1)+dz1*y1(2))*dz
+ end do
+ pvpart=(yh1(1)*dt2+yh1(2)*dt1)*dtt
+ ylat=ylat0+part(ipart)%ylat*dy
+ if (ylat.lt.0.) pvpart=-1.*pvpart
+
+
+ ! For domain-filling option 2 (stratospheric O3), do the rest only in the stratosphere
+ !*****************************************************************************
+
+ if (((part(ipart)%z.gt.3000.).and. &
+ (pvpart.gt.pvcrit)).or.(mdomainfill.eq.1)) then
+ part(ipart)%nclass=min(int(ran1(idummy)* &
+ real(nclassunc))+1,nclassunc)
+ numactiveparticles=numactiveparticles+1
+ numparticlecount=numparticlecount+1
+ part(ipart)%npoint=numparticlecount
+ part(ipart)%idt=mintime
+ part(ipart)%tstart=itime
+ part(ipart)%mass(1)=xmassperparticle
+ if (mdomainfill.eq.2) part(ipart)%mass(1)= &
+ part(ipart)%mass(1)*pvpart*48./29.*ozonescale/10.**9
+ else
+ stop 'boundcond_domainfill error: look into original to understand what should happen here'
+ endif
+ end do ! particles
+ end do ! release locations in column
+ end do ! western and eastern boundary
+ end do ! south to north
+
+
+ !*****************************************
+ ! Southern and northern boundary condition
+ !*****************************************
+
+ ! Loop from west to east
+ !***********************
+
+ do ix=nx_we(1),nx_we(2)
+
+ ! Loop over southern (index 1) and northern (index 2) boundary
+ !*************************************************************
+
+ do k=1,2
+ ylat=ylat0+real(ny_sn(k))*dy
+ cosfact=cos(ylat*pi180)
+
+ ! Loop over all release locations in a column
+ !********************************************
+
+ do j=1,numcolumn_sn(k,ix)
+
+ ! Determine, for each release location, the area of the corresponding boundary
+ !*****************************************************************************
+
+ if (j.eq.1) then
+ deltaz=(zcolumn_sn(k,ix,2)+zcolumn_sn(k,ix,1))/2.
+ else if (j.eq.numcolumn_sn(k,ix)) then
+ ! deltaz=height(nz)-(zcolumn_sn(k,ix,j-1)+
+ ! + zcolumn_sn(k,ix,j))/2.
+ ! In order to avoid taking a very high column for very many particles,
+ ! use the deltaz from one particle below instead
+ deltaz=(zcolumn_sn(k,ix,j)-zcolumn_sn(k,ix,j-2))/2.
+ else
+ deltaz=(zcolumn_sn(k,ix,j+1)-zcolumn_sn(k,ix,j-1))/2.
+ endif
+ if ((ix.eq.nx_we(1)).or.(ix.eq.nx_we(2))) then
+ boundarea=deltaz*111198.5/2.*cosfact*dx
+ else
+ boundarea=deltaz*111198.5*cosfact*dx
+ endif
+
+
+ ! Interpolate the wind velocity and density to the release location
+ !******************************************************************
+
+ ! Determine the model level below the release position
+ !*****************************************************
+
+ do i=2,nz
+ if (height(i).gt.zcolumn_sn(k,ix,j)) then
+ indz=i-1
+ indzp=i
+ exit
+ endif
+ end do
+
+ ! Vertical distance to the level below and above current position
+ !****************************************************************
+
+ dz1=zcolumn_sn(k,ix,j)-height(indz)
+ dz2=height(indzp)-zcolumn_sn(k,ix,j)
+ dz=1./(dz1+dz2)
+
+ ! Vertical and temporal interpolation
+ !************************************
+
+ do m=1,2
+ indexh=memind(m)
+ do in=1,2
+ indzh=indz+in-1
+ windl(in)=vv(ix,ny_sn(k),indzh,indexh)
+ rhol(in)=rho(ix,ny_sn(k),indzh,indexh)
+ end do
+
+ windhl(m)=(dz2*windl(1)+dz1*windl(2))*dz
+ rhohl(m)=(dz2*rhol(1)+dz1*rhol(2))*dz
+ end do
+
+ windx=(windhl(1)*dt2+windhl(2)*dt1)*dtt
+ rhox=(rhohl(1)*dt2+rhohl(2)*dt1)*dtt
+
+ ! Calculate mass flux
+ !********************
+
+ fluxofmass=windx*rhox*boundarea*real(lsynctime)
+
+ ! If the mass flux is directed into the domain, add it to previous mass fluxes;
+ ! if it is out of the domain, set accumulated mass flux to zero
+ !******************************************************************************
+
+ if (k.eq.1) then
+ if (fluxofmass.ge.0.) then
+ acc_mass_sn(k,ix,j)=acc_mass_sn(k,ix,j)+fluxofmass
+ else
+ acc_mass_sn(k,ix,j)=0.
+ endif
+ else
+ if (fluxofmass.le.0.) then
+ acc_mass_sn(k,ix,j)=acc_mass_sn(k,ix,j)+abs(fluxofmass)
+ else
+ acc_mass_sn(k,ix,j)=0.
+ endif
+ endif
+ accmasst=accmasst+acc_mass_sn(k,ix,j)
+
+ ! If the accumulated mass exceeds half the mass that each particle shall carry,
+ ! one (or more) particle(s) is (are) released and the accumulated mass is
+ ! reduced by the mass of this (these) particle(s)
+ !******************************************************************************
+
+ if (acc_mass_sn(k,ix,j).ge.xmassperparticle/2.) then
+ mmass=int((acc_mass_sn(k,ix,j)+xmassperparticle/2.)/ &
+ xmassperparticle)
+ acc_mass_sn(k,ix,j)=acc_mass_sn(k,ix,j)- &
+ real(mmass)*xmassperparticle
+ else
+ mmass=0
+ endif
+
+ do m=1,mmass
+ call get_new_part_index(ipart)
+ call spawn_particle(itime, ipart)
+
+ ! Assign particle positions
+ !**************************
+ call set_ylat(ipart,real(ny_sn(k),kind=dp))
+ if (ix.eq.nx_we(1)) then
+ call set_xlon(ipart,real(real(ix)+0.5*ran1(idummy),kind=dp))
+ else if (ix.eq.nx_we(2)) then
+ call set_xlon(ipart,real(real(ix)-0.5*ran1(idummy),kind=dp))
+ else
+ call set_xlon(ipart,real(real(ix)+(ran1(idummy)-.5),kind=dp))
+ endif
+ if (j.eq.1) then
+ call set_z(ipart,zcolumn_sn(k,ix,1)+(zcolumn_sn(k,ix,2)- &
+ zcolumn_sn(k,ix,1))/4.)
+ else if (j.eq.numcolumn_sn(k,ix)) then
+ call set_z(ipart,(2.*zcolumn_sn(k,ix,j)+ &
+ zcolumn_sn(k,ix,j-1)+height(nz))/4.)
+ else
+ call set_z(ipart,zcolumn_sn(k,ix,j-1)+ran1(idummy)* &
+ (zcolumn_sn(k,ix,j+1)-zcolumn_sn(k,ix,j-1)))
+ endif
+
+ call update_z_to_zeta(itime, ipart)
+
+ ! Interpolate PV to the particle position
+ !****************************************
+ ixm=int(part(ipart)%xlon)
+ jym=int(part(ipart)%ylat)
+ ixp=ixm+1
+ jyp=jym+1
+ ddx=part(ipart)%xlon-real(ixm)
+ ddy=part(ipart)%ylat-real(jym)
+ rddx=1.-ddx
+ rddy=1.-ddy
+ p1=rddx*rddy
+ p2=ddx*rddy
+ p3=rddx*ddy
+ p4=ddx*ddy
+ do i=2,nz
+ if (real(height(i),kind=dp).gt.part(ipart)%z) then
+ indzm=i-1
+ indzp=i
+ exit
+ endif
+ end do
+ dz1=real(part(ipart)%z)-height(indzm)
+ dz2=height(indzp)-real(part(ipart)%z)
+ dz=1./(dz1+dz2)
+ do mm=1,2
+ indexh=memind(mm)
+ do in=1,2
+ indzh=indzm+in-1
+ y1(in)=p1*pv(ixm,jym,indzh,indexh) &
+ +p2*pv(ixp,jym,indzh,indexh) &
+ +p3*pv(ixm,jyp,indzh,indexh) &
+ +p4*pv(ixp,jyp,indzh,indexh)
+ end do
+ yh1(mm)=(dz2*y1(1)+dz1*y1(2))*dz
+ end do
+ pvpart=(yh1(1)*dt2+yh1(2)*dt1)*dtt
+ if (ylat.lt.0.) pvpart=-1.*pvpart
+
+
+ ! For domain-filling option 2 (stratospheric O3), do the rest only in the stratosphere
+ !*****************************************************************************
+
+ if (((part(ipart)%z.gt.3000.).and. &
+ (pvpart.gt.pvcrit)).or.(mdomainfill.eq.1)) then
+ part(ipart)%nclass=min(int(ran1(idummy)* &
+ real(nclassunc))+1,nclassunc)
+ numactiveparticles=numactiveparticles+1
+ numparticlecount=numparticlecount+1
+ part(ipart)%npoint=numparticlecount
+ part(ipart)%idt=mintime
+ part(ipart)%mass(1)=xmassperparticle
+ if (mdomainfill.eq.2) part(ipart)%mass(1)= &
+ part(ipart)%mass(1)*pvpart*48./29.*ozonescale/10.**9
+ else
+ stop 'boundcond_domainfill error: look into original to understand what should happen here'
+ endif
+ end do ! particles
+ end do ! releases per column
+ end do ! east west
+ end do ! north south
+
+ ! If particles shall be dumped, then accumulated masses at the domain boundaries
+ ! must be dumped, too, to be used for later runs
+ !*****************************************************************************
+
+ if ((ipout.gt.0).and.(itime.eq.loutend)) then
+ open(unitboundcond,file=path(2)(1:length(2))//'boundcond.bin', &
+ form='unformatted')
+ write(unitboundcond) numcolumn_we,numcolumn_sn, &
+ zcolumn_we,zcolumn_sn,acc_mass_we,acc_mass_sn
+ close(unitboundcond)
+ endif
+end subroutine boundcond_domainfill
\ No newline at end of file
diff --git a/src/drydepokernel.f90 b/src/redundant/drydepokernel.f90
similarity index 100%
rename from src/drydepokernel.f90
rename to src/redundant/drydepokernel.f90
diff --git a/src/drydepokernel_nest.f90 b/src/redundant/drydepokernel_nest.f90
similarity index 100%
rename from src/drydepokernel_nest.f90
rename to src/redundant/drydepokernel_nest.f90
diff --git a/src/dynamic_viscosity.f90 b/src/redundant/dynamic_viscosity.f90
similarity index 100%
rename from src/dynamic_viscosity.f90
rename to src/redundant/dynamic_viscosity.f90
diff --git a/src/redundant/ew.f90 b/src/redundant/ew.f90
new file mode 100644
index 00000000..05f10056
--- /dev/null
+++ b/src/redundant/ew.f90
@@ -0,0 +1,56 @@
+! SPDX-FileCopyrightText: FLEXPART 1998-2019, see flexpart_license.txt
+! SPDX-License-Identifier: GPL-3.0-or-later
+
+real function ew(x,p)
+
+ !****************************************************************
+ !SAETTIGUNGSDAMPFDRUCK UEBER WASSER IN PA. X IN KELVIN.
+ !NACH DER GOFF-GRATCH-FORMEL.
+ !****************************************************************
+
+ implicit none
+
+ real :: x, y, a, p, f_qvsat!, c, d
+
+ ew=0.
+ if(x.le.0.) stop 'sorry: t not in [k]'
+ ! Formula of Goff and Gratch (after Murray, 1966)
+ ! if (x.lt.273.15) then
+ ! ! Above ice
+ ! a = 273.15/x
+ ! y = -20.947031*a - 3.56654*log(a) - 2.01889049/a
+ ! ew = 5.75185606E10*exp(y)
+ ! else
+ ! ! Above water
+ ! a = 373.15/x
+ ! y = -18.1972839*a + 5.02808*log(a) - 70242.1852*exp(-26.1205253/a) + &
+ ! 58.0691913*exp(-8.03945282*a)
+ ! ew = 7.95357242E10*exp(y)
+ ! endif
+
+ ! ! Formula of Magnus (after Murray, 1966)
+ ! if (x.lt.273.15) then
+ ! ! Above ice
+ ! ew = 6.1078*exp(21.8745584*(x-273.15)/(x-7.66))
+ ! else
+ ! ! Above water
+ ! ew = 6.1078*exp(17.2693882*(x-273.15)/(x-35.86))
+ ! endif
+
+ ! Formula of Buck 1981
+ ew = f_qvsat(p,x)
+
+ ! ! Original
+ ! y=373.15/x ! changed 373.16 to 373.15
+ ! a=-7.90298*(y-1.)
+ ! a=a+(5.02808*alog(y)) ! removed 0.43429*
+ ! c=(1.-(1./y))*11.344
+ ! c=-1.+(10.**c)
+ ! c=-1.3816*c/(10.**7)
+ ! d=(1.-y)*3.49149
+ ! d=-1.+(10.**d)
+ ! d=8.1328*d/(10.**3)
+ ! y=a+c+d
+ ! ew=101324.6*(10.**y) ! Saettigungsdampfdruck in Pa
+
+end function ew
diff --git a/src/fluxoutput.f90 b/src/redundant/fluxoutput.f90
similarity index 100%
rename from src/fluxoutput.f90
rename to src/redundant/fluxoutput.f90
diff --git a/src/get_vdep_prob.f90 b/src/redundant/get_vdep_prob.f90
similarity index 98%
rename from src/get_vdep_prob.f90
rename to src/redundant/get_vdep_prob.f90
index caac2ed1..abb6f2a4 100644
--- a/src/get_vdep_prob.f90
+++ b/src/redundant/get_vdep_prob.f90
@@ -33,9 +33,9 @@ subroutine get_vdep_prob(itime,xt,yt,zt,prob)
implicit none
real(kind=dp) :: xt,yt
- real :: zt,xtn,ytn
+ real :: zt!,xtn,ytn
integer :: itime,i,j,k,memindnext
- integer :: nix,njy,ks
+ integer :: ks!nix,njy,
real :: prob(maxspec),vdepo(maxspec)
real,parameter :: eps=nxmax/3.e5
@@ -62,10 +62,9 @@ subroutine get_vdep_prob(itime,xt,yt,zt,prob)
if ((xt.gt.xln(j)+eps).and.(xt.lt.xrn(j)-eps).and. &
(yt.gt.yln(j)+eps).and.(yt.lt.yrn(j)-eps)) then
ngrid=j
- goto 23
+ exit
endif
end do
-23 continue
endif
diff --git a/src/get_wetscav.f90 b/src/redundant/get_wetscav.f90
similarity index 64%
rename from src/get_wetscav.f90
rename to src/redundant/get_wetscav.f90
index 1728fc05..0f7f6f7d 100644
--- a/src/get_wetscav.f90
+++ b/src/redundant/get_wetscav.f90
@@ -46,6 +46,9 @@ subroutine get_wetscav(itime,ltsample,loutnext,jpart,ks,grfraction,inc_count,blc
use point_mod
use par_mod
use com_mod
+ use interpol_mod, only: interpol_rain, interpol_rain_nests
+ use particle_mod
+ use coordinates_ecmwf
implicit none
@@ -75,79 +78,78 @@ subroutine get_wetscav(itime,ltsample,loutnext,jpart,ks,grfraction,inc_count,blc
logical :: readclouds_this_nest
- wetscav=0.
+ wetscav=0.
! Determine which nesting level to be used
!*****************************************
- ngrid=0
- do j=numbnests,1,-1
- if ((xtra1(jpart).gt.xln(j)).and.(xtra1(jpart).lt.xrn(j)).and. &
- (ytra1(jpart).gt.yln(j)).and.(ytra1(jpart).lt.yrn(j))) then
- ngrid=j
- goto 23
- endif
- end do
-23 continue
-
+ ngrid=0
+ do j=numbnests,1,-1
+ if ((part(jpart)%xlon.gt.xln(j)).and.(part(jpart)%xlon.lt.xrn(j)).and. &
+ (part(jpart)%ylat.gt.yln(j)).and.(part(jpart)%ylat.lt.yrn(j))) then
+ ngrid=j
+ exit
+ endif
+ end do
! Determine nested grid coordinates
!**********************************
- readclouds_this_nest=.false.
-
- if (ngrid.gt.0) then
- xtn=(xtra1(jpart)-xln(ngrid))*xresoln(ngrid)
- ytn=(ytra1(jpart)-yln(ngrid))*yresoln(ngrid)
- ix=int(xtn)
- jy=int(ytn)
- if (readclouds_nest(ngrid)) readclouds_this_nest=.true.
- else
- ix=int(xtra1(jpart))
- jy=int(ytra1(jpart))
- endif
+ readclouds_this_nest=.false.
+
+ if (ngrid.gt.0) then
+ xtn=(part(jpart)%xlon-xln(ngrid))*xresoln(ngrid)
+ ytn=(part(jpart)%ylat-yln(ngrid))*yresoln(ngrid)
+ ix=int(xtn)
+ jy=int(ytn)
+ if (readclouds_nest(ngrid)) readclouds_this_nest=.true.
+ else
+ ix=int(part(jpart)%xlon)
+ jy=int(part(jpart)%ylat)
+ endif
! Interpolate large scale precipitation, convective precipitation and
! total cloud cover
! Note that interpolated time refers to itime-0.5*ltsample [PS]
!********************************************************************
- interp_time=nint(itime-0.5*ltsample)
-
- n=memind(2)
- if (abs(memtime(1)-interp_time).lt.abs(memtime(2)-interp_time)) &
- n=memind(1)
-
- if (ngrid.eq.0) then
- call interpol_rain(lsprec,convprec,tcc,nxmax,nymax, &
- 1,nx,ny,n,real(xtra1(jpart)),real(ytra1(jpart)),1, &
- memtime(1),memtime(2),interp_time,lsp,convp,cc)
- else
- call interpol_rain_nests(lsprecn,convprecn,tccn, &
- nxmaxn,nymaxn,1,maxnests,ngrid,nxn,nyn,n,xtn,ytn,1, &
- memtime(1),memtime(2),interp_time,lsp,convp,cc)
- endif
+ interp_time=nint(itime-0.5*ltsample)
+
+ n=memind(2)
+ if (abs(memtime(1)-interp_time).lt.abs(memtime(2)-interp_time)) &
+ n=memind(1)
+
+ if (ngrid.eq.0) then
+ call interpol_rain(lsprec,convprec,tcc,nxmax,nymax, &
+ 1,nx,ny,n,real(part(jpart)%xlon),real(part(jpart)%ylat),1, &
+ memtime(1),memtime(2),interp_time,lsp,convp,cc)
+ else
+ call interpol_rain_nests(lsprecn,convprecn,tccn, &
+ nxmaxn,nymaxn,1,maxnests,ngrid,nxn,nyn,n,xtn,ytn,1, &
+ memtime(1),memtime(2),interp_time,lsp,convp,cc)
+ endif
! If total precipitation is less than 0.01 mm/h - no scavenging occurs
- if ((lsp.lt.0.01).and.(convp.lt.0.01)) goto 20
+ if ((lsp.lt.0.01).and.(convp.lt.0.01)) return
! get the level were the actual particle is in
- do il=2,nz
- if (height(il).gt.ztra1(jpart)) then
- hz=il-1
- exit
- endif
- end do
-
- if (ngrid.eq.0) then
- clouds_v=clouds(ix,jy,hz,n)
- clouds_h=cloudsh(ix,jy,n)
- else
- clouds_v=cloudsn(ix,jy,hz,n,ngrid)
- clouds_h=cloudshn(ix,jy,n,ngrid)
+ call update_zeta_to_z(itime,jpart)
+ do il=2,nz
+ if (height(il).gt.part(jpart)%z) then
+ hz=il-1
+ exit
endif
+ end do
+
+ if (ngrid.eq.0) then
+ clouds_v=clouds(ix,jy,hz,n)
+ clouds_h=cloudsh(ix,jy,n)
+ else
+ clouds_v=cloudsn(ix,jy,hz,n,ngrid)
+ clouds_h=cloudshn(ix,jy,n,ngrid)
+ endif
! if there is no precipitation or the particle is above the clouds no
! scavenging is done
- if (clouds_v.le.1) goto 20
+ if (clouds_v.le.1) return
! 1) Parameterization of the the area fraction of the grid cell where the
! precipitation occurs: the absolute limit is the total cloud cover, but
@@ -156,161 +158,158 @@ subroutine get_wetscav(itime,ltsample,loutnext,jpart,ks,grfraction,inc_count,blc
! convective precipitation.
!**************************************************************************
- if (lsp.gt.20.) then
- i=5
- else if (lsp.gt.8.) then
- i=4
- else if (lsp.gt.3.) then
- i=3
- else if (lsp.gt.1.) then
- i=2
- else
- i=1
- endif
-
- if (convp.gt.20.) then
- j=5
- else if (convp.gt.8.) then
- j=4
- else if (convp.gt.3.) then
- j=3
- else if (convp.gt.1.) then
- j=2
- else
- j=1
- endif
+ if (lsp.gt.20.) then
+ i=5
+ else if (lsp.gt.8.) then
+ i=4
+ else if (lsp.gt.3.) then
+ i=3
+ else if (lsp.gt.1.) then
+ i=2
+ else
+ i=1
+ endif
+
+ if (convp.gt.20.) then
+ j=5
+ else if (convp.gt.8.) then
+ j=4
+ else if (convp.gt.3.) then
+ j=3
+ else if (convp.gt.1.) then
+ j=2
+ else
+ j=1
+ endif
!ZHG oct 2014 : Calculated for 1) both 2) lsp 3) convp - 2 and 3 not used removed by SE
! Tentatively differentiate the grfraction for lsp and convp for treating differently the two forms
! for now they are treated the same
- grfraction(1)=max(0.05,cc*(lsp*lfr(i)+convp*cfr(j))/(lsp+convp))
+ grfraction(1)=max(0.05,cc*(lsp*lfr(i)+convp*cfr(j))/(lsp+convp))
! 2) Computation of precipitation rate in sub-grid cell
!******************************************************
- prec(1)=(lsp+convp)/grfraction(1)
+ prec(1)=(lsp+convp)/grfraction(1)
! 3) Computation of scavenging coefficients for all species
! Computation of wet deposition
!**********************************************************
- if (ngrid.gt.0) then
- act_temp=ttn(ix,jy,hz,n,ngrid)
- else
- act_temp=tt(ix,jy,hz,n)
- endif
+ if (ngrid.gt.0) then
+ act_temp=ttn(ix,jy,hz,n,ngrid)
+ else
+ act_temp=tt(ix,jy,hz,n)
+ endif
!***********************
! BELOW CLOUD SCAVENGING
!***********************
- if (clouds_v.ge.4) then !below cloud
+ if (clouds_v.ge.4) then !below cloud
! For gas: if positive below-cloud parameters (A or B), and dquer<=0
!******************************************************************
- if ((dquer(ks).le.0.).and.(weta_gas(ks).gt.0..or.wetb_gas(ks).gt.0.)) then
- blc_count(ks)=blc_count(ks)+1
- wetscav=weta_gas(ks)*prec(1)**wetb_gas(ks)
+ if ((dquer(ks).le.0.).and.(weta_gas(ks).gt.0..or.wetb_gas(ks).gt.0.)) then
+ blc_count(ks)=blc_count(ks)+1
+ wetscav=weta_gas(ks)*prec(1)**wetb_gas(ks)
! For aerosols: if positive below-cloud parameters (Crain/Csnow or B), and dquer>0
!*********************************************************************************
- else if ((dquer(ks).gt.0.).and.(crain_aero(ks).gt.0..or.csnow_aero(ks).gt.0.)) then
- blc_count(ks)=blc_count(ks)+1
+ else if ((dquer(ks).gt.0.).and.(crain_aero(ks).gt.0..or.csnow_aero(ks).gt.0.)) then
+ blc_count(ks)=blc_count(ks)+1
!NIK 17.02.2015
! For the calculation here particle size needs to be in meter and not um as dquer is
! changed in readreleases
! For particles larger than 10 um use the largest size defined in the parameterizations (10um)
- dquer_m=min(10.,dquer(ks))/1000000. !conversion from um to m
+ dquer_m=min(10.,dquer(ks))/1000000. !conversion from um to m
! Rain:
- if (act_temp .ge. 273. .and. crain_aero(ks).gt.0.) then
+ if (act_temp .ge. 273. .and. crain_aero(ks).gt.0.) then
! ZHG 2014 : Particle RAIN scavenging coefficient based on Laakso et al 2003,
! the below-cloud scavenging (rain efficienty) parameter Crain (=crain_aero) from SPECIES file
- wetscav=crain_aero(ks)*10**(bclr(1)+(bclr(2)*(log10(dquer_m))**(-4))+ &
- & (bclr(3)*(log10(dquer_m))**(-3))+ (bclr(4)*(log10(dquer_m))**(-2))+&
- &(bclr(5)*(log10(dquer_m))**(-1))+bclr(6)* (prec(1))**(0.5))
+ wetscav=crain_aero(ks)*10**(bclr(1)+(bclr(2)*(log10(dquer_m))**(-4))+ &
+ & (bclr(3)*(log10(dquer_m))**(-3))+ (bclr(4)*(log10(dquer_m))**(-2))+&
+ &(bclr(5)*(log10(dquer_m))**(-1))+bclr(6)* (prec(1))**(0.5))
! Snow:
- elseif (act_temp .lt. 273. .and. csnow_aero(ks).gt.0.) then
+ elseif (act_temp .lt. 273. .and. csnow_aero(ks).gt.0.) then
! ZHG 2014 : Particle SNOW scavenging coefficient based on Kyro et al 2009,
! the below-cloud scavenging (Snow efficiency) parameter Csnow (=csnow_aero) from SPECIES file
- wetscav=csnow_aero(ks)*10**(bcls(1)+(bcls(2)*(log10(dquer_m))**(-4))+&
- &(bcls(3)*(log10(dquer_m))**(-3))+ (bcls(4)*(log10(dquer_m))**(-2))+&
- &(bcls(5)*(log10(dquer_m))**(-1))+ bcls(6)* (prec(1))**(0.5))
+ wetscav=csnow_aero(ks)*10**(bcls(1)+(bcls(2)*(log10(dquer_m))**(-4))+&
+ &(bcls(3)*(log10(dquer_m))**(-3))+ (bcls(4)*(log10(dquer_m))**(-2))+&
+ &(bcls(5)*(log10(dquer_m))**(-1))+ bcls(6)* (prec(1))**(0.5))
- endif
-
- endif ! gas or particle
+ endif
+
+ endif ! gas or particle
! endif ! positive below-cloud scavenging parameters given in Species file
- endif !end BELOW
+ endif !end BELOW
!********************
! IN CLOUD SCAVENGING
!********************
- if (clouds_v.lt.4) then ! In-cloud
+ if (clouds_v.lt.4) then ! In-cloud
! NIK 13 may 2015: only do incloud if positive in-cloud scavenging parameters are
! given in species file, or if gas and positive Henry's constant
- if ((ccn_aero(ks).gt.0. .or. in_aero(ks).gt.0.).or.(henry(ks).gt.0.and.dquer(ks).le.0)) then
- inc_count(ks)=inc_count(ks)+1
+ if ((ccn_aero(ks).gt.0. .or. in_aero(ks).gt.0.).or.(henry(ks).gt.0.and.dquer(ks).le.0)) then
+ inc_count(ks)=inc_count(ks)+1
! if negative coefficients (turned off) set to zero for use in equation
- if (ccn_aero(ks).lt.0.) ccn_aero(ks)=0.
- if (in_aero(ks).lt.0.) in_aero(ks)=0.
+ if (ccn_aero(ks).lt.0.) ccn_aero(ks)=0.
+ if (in_aero(ks).lt.0.) in_aero(ks)=0.
!ZHG 2015 Cloud liquid & ice water (CLWC+CIWC) from ECMWF
! nested fields
- if (ngrid.gt.0.and.readclouds_this_nest) then
- cl=ctwcn(ix,jy,n,ngrid)*(grfraction(1)/cc)
- else if (ngrid.eq.0.and.readclouds) then
- cl=ctwc(ix,jy,n)*(grfraction(1)/cc)
- else !parameterize cloudwater m2/m3
+ if (ngrid.gt.0.and.readclouds_this_nest) then
+ cl=ctwcn(ix,jy,n,ngrid)*(grfraction(1)/cc)
+ else if (ngrid.eq.0.and.readclouds) then
+ cl=ctwc(ix,jy,n)*(grfraction(1)/cc)
+ else !parameterize cloudwater m2/m3
!ZHG updated parameterization of cloud water to better reproduce the values coming from ECMWF
! sec test
! cl=1E6*1E-7*prec(1)**0.3 !Sec GFS new
- cl=1E6*2E-7*prec(1)**0.36 !Sec ECMWF new, is also suitable for GFS
+ cl=1E6*2E-7*prec(1)**0.36 !Sec ECMWF new, is also suitable for GFS
! cl=2E-7*prec(1)**0.36 !Andreas
! cl=1.6E-6*prec(1)**0.36 !Henrik
- endif
+ endif
!ZHG: Calculate the partition between liquid and water phase water.
- if (act_temp .le. 253.) then
- liq_frac=0
- ice_frac=1
- else if (act_temp .ge. 273.) then
- liq_frac=1
- ice_frac=0
- else
+ if (act_temp .le. 253.) then
+ liq_frac=0
+ ice_frac=1
+ else if (act_temp .ge. 273.) then
+ liq_frac=1
+ ice_frac=0
+ else
! sec bugfix after FLEXPART paper review, liq_frac was 1-liq_frac
! IP bugfix v10.4, calculate ice_frac and liq_frac
- ice_frac= ((act_temp-273.)/(273.-253.))**2.
- !liq_frac = 1-ice_frac !((act_temp-253.)/(273.-253.))**2.
- liq_frac=max(0.,1.-ice_frac)
- end if
+ ice_frac= ((act_temp-273.)/(273.-253.))**2.
+ !liq_frac = 1-ice_frac !((act_temp-253.)/(273.-253.))**2.
+ liq_frac=max(0.,1.-ice_frac)
+ end if
! ZHG: Calculate the aerosol partition based on cloud phase and Ai and Bi
! frac_act = liq_frac*ccn_aero(ks) +(1-liq_frac)*in_aero(ks)
! IP, use ice_frac and liq_frac
- frac_act = liq_frac*ccn_aero(ks) + ice_frac*in_aero(ks)
+ frac_act = liq_frac*ccn_aero(ks) + ice_frac*in_aero(ks)
!ZHG Use the activated fraction and the liqid water to calculate the washout
! AEROSOL
!********
- if (dquer(ks).gt.0.) then
- S_i= frac_act/cl
+ if (dquer(ks).gt.0.) then
+ S_i= frac_act/cl
! GAS
!****
- else
- cle=(1-cl)/(henry(ks)*(r_air/3500.)*act_temp)+cl
- S_i=1/cle
- endif ! gas or particle
+ else
+ cle=(1-cl)/(henry(ks)*(r_air/3500.)*act_temp)+cl
+ S_i=1/cle
+ endif ! gas or particle
! scavenging coefficient based on Hertel et al 1995 - using the S_i for either gas or aerosol
!SEC wetscav fix, the cloud height is no longer needed, it gives wrong results
- wetscav=incloud_ratio*S_i*(prec(1)/3.6E6)
- endif ! positive in-cloud scavenging parameters given in Species file
- endif !incloud
-
-
-20 continue
+ wetscav=incloud_ratio*S_i*(prec(1)/3.6E6)
+ endif ! positive in-cloud scavenging parameters given in Species file
+ endif !incloud
end subroutine get_wetscav
diff --git a/src/getfields.f90 b/src/redundant/getfields.f90
similarity index 91%
rename from src/getfields.f90
rename to src/redundant/getfields.f90
index 3965c3f4..f3d16edd 100644
--- a/src/getfields.f90
+++ b/src/redundant/getfields.f90
@@ -80,7 +80,6 @@ subroutine getfields(itime,nstop,metdata_format)
!**************************************************************
nstop=0
-
if ((ldirect*wftime(1).gt.ldirect*itime).or. &
(ldirect*wftime(numbwf).lt.ldirect*itime)) then
write(*,*) 'FLEXPART WARNING: NO WIND FIELDS ARE AVAILABLE.'
@@ -118,7 +117,11 @@ subroutine getfields(itime,nstop,metdata_format)
do indj=indmin,numbwf-1
if (ldirect*wftime(indj+1).gt.ldirect*itime) then
if (metdata_format.eq.GRIBFILE_CENTRE_ECMWF) then
+ call SYSTEM_CLOCK(count_clock, count_rate, count_max)
+ s_temp = (count_clock - count_clock0)/real(count_rate)
call readwind_ecmwf(indj+1,memind(2),uuh,vvh,wwh)
+ call SYSTEM_CLOCK(count_clock, count_rate, count_max)
+ s_readwind = s_readwind + ((count_clock - count_clock0)/real(count_rate)-s_temp)
else
call readwind_gfs(indj+1,memind(2),uuh,vvh,wwh)
end if
@@ -153,7 +156,11 @@ subroutine getfields(itime,nstop,metdata_format)
(ldirect*wftime(indj+1).gt.ldirect*itime)) then
memind(1)=1
if (metdata_format.eq.GRIBFILE_CENTRE_ECMWF) then
+ call SYSTEM_CLOCK(count_clock, count_rate, count_max)
+ s_temp = (count_clock - count_clock0)/real(count_rate)
call readwind_ecmwf(indj,memind(1),uuh,vvh,wwh)
+ call SYSTEM_CLOCK(count_clock, count_rate, count_max)
+ s_readwind = s_readwind + ((count_clock - count_clock0)/real(count_rate)-s_temp)
else
call readwind_gfs(indj,memind(1),uuh,vvh,wwh)
end if
@@ -169,7 +176,11 @@ subroutine getfields(itime,nstop,metdata_format)
memtime(1)=wftime(indj)
memind(2)=2
if (metdata_format.eq.GRIBFILE_CENTRE_ECMWF) then
+ call SYSTEM_CLOCK(count_clock, count_rate, count_max)
+ s_temp = (count_clock - count_clock0)/real(count_rate)
call readwind_ecmwf(indj+1,memind(2),uuh,vvh,wwh)
+ call SYSTEM_CLOCK(count_clock, count_rate, count_max)
+ s_readwind = s_readwind + ((count_clock - count_clock0)/real(count_rate)-s_temp)
else
call readwind_gfs(indj+1,memind(2),uuh,vvh,wwh)
end if
diff --git a/src/getfields_mpi.f90 b/src/redundant/getfields_mpi.f90
similarity index 100%
rename from src/getfields_mpi.f90
rename to src/redundant/getfields_mpi.f90
diff --git a/src/gethourlyOH.f90 b/src/redundant/gethourlyOH.f90
similarity index 100%
rename from src/gethourlyOH.f90
rename to src/redundant/gethourlyOH.f90
diff --git a/src/getrb.f90 b/src/redundant/getrb.f90
similarity index 100%
rename from src/getrb.f90
rename to src/redundant/getrb.f90
diff --git a/src/getrc.f90 b/src/redundant/getrc.f90
similarity index 100%
rename from src/getrc.f90
rename to src/redundant/getrc.f90
diff --git a/src/getvdep.f90 b/src/redundant/getvdep.f90
similarity index 100%
rename from src/getvdep.f90
rename to src/redundant/getvdep.f90
diff --git a/src/getvdep_nests.f90 b/src/redundant/getvdep_nests.f90
similarity index 100%
rename from src/getvdep_nests.f90
rename to src/redundant/getvdep_nests.f90
diff --git a/src/gridcheck_ecmwf.f90 b/src/redundant/gridcheck_ecmwf.f90
similarity index 99%
rename from src/gridcheck_ecmwf.f90
rename to src/redundant/gridcheck_ecmwf.f90
index 313feb76..f80721cc 100644
--- a/src/gridcheck_ecmwf.f90
+++ b/src/redundant/gridcheck_ecmwf.f90
@@ -243,7 +243,7 @@ subroutine gridcheck_ecmwf
WRITE(*,*) 'FLEXPART error: Too many grid points in x direction.'
WRITE(*,*) 'Reduce resolution of wind fields.'
WRITE(*,*) 'Or change parameter settings in file ecmwf_mod.'
- WRITE(*,*) nx,nxmax
+ WRITE(*,*) isec2(2),nxmax
! STOP
ENDIF
@@ -481,6 +481,7 @@ subroutine gridcheck_ecmwf
akm(nwz-i+1)=zsec2(j)
! write (*,*) 'ifield:',ifield,k,j,zsec2(10+j)
bkm(nwz-i+1)=zsec2(k)
+ wheight(nwz-i+1)=akm(nwz-i+1)/101325.+bkm(nwz-i+1) ! From FLEXTRA
end do
!
@@ -494,10 +495,13 @@ subroutine gridcheck_ecmwf
akz(1)=0.
bkz(1)=1.0
+ uvheight(1)=1.
do i=1,nuvz
+ uvheight(i+1)=0.5*(wheight(i+1)+wheight(i)) ! From FLEXTRA
akz(i+1)=0.5*(akm(i+1)+akm(i))
bkz(i+1)=0.5*(bkm(i+1)+bkm(i))
end do
+ ! exuvheight=wheight
nuvz=nuvz+1
! NOTE: In FLEXPART versions up to 4.0, the number of model levels was doubled
diff --git a/src/gridcheck_gfs.f90 b/src/redundant/gridcheck_gfs.f90
similarity index 100%
rename from src/gridcheck_gfs.f90
rename to src/redundant/gridcheck_gfs.f90
diff --git a/src/gridcheck_nests.f90 b/src/redundant/gridcheck_nests.f90
similarity index 100%
rename from src/gridcheck_nests.f90
rename to src/redundant/gridcheck_nests.f90
diff --git a/src/hanna.f90 b/src/redundant/hanna.f90
similarity index 100%
rename from src/hanna.f90
rename to src/redundant/hanna.f90
diff --git a/src/hanna1.f90 b/src/redundant/hanna1.f90
similarity index 100%
rename from src/hanna1.f90
rename to src/redundant/hanna1.f90
diff --git a/src/hanna_mod.f90 b/src/redundant/hanna_mod.f90
similarity index 59%
rename from src/hanna_mod.f90
rename to src/redundant/hanna_mod.f90
index 91717ec4..44e299e2 100644
--- a/src/hanna_mod.f90
+++ b/src/redundant/hanna_mod.f90
@@ -5,4 +5,7 @@ module hanna_mod
real :: ust,wst,ol,h,zeta,sigu,sigv,tlu,tlv,tlw
real :: sigw,dsigwdz,dsigw2dz
+!$OMP THREADPRIVATE(ust,wst,ol,h,zeta,sigu,sigv,tlu,tlv,tlw, &
+!$OMP sigw,dsigwdz,dsigw2dz)
+
end module hanna_mod
diff --git a/src/hanna_short.f90 b/src/redundant/hanna_short.f90
similarity index 100%
rename from src/hanna_short.f90
rename to src/redundant/hanna_short.f90
diff --git a/src/init_domainfill.f90 b/src/redundant/init_domainfill.f90
similarity index 71%
rename from src/init_domainfill.f90
rename to src/redundant/init_domainfill.f90
index 8f02c051..a7761088 100644
--- a/src/init_domainfill.f90
+++ b/src/redundant/init_domainfill.f90
@@ -31,21 +31,26 @@ subroutine init_domainfill
use par_mod
use com_mod
use random_mod
+ use interpol_mod
+ use coordinates_ecmwf
+ use particle_mod
implicit none
- integer :: j,ix,jy,kz,ncolumn,numparttot
+ integer :: j,kz,lix,ljy,ncolumn,numparttot
real :: gridarea(0:nymax-1),pp(nzmax),ylat,ylatp,ylatm,hzone
real :: cosfactm,cosfactp,deltacol,dz1,dz2,dz,pnew,fractus
real,parameter :: pih=pi/180.
real :: colmass(0:nxmax-1,0:nymax-1),colmasstotal,zposition
- integer :: ixm,ixp,jym,jyp,indzm,indzp,in,indzh,i,jj
- real :: pvpart,ddx,ddy,rddx,rddy,p1,p2,p3,p4,y1(2)
+ integer :: ixm,jym,indzm,in,indzh,i,jj,ii
+ real :: pvpart,y1(2)
integer :: idummy = -11
+ real :: frac,psint,zzlev,zzlev2,ttemp
+ logical :: deall
! Determine the release region (only full grid cells), over which particles
! shall be initialized
! Use 2 fields for west/east and south/north boundary
@@ -72,6 +77,7 @@ subroutine init_domainfill
!***********************************************
if (gdomainfill.and.ipin.ne.0) return
+
! Do not release particles twice (i.e., not at both in the leftmost and rightmost
! grid cell) for a global domain
!*****************************************************************************
@@ -82,8 +88,8 @@ subroutine init_domainfill
! see Netz, Formeln der Mathematik, 5. Auflage (1983), p.90
!************************************************************
- do jy=ny_sn(1),ny_sn(2) ! loop about latitudes
- ylat=ylat0+real(jy)*dy
+ do ljy=ny_sn(1),ny_sn(2) ! loop about latitudes
+ ylat=ylat0+real(ljy)*dy
ylatp=ylat+0.5*dy
ylatm=ylat-0.5*dy
if ((ylatm.lt.0).and.(ylatp.gt.0.)) then
@@ -99,7 +105,7 @@ subroutine init_domainfill
sqrt(r_earth**2-cosfactp**2)
endif
endif
- gridarea(jy)=2.*pi*r_earth*hzone*dx/360.
+ gridarea(ljy)=2.*pi*r_earth*hzone*dx/360.
end do
! Do the same for the south pole
@@ -133,17 +139,20 @@ subroutine init_domainfill
!*********************************************************************
colmasstotal=0.
- do jy=ny_sn(1),ny_sn(2) ! loop about latitudes
- do ix=nx_we(1),nx_we(2) ! loop about longitudes
- pp(1)=rho(ix,jy,1,1)*r_air*tt(ix,jy,1,1)
- pp(nz)=rho(ix,jy,nz,1)*r_air*tt(ix,jy,nz,1)
- colmass(ix,jy)=(pp(1)-pp(nz))/ga*gridarea(jy)
- colmasstotal=colmasstotal+colmass(ix,jy)
+ do ljy=ny_sn(1),ny_sn(2) ! loop about latitudes
+ do lix=nx_we(1),nx_we(2) ! loop about longitudes
+ pp(1)=rho(lix,ljy,1,1)*r_air*tt(lix,ljy,1,1)
+ pp(nz)=rho(lix,ljy,nz,1)*r_air*tt(lix,ljy,nz,1)
+ colmass(lix,ljy)=(pp(1)-pp(nz))/ga*gridarea(ljy)
+ colmasstotal=colmasstotal+colmass(lix,ljy)
end do
end do
write(*,*) 'Atm. mass: ',colmasstotal
+! Allocate memory for storing the particles
+!******************************************
+ call allocate_particles(npart(1))
if (ipin.eq.0) numpart=0
@@ -152,12 +161,12 @@ subroutine init_domainfill
numparttot=0
numcolumn=0
- do jy=ny_sn(1),ny_sn(2) ! loop about latitudes
- ylat=ylat0+real(jy)*dy
- do ix=nx_we(1),nx_we(2) ! loop about longitudes
- ncolumn=nint(0.999*real(npart(1))*colmass(ix,jy)/ &
+ do ljy=ny_sn(1),ny_sn(2) ! loop about latitudes
+ ylat=ylat0+real(ljy)*dy
+ do lix=nx_we(1),nx_we(2) ! loop about longitudes
+ ncolumn=nint(0.999*real(npart(1))*colmass(lix,ljy)/ &
colmasstotal)
- if (ncolumn.eq.0) goto 30
+ if (ncolumn.eq.0) cycle
if (ncolumn.gt.numcolumn) numcolumn=ncolumn
! Calculate pressure at the altitudes of model surfaces, using the air density
@@ -165,7 +174,7 @@ subroutine init_domainfill
!*****************************************************************************
do kz=1,nz
- pp(kz)=rho(ix,jy,kz,1)*r_air*tt(ix,jy,kz,1)
+ pp(kz)=rho(lix,ljy,kz,1)*r_air*tt(lix,ljy,kz,1)
end do
@@ -199,40 +208,46 @@ subroutine init_domainfill
! Do the following steps only if particles are not read in from previous model run
!*****************************************************************************
if (ipin.eq.0) then
- xtra1(numpart+jj)=real(ix)-0.5+ran1(idummy)
- if (ix.eq.0) xtra1(numpart+jj)=ran1(idummy)
- if (ix.eq.nxmin1) xtra1(numpart+jj)= &
- real(nxmin1)-ran1(idummy)
- ytra1(numpart+jj)=real(jy)-0.5+ran1(idummy)
- ztra1(numpart+jj)=(height(kz)*dz2+height(kz+1)*dz1)*dz
- if (ztra1(numpart+jj).gt.height(nz)-0.5) &
- ztra1(numpart+jj)=height(nz)-0.5
-
-
+ ! First spawn the particle into existence
+ !****************************************
+ call spawn_particle(0,numpart+jj)
+ call set_xlon(numpart+jj,real(real(lix)-0.5+ran1(idummy),kind=dp))
+ if (lix.eq.0) call set_xlon(numpart+jj,real(ran1(idummy),kind=dp))
+ if (lix.eq.nxmin1) &
+ call set_xlon(numpart+jj,real(real(nxmin1)-ran1(idummy),kind=dp))
+ call set_ylat(numpart+jj,real(real(ljy)-0.5+ran1(idummy),kind=dp))
+ call set_z(numpart+jj,(height(kz)*dz2+height(kz+1)*dz1)*dz)
+ if (real(part(numpart+jj)%z).gt.height(nz)-0.5) &
+ call set_z(numpart+jj,height(nz)-0.5)
+
+ call update_z_to_zeta(0, numpart+jj)
+
! Interpolate PV to the particle position
!****************************************
- ixm=int(xtra1(numpart+jj))
- jym=int(ytra1(numpart+jj))
+ ixm=int(part(numpart+jj)%xlon)
+ jym=int(part(numpart+jj)%ylat)
ixp=ixm+1
jyp=jym+1
- ddx=xtra1(numpart+jj)-real(ixm)
- ddy=ytra1(numpart+jj)-real(jym)
+ ddx=part(numpart+jj)%xlon-real(ixm)
+ ddy=part(numpart+jj)%ylat-real(jym)
rddx=1.-ddx
rddy=1.-ddy
p1=rddx*rddy
p2=ddx*rddy
p3=rddx*ddy
p4=ddx*ddy
+
+!***************************************************************************
+
do i=2,nz
- if (height(i).gt.ztra1(numpart+jj)) then
+ if (real(height(i),kind=dp).gt.part(numpart+jj)%z) then
indzm=i-1
indzp=i
- goto 6
+ exit
endif
end do
-6 continue
- dz1=ztra1(numpart+jj)-height(indzm)
- dz2=height(indzp)-ztra1(numpart+jj)
+ dz1=real(part(numpart+jj)%z)-height(indzm)
+ dz2=height(indzp)-real(part(numpart+jj)%z)
dz=1./(dz1+dz2)
do in=1,2
indzh=indzm+in-1
@@ -248,23 +263,19 @@ subroutine init_domainfill
! For domain-filling option 2 (stratospheric O3), do the rest only in the stratosphere
!*****************************************************************************
- if (((ztra1(numpart+jj).gt.3000.).and. &
+ if (((part(numpart+jj)%z.gt.3000.).and. &
(pvpart.gt.pvcrit)).or.(mdomainfill.eq.1)) then
! Assign certain properties to the particle
!******************************************
- nclass(numpart+jj)=min(int(ran1(idummy)* &
+ part(numpart+jj)%nclass=min(int(ran1(idummy)* &
real(nclassunc))+1,nclassunc)
numparticlecount=numparticlecount+1
- npoint(numpart+jj)=numparticlecount
- idt(numpart+jj)=mintime
- itra1(numpart+jj)=0
- itramem(numpart+jj)=0
- itrasplit(numpart+jj)=itra1(numpart+jj)+ldirect* &
- itsplit
- xmass1(numpart+jj,1)=colmass(ix,jy)/real(ncolumn)
- if (mdomainfill.eq.2) xmass1(numpart+jj,1)= &
- xmass1(numpart+jj,1)*pvpart*48./29.*ozonescale/10.**9
+ part(numpart+jj)%npoint=numparticlecount
+ part(numpart+jj)%idt=mintime
+ part(numpart+jj)%mass(1)=colmass(lix,ljy)/real(ncolumn)
+ if (mdomainfill.eq.2) part(numpart+jj)%mass(1)= &
+ part(numpart+jj)%mass(1)*pvpart*48./29.*ozonescale/10.**9
else
jj=jj-1
endif
@@ -274,7 +285,6 @@ subroutine init_domainfill
end do
numparttot=numparttot+ncolumn
if (ipin.eq.0) numpart=numpart+jj
-30 continue
end do
end do
@@ -282,11 +292,11 @@ subroutine init_domainfill
! Check whether numpart is really smaller than maxpart
!*****************************************************
-! ESO :TODO: this warning need to be moved further up, else out-of-bounds error earlier
- if (numpart.gt.maxpart) then
- write(*,*) 'numpart too large: change source in init_atm_mass.f'
- write(*,*) 'numpart: ',numpart,' maxpart: ',maxpart
- endif
+! ! ESO :TODO: this warning need to be moved further up, else out-of-bounds error earlier
+! if (numpart.gt.maxpart) then
+! write(*,*) 'numpart too large: change source in init_atm_mass.f'
+! write(*,*) 'numpart: ',numpart,' maxpart: ',maxpart
+! endif
xmassperparticle=colmasstotal/real(numparttot)
@@ -296,9 +306,9 @@ subroutine init_domainfill
!***********************************************
do j=1,numpart
- if ((xtra1(j).lt.0.).or.(xtra1(j).ge.real(nxmin1)).or. &
- (ytra1(j).lt.0.).or.(ytra1(j).ge.real(nymin1))) then
- itra1(j)=-999999999
+ if ((part(j)%xlon.lt.0.).or.(part(j)%xlon.ge.real(nxmin1,kind=dp)).or. &
+ (part(j)%ylat.lt.0.).or.(part(j)%ylat.ge.real(nymin1,kind=dp))) then
+ call terminate_particle(j)
endif
end do
@@ -321,12 +331,12 @@ subroutine init_domainfill
write(*,*) 'If ',fractus,' <1, better use more particles'
fractus=sqrt(max(fractus,1.))/2.
- do jy=ny_sn(1),ny_sn(2) ! loop about latitudes
- do ix=nx_we(1),nx_we(2) ! loop about longitudes
- ncolumn=nint(0.999/fractus*real(npart(1))*colmass(ix,jy) &
+ do ljy=ny_sn(1),ny_sn(2) ! loop about latitudes
+ do lix=nx_we(1),nx_we(2) ! loop about longitudes
+ ncolumn=nint(0.999/fractus*real(npart(1))*colmass(lix,ljy) &
/colmasstotal)
if (ncolumn.gt.maxcolumn) stop 'maxcolumn too small'
- if (ncolumn.eq.0) goto 80
+ if (ncolumn.eq.0) cycle
! Memorize how many particles per column shall be used for all boundaries
@@ -334,17 +344,17 @@ subroutine init_domainfill
! Use 2 fields for west/east and south/north boundary
!************************************************************************
- if (ix.eq.nx_we(1)) numcolumn_we(1,jy)=ncolumn
- if (ix.eq.nx_we(2)) numcolumn_we(2,jy)=ncolumn
- if (jy.eq.ny_sn(1)) numcolumn_sn(1,ix)=ncolumn
- if (jy.eq.ny_sn(2)) numcolumn_sn(2,ix)=ncolumn
+ if (lix.eq.nx_we(1)) numcolumn_we(1,ljy)=ncolumn
+ if (lix.eq.nx_we(2)) numcolumn_we(2,ljy)=ncolumn
+ if (ljy.eq.ny_sn(1)) numcolumn_sn(1,lix)=ncolumn
+ if (ljy.eq.ny_sn(2)) numcolumn_sn(2,lix)=ncolumn
! Calculate pressure at the altitudes of model surfaces, using the air density
! information, which is stored as a 3-d field
!*****************************************************************************
do kz=1,nz
- pp(kz)=rho(ix,jy,kz,1)*r_air*tt(ix,jy,kz,1)
+ pp(kz)=rho(lix,ljy,kz,1)*r_air*tt(lix,ljy,kz,1)
end do
! Determine the reference starting altitudes
@@ -366,33 +376,39 @@ subroutine init_domainfill
! This is further used in subroutine boundcond_domainfill.f
!***********************************************************
- if (ix.eq.nx_we(1)) zcolumn_we(1,jy,j)=zposition
- if (ix.eq.nx_we(2)) zcolumn_we(2,jy,j)=zposition
- if (jy.eq.ny_sn(1)) zcolumn_sn(1,ix,j)=zposition
- if (jy.eq.ny_sn(2)) zcolumn_sn(2,ix,j)=zposition
+ if (lix.eq.nx_we(1)) zcolumn_we(1,ljy,j)=zposition
+ if (lix.eq.nx_we(2)) zcolumn_we(2,ljy,j)=zposition
+ if (ljy.eq.ny_sn(1)) zcolumn_sn(1,lix,j)=zposition
+ if (ljy.eq.ny_sn(2)) zcolumn_sn(2,lix,j)=zposition
! Initialize mass that has accumulated at boundary to zero
!*********************************************************
- acc_mass_we(1,jy,j)=0.
- acc_mass_we(2,jy,j)=0.
- acc_mass_sn(1,jy,j)=0.
- acc_mass_sn(2,jy,j)=0.
+ acc_mass_we(1,ljy,j)=0.
+ acc_mass_we(2,ljy,j)=0.
+ acc_mass_sn(1,ljy,j)=0.
+ acc_mass_sn(2,ljy,j)=0.
endif
end do
end do
-80 continue
end do
end do
-! Reduce numpart if invalid particles at end of arrays
+! If there were more particles allocated than used,
+! Deallocate unused memory and update numpart
+!**************************************************
+ deall=.false.
do i=numpart, 1, -1
- if (itra1(i).eq.-999999999) then
- numpart=numpart-1
- else
- exit
- end if
- end do
+ if (.not. part(i)%alive) then
+ deall=.true.
+ numpart = numpart - 1
+ else
+ exit
+ endif
+ end do
+
+ if (deall) call deallocate_particle(numpart) !Deallocates everything above numpart (F2008)
+
! If particles shall be read in to continue an existing run,
! then the accumulated masses at the domain boundaries must be read in, too.
diff --git a/src/init_domainfill_mpi.f90 b/src/redundant/init_domainfill_mpi.f90
similarity index 100%
rename from src/init_domainfill_mpi.f90
rename to src/redundant/init_domainfill_mpi.f90
diff --git a/src/initial_cond_calc.f90 b/src/redundant/initial_cond_calc.f90
similarity index 76%
rename from src/initial_cond_calc.f90
rename to src/redundant/initial_cond_calc.f90
index c1aec603..8945ffc4 100644
--- a/src/initial_cond_calc.f90
+++ b/src/redundant/initial_cond_calc.f90
@@ -17,10 +17,13 @@ subroutine initial_cond_calc(itime,i)
use outg_mod
use par_mod
use com_mod
+ use interpol_mod, only: interpol_density,ix,jy,ixp,jyp
+ use coordinates_ecmwf
+ use particle_mod
implicit none
- integer :: itime,i,ix,jy,ixp,jyp,kz,ks
+ integer :: itime,i,kz,ks
integer :: il,ind,indz,indzp,nrelpointer
real :: rddx,rddy,p1,p2,p3,p4,dz1,dz2,dz
real :: ddx,ddy
@@ -34,7 +37,7 @@ subroutine initial_cond_calc(itime,i)
!**************************************************************************
- if (itra1(i).ne.itime) return
+ if (.not. part(i)%alive) return
! Depending on output option, calculate air density or set it to 1
! linit_cond: 1=mass unit, 2=mass mixing ratio unit
@@ -42,49 +45,12 @@ subroutine initial_cond_calc(itime,i)
if (linit_cond.eq.1) then ! mass unit
-
- ix=int(xtra1(i))
- jy=int(ytra1(i))
- ixp=ix+1
- jyp=jy+1
- ddx=xtra1(i)-real(ix)
- ddy=ytra1(i)-real(jy)
- rddx=1.-ddx
- rddy=1.-ddy
- p1=rddx*rddy
- p2=ddx*rddy
- p3=rddx*ddy
- p4=ddx*ddy
-
- do il=2,nz
- if (height(il).gt.ztra1(i)) then
- indz=il-1
- indzp=il
- goto 6
- endif
- end do
-6 continue
-
- dz1=ztra1(i)-height(indz)
- dz2=height(indzp)-ztra1(i)
- dz=1./(dz1+dz2)
-
- ! Take density from 2nd wind field in memory (accurate enough, no time interpolation needed)
- !*****************************************************************************
- mind2=memind(2)
-
- do ind=indz,indzp
- rhoprof(ind-indz+1)=p1*rho(ix ,jy ,ind,mind2) &
- +p2*rho(ixp,jy ,ind,mind2) &
- +p3*rho(ix ,jyp,ind,mind2) &
- +p4*rho(ixp,jyp,ind,mind2)
- end do
- rhoi=(dz1*rhoprof(2)+dz2*rhoprof(1))*dz
+ call update_zeta_to_z(itime,i)
+ call interpol_density(itime,i,rhoi)
elseif (linit_cond.eq.2) then ! mass mixing ratio unit
rhoi=1.
endif
-
!****************************************************************************
! 1. Evaluate grid concentrations using a uniform kernel of bandwidths dx, dy
!****************************************************************************
@@ -99,18 +65,18 @@ subroutine initial_cond_calc(itime,i)
if ((ioutputforeachrelease.eq.0).or.(mdomainfill.eq.1)) then
nrelpointer=1
else
- nrelpointer=npoint(i)
+ nrelpointer=part(i)%npoint
endif
do kz=1,numzgrid ! determine height of cell
- if (outheight(kz).gt.ztra1(i)) goto 21
+ if (real(outheight(kz),kind=dp).gt.part(i)%z) exit
end do
-21 continue
+
if (kz.le.numzgrid) then ! inside output domain
- xl=(xtra1(i)*dx+xoutshift)/dxout
- yl=(ytra1(i)*dy+youtshift)/dyout
+ xl=(part(i)%xlon*dx+xoutshift)/dxout
+ yl=(part(i)%ylat*dy+youtshift)/dyout
ix=int(xl)
if (xl.lt.0.) ix=ix-1
jy=int(yl)
@@ -128,7 +94,7 @@ subroutine initial_cond_calc(itime,i)
do ks=1,nspec
init_cond(ix,jy,kz,ks,nrelpointer)= &
init_cond(ix,jy,kz,ks,nrelpointer)+ &
- xmass1(i,ks)/rhoi
+ part(i)%mass(ks)/rhoi
end do
endif
@@ -161,7 +127,7 @@ subroutine initial_cond_calc(itime,i)
w=wx*wy
do ks=1,nspec
init_cond(ix,jy,kz,ks,nrelpointer)= &
- init_cond(ix,jy,kz,ks,nrelpointer)+xmass1(i,ks)/rhoi*w
+ init_cond(ix,jy,kz,ks,nrelpointer)+part(i)%mass(ks)/rhoi*w
end do
endif
@@ -169,7 +135,7 @@ subroutine initial_cond_calc(itime,i)
w=wx*(1.-wy)
do ks=1,nspec
init_cond(ix,jyp,kz,ks,nrelpointer)= &
- init_cond(ix,jyp,kz,ks,nrelpointer)+xmass1(i,ks)/rhoi*w
+ init_cond(ix,jyp,kz,ks,nrelpointer)+part(i)%mass(ks)/rhoi*w
end do
endif
endif
@@ -180,7 +146,7 @@ subroutine initial_cond_calc(itime,i)
w=(1.-wx)*(1.-wy)
do ks=1,nspec
init_cond(ixp,jyp,kz,ks,nrelpointer)= &
- init_cond(ixp,jyp,kz,ks,nrelpointer)+xmass1(i,ks)/rhoi*w
+ init_cond(ixp,jyp,kz,ks,nrelpointer)+part(i)%mass(ks)/rhoi*w
end do
endif
@@ -188,7 +154,7 @@ subroutine initial_cond_calc(itime,i)
w=(1.-wx)*wy
do ks=1,nspec
init_cond(ixp,jy,kz,ks,nrelpointer)= &
- init_cond(ixp,jy,kz,ks,nrelpointer)+xmass1(i,ks)/rhoi*w
+ init_cond(ixp,jy,kz,ks,nrelpointer)+part(i)%mass(ks)/rhoi*w
end do
endif
endif
diff --git a/src/initial_cond_output.f90 b/src/redundant/initial_cond_output.f90
similarity index 100%
rename from src/initial_cond_output.f90
rename to src/redundant/initial_cond_output.f90
diff --git a/src/initial_cond_output_inversion.f90 b/src/redundant/initial_cond_output_inversion.f90
similarity index 100%
rename from src/initial_cond_output_inversion.f90
rename to src/redundant/initial_cond_output_inversion.f90
diff --git a/src/initialize_cbl_vel.f90 b/src/redundant/initialize_cbl_vel.f90
similarity index 98%
rename from src/initialize_cbl_vel.f90
rename to src/redundant/initialize_cbl_vel.f90
index 93c2881a..6b206564 100644
--- a/src/initialize_cbl_vel.f90
+++ b/src/redundant/initialize_cbl_vel.f90
@@ -22,7 +22,7 @@ subroutine initialize_cbl_vel(idum,zp,ust,wst,h,sigmaw,wp, ol)
real :: usurad2,usurad2p,C0,costluar4,eps
parameter (usurad2=0.7071067812,usurad2p=0.3989422804,C0=2,costluar4=0.66667,eps=0.000001)
- integer idum
+
real :: wp,zp,ust,wst,h,dens,ddens,sigmaw,dsigmawdz,tlw,dcas,dcas1!,ran3,gasdev
real :: w3,w2
real :: z, &
@@ -41,7 +41,9 @@ subroutine initialize_cbl_vel(idum,zp,ust,wst,h,sigmaw,wp, ol)
wb,wa
real timedir
real ol, transition
-
+ integer :: idum
+ integer :: thread
+
!---------------------------------------------------------------------------
timedir=ldirect !direction of time forward (1) or backward(-1)
z=zp/h
diff --git a/src/initialize.f90 b/src/redundant/initialize_particle.f90
similarity index 73%
rename from src/initialize.f90
rename to src/redundant/initialize_particle.f90
index 17d6d190..6154d803 100644
--- a/src/initialize.f90
+++ b/src/redundant/initialize_particle.f90
@@ -1,8 +1,7 @@
! SPDX-FileCopyrightText: FLEXPART 1998-2019, see flexpart_license.txt
! SPDX-License-Identifier: GPL-3.0-or-later
-subroutine initialize(itime,ldt,up,vp,wp, &
- usigold,vsigold,wsigold,xt,yt,zt,icbt)
+subroutine initialize_particle(itime,ipart)
! i i o o o
! o o o i i i o
!*****************************************************************************
@@ -32,9 +31,7 @@ subroutine initialize(itime,ldt,up,vp,wp, &
! ldt [s] Suggested time step for next integration *
! ladvance [s] Total integration time period *
! rannumb(maxrand) normally distributed random variables *
- ! up,vp,wp random velocities due to turbulence *
! usig,vsig,wsig uncertainties of wind velocities due to interpolation *
- ! usigold,vsigold,wsigold like usig, etc., but for the last time step *
! xt,yt,zt Next time step's spatial position of trajectory *
! *
! *
@@ -48,25 +45,45 @@ subroutine initialize(itime,ldt,up,vp,wp, &
use par_mod
use com_mod
+ use windfields_mod
use interpol_mod
- use hanna_mod
+ use turbulence_mod
use random_mod, only: ran3
+ use interpol_mod
+ use coordinates_ecmwf
+ use particle_mod
+
+ use omp_lib
implicit none
- integer :: itime
- integer :: ldt,nrand
- integer(kind=2) :: icbt
- real :: zt,dz,dz1,dz2,up,vp,wp,usigold,vsigold,wsigold
- real(kind=dp) :: xt,yt
+ integer,intent(in) :: &
+ itime, &
+ ipart
+ integer :: i,j,k,m,indexh
+ integer :: nrand
+ real :: dz,dz1,dz2,wp
+ real :: ttemp,dummy1,dummy2
+ real :: xt,yt,zt,zteta
+ integer :: thread
save idummy
integer :: idummy = -7
- icbt=1 ! initialize particle to "no reflection"
+!$OMP THREADPRIVATE(idummy)
+!$ if (idummy.eq.-7) then
+!$ thread = OMP_GET_THREAD_NUM()
+!$ idummy = idummy - thread
+!$ endif
+
+ part(ipart)%icbt=1 ! initialize particle to no "reflection"
nrand=int(ran3(idummy)*real(maxrand-1))+1
+ xt = real(part(ipart)%xlon)
+ yt = real(part(ipart)%ylat)
+ zt = real(part(ipart)%z)
+ zteta = real(part(ipart)%zeta)
!******************************
! 2. Interpolate necessary data
@@ -74,12 +91,8 @@ subroutine initialize(itime,ldt,up,vp,wp, &
! Compute maximum mixing height around particle position
!*******************************************************
-
- ix=int(xt)
- jy=int(yt)
- ixp=ix+1
- jyp=jy+1
-
+ call determine_grid_coordinates(xt,yt)
+
h=max(hmix(ix ,jy,1,memind(1)), &
hmix(ixp,jy ,1,memind(1)), &
hmix(ix ,jyp,1,memind(1)), &
@@ -99,8 +112,7 @@ subroutine initialize(itime,ldt,up,vp,wp, &
if (zeta.le.1.) then
- call interpol_all(itime,real(xt),real(yt),zt)
-
+ call interpol_all(itime,xt,yt,zt,zteta)
! Vertical interpolation of u,v,w,rho and drhodz
!***********************************************
@@ -108,15 +120,7 @@ subroutine initialize(itime,ldt,up,vp,wp, &
! Vertical distance to the level below and above current position
! both in terms of (u,v) and (w) fields
!****************************************************************
-
- dz1=zt-height(indz)
- dz2=height(indzp)-zt
- dz=1./(dz1+dz2)
-
- u=(dz1*uprof(indzp)+dz2*uprof(indz))*dz
- v=(dz1*vprof(indzp)+dz2*vprof(indz))*dz
- w=(dz1*wprof(indzp)+dz2*wprof(indz))*dz
-
+ call interpol_mixinglayer(zt,zteta,dummy1,dummy2)
! Compute the turbulent disturbances
@@ -134,18 +138,18 @@ subroutine initialize(itime,ldt,up,vp,wp, &
!*****************************************
if (nrand+2.gt.maxrand) nrand=1
- up=rannumb(nrand)*sigu
- vp=rannumb(nrand+1)*sigv
- wp=rannumb(nrand+2)
+ part(ipart)%turbvel%u=rannumb(nrand)*sigu
+ part(ipart)%turbvel%v=rannumb(nrand+1)*sigv
+ part(ipart)%turbvel%w=rannumb(nrand+2)
if (.not.turbswitch) then ! modified by mc
- wp=wp*sigw
+ part(ipart)%turbvel%w=part(ipart)%turbvel%w*sigw
else if (cblflag.eq.1) then ! modified by mc
if(-h/ol.gt.5) then
-!if (ol.lt.0.) then
-!if (ol.gt.0.) then !by mc : only for test correct is lt.0
- call initialize_cbl_vel(idummy,zt,ust,wst,h,sigw,wp,ol)
+ !if (ol.lt.0.) then
+ !if (ol.gt.0.) then !by mc : only for test correct is lt.0
+ call initialize_cbl_vel(idummy,zt,ust,wst,h,sigw,part(ipart)%turbvel%w,ol)
else
- wp=wp*sigw
+ part(ipart)%turbvel%w=part(ipart)%turbvel%w*sigw
end if
end if
@@ -154,17 +158,19 @@ subroutine initialize(itime,ldt,up,vp,wp, &
!*****************************************
if (turbswitch) then
- ldt=int(min(tlw,h/max(2.*abs(wp*sigw),1.e-5), &
+ part(ipart)%idt=int(min(tlw,h/max(2.*abs(part(ipart)%turbvel%w*sigw),1.e-5), &
0.5/abs(dsigwdz),600.)*ctl)
else
- ldt=int(min(tlw,h/max(2.*abs(wp),1.e-5),600.)*ctl)
+ part(ipart)%idt=int(min(tlw,h/max(2.*abs(part(ipart)%turbvel%w),1.e-5),600.)*ctl)
endif
- ldt=max(ldt,mintime)
+ part(ipart)%idt=max(part(ipart)%idt,mintime)
+ call interpol_average()
+ ! usig=(usigprof(indzp)+usigprof(indz))/2.
+ ! vsig=(vsigprof(indzp)+vsigprof(indz))/2.
+ ! wsig=(wsigprof(indzp)+wsigprof(indz))/2.
- usig=(usigprof(indzp)+usigprof(indz))/2.
- vsig=(vsigprof(indzp)+vsigprof(indz))/2.
- wsig=(wsigprof(indzp)+wsigprof(indz))/2.
+ ! wsigeta=(wsigprofeta(indzpeta)+wsigprofeta(indzeta))/2.
else
@@ -180,7 +186,7 @@ subroutine initialize(itime,ldt,up,vp,wp, &
! Interpolate the wind
!*********************
- call interpol_wind(itime,real(xt),real(yt),zt)
+ call interpol_wind(itime,xt,yt,zt,zteta,10)
! Compute everything for above the PBL
@@ -188,13 +194,13 @@ subroutine initialize(itime,ldt,up,vp,wp, &
! Assume constant turbulent perturbations
!****************************************
- ldt=abs(lsynctime)
+ part(ipart)%idt=abs(lsynctime)
if (nrand+1.gt.maxrand) nrand=1
- up=rannumb(nrand)*0.3
- vp=rannumb(nrand+1)*0.3
+ part(ipart)%turbvel%u=rannumb(nrand)*0.3
+ part(ipart)%turbvel%v=rannumb(nrand+1)*0.3
nrand=nrand+2
- wp=0.
+ part(ipart)%turbvel%w=0.
sigw=0.
endif
@@ -212,8 +218,15 @@ subroutine initialize(itime,ldt,up,vp,wp, &
!****************************************************************
if (nrand+2.gt.maxrand) nrand=1
- usigold=rannumb(nrand)*usig
- vsigold=rannumb(nrand+1)*vsig
- wsigold=rannumb(nrand+2)*wsig
-
-end subroutine initialize
+ part(ipart)%mesovel%u=rannumb(nrand)*usig
+ part(ipart)%mesovel%v=rannumb(nrand+1)*vsig
+ select case (wind_coord_type)
+ case ('ETA')
+ part(ipart)%mesovel%w=rannumb(nrand+2)*wsigeta
+ case ('METER')
+ part(ipart)%mesovel%w=rannumb(nrand+2)*wsig
+ case default
+ part(ipart)%mesovel%w=rannumb(nrand+2)*wsig
+ end select
+
+end subroutine initialize_particle
diff --git a/src/interpol_all.f90 b/src/redundant/interpol_all.f90
similarity index 58%
rename from src/interpol_all.f90
rename to src/redundant/interpol_all.f90
index 1a701e9b..2d5fd994 100644
--- a/src/interpol_all.f90
+++ b/src/redundant/interpol_all.f90
@@ -1,7 +1,7 @@
! SPDX-FileCopyrightText: FLEXPART 1998-2019, see flexpart_license.txt
! SPDX-License-Identifier: GPL-3.0-or-later
-subroutine interpol_all(itime,xt,yt,zt)
+subroutine interpol_all(itime,xt,yt,zt,zteta)
! i i i i
!*****************************************************************************
! *
@@ -38,11 +38,12 @@ subroutine interpol_all(itime,xt,yt,zt)
integer :: itime
real :: xt,yt,zt
+ real:: zteta
! Auxiliary variables needed for interpolation
real :: ust1(2),wst1(2),oli1(2),oliaux
- real :: y1(2),y2(2),y3(2),rho1(2),rhograd1(2)
- real :: usl,vsl,wsl,usq,vsq,wsq,xaux
+ real :: y1(2),y2(2),y3(2),rho1(2),rhograd1(2),psint(2)
+ real :: usl,vsl,wsl,usq,vsq,wsq,xaux,deta1(2),detatemp
integer :: i,m,n,indexh
real,parameter :: eps=1.0e-30
@@ -119,10 +120,9 @@ subroutine interpol_all(itime,xt,yt,zt)
if (height(i).gt.zt) then
indz=i-1
indzp=i
- goto 6
+ exit
endif
end do
-6 continue
!**************************************
! 1.) Bilinear horizontal interpolation
@@ -133,71 +133,15 @@ subroutine interpol_all(itime,xt,yt,zt)
!***************************************
do n=indz,indzp
- usl=0.
- vsl=0.
wsl=0.
- usq=0.
- vsq=0.
wsq=0.
do m=1,2
indexh=memind(m)
- if (ngrid.lt.0) then
- y1(m)=p1*uupol(ix ,jy ,n,indexh) &
- +p2*uupol(ixp,jy ,n,indexh) &
- +p3*uupol(ix ,jyp,n,indexh) &
- +p4*uupol(ixp,jyp,n,indexh)
- y2(m)=p1*vvpol(ix ,jy ,n,indexh) &
- +p2*vvpol(ixp,jy ,n,indexh) &
- +p3*vvpol(ix ,jyp,n,indexh) &
- +p4*vvpol(ixp,jyp,n,indexh)
- usl=usl+uupol(ix ,jy ,n,indexh)+uupol(ixp,jy ,n,indexh) &
- +uupol(ix ,jyp,n,indexh)+uupol(ixp,jyp,n,indexh)
- vsl=vsl+vvpol(ix ,jy ,n,indexh)+vvpol(ixp,jy ,n,indexh) &
- +vvpol(ix ,jyp,n,indexh)+vvpol(ixp,jyp,n,indexh)
-
- usq=usq+uupol(ix ,jy ,n,indexh)*uupol(ix ,jy ,n,indexh)+ &
- uupol(ixp,jy ,n,indexh)*uupol(ixp,jy ,n,indexh)+ &
- uupol(ix ,jyp,n,indexh)*uupol(ix ,jyp,n,indexh)+ &
- uupol(ixp,jyp,n,indexh)*uupol(ixp,jyp,n,indexh)
- vsq=vsq+vvpol(ix ,jy ,n,indexh)*vvpol(ix ,jy ,n,indexh)+ &
- vvpol(ixp,jy ,n,indexh)*vvpol(ixp,jy ,n,indexh)+ &
- vvpol(ix ,jyp,n,indexh)*vvpol(ix ,jyp,n,indexh)+ &
- vvpol(ixp,jyp,n,indexh)*vvpol(ixp,jyp,n,indexh)
- else
- y1(m)=p1*uu(ix ,jy ,n,indexh) &
- +p2*uu(ixp,jy ,n,indexh) &
- +p3*uu(ix ,jyp,n,indexh) &
- +p4*uu(ixp,jyp,n,indexh)
- y2(m)=p1*vv(ix ,jy ,n,indexh) &
- +p2*vv(ixp,jy ,n,indexh) &
- +p3*vv(ix ,jyp,n,indexh) &
- +p4*vv(ixp,jyp,n,indexh)
- usl=usl+uu(ix ,jy ,n,indexh)+uu(ixp,jy ,n,indexh) &
- +uu(ix ,jyp,n,indexh)+uu(ixp,jyp,n,indexh)
- vsl=vsl+vv(ix ,jy ,n,indexh)+vv(ixp,jy ,n,indexh) &
- +vv(ix ,jyp,n,indexh)+vv(ixp,jyp,n,indexh)
-
- usq=usq+uu(ix ,jy ,n,indexh)*uu(ix ,jy ,n,indexh)+ &
- uu(ixp,jy ,n,indexh)*uu(ixp,jy ,n,indexh)+ &
- uu(ix ,jyp,n,indexh)*uu(ix ,jyp,n,indexh)+ &
- uu(ixp,jyp,n,indexh)*uu(ixp,jyp,n,indexh)
- vsq=vsq+vv(ix ,jy ,n,indexh)*vv(ix ,jy ,n,indexh)+ &
- vv(ixp,jy ,n,indexh)*vv(ixp,jy ,n,indexh)+ &
- vv(ix ,jyp,n,indexh)*vv(ix ,jyp,n,indexh)+ &
- vv(ixp,jyp,n,indexh)*vv(ixp,jyp,n,indexh)
- endif
+
y3(m)=p1*ww(ix ,jy ,n,indexh) &
+p2*ww(ixp,jy ,n,indexh) &
+p3*ww(ix ,jyp,n,indexh) &
+p4*ww(ixp,jyp,n,indexh)
- rhograd1(m)=p1*drhodz(ix ,jy ,n,indexh) &
- +p2*drhodz(ixp,jy ,n,indexh) &
- +p3*drhodz(ix ,jyp,n,indexh) &
- +p4*drhodz(ixp,jyp,n,indexh)
- rho1(m)=p1*rho(ix ,jy ,n,indexh) &
- +p2*rho(ixp,jy ,n,indexh) &
- +p3*rho(ix ,jyp,n,indexh) &
- +p4*rho(ixp,jyp,n,indexh)
wsl=wsl+ww(ix ,jy ,n,indexh)+ww(ixp,jy ,n,indexh) &
+ww(ix ,jyp,n,indexh)+ww(ixp,jyp,n,indexh)
wsq=wsq+ww(ix ,jy ,n,indexh)*ww(ix ,jy ,n,indexh)+ &
@@ -205,16 +149,118 @@ subroutine interpol_all(itime,xt,yt,zt)
ww(ix ,jyp,n,indexh)*ww(ix ,jyp,n,indexh)+ &
ww(ixp,jyp,n,indexh)*ww(ixp,jyp,n,indexh)
end do
- uprof(n)=(y1(1)*dt2+y1(2)*dt1)*dtt
- vprof(n)=(y2(1)*dt2+y2(2)*dt1)*dtt
wprof(n)=(y3(1)*dt2+y3(2)*dt1)*dtt
- rhoprof(n)=(rho1(1)*dt2+rho1(2)*dt1)*dtt
- rhogradprof(n)=(rhograd1(1)*dt2+rhograd1(2)*dt1)*dtt
indzindicator(n)=.false.
! Compute standard deviations
!****************************
+ xaux=wsq-wsl*wsl/8.
+ if (xaux.lt.eps) then
+ wsigprof(n)=0.
+ else
+ wsigprof(n)=sqrt(xaux/7.)
+ endif
+
+ end do
+
+
+ ! Same for zt in eta coordinates
+ !*******************************
+ indzeta=nz-1
+ indzpeta=nz
+ do i=2,nz
+ if (wheight(i).lt.zteta) then
+ indzeta=i-1
+ indzpeta=i
+ exit
+ endif
+ end do
+
+ induv=nz-1
+ indpuv=nz
+ do i=2,nz
+ if (uvheight(i).lt.zteta) then
+ induv=i-1
+ indpuv=i
+ exit
+ endif
+ end do
+
+ !**************************************
+ ! 1.) Bilinear horizontal interpolation
+ ! 2.) Temporal interpolation (linear)
+ !**************************************
+
+ ! Loop over 2 time steps and indz levels
+ !***************************************
+
+ do n=induv,indpuv
+ usl=0.
+ vsl=0.
+ usq=0.
+ vsq=0.
+ do m=1,2
+ indexh=memind(m)
+ if (ngrid.lt.0) then
+ y1(m)=p1*uupoleta(ix ,jy ,n,indexh) &
+ +p2*uupoleta(ixp,jy ,n,indexh) &
+ +p3*uupoleta(ix ,jyp,n,indexh) &
+ +p4*uupoleta(ixp,jyp,n,indexh)
+ y2(m)=p1*vvpoleta(ix ,jy ,n,indexh) &
+ +p2*vvpoleta(ixp,jy ,n,indexh) &
+ +p3*vvpoleta(ix ,jyp,n,indexh) &
+ +p4*vvpoleta(ixp,jyp,n,indexh)
+ usl=usl+uupoleta(ix ,jy ,n,indexh)+uupoleta(ixp,jy ,n,indexh) &
+ +uupoleta(ix ,jyp,n,indexh)+uupoleta(ixp,jyp,n,indexh)
+ vsl=vsl+vvpoleta(ix ,jy ,n,indexh)+vvpoleta(ixp,jy ,n,indexh) &
+ +vvpoleta(ix ,jyp,n,indexh)+vvpoleta(ixp,jyp,n,indexh)
+
+ usq=usq+uupoleta(ix ,jy ,n,indexh)*uupoleta(ix ,jy ,n,indexh)+ &
+ uupoleta(ixp,jy ,n,indexh)*uupoleta(ixp,jy ,n,indexh)+ &
+ uupoleta(ix ,jyp,n,indexh)*uupoleta(ix ,jyp,n,indexh)+ &
+ uupoleta(ixp,jyp,n,indexh)*uupoleta(ixp,jyp,n,indexh)
+ vsq=vsq+vvpoleta(ix ,jy ,n,indexh)*vvpoleta(ix ,jy ,n,indexh)+ &
+ vvpoleta(ixp,jy ,n,indexh)*vvpoleta(ixp,jy ,n,indexh)+ &
+ vvpoleta(ix ,jyp,n,indexh)*vvpoleta(ix ,jyp,n,indexh)+ &
+ vvpoleta(ixp,jyp,n,indexh)*vvpoleta(ixp,jyp,n,indexh)
+ else
+ y1(m)=p1*uueta(ix ,jy ,n,indexh) &
+ +p2*uueta(ixp,jy ,n,indexh) &
+ +p3*uueta(ix ,jyp,n,indexh) &
+ +p4*uueta(ixp,jyp,n,indexh)
+ y2(m)=p1*vveta(ix ,jy ,n,indexh) &
+ +p2*vveta(ixp,jy ,n,indexh) &
+ +p3*vveta(ix ,jyp,n,indexh) &
+ +p4*vveta(ixp,jyp,n,indexh)
+ usl=usl+uueta(ix ,jy ,n,indexh)+uueta(ixp,jy ,n,indexh) &
+ +uueta(ix ,jyp,n,indexh)+uueta(ixp,jyp,n,indexh)
+ vsl=vsl+vveta(ix ,jy ,n,indexh)+vveta(ixp,jy ,n,indexh) &
+ +vveta(ix ,jyp,n,indexh)+vveta(ixp,jyp,n,indexh)
+
+ usq=usq+uueta(ix ,jy ,n,indexh)*uueta(ix ,jy ,n,indexh)+ &
+ uueta(ixp,jy ,n,indexh)*uueta(ixp,jy ,n,indexh)+ &
+ uueta(ix ,jyp,n,indexh)*uueta(ix ,jyp,n,indexh)+ &
+ uueta(ixp,jyp,n,indexh)*uueta(ixp,jyp,n,indexh)
+ vsq=vsq+vveta(ix ,jy ,n,indexh)*vveta(ix ,jy ,n,indexh)+ &
+ vveta(ixp,jy ,n,indexh)*vveta(ixp,jy ,n,indexh)+ &
+ vveta(ix ,jyp,n,indexh)*vveta(ix ,jyp,n,indexh)+ &
+ vveta(ixp,jyp,n,indexh)*vveta(ixp,jyp,n,indexh)
+ endif
+ rhograd1(m)=p1*drhodzeta(ix ,jy ,n,indexh) &
+ +p2*drhodzeta(ixp,jy ,n,indexh) &
+ +p3*drhodzeta(ix ,jyp,n,indexh) &
+ +p4*drhodzeta(ixp,jyp,n,indexh)
+ rho1(m)=p1*rhoeta(ix ,jy ,n,indexh) &
+ +p2*rhoeta(ixp,jy ,n,indexh) &
+ +p3*rhoeta(ix ,jyp,n,indexh) &
+ +p4*rhoeta(ixp,jyp,n,indexh)
+ end do
+ uprof(n)=(y1(1)*dt2+y1(2)*dt1)*dtt
+ vprof(n)=(y2(1)*dt2+y2(2)*dt1)*dtt
+ rhoprof(n)=(rho1(1)*dt2+rho1(2)*dt1)*dtt
+ rhogradprof(n)=(rhograd1(1)*dt2+rhograd1(2)*dt1)*dtt
+
xaux=usq-usl*usl/8.
if (xaux.lt.eps) then
usigprof(n)=0.
@@ -229,6 +275,28 @@ subroutine interpol_all(itime,xt,yt,zt)
vsigprof(n)=sqrt(xaux/7.)
endif
+ end do
+
+ do n=indzeta,indzpeta
+ wsl=0.
+ wsq=0.
+ do m=1,2
+ indexh=memind(m)
+
+ y3(m)=p1*wweta(ix ,jy ,n,indexh) &
+ +p2*wweta(ixp,jy ,n,indexh) &
+ +p3*wweta(ix ,jyp,n,indexh) &
+ +p4*wweta(ixp,jyp,n,indexh)
+
+ wsl=wsl+wweta(ix ,jy ,n,indexh)+wweta(ixp,jy ,n,indexh) &
+ +wweta(ix ,jyp,n,indexh)+wweta(ixp,jyp,n,indexh)
+ wsq=wsq+wweta(ix ,jy ,n,indexh)*wweta(ix ,jy ,n,indexh)+ &
+ wweta(ixp,jy ,n,indexh)*wweta(ixp,jy ,n,indexh)+ &
+ wweta(ix ,jyp,n,indexh)*wweta(ix ,jyp,n,indexh)+ &
+ wweta(ixp,jyp,n,indexh)*wweta(ixp,jyp,n,indexh)
+
+ end do
+ wprofeta(n)=(y3(1)*dt2+y3(2)*dt1)*dtt
xaux=wsq-wsl*wsl/8.
if (xaux.lt.eps) then
@@ -238,6 +306,4 @@ subroutine interpol_all(itime,xt,yt,zt)
endif
end do
-
-
end subroutine interpol_all
diff --git a/src/interpol_all_nests.f90 b/src/redundant/interpol_all_nests.f90
similarity index 99%
rename from src/interpol_all_nests.f90
rename to src/redundant/interpol_all_nests.f90
index 4512ac2d..a26b7b40 100644
--- a/src/interpol_all_nests.f90
+++ b/src/redundant/interpol_all_nests.f90
@@ -121,10 +121,9 @@ subroutine interpol_all_nests(itime,xt,yt,zt)
if (height(i).gt.zt) then
indz=i-1
indzp=i
- goto 6
+ exit
endif
end do
-6 continue
!**************************************
! 1.) Bilinear horizontal interpolation
@@ -217,5 +216,4 @@ subroutine interpol_all_nests(itime,xt,yt,zt)
endif
end do
-
end subroutine interpol_all_nests
diff --git a/src/interpol_misslev.f90 b/src/redundant/interpol_misslev.f90
similarity index 51%
rename from src/interpol_misslev.f90
rename to src/redundant/interpol_misslev.f90
index 0b178f3c..96db1622 100644
--- a/src/interpol_misslev.f90
+++ b/src/redundant/interpol_misslev.f90
@@ -2,7 +2,7 @@
! SPDX-License-Identifier: GPL-3.0-or-later
subroutine interpol_misslev(n)
- ! i
+ !
!*****************************************************************************
! *
! This subroutine interpolates u,v,w, density and density gradients. *
@@ -35,7 +35,7 @@ subroutine interpol_misslev(n)
! Auxiliary variables needed for interpolation
real :: y1(2),y2(2),y3(2),rho1(2),rhograd1(2)
- real :: usl,vsl,wsl,usq,vsq,wsq,xaux
+ real :: usl,vsl,wsl,usq,vsq,wsq,xaux,psint(2),psint_t
integer :: m,n,indexh
real,parameter :: eps=1.0e-30
@@ -61,63 +61,11 @@ subroutine interpol_misslev(n)
wsq=0.
do m=1,2
indexh=memind(m)
- if (ngrid.lt.0) then
- y1(m)=p1*uupol(ix ,jy ,n,indexh) &
- +p2*uupol(ixp,jy ,n,indexh) &
- +p3*uupol(ix ,jyp,n,indexh) &
- +p4*uupol(ixp,jyp,n,indexh)
- y2(m)=p1*vvpol(ix ,jy ,n,indexh) &
- +p2*vvpol(ixp,jy ,n,indexh) &
- +p3*vvpol(ix ,jyp,n,indexh) &
- +p4*vvpol(ixp,jyp,n,indexh)
- usl=usl+uupol(ix ,jy ,n,indexh)+uupol(ixp,jy ,n,indexh) &
- +uupol(ix ,jyp,n,indexh)+uupol(ixp,jyp,n,indexh)
- vsl=vsl+vvpol(ix ,jy ,n,indexh)+vvpol(ixp,jy ,n,indexh) &
- +vvpol(ix ,jyp,n,indexh)+vvpol(ixp,jyp,n,indexh)
-
- usq=usq+uupol(ix ,jy ,n,indexh)*uupol(ix ,jy ,n,indexh)+ &
- uupol(ixp,jy ,n,indexh)*uupol(ixp,jy ,n,indexh)+ &
- uupol(ix ,jyp,n,indexh)*uupol(ix ,jyp,n,indexh)+ &
- uupol(ixp,jyp,n,indexh)*uupol(ixp,jyp,n,indexh)
- vsq=vsq+vvpol(ix ,jy ,n,indexh)*vvpol(ix ,jy ,n,indexh)+ &
- vvpol(ixp,jy ,n,indexh)*vvpol(ixp,jy ,n,indexh)+ &
- vvpol(ix ,jyp,n,indexh)*vvpol(ix ,jyp,n,indexh)+ &
- vvpol(ixp,jyp,n,indexh)*vvpol(ixp,jyp,n,indexh)
- else
- y1(m)=p1*uu(ix ,jy ,n,indexh) &
- +p2*uu(ixp,jy ,n,indexh) &
- +p3*uu(ix ,jyp,n,indexh) &
- +p4*uu(ixp,jyp,n,indexh)
- y2(m)=p1*vv(ix ,jy ,n,indexh) &
- +p2*vv(ixp,jy ,n,indexh) &
- +p3*vv(ix ,jyp,n,indexh) &
- +p4*vv(ixp,jyp,n,indexh)
- usl=usl+uu(ix ,jy ,n,indexh)+uu(ixp,jy ,n,indexh) &
- +uu(ix ,jyp,n,indexh)+uu(ixp,jyp,n,indexh)
- vsl=vsl+vv(ix ,jy ,n,indexh)+vv(ixp,jy ,n,indexh) &
- +vv(ix ,jyp,n,indexh)+vv(ixp,jyp,n,indexh)
-
- usq=usq+uu(ix ,jy ,n,indexh)*uu(ix ,jy ,n,indexh)+ &
- uu(ixp,jy ,n,indexh)*uu(ixp,jy ,n,indexh)+ &
- uu(ix ,jyp,n,indexh)*uu(ix ,jyp,n,indexh)+ &
- uu(ixp,jyp,n,indexh)*uu(ixp,jyp,n,indexh)
- vsq=vsq+vv(ix ,jy ,n,indexh)*vv(ix ,jy ,n,indexh)+ &
- vv(ixp,jy ,n,indexh)*vv(ixp,jy ,n,indexh)+ &
- vv(ix ,jyp,n,indexh)*vv(ix ,jyp,n,indexh)+ &
- vv(ixp,jyp,n,indexh)*vv(ixp,jyp,n,indexh)
- endif
+
y3(m)=p1*ww(ix ,jy ,n,indexh) &
+p2*ww(ixp,jy ,n,indexh) &
+p3*ww(ix ,jyp,n,indexh) &
+p4*ww(ixp,jyp,n,indexh)
- rhograd1(m)=p1*drhodz(ix ,jy ,n,indexh) &
- +p2*drhodz(ixp,jy ,n,indexh) &
- +p3*drhodz(ix ,jyp,n,indexh) &
- +p4*drhodz(ixp,jyp,n,indexh)
- rho1(m)=p1*rho(ix ,jy ,n,indexh) &
- +p2*rho(ixp,jy ,n,indexh) &
- +p3*rho(ix ,jyp,n,indexh) &
- +p4*rho(ixp,jyp,n,indexh)
wsl=wsl+ww(ix ,jy ,n,indexh)+ww(ixp,jy ,n,indexh) &
+ww(ix ,jyp,n,indexh)+ww(ixp,jyp,n,indexh)
wsq=wsq+ww(ix ,jy ,n,indexh)*ww(ix ,jy ,n,indexh)+ &
@@ -125,12 +73,104 @@ subroutine interpol_misslev(n)
ww(ix ,jyp,n,indexh)*ww(ix ,jyp,n,indexh)+ &
ww(ixp,jyp,n,indexh)*ww(ixp,jyp,n,indexh)
end do
+ wprof(n)=(y3(1)*dt2+y3(2)*dt1)*dtt
+ indzindicator(n)=.false.
+
+
+ ! Compute standard deviations
+ !****************************
+
+ xaux=wsq-wsl*wsl/8.
+ if (xaux.lt.eps) then
+ wsigprof(n)=0.
+ else
+ wsigprof(n)=sqrt(xaux/7.)
+ endif
+
+ ! Same for eta coordinates
+ usl=0.
+ vsl=0.
+ wsl=0.
+ usq=0.
+ vsq=0.
+ wsq=0.
+ do m=1,2
+ indexh=memind(m)
+
+ if (ngrid.lt.0) then
+ y1(m)=p1*uupoleta(ix ,jy ,n,indexh) &
+ +p2*uupoleta(ixp,jy ,n,indexh) &
+ +p3*uupoleta(ix ,jyp,n,indexh) &
+ +p4*uupoleta(ixp,jyp,n,indexh)
+ y2(m)=p1*vvpoleta(ix ,jy ,n,indexh) &
+ +p2*vvpoleta(ixp,jy ,n,indexh) &
+ +p3*vvpoleta(ix ,jyp,n,indexh) &
+ +p4*vvpoleta(ixp,jyp,n,indexh)
+ usl=usl+uupoleta(ix ,jy ,n,indexh)+uupoleta(ixp,jy ,n,indexh) &
+ +uupoleta(ix ,jyp,n,indexh)+uupoleta(ixp,jyp,n,indexh)
+ vsl=vsl+vvpoleta(ix ,jy ,n,indexh)+vvpoleta(ixp,jy ,n,indexh) &
+ +vvpoleta(ix ,jyp,n,indexh)+vvpoleta(ixp,jyp,n,indexh)
+
+ usq=usq+uupoleta(ix ,jy ,n,indexh)*uupoleta(ix ,jy ,n,indexh)+ &
+ uupoleta(ixp,jy ,n,indexh)*uupoleta(ixp,jy ,n,indexh)+ &
+ uupoleta(ix ,jyp,n,indexh)*uupoleta(ix ,jyp,n,indexh)+ &
+ uupoleta(ixp,jyp,n,indexh)*uupoleta(ixp,jyp,n,indexh)
+ vsq=vsq+vvpoleta(ix ,jy ,n,indexh)*vvpoleta(ix ,jy ,n,indexh)+ &
+ vvpoleta(ixp,jy ,n,indexh)*vvpoleta(ixp,jy ,n,indexh)+ &
+ vvpoleta(ix ,jyp,n,indexh)*vvpoleta(ix ,jyp,n,indexh)+ &
+ vvpoleta(ixp,jyp,n,indexh)*vvpoleta(ixp,jyp,n,indexh)
+ else
+ y1(m)=p1*uueta(ix ,jy ,n,indexh) &
+ +p2*uueta(ixp,jy ,n,indexh) &
+ +p3*uueta(ix ,jyp,n,indexh) &
+ +p4*uueta(ixp,jyp,n,indexh)
+ y2(m)=p1*vveta(ix ,jy ,n,indexh) &
+ +p2*vveta(ixp,jy ,n,indexh) &
+ +p3*vveta(ix ,jyp,n,indexh) &
+ +p4*vveta(ixp,jyp,n,indexh)
+ usl=usl+uueta(ix ,jy ,n,indexh)+uueta(ixp,jy ,n,indexh) &
+ +uueta(ix ,jyp,n,indexh)+uueta(ixp,jyp,n,indexh)
+ vsl=vsl+vveta(ix ,jy ,n,indexh)+vveta(ixp,jy ,n,indexh) &
+ +vveta(ix ,jyp,n,indexh)+vveta(ixp,jyp,n,indexh)
+
+ usq=usq+uueta(ix ,jy ,n,indexh)*uueta(ix ,jy ,n,indexh)+ &
+ uueta(ixp,jy ,n,indexh)*uueta(ixp,jy ,n,indexh)+ &
+ uueta(ix ,jyp,n,indexh)*uueta(ix ,jyp,n,indexh)+ &
+ uueta(ixp,jyp,n,indexh)*uueta(ixp,jyp,n,indexh)
+ vsq=vsq+vveta(ix ,jy ,n,indexh)*vveta(ix ,jy ,n,indexh)+ &
+ vveta(ixp,jy ,n,indexh)*vveta(ixp,jy ,n,indexh)+ &
+ vveta(ix ,jyp,n,indexh)*vveta(ix ,jyp,n,indexh)+ &
+ vveta(ixp,jyp,n,indexh)*vveta(ixp,jyp,n,indexh)
+ endif
+ y3(m)=p1*wweta(ix ,jy ,n,indexh) &
+ +p2*wweta(ixp,jy ,n,indexh) &
+ +p3*wweta(ix ,jyp,n,indexh) &
+ +p4*wweta(ixp,jyp,n,indexh)
+ rhograd1(m)=p1*drhodzeta(ix ,jy ,n,indexh) &
+ +p2*drhodzeta(ixp,jy ,n,indexh) &
+ +p3*drhodzeta(ix ,jyp,n,indexh) &
+ +p4*drhodzeta(ixp,jyp,n,indexh)
+ rho1(m)=p1*rhoeta(ix ,jy ,n,indexh) &
+ +p2*rhoeta(ixp,jy ,n,indexh) &
+ +p3*rhoeta(ix ,jyp,n,indexh) &
+ +p4*rhoeta(ixp,jyp,n,indexh)
+
+ wsl=wsl+wweta(ix ,jy ,n,indexh)+wweta(ixp,jy ,n,indexh) &
+ +wweta(ix ,jyp,n,indexh)+wweta(ixp,jyp,n,indexh)
+ wsq=wsq+wweta(ix ,jy ,n,indexh)*wweta(ix ,jy ,n,indexh)+ &
+ wweta(ixp,jy ,n,indexh)*wweta(ixp,jy ,n,indexh)+ &
+ wweta(ix ,jyp,n,indexh)*wweta(ix ,jyp,n,indexh)+ &
+ wweta(ixp,jyp,n,indexh)*wweta(ixp,jyp,n,indexh)
+ end do
+
+ ! Convert w from Pa/s to eta/s, following FLEXTRA
+ !************************************************
+
uprof(n)=(y1(1)*dt2+y1(2)*dt1)*dtt
vprof(n)=(y2(1)*dt2+y2(2)*dt1)*dtt
- wprof(n)=(y3(1)*dt2+y3(2)*dt1)*dtt
+ wprofeta(n)=(y3(1)*dt2+y3(2)*dt1)*dtt
rhoprof(n)=(rho1(1)*dt2+rho1(2)*dt1)*dtt
rhogradprof(n)=(rhograd1(1)*dt2+rhograd1(2)*dt1)*dtt
- indzindicator(n)=.false.
! Compute standard deviations
@@ -150,13 +190,10 @@ subroutine interpol_misslev(n)
vsigprof(n)=sqrt(xaux/7.)
endif
-
xaux=wsq-wsl*wsl/8.
if (xaux.lt.eps) then
- wsigprof(n)=0.
+ wsigprofeta(n)=0.
else
- wsigprof(n)=sqrt(xaux/7.)
+ wsigprofeta(n)=sqrt(xaux/7.)
endif
-
-
end subroutine interpol_misslev
diff --git a/src/interpol_misslev_nests.f90 b/src/redundant/interpol_misslev_nests.f90
similarity index 99%
rename from src/interpol_misslev_nests.f90
rename to src/redundant/interpol_misslev_nests.f90
index f3dbc0d6..e676a9c7 100644
--- a/src/interpol_misslev_nests.f90
+++ b/src/redundant/interpol_misslev_nests.f90
@@ -127,5 +127,4 @@ subroutine interpol_misslev_nests(n)
else
wsigprof(n)=sqrt(xaux/7.)
endif
-
end subroutine interpol_misslev_nests
diff --git a/src/interpol_rain.f90 b/src/redundant/interpol_rain.f90
similarity index 86%
rename from src/interpol_rain.f90
rename to src/redundant/interpol_rain.f90
index 8c934906..af06bd2f 100644
--- a/src/interpol_rain.f90
+++ b/src/redundant/interpol_rain.f90
@@ -2,7 +2,7 @@
! SPDX-License-Identifier: GPL-3.0-or-later
subroutine interpol_rain(yy1,yy2,yy3,nxmax,nymax,nzmax,nx, &
- ny,iwftouse,xt,yt,level,itime1,itime2,itime,yint1,yint2,yint3)
+ ny,iwftouse,xt,yt,level,itime1,itime2,itime,yint1,yint2,yint3)
! i i i i i i i
!i i i i i i i i o o o
!****************************************************************************
@@ -95,38 +95,37 @@ subroutine interpol_rain(yy1,yy2,yy3,nxmax,nymax,nzmax,nx, &
! Loop over 2 time steps
!***********************
-! do m=1,2
- indexh=iwftouse
+ ! do m=1,2
+ indexh=iwftouse
- y1(1)=p1*yy1(ix ,jy ,level,indexh) &
- + p2*yy1(ixp,jy ,level,indexh) &
- + p3*yy1(ix ,jyp,level,indexh) &
- + p4*yy1(ixp,jyp,level,indexh)
- y2(1)=p1*yy2(ix ,jy ,level,indexh) &
- + p2*yy2(ixp,jy ,level,indexh) &
- + p3*yy2(ix ,jyp,level,indexh) &
- + p4*yy2(ixp,jyp,level,indexh)
- y3(1)=p1*yy3(ix ,jy ,level,indexh) &
- + p2*yy3(ixp,jy ,level,indexh) &
- + p3*yy3(ix ,jyp,level,indexh) &
- + p4*yy3(ixp,jyp,level,indexh)
-! end do
+ y1(1)=p1*yy1(ix ,jy ,level,indexh) &
+ + p2*yy1(ixp,jy ,level,indexh) &
+ + p3*yy1(ix ,jyp,level,indexh) &
+ + p4*yy1(ixp,jyp,level,indexh)
+ y2(1)=p1*yy2(ix ,jy ,level,indexh) &
+ + p2*yy2(ixp,jy ,level,indexh) &
+ + p3*yy2(ix ,jyp,level,indexh) &
+ + p4*yy2(ixp,jyp,level,indexh)
+ y3(1)=p1*yy3(ix ,jy ,level,indexh) &
+ + p2*yy3(ixp,jy ,level,indexh) &
+ + p3*yy3(ix ,jyp,level,indexh) &
+ + p4*yy3(ixp,jyp,level,indexh)
+ ! end do
!************************************
! 2.) Temporal interpolation (linear) - skip to be consistent with clouds
!************************************
-! dt1=real(itime-itime1)
-! dt2=real(itime2-itime)
-! dt=dt1+dt2
+ ! dt1=real(itime-itime1)
+ ! dt2=real(itime2-itime)
+ ! dt=dt1+dt2
-! yint1=(y1(1)*dt2+y1(2)*dt1)/dt
-! yint2=(y2(1)*dt2+y2(2)*dt1)/dt
-! yint3=(y3(1)*dt2+y3(2)*dt1)/dt
+ ! yint1=(y1(1)*dt2+y1(2)*dt1)/dt
+ ! yint2=(y2(1)*dt2+y2(2)*dt1)/dt
+ ! yint3=(y3(1)*dt2+y3(2)*dt1)/dt
yint1=y1(1)
yint2=y2(1)
yint3=y3(1)
-
end subroutine interpol_rain
diff --git a/src/interpol_rain_nests.f90 b/src/redundant/interpol_rain_nests.f90
similarity index 98%
rename from src/interpol_rain_nests.f90
rename to src/redundant/interpol_rain_nests.f90
index 1d8e3d5e..63c09123 100644
--- a/src/interpol_rain_nests.f90
+++ b/src/redundant/interpol_rain_nests.f90
@@ -74,7 +74,7 @@ subroutine interpol_rain_nests(yy1,yy2,yy3,nxmaxn,nymaxn,nzmax, &
! if (yt.ge.(real(nyn(ngrid)-1)-0.0001)) &
! yt=real(nyn(ngrid)-1)-0.0001
-! ESO make it consistent with interpol_rain
+ ! ESO make it consistent with interpol_rain
if (xt.ge.(real(nxn(ngrid)-1))) xt=real(nxn(ngrid)-1)-0.00001
if (yt.ge.(real(nyn(ngrid)-1))) yt=real(nyn(ngrid)-1)-0.00001
@@ -106,8 +106,8 @@ subroutine interpol_rain_nests(yy1,yy2,yy3,nxmaxn,nymaxn,nzmax, &
! Loop over 2 time steps
!***********************
-! do m=1,2
-! indexh=memind(m)
+ ! do m=1,2
+ ! indexh=memind(m)
indexh=iwftouse
y1(1)=p1*yy1(ix ,jy ,level,indexh,ngrid) &
@@ -122,7 +122,7 @@ subroutine interpol_rain_nests(yy1,yy2,yy3,nxmaxn,nymaxn,nzmax, &
+ p2*yy3(ixp,jy ,level,indexh,ngrid) &
+ p3*yy3(ix ,jyp,level,indexh,ngrid) &
+ p4*yy3(ixp,jyp,level,indexh,ngrid)
-! end do
+ ! end do
!************************************
@@ -140,5 +140,4 @@ subroutine interpol_rain_nests(yy1,yy2,yy3,nxmaxn,nymaxn,nzmax, &
yint1=y1(1)
yint2=y2(1)
yint3=y3(1)
-
end subroutine interpol_rain_nests
diff --git a/src/interpol_vdep.f90 b/src/redundant/interpol_vdep.f90
similarity index 97%
rename from src/interpol_vdep.f90
rename to src/redundant/interpol_vdep.f90
index 752487fd..33ecbf33 100644
--- a/src/interpol_vdep.f90
+++ b/src/redundant/interpol_vdep.f90
@@ -35,7 +35,6 @@ subroutine interpol_vdep(level,vdepo)
real :: y(2),vdepo
! a) Bilinear horizontal interpolation
-! write(*,*) 'interpol: ',dt1,dt2,dtt,lsynctime,ix,jy
do m=1,2
indexh=memind(m)
@@ -52,6 +51,4 @@ subroutine interpol_vdep(level,vdepo)
vdepo=(y(1)*dt2+y(2)*dt1)*dtt
depoindicator(level)=.false.
-
-
end subroutine interpol_vdep
diff --git a/src/interpol_vdep_nests.f90 b/src/redundant/interpol_vdep_nests.f90
similarity index 100%
rename from src/interpol_vdep_nests.f90
rename to src/redundant/interpol_vdep_nests.f90
diff --git a/src/interpol_wind.f90 b/src/redundant/interpol_wind.f90
similarity index 52%
rename from src/interpol_wind.f90
rename to src/redundant/interpol_wind.f90
index 172a5740..b2b8f83e 100644
--- a/src/interpol_wind.f90
+++ b/src/redundant/interpol_wind.f90
@@ -1,7 +1,7 @@
! SPDX-FileCopyrightText: FLEXPART 1998-2019, see flexpart_license.txt
! SPDX-License-Identifier: GPL-3.0-or-later
-subroutine interpol_wind(itime,xt,yt,zt)
+subroutine interpol_wind(itime,xt,yt,zt,zteta,pp)
! i i i i
!*****************************************************************************
! *
@@ -35,13 +35,14 @@ subroutine interpol_wind(itime,xt,yt,zt)
implicit none
- integer :: itime
+ integer :: itime,pp
real :: xt,yt,zt
+ real :: zteta
! Auxiliary variables needed for interpolation
- real :: dz1,dz2,dz
- real :: u1(2),v1(2),w1(2),uh(2),vh(2),wh(2)
- real :: usl,vsl,wsl,usq,vsq,wsq,xaux
+ real :: dz1,dz2,dz,psint(2)
+ real :: u1(2),v1(2),w1(2),dpdeta1(2),uh(2),vh(2),wh(2)
+ real :: usl,vsl,wsl,usq,vsq,wsq,xaux,dpdeta(2),psint_t,dpdetatemp
integer :: i,m,n,indexh,indzh
real,parameter :: eps=1.0e-30
@@ -71,15 +72,13 @@ subroutine interpol_wind(itime,xt,yt,zt)
! Determine the level below the current position for u,v
!*******************************************************
-
+ indz=nz-1
do i=2,nz
if (height(i).gt.zt) then
indz=i-1
- goto 6
+ exit
endif
end do
-6 continue
-
! Vertical distance to the level below and above current position
!****************************************************************
@@ -96,66 +95,12 @@ subroutine interpol_wind(itime,xt,yt,zt)
! Loop over 2 time steps and 2 levels
!************************************
- usl=0.
- vsl=0.
wsl=0.
- usq=0.
- vsq=0.
wsq=0.
do m=1,2
indexh=memind(m)
do n=1,2
indzh=indz+n-1
-
- if (ngrid.lt.0) then
- u1(n)=p1*uupol(ix ,jy ,indzh,indexh) &
- +p2*uupol(ixp,jy ,indzh,indexh) &
- +p3*uupol(ix ,jyp,indzh,indexh) &
- +p4*uupol(ixp,jyp,indzh,indexh)
- v1(n)=p1*vvpol(ix ,jy ,indzh,indexh) &
- +p2*vvpol(ixp,jy ,indzh,indexh) &
- +p3*vvpol(ix ,jyp,indzh,indexh) &
- +p4*vvpol(ixp,jyp,indzh,indexh)
- usl=usl+uupol(ix ,jy ,indzh,indexh)+ &
- uupol(ixp,jy ,indzh,indexh) &
- +uupol(ix ,jyp,indzh,indexh)+uupol(ixp,jyp,indzh,indexh)
- vsl=vsl+vvpol(ix ,jy ,indzh,indexh)+ &
- vvpol(ixp,jy ,indzh,indexh) &
- +vvpol(ix ,jyp,indzh,indexh)+vvpol(ixp,jyp,indzh,indexh)
-
- usq=usq+uupol(ix ,jy ,indzh,indexh)* &
- uupol(ix ,jy ,indzh,indexh)+ &
- uupol(ixp,jy ,indzh,indexh)*uupol(ixp,jy ,indzh,indexh)+ &
- uupol(ix ,jyp,indzh,indexh)*uupol(ix ,jyp,indzh,indexh)+ &
- uupol(ixp,jyp,indzh,indexh)*uupol(ixp,jyp,indzh,indexh)
- vsq=vsq+vvpol(ix ,jy ,indzh,indexh)* &
- vvpol(ix ,jy ,indzh,indexh)+ &
- vvpol(ixp,jy ,indzh,indexh)*vvpol(ixp,jy ,indzh,indexh)+ &
- vvpol(ix ,jyp,indzh,indexh)*vvpol(ix ,jyp,indzh,indexh)+ &
- vvpol(ixp,jyp,indzh,indexh)*vvpol(ixp,jyp,indzh,indexh)
- else
- u1(n)=p1*uu(ix ,jy ,indzh,indexh) &
- +p2*uu(ixp,jy ,indzh,indexh) &
- +p3*uu(ix ,jyp,indzh,indexh) &
- +p4*uu(ixp,jyp,indzh,indexh)
- v1(n)=p1*vv(ix ,jy ,indzh,indexh) &
- +p2*vv(ixp,jy ,indzh,indexh) &
- +p3*vv(ix ,jyp,indzh,indexh) &
- +p4*vv(ixp,jyp,indzh,indexh)
- usl=usl+uu(ix ,jy ,indzh,indexh)+uu(ixp,jy ,indzh,indexh) &
- +uu(ix ,jyp,indzh,indexh)+uu(ixp,jyp,indzh,indexh)
- vsl=vsl+vv(ix ,jy ,indzh,indexh)+vv(ixp,jy ,indzh,indexh) &
- +vv(ix ,jyp,indzh,indexh)+vv(ixp,jyp,indzh,indexh)
-
- usq=usq+uu(ix ,jy ,indzh,indexh)*uu(ix ,jy ,indzh,indexh)+ &
- uu(ixp,jy ,indzh,indexh)*uu(ixp,jy ,indzh,indexh)+ &
- uu(ix ,jyp,indzh,indexh)*uu(ix ,jyp,indzh,indexh)+ &
- uu(ixp,jyp,indzh,indexh)*uu(ixp,jyp,indzh,indexh)
- vsq=vsq+vv(ix ,jy ,indzh,indexh)*vv(ix ,jy ,indzh,indexh)+ &
- vv(ixp,jy ,indzh,indexh)*vv(ixp,jy ,indzh,indexh)+ &
- vv(ix ,jyp,indzh,indexh)*vv(ix ,jyp,indzh,indexh)+ &
- vv(ixp,jyp,indzh,indexh)*vv(ixp,jyp,indzh,indexh)
- endif
w1(n)=p1*ww(ix ,jy ,indzh,indexh) &
+p2*ww(ixp,jy ,indzh,indexh) &
+p3*ww(ix ,jyp,indzh,indexh) &
@@ -173,8 +118,6 @@ subroutine interpol_wind(itime,xt,yt,zt)
! 2.) Linear vertical interpolation
!**********************************
- uh(m)=dz2*u1(1)+dz1*u1(2)
- vh(m)=dz2*v1(1)+dz1*v1(2)
wh(m)=dz2*w1(1)+dz1*w1(2)
end do
@@ -183,14 +126,158 @@ subroutine interpol_wind(itime,xt,yt,zt)
! 3.) Temporal interpolation (linear)
!************************************
- u=(uh(1)*dt2+uh(2)*dt1)*dtt
- v=(vh(1)*dt2+vh(2)*dt1)*dtt
w=(wh(1)*dt2+wh(2)*dt1)*dtt
-
! Compute standard deviations
!****************************
+ xaux=wsq-wsl*wsl/16.
+ if (xaux.lt.eps) then
+ wsig=0.
+ else
+ wsig=sqrt(xaux/15.)
+ endif
+
+ ! Same for eta coordinates
+ !*************************
+
+ induv=nz-1
+ indpuv=nz
+ do i=2,nz
+ if (uvheight(i).lt.zteta) then
+ induv=i-1
+ indpuv=i
+ exit
+ endif
+ end do
+
+ dz=1./(uvheight(induv+1)-uvheight(induv))
+ dz1=(zteta-uvheight(induv))*dz
+ dz2=(uvheight(induv+1)-zteta)*dz
+ ! if (pp.eq.1) write(*,*) 'uv: ', zteta,induv,uvheight(induv),uvheight(indpuv),dz1,dz2
+
+ usl=0.
+ vsl=0.
+ usq=0.
+ vsq=0.
+ do m=1,2
+ indexh=memind(m)
+ do n=1,2
+ indzh=induv+n-1
+
+ if (ngrid.lt.0) then
+ u1(n)=p1*uupoleta(ix ,jy ,indzh,indexh) &
+ +p2*uupoleta(ixp,jy ,indzh,indexh) &
+ +p3*uupoleta(ix ,jyp,indzh,indexh) &
+ +p4*uupoleta(ixp,jyp,indzh,indexh)
+ v1(n)=p1*vvpoleta(ix ,jy ,indzh,indexh) &
+ +p2*vvpoleta(ixp,jy ,indzh,indexh) &
+ +p3*vvpoleta(ix ,jyp,indzh,indexh) &
+ +p4*vvpoleta(ixp,jyp,indzh,indexh)
+ usl=usl+uupoleta(ix ,jy ,indzh,indexh)+ &
+ uupoleta(ixp,jy ,indzh,indexh) &
+ +uupoleta(ix ,jyp,indzh,indexh)+uupoleta(ixp,jyp,indzh,indexh)
+ vsl=vsl+vvpoleta(ix ,jy ,indzh,indexh)+ &
+ vvpoleta(ixp,jy ,indzh,indexh) &
+ +vvpoleta(ix ,jyp,indzh,indexh)+vvpoleta(ixp,jyp,indzh,indexh)
+
+ usq=usq+uupoleta(ix ,jy ,indzh,indexh)* &
+ uupoleta(ix ,jy ,indzh,indexh)+ &
+ uupoleta(ixp,jy ,indzh,indexh)*uupoleta(ixp,jy ,indzh,indexh)+ &
+ uupoleta(ix ,jyp,indzh,indexh)*uupoleta(ix ,jyp,indzh,indexh)+ &
+ uupoleta(ixp,jyp,indzh,indexh)*uupoleta(ixp,jyp,indzh,indexh)
+ vsq=vsq+vvpoleta(ix ,jy ,indzh,indexh)* &
+ vvpoleta(ix ,jy ,indzh,indexh)+ &
+ vvpoleta(ixp,jy ,indzh,indexh)*vvpoleta(ixp,jy ,indzh,indexh)+ &
+ vvpoleta(ix ,jyp,indzh,indexh)*vvpoleta(ix ,jyp,indzh,indexh)+ &
+ vvpoleta(ixp,jyp,indzh,indexh)*vvpoleta(ixp,jyp,indzh,indexh)
+ else
+ u1(n)=p1*uueta(ix ,jy ,indzh,indexh) &
+ +p2*uueta(ixp,jy ,indzh,indexh) &
+ +p3*uueta(ix ,jyp,indzh,indexh) &
+ +p4*uueta(ixp,jyp,indzh,indexh)
+ v1(n)=p1*vveta(ix ,jy ,indzh,indexh) &
+ +p2*vveta(ixp,jy ,indzh,indexh) &
+ +p3*vveta(ix ,jyp,indzh,indexh) &
+ +p4*vveta(ixp,jyp,indzh,indexh)
+ usl=usl+uueta(ix ,jy ,indzh,indexh)+uueta(ixp,jy ,indzh,indexh) &
+ +uueta(ix ,jyp,indzh,indexh)+uueta(ixp,jyp,indzh,indexh)
+ vsl=vsl+vveta(ix ,jy ,indzh,indexh)+vveta(ixp,jy ,indzh,indexh) &
+ +vveta(ix ,jyp,indzh,indexh)+vveta(ixp,jyp,indzh,indexh)
+
+ usq=usq+uueta(ix ,jy ,indzh,indexh)*uueta(ix ,jy ,indzh,indexh)+ &
+ uueta(ixp,jy ,indzh,indexh)*uueta(ixp,jy ,indzh,indexh)+ &
+ uueta(ix ,jyp,indzh,indexh)*uueta(ix ,jyp,indzh,indexh)+ &
+ uueta(ixp,jyp,indzh,indexh)*uueta(ixp,jyp,indzh,indexh)
+ vsq=vsq+vveta(ix ,jy ,indzh,indexh)*vveta(ix ,jy ,indzh,indexh)+ &
+ vveta(ixp,jy ,indzh,indexh)*vveta(ixp,jy ,indzh,indexh)+ &
+ vveta(ix ,jyp,indzh,indexh)*vveta(ix ,jyp,indzh,indexh)+ &
+ vveta(ixp,jyp,indzh,indexh)*vveta(ixp,jyp,indzh,indexh)
+ endif
+ end do
+
+ !**********************************
+ ! 2.) Linear vertical interpolation
+ !**********************************
+ uh(m)=dz2*u1(1)+dz1*u1(2)
+ vh(m)=dz2*v1(1)+dz1*v1(2)
+ end do
+
+ indzeta=nz-1
+ indzpeta=nz
+ do i=2,nz
+ if (wheight(i).lt.zteta) then
+ indzeta=i-1
+ indzpeta=i
+ exit
+ endif
+ end do
+
+ dz=1./(wheight(indzeta+1)-wheight(indzeta))
+ dz1=(zteta-wheight(indzeta))*dz
+ dz2=(wheight(indzeta+1)-zteta)*dz
+ ! if (pp.eq.1) write(*,*) 'w: ', zteta,indzeta,wheight(indzeta),wheight(indzpeta),dz1,dz2
+
+ wsl=0.
+ wsq=0.
+ do m=1,2
+ indexh=memind(m)
+ do n=1,2
+ indzh=indzeta+n-1
+ w1(n)=p1*wweta(ix ,jy ,indzh,indexh) &
+ +p2*wweta(ixp,jy ,indzh,indexh) &
+ +p3*wweta(ix ,jyp,indzh,indexh) &
+ +p4*wweta(ixp,jyp,indzh,indexh)
+
+ wsl=wsl+wweta(ix ,jy ,indzh,indexh)+wweta(ixp,jy ,indzh,indexh) &
+ +wweta(ix ,jyp,indzh,indexh)+wweta(ixp,jyp,indzh,indexh)
+ wsq=wsq+wweta(ix ,jy ,indzh,indexh)*wweta(ix ,jy ,indzh,indexh)+ &
+ wweta(ixp,jy ,indzh,indexh)*wweta(ixp,jy ,indzh,indexh)+ &
+ wweta(ix ,jyp,indzh,indexh)*wweta(ix ,jyp,indzh,indexh)+ &
+ wweta(ixp,jyp,indzh,indexh)*wweta(ixp,jyp,indzh,indexh)
+ end do
+
+ !**********************************
+ ! 2.) Linear vertical interpolation
+ !**********************************
+ wh(m)=dz2*w1(1)+dz1*w1(2)
+ end do
+
+ !************************************
+ ! 3.) Temporal interpolation (linear)
+ !************************************
+
+ u=(uh(1)*dt2+uh(2)*dt1)*dtt
+ v=(vh(1)*dt2+vh(2)*dt1)*dtt
+ weta=(wh(1)*dt2+wh(2)*dt1)*dtt
+
+ xaux=wsq-wsl*wsl/16.
+ if (xaux.lt.eps) then
+ wsigeta=0.
+ else
+ wsigeta=sqrt(xaux/15.)
+ endif
+
xaux=usq-usl*usl/16.
if (xaux.lt.eps) then
usig=0.
@@ -205,12 +292,4 @@ subroutine interpol_wind(itime,xt,yt,zt)
vsig=sqrt(xaux/15.)
endif
-
- xaux=wsq-wsl*wsl/16.
- if (xaux.lt.eps) then
- wsig=0.
- else
- wsig=sqrt(xaux/15.)
- endif
-
end subroutine interpol_wind
diff --git a/src/interpol_wind_nests.f90 b/src/redundant/interpol_wind_nests.f90
similarity index 99%
rename from src/interpol_wind_nests.f90
rename to src/redundant/interpol_wind_nests.f90
index 1d25482b..0434058f 100644
--- a/src/interpol_wind_nests.f90
+++ b/src/redundant/interpol_wind_nests.f90
@@ -76,11 +76,9 @@ subroutine interpol_wind_nests(itime,xt,yt,zt)
do i=2,nz
if (height(i).gt.zt) then
indz=i-1
- goto 6
+ exit
endif
end do
-6 continue
-
! Vertical distance to the level below and above current position
!****************************************************************
diff --git a/src/redundant/interpol_wind_short.f90 b/src/redundant/interpol_wind_short.f90
new file mode 100644
index 00000000..37c24eec
--- /dev/null
+++ b/src/redundant/interpol_wind_short.f90
@@ -0,0 +1,201 @@
+! SPDX-FileCopyrightText: FLEXPART 1998-2019, see flexpart_license.txt
+! SPDX-License-Identifier: GPL-3.0-or-later
+
+subroutine interpol_wind_short(itime,xt,yt,zt,zteta)
+ ! i i i i
+ !*****************************************************************************
+ ! *
+ ! This subroutine interpolates the wind data to current trajectory position.*
+ ! *
+ ! Author: A. Stohl *
+ ! *
+ ! 16 December 1997 *
+ ! *
+ ! Revision March 2005 by AST : all output variables in common block *
+ ! *
+ !*****************************************************************************
+ ! *
+ ! Variables: *
+ ! u,v,w wind components *
+ ! itime [s] current temporal position *
+ ! memtime(3) [s] times of the wind fields in memory *
+ ! xt,yt,zt coordinates position for which wind data shall be *
+ ! calculated *
+ ! *
+ ! Constants: *
+ ! *
+ !*****************************************************************************
+
+ use par_mod
+ use com_mod
+ use interpol_mod
+
+ implicit none
+
+ integer, intent(in) :: itime
+ real, intent(in) :: xt,yt,zt
+ real, intent(in) :: zteta
+
+ ! Auxiliary variables needed for interpolation
+ real :: dz1,dz2,dz
+ real :: u1(2),v1(2),w1(2),uh(2),vh(2),wh(2),dpdeta1(2)
+ integer :: i,m,n,indexh,indzh,psint(2),psint_t,dpdeta
+
+
+ !********************************************
+ ! Multilinear interpolation in time and space
+ !********************************************
+
+ ddx=xt-real(ix)
+ ddy=yt-real(jy)
+ rddx=1.-ddx
+ rddy=1.-ddy
+ p1=rddx*rddy
+ p2=ddx*rddy
+ p3=rddx*ddy
+ p4=ddx*ddy
+
+ ! Calculate variables for time interpolation
+ !*******************************************
+
+ dt1=real(itime-memtime(1))
+ dt2=real(memtime(2)-itime)
+ dtt=1./(dt1+dt2)
+
+ ! Determine the level below the current position for u,v
+ !*******************************************************
+
+ do i=2,nz
+ if (height(i).gt.zt) then
+ indz=i-1
+ exit
+ endif
+ end do
+
+ ! Vertical distance to the level below and above current position
+ !****************************************************************
+
+ dz=1./(height(indz+1)-height(indz))
+ dz1=(zt-height(indz))*dz
+ dz2=(height(indz+1)-zt)*dz
+
+
+ !**********************************************************************
+ ! 1.) Bilinear horizontal interpolation
+ ! This has to be done separately for 6 fields (Temporal(2)*Vertical(3))
+ !**********************************************************************
+
+ ! Loop over 2 time steps and 2 levels
+ !************************************
+ do m=1,2
+ indexh=memind(m)
+ do n=1,2
+ indzh=indz+n-1
+ w1(n)=p1*ww(ix ,jy ,indzh,indexh) &
+ +p2*ww(ixp,jy ,indzh,indexh) &
+ +p3*ww(ix ,jyp,indzh,indexh) &
+ +p4*ww(ixp,jyp,indzh,indexh)
+ end do
+
+
+ !**********************************
+ ! 2.) Linear vertical interpolation
+ !**********************************
+
+ wh(m)=dz2*w1(1)+dz1*w1(2)
+ end do
+
+
+
+ !************************************
+ ! 3.) Temporal interpolation (linear)
+ !************************************
+ w=(wh(1)*dt2+wh(2)*dt1)*dtt
+
+
+ ! Same for eta coordinates
+ !*************************
+
+ induv=nz-1
+ dz1=1.
+ dz2=0.
+ dz=1.
+ do i=2,nz
+ if (uvheight(i).lt.zteta) then
+ induv=i-1
+ dz=1./(uvheight(induv+1)-uvheight(induv))
+ dz1=(zteta-uvheight(induv))*dz
+ dz2=(uvheight(induv+1)-zteta)*dz
+ exit
+ endif
+ end do
+
+ do m=1,2
+ indexh=memind(m)
+ do n=1,2
+ indzh=induv+n-1
+
+ if (ngrid.lt.0) then
+ u1(n)=p1*uupoleta(ix ,jy ,indzh,indexh) &
+ +p2*uupoleta(ixp,jy ,indzh,indexh) &
+ +p3*uupoleta(ix ,jyp,indzh,indexh) &
+ +p4*uupoleta(ixp,jyp,indzh,indexh)
+ v1(n)=p1*vvpoleta(ix ,jy ,indzh,indexh) &
+ +p2*vvpoleta(ixp,jy ,indzh,indexh) &
+ +p3*vvpoleta(ix ,jyp,indzh,indexh) &
+ +p4*vvpoleta(ixp,jyp,indzh,indexh)
+ else
+ u1(n)=p1*uueta(ix ,jy ,indzh,indexh) &
+ +p2*uueta(ixp,jy ,indzh,indexh) &
+ +p3*uueta(ix ,jyp,indzh,indexh) &
+ +p4*uueta(ixp,jyp,indzh,indexh)
+ v1(n)=p1*vveta(ix ,jy ,indzh,indexh) &
+ +p2*vveta(ixp,jy ,indzh,indexh) &
+ +p3*vveta(ix ,jyp,indzh,indexh) &
+ +p4*vveta(ixp,jyp,indzh,indexh)
+ endif
+ end do
+
+ !**********************************
+ ! 2.) Linear vertical interpolation
+ !**********************************
+
+ uh(m)=dz2*u1(1)+dz1*u1(2)
+ vh(m)=dz2*v1(1)+dz1*v1(2)
+ end do
+
+ indzeta=nz-1
+ dz1=1.
+ dz2=0.
+ dz=1.
+ do i=2,nz
+ if (wheight(i).lt.zteta) then
+ indzeta=i-1
+ dz=1./(wheight(indzeta+1)-wheight(indzeta))
+ dz1=(zteta-wheight(indzeta))*dz
+ dz2=(wheight(indzeta+1)-zteta)*dz
+ exit
+ endif
+ end do
+
+ do m=1,2
+ indexh=memind(m)
+ do n=1,2
+ indzh=indzeta+n-1
+ w1(n)=p1*wweta(ix ,jy ,indzh,indexh) &
+ +p2*wweta(ixp,jy ,indzh,indexh) &
+ +p3*wweta(ix ,jyp,indzh,indexh) &
+ +p4*wweta(ixp,jyp,indzh,indexh)
+ end do
+ wh(m)=dz2*w1(1)+dz1*w1(2)
+ end do
+
+ !************************************
+ ! 3.) Temporal interpolation (linear)
+ !************************************
+
+ u=(uh(1)*dt2+uh(2)*dt1)*dtt
+ v=(vh(1)*dt2+vh(2)*dt1)*dtt
+ weta=(wh(1)*dt2+wh(2)*dt1)*dtt
+
+end subroutine interpol_wind_short
diff --git a/src/interpol_wind_short_nests.f90 b/src/redundant/interpol_wind_short_nests.f90
similarity index 99%
rename from src/interpol_wind_short_nests.f90
rename to src/redundant/interpol_wind_short_nests.f90
index 165d11dd..13fcda13 100644
--- a/src/interpol_wind_short_nests.f90
+++ b/src/redundant/interpol_wind_short_nests.f90
@@ -67,11 +67,9 @@ subroutine interpol_wind_short_nests(itime,xt,yt,zt)
do i=2,nz
if (height(i).gt.zt) then
indz=i-1
- goto 6
+ exit
endif
end do
-6 continue
-
! Vertical distance to the level below and above current position
!****************************************************************
diff --git a/src/juldate.f90 b/src/redundant/juldate.f90
similarity index 100%
rename from src/juldate.f90
rename to src/redundant/juldate.f90
diff --git a/src/mpi_mod.f90 b/src/redundant/mpi_mod.f90
similarity index 99%
rename from src/mpi_mod.f90
rename to src/redundant/mpi_mod.f90
index f7b6717c..7c0b31b8 100644
--- a/src/mpi_mod.f90
+++ b/src/redundant/mpi_mod.f90
@@ -186,7 +186,7 @@ contains
if (mp_ierr /= 0) goto 100
call MPI_COMM_SIZE(MPI_COMM_WORLD, mp_np, mp_ierr)
if (mp_ierr /= 0) goto 100
-
+ write(*,*) 'Proces: ', mp_pid
! Variable mpi_mode is used to handle subroutines common to parallel/serial version
if (lmp_sync) then
@@ -284,8 +284,10 @@ contains
mp_partgroup_rank(i) = j
end do
+ write(*,*) 'There are ', mp_np, ' processes running.'
call MPI_Group_incl (world_group_id, mp_np-1, mp_partgroup_rank, &
&mp_partgroup_pid, mp_ierr)
+ write(*,*) mp_partgroup_rank, mp_partgroup_pid
if (mp_ierr /= 0) goto 100
call MPI_Comm_create (MPI_COMM_WORLD, mp_partgroup_pid, mp_partgroup_comm, mp_ierr)
if (mp_ierr /= 0) goto 100
diff --git a/src/obukhov.f90 b/src/redundant/obukhov.f90
similarity index 98%
rename from src/obukhov.f90
rename to src/redundant/obukhov.f90
index 264c48ba..c58d9fd2 100644
--- a/src/obukhov.f90
+++ b/src/redundant/obukhov.f90
@@ -50,7 +50,7 @@ real function obukhov(ps,tsurf,tdsurf,tlev,ustar,hf,akm,bkm,plev,metdata_format)
real :: ak1,bk1,theta,thetastar
- e=ew(tdsurf) ! vapor pressure
+ e=ew(tdsurf,ps) ! vapor pressure
tv=tsurf*(1.+0.378*e/ps) ! virtual temperature
rhoa=ps/(r_air*tv) ! air density
if (metdata_format.eq.GRIBFILE_CENTRE_ECMWF) then
diff --git a/src/ohreaction.f90 b/src/redundant/ohreaction.f90
similarity index 79%
rename from src/ohreaction.f90
rename to src/redundant/ohreaction.f90
index 8fe187d9..ec2a9747 100644
--- a/src/ohreaction.f90
+++ b/src/redundant/ohreaction.f90
@@ -27,11 +27,12 @@ subroutine ohreaction(itime,ltsample,loutnext)
use oh_mod
use par_mod
use com_mod
+ use particle_mod
implicit none
integer :: jpart,itime,ltsample,loutnext,ldeltat,j,k,ix,jy!,ijx,jjy
- integer :: ngrid,interp_time,n,m,h,indz,i!,ia,il
+ integer :: ngrid,interp_time,m,n,h,indz,i!,ia,il
integer :: jjjjmmdd,hhmmss,OHx,OHy,OHz
real, dimension(nzOH) :: altOHtop
real :: xlon,ylat
@@ -57,29 +58,32 @@ subroutine ohreaction(itime,ltsample,loutnext)
! Loop over particles
!*****************************************
+! !$OMP PARALLEL PRIVATE(jpart,xtn,ytn,j,k,ix,jy,interp_time, &
+! !$OMP n,indz,i,xlon,ylat,OHx,OHy,OHz,oh_average,temp,ohrate, &
+! !$OMP restmass,ohreacted,altOHtop,ngrid)
+! !$OMP DO
do jpart=1,numpart
! Determine which nesting level to be used
ngrid=0
do j=numbnests,1,-1
- if ((xtra1(jpart).gt.xln(j)).and.(xtra1(jpart).lt.xrn(j)).and. &
- (ytra1(jpart).gt.yln(j)).and.(ytra1(jpart).lt.yrn(j))) then
+ if ((part(jpart)%xlon.gt.xln(j)).and.(part(jpart)%xlon.lt.xrn(j)).and. &
+ (part(jpart)%ylat.gt.yln(j)).and.(part(jpart)%ylat.lt.yrn(j))) then
ngrid=j
- goto 23
+ exit
endif
end do
-23 continue
! Determine nested grid coordinates
if (ngrid.gt.0) then
- xtn=(xtra1(jpart)-xln(ngrid))*xresoln(ngrid)
- ytn=(ytra1(jpart)-yln(ngrid))*yresoln(ngrid)
+ xtn=(part(jpart)%xlon-xln(ngrid))*xresoln(ngrid)
+ ytn=(part(jpart)%ylat-yln(ngrid))*yresoln(ngrid)
ix=int(xtn)
jy=int(ytn)
else
- ix=int(xtra1(jpart))
- jy=int(ytra1(jpart))
+ ix=int(part(jpart)%xlon)
+ jy=int(part(jpart)%ylat)
endif
interp_time=nint(itime-0.5*ltsample)
@@ -87,36 +91,35 @@ subroutine ohreaction(itime,ltsample,loutnext)
if(abs(memtime(1)-interp_time).lt.abs(memtime(2)-interp_time)) n=1
do i=2,nz
- if (height(i).gt.ztra1(jpart)) then
+ if (height(i).gt.part(jpart)%z) then
indz=i-1
- goto 6
+ exit
endif
end do
-6 continue
! Get OH from nearest grid-cell and specific month
!*************************************************
! world coordinates
- xlon=xtra1(jpart)*dx+xlon0
+ xlon=part(jpart)%xlon*dx+xlon0
if (xlon.gt.180) then
xlon=xlon-360
endif
- ylat=ytra1(jpart)*dy+ylat0
+ ylat=part(jpart)%ylat*dy+ylat0
! get position in the OH field
OHx=minloc(abs(lonOH-xlon),dim=1,mask=abs(lonOH-xlon).eq.minval(abs(lonOH-xlon)))
OHy=minloc(abs(latOH-ylat),dim=1,mask=abs(latOH-ylat).eq.minval(abs(latOH-ylat)))
! get the level of the OH field for the particle
- ! ztra1 is the z-coord of the trajectory above model orography in metres
+ ! z is the z-coord of the trajectory above model orography in metres
! altOH is the height of the centre of the level in the OH field above orography
do i=2,nzOH
altOHtop(i-1)=altOH(i)+0.5*(altOH(i)-altOH(i-1))
end do
altOHtop(nzOH)=altOH(nzOH)+0.5*(altOH(nzOH)-altOH(nzOH-1))
- OHz=minloc(abs(altOHtop-ztra1(jpart)),dim=1,mask=abs(altOHtop-ztra1(jpart))&
- &.eq.minval(abs(altOHtop-ztra1(jpart))))
+ OHz=minloc(abs(altOHtop-part(jpart)%z),dim=1,mask=abs(altOHtop-part(jpart)%z)&
+ &.eq.minval(abs(altOHtop-part(jpart)%z)))
! Interpolate between hourly OH fields to current time
!*****************************************************
@@ -136,22 +139,24 @@ subroutine ohreaction(itime,ltsample,loutnext)
if (ohcconst(k).gt.0.) then
ohrate=ohcconst(k)*temp**ohnconst(k)*exp(-ohdconst(k)/temp)*oh_average
! new particle mass
- restmass = xmass1(jpart,k)*exp(-1*ohrate*abs(ltsample))
+ restmass = part(jpart)%mass(k)*exp(-1*ohrate*abs(ltsample))
if (restmass .gt. smallnum) then
- xmass1(jpart,k)=restmass
+ part(jpart)%mass(k)=restmass
else
- xmass1(jpart,k)=0.
+ part(jpart)%mass(k)=0.
endif
- ohreacted=xmass1(jpart,k)*(1-exp(-1*ohrate*abs(ltsample)))
+ ohreacted=part(jpart)%mass(k)*(1-exp(-1*ohrate*abs(ltsample)))
+ if (jpart.eq.535) write(*,*) 'ohreaction', part(jpart)%mass(k),k
else
ohreacted=0.
endif
end do
-
endif ! oh_average.gt.smallnum
end do !continue loop over all particles
+! !$OMP END DO
+! !$OMP END PARALLEL
end subroutine ohreaction
diff --git a/src/openouttraj.f90 b/src/redundant/openouttraj.f90
similarity index 100%
rename from src/openouttraj.f90
rename to src/redundant/openouttraj.f90
diff --git a/src/openreceptors.f90 b/src/redundant/openreceptors.f90
similarity index 100%
rename from src/openreceptors.f90
rename to src/redundant/openreceptors.f90
diff --git a/src/outgrid_init.f90 b/src/redundant/outgrid_init.f90
similarity index 100%
rename from src/outgrid_init.f90
rename to src/redundant/outgrid_init.f90
diff --git a/src/outgrid_init_nest.f90 b/src/redundant/outgrid_init_nest.f90
similarity index 100%
rename from src/outgrid_init_nest.f90
rename to src/redundant/outgrid_init_nest.f90
diff --git a/src/part0.f90 b/src/redundant/part0.f90
similarity index 100%
rename from src/part0.f90
rename to src/redundant/part0.f90
diff --git a/src/partdep.f90 b/src/redundant/partdep.f90
similarity index 100%
rename from src/partdep.f90
rename to src/redundant/partdep.f90
diff --git a/src/redundant/partoutput.f90 b/src/redundant/partoutput.f90
new file mode 100644
index 00000000..26649c47
--- /dev/null
+++ b/src/redundant/partoutput.f90
@@ -0,0 +1,226 @@
+! SPDX-FileCopyrightText: FLEXPART 1998-2019, see flexpart_license.txt
+! SPDX-License-Identifier: GPL-3.0-or-later
+
+subroutine partoutput(itime)!,active_per_rel)
+ ! i
+ !*****************************************************************************
+ ! *
+ ! Dump all particle positions *
+ ! *
+ ! Author: A. Stohl *
+ ! *
+ ! 12 March 1999 *
+ ! *
+ !*****************************************************************************
+ ! *
+ ! Variables: *
+ ! *
+ !*****************************************************************************
+
+ use par_mod
+ use com_mod
+ use date_mod
+ use interpol_mod
+ use coordinates_ecmwf
+ use particle_mod
+#ifdef USE_NCF
+ use netcdf
+ use netcdf_output_mod, only: partoutput_netcdf,open_partoutput_file,close_partoutput_file
+ use omp_lib, only: OMP_GET_THREAD_NUM
+#endif
+
+ implicit none
+
+ real(kind=dp) :: jul
+ integer :: itime,i,j,jjjjmmdd,ihmmss
+ !integer :: ix,jy,ixp,jyp,indexh,m,il,ind,indz,indzp
+ !real :: xlon,ylat,ztemp
+ !real :: topo,hmixi,qvi,tri
+ !real :: tti,rhoi,pvi
+ real :: tr(2),hm(2)
+ character :: adate*8,atime*6
+
+ real :: xlon(numpart),ylat(numpart),ztemp1,ztemp2
+ real :: tti(numpart),rhoi(numpart),pvi(numpart),qvi(numpart)
+ real :: topo(numpart),hmixi(numpart),tri(numpart),ztemp(numpart)
+ real :: masstemp(numpart,nspec)
+ !logical :: active_per_rel(maxpoint)
+
+#ifdef USE_NCF
+ integer :: ncid, mythread, thread_divide(12),mass_divide(nspec)
+#endif
+
+ ! Some variables needed for temporal interpolation
+ !*************************************************
+ call find_time_variables(itime)
+
+!$OMP PARALLEL PRIVATE(i,tr,hm)
+!$OMP DO
+ do i=1,numpart
+ ! Take only valid particles
+ !**************************
+ xlon(i)=-1.
+ ylat(i)=-1.
+ tti(i)=-1.
+ rhoi(i)=-1.
+ pvi(i)=-1.
+ qvi(i)=-1.
+ topo(i)=-1.
+ hmixi(i)=-1.
+ tri(i)=-1.
+ ztemp(i)=-1.
+ do j=1,nspec
+ masstemp(i,j)=-1.
+ end do
+ if (part(i)%alive) then
+ xlon(i)=xlon0+part(i)%xlon*dx
+ ylat(i)=ylat0+part(i)%ylat*dy
+
+ !*****************************************************************************
+ ! Interpolate several variables (PV, specific humidity, etc.) to particle position
+ !*****************************************************************************
+ call determine_grid_coordinates(real(part(i)%xlon),real(part(i)%ylat))
+ call find_grid_distances(real(part(i)%xlon),real(part(i)%ylat))
+ ! Topography
+ !***********
+ call bilinear_horizontal_interpolation_2dim(oro,topo(i))
+
+ ! First set dz1out from interpol_mod to -1 so it only is calculated once per particle
+ !************************************************************************************
+ dz1out=-1
+ ! Potential vorticity
+ call interpol_partoutput_value('PV',pvi(i),i)
+ ! Specific humidity
+ call interpol_partoutput_value('QV',qvi(i),i)
+ ! Temperature
+ call interpol_partoutput_value('TT',tti(i),i)
+ ! Density
+ call interpol_partoutput_value('RH',rhoi(i),i)
+ ! Reset dz1out
+ !*************
+ dz1out=-1
+
+ ! Tropopause and PBL height
+ !**************************
+ ! Tropopause
+ call bilinear_horizontal_interpolation(tropopause,tr,1,1)
+ call temporal_interpolation(tr(1),tr(2),tri(i))
+ ! PBL height
+ call bilinear_horizontal_interpolation(hmix,hm,1,1)
+ call temporal_interpolation(hm(1),hm(2),hmixi(i))
+
+
+ ! Convert eta z coordinate to meters if necessary
+ !************************************************
+ call update_zeta_to_z(itime, i)
+ ztemp(i)=part(i)%z
+
+ ! Assign the masses
+ !******************
+ do j=1,nspec
+ masstemp(i,j)=part(i)%mass(j)
+ end do
+ endif
+ end do
+
+!$OMP END DO
+!$OMP END PARALLEL
+ if (numpart.gt.0) then
+ write(*,*) 'topo: ', topo(1), 'z:', part(1)%zeta,part(1)%z
+ write(*,*) 'xtra,xeta: ', part(1)%xlon
+ write(*,*) 'ytra,yeta: ', part(1)%ylat
+ write(*,*) pvi(1),qvi(1),tti(1),rhoi(1),part(1)%alive,&
+ count%alive,count%spawned,count%terminated
+ endif
+
+ ! Determine current calendar date, needed for the file name
+ !**********************************************************
+
+ jul=bdate+real(itime,kind=dp)/86400._dp
+ call caldate(jul,jjjjmmdd,ihmmss)
+ write(adate,'(i8.8)') jjjjmmdd
+ write(atime,'(i6.6)') ihmmss
+
+ if (lnetcdfout.eq.1) then
+ ! open output file
+ call open_partoutput_file(ncid)
+
+ ! Dividing the openmp threads for writing
+ j=0
+ do i=1,10
+ if (j.eq.numthreads) j = 0
+ thread_divide(i) = j
+ j = j + 1
+ end do
+ do i=1,nspec
+ if (j.eq.numthreads) j = 0
+ mass_divide(i) = j
+ j = j + 1
+ end do
+
+ ! First allocate the time and particle dimention within the netcdf file
+ call partoutput_netcdf(itime,xlon,'TI',j,ncid)
+ call partoutput_netcdf(itime,xlon,'PA',j,ncid)
+
+ ! Fill the fields in parallel
+ if (numpart.gt.0) then
+!$OMP PARALLEL PRIVATE(j,mythread)
+#ifdef USE_NCF
+ mythread = omp_get_thread_num()
+ if (mythread.eq.thread_divide(1)) call partoutput_netcdf(itime,xlon,'LO',j,ncid)
+ if (mythread.eq.thread_divide(2)) call partoutput_netcdf(itime,ylat,'LA',j,ncid)
+ if (mythread.eq.thread_divide(3)) call partoutput_netcdf(itime,ztemp,'ZZ',j,ncid)
+ !if (mythread.eq.thread_divide(12)) call partoutput_netcdf_int(itime,itramem(1:numpart),'IT',j,ncid)
+ if (mythread.eq.thread_divide(4)) call partoutput_netcdf(itime,topo,'TO',j,ncid)
+ if (mythread.eq.thread_divide(5)) call partoutput_netcdf(itime,pvi,'PV',j,ncid)
+ if (mythread.eq.thread_divide(6)) call partoutput_netcdf(itime,qvi,'QV',j,ncid)
+ if (mythread.eq.thread_divide(7)) call partoutput_netcdf(itime,rhoi,'RH',j,ncid)
+ if (mythread.eq.thread_divide(8)) call partoutput_netcdf(itime,hmixi,'HM',j,ncid)
+ if (mythread.eq.thread_divide(9)) call partoutput_netcdf(itime,tri,'TR',j,ncid)
+ if (mythread.eq.thread_divide(10)) call partoutput_netcdf(itime,tti,'TT',j,ncid)
+ do j=1,nspec
+ if (mythread.eq.mass_divide(j)) call partoutput_netcdf(itime,masstemp(:,j),'MA',j,ncid)
+ end do
+#endif
+!$OMP END PARALLEL
+ endif
+ call close_partoutput_file(ncid)
+ else
+ ! Open output file and write the output
+ !**************************************
+
+ if (ipout.eq.1.or.ipout.eq.3) then
+ open(unitpartout,file=path(2)(1:length(2))//'partposit_'//adate// &
+ atime,form='unformatted')
+ else
+ open(unitpartout,file=path(2)(1:length(2))//'partposit_end', &
+ form='unformatted')
+ endif
+
+ ! Write current time to file
+ !***************************
+
+ write(unitpartout) itime
+ do i=1,numpart
+ ! Take only valid particles
+ !**************************
+
+ if (part(i)%alive) then
+ ! Write the output
+ !*****************
+ write(unitpartout) part(i)%npoint,xlon(i),ylat(i),part(i)%z, &
+ part(i)%tstart,topo(i),pvi(i),qvi(i),rhoi(i),hmixi(i),tri(i),tti(i), &
+ (part(i)%mass(j),j=1,nspec)
+ endif
+ end do
+
+
+ write(unitpartout) -99999,-9999.9,-9999.9,-9999.9,-99999, &
+ -9999.9,-9999.9,-9999.9,-9999.9,-9999.9,-9999.9,-9999.9, &
+ (-9999.9,j=1,nspec)
+
+
+ close(unitpartout)
+ endif
+
+end subroutine partoutput
diff --git a/src/partoutput_average.f90 b/src/redundant/partoutput_average.f90
similarity index 99%
rename from src/partoutput_average.f90
rename to src/redundant/partoutput_average.f90
index 137a16ed..ecd0c577 100644
--- a/src/partoutput_average.f90
+++ b/src/redundant/partoutput_average.f90
@@ -73,7 +73,7 @@ subroutine partoutput_average(itime)
if (itra1(i).eq.itime) then
part_av_topo(i)=part_av_topo(i)/float(npart_av(i))
- part_av_z(i)=part_av_z(i)/float(npart_av(i))
+ !part_av_z(i)=part_av_z(i)/float(npart_av(i))
part_av_pv(i)=part_av_pv(i)/float(npart_av(i))
part_av_qv(i)=part_av_qv(i)/float(npart_av(i))
part_av_tt(i)=part_av_tt(i)/float(npart_av(i))
@@ -189,6 +189,8 @@ subroutine partoutput_average(itime)
! Write the output
!*****************
+
+
do i=1,numpart
if (itra1(i).eq.itime) then
write(unitpartout_average,rec=i) ishort_xlon(i),ishort_ylat(i),ishort_z(i), &
diff --git a/src/partoutput_average_mpi.f90 b/src/redundant/partoutput_average_mpi.f90
similarity index 100%
rename from src/partoutput_average_mpi.f90
rename to src/redundant/partoutput_average_mpi.f90
diff --git a/src/partoutput_mpi.f90 b/src/redundant/partoutput_mpi.f90
similarity index 100%
rename from src/partoutput_mpi.f90
rename to src/redundant/partoutput_mpi.f90
diff --git a/src/partoutput_short.f90 b/src/redundant/partoutput_short.f90
similarity index 100%
rename from src/partoutput_short.f90
rename to src/redundant/partoutput_short.f90
diff --git a/src/partoutput_short_mpi.f90 b/src/redundant/partoutput_short_mpi.f90
similarity index 100%
rename from src/partoutput_short_mpi.f90
rename to src/redundant/partoutput_short_mpi.f90
diff --git a/src/redundant/partpos_average.f90 b/src/redundant/partpos_average.f90
new file mode 100644
index 00000000..eef0c8a2
--- /dev/null
+++ b/src/redundant/partpos_average.f90
@@ -0,0 +1,120 @@
+! SPDX-FileCopyrightText: FLEXPART 1998-2019, see flexpart_license.txt
+! SPDX-License-Identifier: GPL-3.0-or-later
+
+
+subroutine partpos_average(itime,j)
+
+
+!**********************************************************************
+! This subroutine averages particle quantities, to be used for particle
+! dump (in partoutput.f90). Averaging is done over output interval.
+!**********************************************************************
+
+ use par_mod
+ use com_mod
+ use interpol_mod
+ use coordinates_ecmwf
+
+ implicit none
+
+ integer :: itime,j
+ real :: xlon,ylat,x,y,z
+ real :: topo,hm(2),hmixi,pvi,qvi
+ real :: tti,rhoi,ttemp
+ real :: uui,vvi
+ real :: tr(2),tri!,energy
+
+
+
+ ! Some variables needed for temporal interpolation
+ !*************************************************
+ call find_time_variables(itime)
+
+ xlon=xlon0+part(j)%xlon*dx
+ ylat=ylat0+part(j)%ylat*dy
+
+ !*****************************************************************************
+ ! Interpolate several variables (PV, specific humidity, etc.) to particle position
+ !*****************************************************************************
+
+ call determine_grid_coordinates(real(part(j)%xlon),real(part(j)%ylat))
+ call find_grid_distances(real(part(j)%xlon),real(part(j)%ylat))
+
+ ! Topography
+ !***********
+ call bilinear_horizontal_interpolation_2dim(oro,topo)
+
+ ! Potential vorticity, specific humidity, temperature, and density
+ !*****************************************************************
+ ! First set dz1out from interpol_mod to -1 so it only is calculated once per particle
+ !************************************************************************************
+ dz1out=-1
+ ! Potential vorticity
+ call interpol_partoutput_value('PV',pvi,j)
+ ! Specific humidity
+ call interpol_partoutput_value('QV',qvi,j)
+ ! Temperature
+ call interpol_partoutput_value('TT',tti,j)
+ ! U wind
+ call interpol_partoutput_value('UU',uui,j)
+ ! V wind
+ call interpol_partoutput_value('VV',vvi,j)
+ ! Density
+ call interpol_partoutput_value('RH',rhoi,j)
+ ! Reset dz1out
+ !*************
+ dz1out=-1
+ ! Tropopause and PBL height
+ !**************************
+ ! Tropopause
+ call bilinear_horizontal_interpolation(tropopause,tr,1,1)
+ call temporal_interpolation(tr(1),tr(2),tri)
+ ! PBL height
+ call bilinear_horizontal_interpolation(hmix,hm,1,1)
+ call temporal_interpolation(hm(1),hm(2),hmixi)
+
+ ! Convert eta z coordinate to meters if necessary. Can be moved to output only
+ !************************************************
+ call update_zeta_to_z(itime,j)
+
+ ! energy=tti*cpa+(ztemp1+topo)*9.81+qvi*2501000.+(uui**2+vvi**2)/2.
+
+ ! Add new values to sum and increase counter by one
+ !**************************************************
+
+ npart_av(j)=npart_av(j)+1
+
+ ! Calculate Cartesian 3D coordinates suitable for averaging
+ !**********************************************************
+
+ xlon=xlon*pi180
+ ylat=ylat*pi180
+ x = cos(ylat)*sin(xlon)
+ y = -1.*cos(ylat)*cos(xlon)
+ z = sin(ylat)
+
+
+ if (j.eq.1) then
+ write(*,*) 'topo: ', topo, 'z:', part(j)%zeta,part(j)%z
+ write(*,*) 'xtra,xeta: ', part(j)%xlon
+ write(*,*) 'ytra,yeta: ', part(j)%ylat
+ write(*,*) pvi,qvi,tti,uui,vvi,rhoi
+ endif
+
+ part_av_cartx(j)=part_av_cartx(j)+x
+ part_av_carty(j)=part_av_carty(j)+y
+ part_av_cartz(j)=part_av_cartz(j)+z
+ part_av_z(j)=part(j)%z!part_av_z(j)+ztemp1
+ part_av_topo(j)=part_av_topo(j)+topo
+ part_av_pv(j)=part_av_pv(j)+pvi
+ part_av_qv(j)=part_av_qv(j)+qvi
+ part_av_tt(j)=part_av_tt(j)+tti
+ part_av_uu(j)=part_av_uu(j)+uui
+ part_av_vv(j)=part_av_vv(j)+vvi
+ part_av_rho(j)=part_av_rho(j)+rhoi
+ part_av_tro(j)=part_av_tro(j)+tri
+ part_av_hmix(j)=part_av_hmix(j)+hmixi
+ ! part_av_energy(j)=part_av_energy(j)+energy
+
+return
+end subroutine partpos_average
diff --git a/src/pbl_profile.f90 b/src/redundant/pbl_profile.f90
similarity index 97%
rename from src/pbl_profile.f90
rename to src/redundant/pbl_profile.f90
index 4fc04813..439cf4e2 100644
--- a/src/pbl_profile.f90
+++ b/src/redundant/pbl_profile.f90
@@ -43,17 +43,18 @@ subroutine pbl_profile(ps,td2m,zml1,t2m,tml1,u10m,uml1,stress,hf)
!********************************************************************
use par_mod
+ use qvsat_mod
implicit none
integer :: iter
real :: ps,td2m,rhoa,zml1,t2m,tml1,u10m,uml1,ustar,hf
real :: al,alold,aldiff,tmean,crit
- real :: deltau,deltat,thetastar,psim,psih,e,ew,tv,stress
+ real :: deltau,deltat,thetastar,psim,psih,e,tv,stress
integer,parameter :: maxiter=10
real,parameter :: r1=0.74
- e=ew(td2m) ! vapor pressure
+ e=ew(td2m,ps) ! vapor pressure
tv=t2m*(1.+0.378*e/ps) ! virtual temperature
rhoa=ps/(r_air*tv) ! air density
diff --git a/src/photo_O1D.f90 b/src/redundant/photo_O1D.f90
similarity index 100%
rename from src/photo_O1D.f90
rename to src/redundant/photo_O1D.f90
diff --git a/src/psih.f90 b/src/redundant/psih.f90
similarity index 100%
rename from src/psih.f90
rename to src/redundant/psih.f90
diff --git a/src/psim.f90 b/src/redundant/psim.f90
similarity index 100%
rename from src/psim.f90
rename to src/redundant/psim.f90
diff --git a/src/raerod.f90 b/src/redundant/raerod.f90
similarity index 100%
rename from src/raerod.f90
rename to src/redundant/raerod.f90
diff --git a/src/re_initialize_particle.f90 b/src/redundant/re_initialize_particle.f90
similarity index 100%
rename from src/re_initialize_particle.f90
rename to src/redundant/re_initialize_particle.f90
diff --git a/src/readOHfield.f90 b/src/redundant/readOHfield.f90
similarity index 100%
rename from src/readOHfield.f90
rename to src/redundant/readOHfield.f90
diff --git a/src/readageclasses.f90 b/src/redundant/readageclasses.f90
similarity index 100%
rename from src/readageclasses.f90
rename to src/redundant/readageclasses.f90
diff --git a/src/readavailable.f90 b/src/redundant/readavailable.f90
similarity index 97%
rename from src/readavailable.f90
rename to src/redundant/readavailable.f90
index 8f26bc0a..06514d33 100644
--- a/src/readavailable.f90
+++ b/src/redundant/readavailable.f90
@@ -18,7 +18,7 @@ subroutine readavailable
! Variables: *
! bdate beginning date as Julian date *
! beg beginning date for windfields *
- ! end ending date for windfields *
+ ! endl ending date for windfields *
! fname filename of wind field, help variable *
! ideltas [s] duration of modelling period *
! idiff time difference between 2 wind fields *
@@ -45,7 +45,7 @@ subroutine readavailable
integer :: i,idiff,ldat,ltim,wftime1(maxwf),numbwfn(maxnests),k
integer :: wftime1n(maxnests,maxwf),wftimen(maxnests,maxwf)
logical :: lwarntd=.true.
- real(kind=dp) :: juldate,jul,beg,end
+ real(kind=dp) :: juldate,jul,beg,endl
character(len=255) :: fname,spec,wfname1(maxwf),wfspec1(maxwf)
character(len=255) :: wfname1n(maxnests,maxwf)
character(len=40) :: wfspec1n(maxnests,maxwf)
@@ -58,12 +58,12 @@ subroutine readavailable
if (ideltas.gt.0) then ! forward trajectories
beg=bdate-1._dp
- end=bdate+real(ideltas,kind=dp)/86400._dp+real(idiffmax,kind=dp)/ &
+ endl=bdate+real(ideltas,kind=dp)/86400._dp+real(idiffmax,kind=dp)/ &
86400._dp
else ! backward trajectories
beg=bdate+real(ideltas,kind=dp)/86400._dp-real(idiffmax,kind=dp)/ &
86400._dp
- end=bdate+1._dp
+ endl=bdate+1._dp
endif
! Open the wind field availability file and read available wind fields
@@ -81,7 +81,7 @@ subroutine readavailable
100 read(unitavailab,'(i8,1x,i6,2(6x,a255))',end=99) &
ldat,ltim,fname,spec
jul=juldate(ldat,ltim)
- if ((jul.ge.beg).and.(jul.le.end)) then
+ if ((jul.ge.beg).and.(jul.le.endl)) then
numbwf=numbwf+1
if (numbwf.gt.maxwf) then ! check exceedance of dimension
write(*,*) 'Number of wind fields needed is too great.'
@@ -118,7 +118,7 @@ subroutine readavailable
700 read(unitavailab,'(i8,1x,i6,2(6x,a255))',end=699) ldat, &
ltim,fname,spec
jul=juldate(ldat,ltim)
- if ((jul.ge.beg).and.(jul.le.end)) then
+ if ((jul.ge.beg).and.(jul.le.endl)) then
numbwfn(k)=numbwfn(k)+1
if (numbwfn(k).gt.maxwf) then ! check exceedance of dimension
write(*,*) 'Number of nested wind fields is too great.'
diff --git a/src/readcommand.f90 b/src/redundant/readcommand.f90
similarity index 97%
rename from src/readcommand.f90
rename to src/redundant/readcommand.f90
index a59fbdf8..6b758578 100644
--- a/src/readcommand.f90
+++ b/src/redundant/readcommand.f90
@@ -98,7 +98,8 @@ subroutine readcommand
linversionout, &
ohfields_path, &
d_trop, &
- d_strat
+ d_strat, &
+ grid_output !LB
! Presetting namelist command
ldirect=0
@@ -133,6 +134,7 @@ subroutine readcommand
cblflag=0 ! if using old-style COMMAND file, set to 1 here to use mc cbl routine
linversionout=0
ohfields_path="../../flexin/"
+ grid_output=1 !LB, option to not write grid
!Af set release-switch
WETBKDEP=.false.
@@ -227,8 +229,11 @@ subroutine readcommand
if (old) call skplin(3,unitcommand)
read(unitcommand,*) surf_only
! Removed for backwards compatibility.
- ! if (old) call skplin(3,unitcommand) !added by mc
- ! read(unitcommand,*) cblflag !added by mc
+ if (old) call skplin(3,unitcommand) !added by mc
+ read(unitcommand,*) cblflag !added by mc
+ !LB grid output option
+ if (old) call skplin(3,unitcommand)
+ read(unitcommand,*) grid_output
close(unitcommand)
@@ -271,6 +276,11 @@ subroutine readcommand
fine=1./real(ifine)
ctl=1./ctl
+ !LB, warn if grid is not written
+ ! if (grid_output.ne.1) then
+ ! write(*,*) 'WARNING: GRID will not be written to file.'
+ ! endif
+
! Set the switches required for the various options for input/output units
!*************************************************************************
!AF Set the switches IND_REL and IND_SAMP for the release and sampling
@@ -326,7 +336,7 @@ subroutine readcommand
write(*,*) ' #### Release is performed above ground lev #### '
end if
WETBKDEP=.true.
- allocate(xscav_frac1(maxpart,maxspec))
+ !allocate(xscav_frac1(maxpart,maxspec))
case (4) ! 4 .. dry deposition in outputfield
ind_rel = 4
if (lroot) then
@@ -335,7 +345,7 @@ subroutine readcommand
write(*,*) ' #### Release is performed above ground lev #### '
end if
DRYBKDEP=.true.
- allocate(xscav_frac1(maxpart,maxspec))
+ !allocate(xscav_frac1(maxpart,maxspec))
end select
endif
diff --git a/src/readdepo.f90 b/src/redundant/readdepo.f90
similarity index 100%
rename from src/readdepo.f90
rename to src/redundant/readdepo.f90
diff --git a/src/readlanduse.f90 b/src/redundant/readlanduse.f90
similarity index 100%
rename from src/readlanduse.f90
rename to src/redundant/readlanduse.f90
diff --git a/src/readoutgrid.f90 b/src/redundant/readoutgrid.f90
similarity index 100%
rename from src/readoutgrid.f90
rename to src/redundant/readoutgrid.f90
diff --git a/src/readoutgrid_nest.f90 b/src/redundant/readoutgrid_nest.f90
similarity index 100%
rename from src/readoutgrid_nest.f90
rename to src/redundant/readoutgrid_nest.f90
diff --git a/src/readpartpositions.f90 b/src/redundant/readpartpositions.f90
similarity index 57%
rename from src/readpartpositions.f90
rename to src/redundant/readpartpositions.f90
index 5690003b..89baa714 100644
--- a/src/readpartpositions.f90
+++ b/src/redundant/readpartpositions.f90
@@ -22,10 +22,13 @@ subroutine readpartpositions
use par_mod
use com_mod
use random_mod
+ use coordinates_ecmwf
+ use particle_mod
+ use netcdf_output_mod
implicit none
- integer :: ibdatein,ibtimein,nspecin,itimein,numpointin,i,j,ix
+ integer :: ibdatein,ibtimein,nspecin,itimein,numpointin,i,j,lix,ios
integer :: id1,id2,it1,it2
real :: xlonin,ylatin,topo,hmixi,pvi,qvi,rhoi,tri,tti
character :: specin*7
@@ -37,6 +40,14 @@ subroutine readpartpositions
! Open header file of dumped particle data
!*****************************************
+ if (lnetcdfout.eq.1) then
+#ifdef USE_NCF
+ call readpartpositions_netcdf(ibtime,ibdate)
+ call get_total_part_num(numpart)
+ numparticlecount=numpart
+ return
+#endif
+ endif
open(unitpartin,file=path(2)(1:length(2))//'header', &
form='unformatted',err=998)
@@ -49,18 +60,31 @@ subroutine readpartpositions
read(unitpartin)
read(unitpartin) nspecin
nspecin=nspecin/3
- if ((ldirect.eq.1).and.(nspec.ne.nspecin)) goto 997
+ if ((ldirect.eq.1).and.(nspec.ne.nspecin)) then
+ write(*,*) ' #### FLEXPART MODEL ERROR IN READPARTPOSITIONS#### '
+ write(*,*) ' #### THE NUMBER OF SPECIES TO BE READ IN DOES #### '
+ write(*,*) ' #### NOT AGREE WITH CURRENT SETTINGS! #### '
+ stop
+ end if
do i=1,nspecin
read(unitpartin)
read(unitpartin)
read(unitpartin) j,specin
- if ((ldirect.eq.1).and.(species(i)(1:7).ne.specin)) goto 996
+ if ((ldirect.eq.1).and.(species(i)(1:7).ne.specin)) then
+ write(*,*) ' #### FLEXPART MODEL ERROR IN READPARTPOSITIONS#### '
+ write(*,*) ' #### SPECIES NAMES TO BE READ IN DO NOT #### '
+ write(*,*) ' #### AGREE WITH CURRENT SETTINGS! #### '
+ stop
+ end if
end do
read(unitpartin) numpointin
- if (numpointin.ne.numpoint) goto 995
-999 continue
+ if (numpointin.ne.numpoint) then
+ write(*,*) ' #### FLEXPART MODEL WARNING IN READPARTPOSITIONS#### '
+ write(*,*) ' #### NUMBER OF RELEASE LOCATIONS DOES NOT #### '
+ write(*,*) ' #### AGREE WITH CURRENT SETTINGS! #### '
+ end if
do i=1,numpointin
read(unitpartin)
read(unitpartin)
@@ -75,7 +99,7 @@ subroutine readpartpositions
read(unitpartin)
read(unitpartin)
- do ix=0,numxgrid-1
+ do lix=0,numxgrid-1
read(unitpartin)
end do
@@ -88,64 +112,48 @@ subroutine readpartpositions
form='unformatted',err=998)
-100 read(unitpartin,end=99) itimein
- i=0
-200 i=i+1
- read(unitpartin) npoint(i),xlonin,ylatin,ztra1(i),itramem(i), &
- topo,pvi,qvi,rhoi,hmixi,tri,tti,(xmass1(i,j),j=1,nspec)
-
- if (xlonin.eq.-9999.9) goto 100
- xtra1(i)=(xlonin-xlon0)/dx
- ytra1(i)=(ylatin-ylat0)/dy
- numparticlecount=max(numparticlecount,npoint(i))
- goto 200
+ do
+ read(unitpartin,iostat=ios) itimein
+ if (ios.lt.0) exit
+ i=0
+ do
+ i=i+1
+ read(unitpartin) part(i)%npoint,xlonin,ylatin,part(i)%z,part(i)%tstart, &
+ topo,pvi,qvi,rhoi,hmixi,tri,tti,(part(i)%mass(j),j=1,nspec)
+ ! For switching coordinates: this happens in timemanager.f90 after the first fields are read
+ if (xlonin.eq.-9999.9) exit
+ call set_xlon(i,real((xlonin-xlon0)/dx,kind=dp))
+ call set_ylat(i,real((ylatin-ylat0)/dy,kind=dp))
+ numparticlecount=max(numparticlecount,part(i)%npoint)
+ end do
+ end do
-99 numpart=i-1
+ numpart=i-1
close(unitpartin)
julin=juldate(ibdatein,ibtimein)+real(itimein,kind=dp)/86400._dp
- if (abs(julin-bdate).gt.1.e-5) goto 994
+ if (abs(julin-bdate).gt.1.e-5) then
+ write(*,*) ' #### FLEXPART MODEL ERROR IN READPARTPOSITIONS#### '
+ write(*,*) ' #### ENDING TIME OF PREVIOUS MODEL RUN DOES #### '
+ write(*,*) ' #### NOT AGREE WITH STARTING TIME OF THIS RUN.#### '
+ call caldate(julin,id1,it1)
+ call caldate(bdate,id2,it2)
+ write(*,*) 'julin: ',julin,id1,it1
+ write(*,*) 'bdate: ',bdate,id2,it2
+ stop
+ end if
do i=1,numpart
julpartin=juldate(ibdatein,ibtimein)+ &
- real(itramem(i),kind=dp)/86400._dp
- nclass(i)=min(int(ran1(idummy)*real(nclassunc))+1, &
+ real(part(i)%tstart,kind=dp)/86400._dp
+ part(i)%nclass=min(int(ran1(idummy)*real(nclassunc))+1, &
nclassunc)
- idt(i)=mintime
- itra1(i)=0
- itramem(i)=nint((julpartin-bdate)*86400.)
- itrasplit(i)=ldirect*itsplit
+ part(i)%idt=mintime
+ part(i)%tstart=nint((julpartin-bdate)*86400.)
end do
return
-
-994 write(*,*) ' #### FLEXPART MODEL ERROR IN READPARTPOSITIONS#### '
- write(*,*) ' #### ENDING TIME OF PREVIOUS MODEL RUN DOES #### '
- write(*,*) ' #### NOT AGREE WITH STARTING TIME OF THIS RUN.#### '
- call caldate(julin,id1,it1)
- call caldate(bdate,id2,it2)
- write(*,*) 'julin: ',julin,id1,it1
- write(*,*) 'bdate: ',bdate,id2,it2
- stop
-
-!995 write(*,*) ' #### FLEXPART MODEL ERROR IN READPARTPOSITIONS#### '
-995 write(*,*) ' #### FLEXPART MODEL WARNING IN READPARTPOSITIONS#### '
- write(*,*) ' #### NUMBER OF RELEASE LOCATIONS DOES NOT #### '
- write(*,*) ' #### AGREE WITH CURRENT SETTINGS! #### '
-! stop
- goto 999
-
-996 write(*,*) ' #### FLEXPART MODEL ERROR IN READPARTPOSITIONS#### '
- write(*,*) ' #### SPECIES NAMES TO BE READ IN DO NOT #### '
- write(*,*) ' #### AGREE WITH CURRENT SETTINGS! #### '
- stop
-
-997 write(*,*) ' #### FLEXPART MODEL ERROR IN READPARTPOSITIONS#### '
- write(*,*) ' #### THE NUMBER OF SPECIES TO BE READ IN DOES #### '
- write(*,*) ' #### NOT AGREE WITH CURRENT SETTINGS! #### '
- stop
-
998 write(*,*) ' #### FLEXPART MODEL ERROR! THE FILE #### '
write(*,*) ' #### '//path(2)(1:length(2))//'grid'//' #### '
write(*,*) ' #### CANNOT BE OPENED. IF A FILE WITH THIS #### '
diff --git a/src/readpartpositions_mpi.f90 b/src/redundant/readpartpositions_mpi.f90
similarity index 100%
rename from src/readpartpositions_mpi.f90
rename to src/redundant/readpartpositions_mpi.f90
diff --git a/src/readpaths.f90 b/src/redundant/readpaths.f90
similarity index 100%
rename from src/readpaths.f90
rename to src/redundant/readpaths.f90
diff --git a/src/readreceptors.f90 b/src/redundant/readreceptors.f90
similarity index 100%
rename from src/readreceptors.f90
rename to src/redundant/readreceptors.f90
diff --git a/src/readreleases.f90 b/src/redundant/readreleases.f90
similarity index 93%
rename from src/readreleases.f90
rename to src/redundant/readreleases.f90
index b25bf624..6907b81a 100644
--- a/src/readreleases.f90
+++ b/src/redundant/readreleases.f90
@@ -595,7 +595,7 @@ subroutine readreleases
close(unitreleasesout)
endif
- if (lroot) write (*,*) 'Particles allocated (maxpart) : ',maxpart
+ !if (lroot) write (*,*) 'Particles allocated (maxpart) : ',maxpart
if (lroot) write (*,*) 'Particles released (numpartmax): ',numpartmax
numpoint=numpoint-1
@@ -632,31 +632,31 @@ subroutine readreleases
! number of particles at some time during the simulation
!************************************************************************
- if (releaserate.gt. &
- 0.99*real(maxpart)/real(lage(nageclass))) then
- if (numpartmax.gt.maxpart.and.lroot) then
- write(*,*) '#####################################################'
- write(*,*) '#### FLEXPART MODEL SUBROUTINE READRELEASES: ####'
- write(*,*) '#### ####'
- write(*,*) '####WARNING - TOTAL NUMBER OF PARTICLES SPECIFIED####'
- write(*,*) '#### IN FILE "RELEASES" MAY AT SOME POINT DURING ####'
- write(*,*) '#### THE SIMULATION EXCEED THE MAXIMUM ALLOWED ####'
- write(*,*) '#### NUMBER (MAXPART).IF RELEASES DO NOT OVERLAP,####'
- write(*,*) '#### FLEXPART CAN POSSIBLY COMPLETE SUCCESSFULLY.####'
- write(*,*) '#### HOWEVER, FLEXPART MAY HAVE TO STOP ####'
- write(*,*) '#### AT SOME TIME DURING THE SIMULATION. PLEASE ####'
- write(*,*) '#### MAKE SURE THAT YOUR SETTINGS ARE CORRECT. ####'
- write(*,*) '#####################################################'
- write(*,*) 'Maximum release rate may be: ',releaserate, &
- ' particles per second'
- write(*,*) 'Maximum allowed release rate is: ', &
- real(maxpart)/real(lage(nageclass)),' particles per second'
- write(*,*) &
- 'Total number of particles released during the simulation is: ', &
- numpartmax
- write(*,*) 'Maximum allowed number of particles is: ',maxpart
- endif
- endif
+ ! if (releaserate.gt. &
+ ! 0.99*real(maxpart)/real(lage(nageclass))) then
+ ! if (numpartmax.gt.maxpart.and.lroot) then
+ ! write(*,*) '#####################################################'
+ ! write(*,*) '#### FLEXPART MODEL SUBROUTINE READRELEASES: ####'
+ ! write(*,*) '#### ####'
+ ! write(*,*) '####WARNING - TOTAL NUMBER OF PARTICLES SPECIFIED####'
+ ! write(*,*) '#### IN FILE "RELEASES" MAY AT SOME POINT DURING ####'
+ ! write(*,*) '#### THE SIMULATION EXCEED THE MAXIMUM ALLOWED ####'
+ ! write(*,*) '#### NUMBER (MAXPART).IF RELEASES DO NOT OVERLAP,####'
+ ! write(*,*) '#### FLEXPART CAN POSSIBLY COMPLETE SUCCESSFULLY.####'
+ ! write(*,*) '#### HOWEVER, FLEXPART MAY HAVE TO STOP ####'
+ ! write(*,*) '#### AT SOME TIME DURING THE SIMULATION. PLEASE ####'
+ ! write(*,*) '#### MAKE SURE THAT YOUR SETTINGS ARE CORRECT. ####'
+ ! write(*,*) '#####################################################'
+ ! write(*,*) 'Maximum release rate may be: ',releaserate, &
+ ! ' particles per second'
+ ! write(*,*) 'Maximum allowed release rate is: ', &
+ ! real(maxpart)/real(lage(nageclass)),' particles per second'
+ ! write(*,*) &
+ ! 'Total number of particles released during the simulation is: ', &
+ ! numpartmax
+ ! write(*,*) 'Maximum allowed number of particles is: ',maxpart
+ ! endif
+ ! endif
if (lroot) then
diff --git a/src/readspecies.f90 b/src/redundant/readspecies.f90
similarity index 100%
rename from src/readspecies.f90
rename to src/redundant/readspecies.f90
diff --git a/src/readwind_ecmwf.f90 b/src/redundant/readwind_ecmwf.f90
similarity index 54%
rename from src/readwind_ecmwf.f90
rename to src/redundant/readwind_ecmwf.f90
index 7b202b43..95b407fd 100644
--- a/src/readwind_ecmwf.f90
+++ b/src/redundant/readwind_ecmwf.f90
@@ -58,15 +58,17 @@ subroutine readwind_ecmwf(indj,n,uuh,vvh,wwh)
!HSO parameters for grib_api
integer :: ifile
integer :: iret
- integer :: igrib
+ integer, dimension(:), allocatable :: igrib
+ integer :: nfield, ii, arsize
integer :: gribVer,parCat,parNum,typSurf,valSurf,discipl,parId
integer :: gotGrid
!HSO end
- real(sp) :: uuh(0:nxmax-1,0:nymax-1,nuvzmax)
- real(sp) :: vvh(0:nxmax-1,0:nymax-1,nuvzmax)
- real(sp) :: wwh(0:nxmax-1,0:nymax-1,nwzmax)
- integer :: indj,i,j,k,n,levdiff2,ifield,iumax,iwmax
+ real(kind=4) :: uuh(0:nxmax-1,0:nymax-1,nuvzmax)
+ real(kind=4) :: vvh(0:nxmax-1,0:nymax-1,nuvzmax)
+ real(kind=4) :: wwh(0:nxmax-1,0:nymax-1,nwzmax)
+ integer :: indj,i,j,k,n,levdiff2,iumax,iwmax!,ifield
+ integer :: kz
! VARIABLES AND ARRAYS NEEDED FOR GRIB DECODING
@@ -77,12 +79,14 @@ subroutine readwind_ecmwf(indj,n,uuh,vvh,wwh)
! coordinate parameters
integer :: isec1(56),isec2(22+nxmax+nymax)
- real(sp) :: zsec4(jpunp)
- real(sp) :: xaux,yaux
- real(dp) :: xauxin,yauxin
- real(sp),parameter :: eps=1.e-4
- real(sp) :: nsss(0:nxmax-1,0:nymax-1),ewss(0:nxmax-1,0:nymax-1)
- real(sp) :: plev1,pmean,tv,fu,hlev1,ff10m,fflev1,conversion_factor
+ real(kind=4), allocatable, dimension(:) :: zsec4
+! real(kind=4) :: zsec4(jpunp)
+ real(kind=4) :: xaux,yaux,xaux0,yaux0
+ real(kind=8) :: xauxin,yauxin
+ real,parameter :: eps=1.e-4
+ real(kind=4) :: nsss(0:nxmax-1,0:nymax-1),ewss(0:nxmax-1,0:nymax-1)
+ real :: plev1,pmean,tv,fu,hlev1,ff10m,fflev1,conversion_factor
+ integer :: stat
logical :: hflswitch,strswitch!,readcloud
@@ -107,33 +111,57 @@ subroutine readwind_ecmwf(indj,n,uuh,vvh,wwh)
if (iret.ne.GRIB_SUCCESS) then
goto 888 ! ERROR DETECTED
endif
+
+ call grib_count_in_file(ifile,nfield)
+
+ ! allocate memory for grib handles
+ allocate(igrib(nfield), stat=stat)
+ if (stat.ne.0) stop "Could not allocate igrib"
+ ! initialise
+ igrib(:) = -1
+
+ do ii = 1,nfield
+ call grib_new_from_file(ifile, igrib(ii), iret)
+ end do
+
+ call grib_close_file(ifile)
+
!turn on support for multi fields messages */
!call grib_multi_support_on
gotGrid=0
- ifield=0
-10 ifield=ifield+1
+
+!$OMP PARALLEL DEFAULT(none) &
+!$OMP SHARED (nfield, igrib, gribFunction, nxfield, ny, nlev_ec, dx, xlon0, ylat0, &
+!$OMP n, tth, uuh, vvh, iumax, qvh, ps, wwh, iwmax, sd, msl, tcc, u10, v10, tt2, &
+!$OMP td2, lsprec, convprec, sshf, hflswitch, ssr, ewss, nsss, strswitch, oro, &
+!$OMP excessoro, lsm, nymin1,ciwch,clwch,readclouds,sumclouds) &
+!$OMP PRIVATE(ii, gribVer, iret, isec1, discipl, parCat, parNum, parId,typSurf, valSurf, &
+!$OMP zsec4, isec2, gribErrorMsg, xauxin, yauxin, xaux, yaux, xaux0, &
+!$OMP yaux0, k, arsize, stat, conversion_factor) &
+!$OMP REDUCTION(+:gotGrid)
!
! GET NEXT FIELDS
!
- call grib_new_from_file(ifile,igrib,iret)
- if (iret.eq.GRIB_END_OF_FILE) then
- goto 50 ! EOF DETECTED
- elseif (iret.ne.GRIB_SUCCESS) then
- goto 888 ! ERROR DETECTED
- endif
+ ! allocate memory for reading from grib
+ allocate(zsec4(nxfield*ny), stat=stat)
+ if (stat.ne.0) stop "Could not allocate zsec4"
+
+!$OMP DO SCHEDULE(static)
+
+ fieldloop : do ii=1,nfield
!first see if we read GRIB1 or GRIB2
- call grib_get_int(igrib,'editionNumber',gribVer,iret)
+ call grib_get_int(igrib(ii),'editionNumber',gribVer,iret)
call grib_check(iret,gribFunction,gribErrorMsg)
if (gribVer.eq.1) then ! GRIB Edition 1
-!print*,'GRiB Edition 1'
-!read the grib2 identifiers
- call grib_get_int(igrib,'indicatorOfParameter',isec1(6),iret)
+ !print*,'GRiB Edition 1'
+ !read the grib2 identifiers
+ call grib_get_int(igrib(ii),'indicatorOfParameter',isec1(6),iret)
call grib_check(iret,gribFunction,gribErrorMsg)
- call grib_get_int(igrib,'level',isec1(8),iret)
+ call grib_get_int(igrib(ii),'level',isec1(8),iret)
call grib_check(iret,gribFunction,gribErrorMsg)
!change code for etadot to code for omega
@@ -147,17 +175,17 @@ subroutine readwind_ecmwf(indj,n,uuh,vvh,wwh)
!print*,'GRiB Edition 2'
!read the grib2 identifiers
- call grib_get_int(igrib,'discipline',discipl,iret)
+ call grib_get_int(igrib(ii),'discipline',discipl,iret)
call grib_check(iret,gribFunction,gribErrorMsg)
- call grib_get_int(igrib,'parameterCategory',parCat,iret)
+ call grib_get_int(igrib(ii),'parameterCategory',parCat,iret)
call grib_check(iret,gribFunction,gribErrorMsg)
- call grib_get_int(igrib,'parameterNumber',parNum,iret)
+ call grib_get_int(igrib(ii),'parameterNumber',parNum,iret)
call grib_check(iret,gribFunction,gribErrorMsg)
- call grib_get_int(igrib,'typeOfFirstFixedSurface',typSurf,iret)
+ call grib_get_int(igrib(ii),'typeOfFirstFixedSurface',typSurf,iret)
call grib_check(iret,gribFunction,gribErrorMsg)
- call grib_get_int(igrib,'level',valSurf,iret)
+ call grib_get_int(igrib(ii),'level',valSurf,iret)
call grib_check(iret,gribFunction,gribErrorMsg)
- call grib_get_int(igrib,'paramId',parId,iret)
+ call grib_get_int(igrib(ii),'paramId',parId,iret)
call grib_check(iret,gribFunction,gribErrorMsg)
!print*,discipl,parCat,parNum,typSurf,valSurf
@@ -242,17 +270,17 @@ subroutine readwind_ecmwf(indj,n,uuh,vvh,wwh)
!HSO get the size and data of the values array
if (isec1(6).ne.-1) then
- call grib_get_real4_array(igrib,'values',zsec4,iret)
+ call grib_get_real4_array(igrib(ii),'values',zsec4,iret)
call grib_check(iret,gribFunction,gribErrorMsg)
endif
!HSO get the required fields from section 2 in a gribex compatible manner
- if (ifield.eq.1) then
- call grib_get_int(igrib,'numberOfPointsAlongAParallel',isec2(2),iret)
+ if (ii.eq.1) then
+ call grib_get_int(igrib(ii),'numberOfPointsAlongAParallel',isec2(2),iret)
call grib_check(iret,gribFunction,gribErrorMsg)
- call grib_get_int(igrib,'numberOfPointsAlongAMeridian',isec2(3),iret)
+ call grib_get_int(igrib(ii),'numberOfPointsAlongAMeridian',isec2(3),iret)
call grib_check(iret,gribFunction,gribErrorMsg)
- call grib_get_int(igrib,'numberOfVerticalCoordinateValues',isec2(12))
+ call grib_get_int(igrib(ii),'numberOfVerticalCoordinateValues',isec2(12))
call grib_check(iret,gribFunction,gribErrorMsg)
! CHECK GRID SPECIFICATIONS
if(isec2(2).ne.nxfield) stop 'READWIND: NX NOT CONSISTENT'
@@ -261,12 +289,13 @@ subroutine readwind_ecmwf(indj,n,uuh,vvh,wwh)
stop 'READWIND: VERTICAL DISCRETIZATION NOT CONSISTENT'
endif ! ifield
+!$OMP CRITICAL
!HSO get the second part of the grid dimensions only from GRiB1 messages
if (isec1(6) .eq. 167 .and. (gotGrid.eq.0)) then
- call grib_get_real8(igrib,'longitudeOfFirstGridPointInDegrees', &
+ call grib_get_real8(igrib(ii),'longitudeOfFirstGridPointInDegrees', &
xauxin,iret)
call grib_check(iret,gribFunction,gribErrorMsg)
- call grib_get_real8(igrib,'latitudeOfLastGridPointInDegrees', &
+ call grib_get_real8(igrib(ii),'latitudeOfLastGridPointInDegrees', &
yauxin,iret)
call grib_check(iret,gribFunction,gribErrorMsg)
if (xauxin.gt.180.) xauxin=xauxin-360.0
@@ -281,102 +310,321 @@ subroutine readwind_ecmwf(indj,n,uuh,vvh,wwh)
stop 'READWIND: LOWER LEFT LATITUDE NOT CONSISTENT'
gotGrid=1
endif ! gotGrid
+!$OMP END CRITICAL
- do j=0,nymin1
- do i=0,nxfield-1
- k=isec1(8)
- if(isec1(6).eq.130) tth(i,j,nlev_ec-k+2,n)= &!! TEMPERATURE
- zsec4(nxfield*(ny-j-1)+i+1)
- if(isec1(6).eq.131) uuh(i,j,nlev_ec-k+2)= &!! U VELOCITY
- zsec4(nxfield*(ny-j-1)+i+1)
- if(isec1(6).eq.132) vvh(i,j,nlev_ec-k+2)= &!! V VELOCITY
- zsec4(nxfield*(ny-j-1)+i+1)
- if(isec1(6).eq.133) then !! SPEC. HUMIDITY
- qvh(i,j,nlev_ec-k+2,n)=zsec4(nxfield*(ny-j-1)+i+1)
- if (qvh(i,j,nlev_ec-k+2,n) .lt. 0.) &
- qvh(i,j,nlev_ec-k+2,n) = 0.
-! this is necessary because the gridded data may contain
-! spurious negative values
- endif
- if(isec1(6).eq.134) ps(i,j,1,n)= &!! SURF. PRESS.
- zsec4(nxfield*(ny-j-1)+i+1)
-
- if(isec1(6).eq.135) wwh(i,j,nlev_ec-k+1)= &!! W VELOCITY
- zsec4(nxfield*(ny-j-1)+i+1)
- if(isec1(6).eq.141) sd(i,j,1,n)= &!! SNOW DEPTH
- zsec4(nxfield*(ny-j-1)+i+1)/conversion_factor
- if(isec1(6).eq.151) msl(i,j,1,n)= &!! SEA LEVEL PRESS.
- zsec4(nxfield*(ny-j-1)+i+1)
- if(isec1(6).eq.164) tcc(i,j,1,n)= &!! CLOUD COVER
- zsec4(nxfield*(ny-j-1)+i+1)
- if(isec1(6).eq.165) u10(i,j,1,n)= &!! 10 M U VELOCITY
- zsec4(nxfield*(ny-j-1)+i+1)
- if(isec1(6).eq.166) v10(i,j,1,n)= &!! 10 M V VELOCITY
- zsec4(nxfield*(ny-j-1)+i+1)
- if(isec1(6).eq.167) tt2(i,j,1,n)= &!! 2 M TEMPERATURE
- zsec4(nxfield*(ny-j-1)+i+1)
- if(isec1(6).eq.168) td2(i,j,1,n)= &!! 2 M DEW POINT
- zsec4(nxfield*(ny-j-1)+i+1)
- if(isec1(6).eq.142) then !! LARGE SCALE PREC.
- lsprec(i,j,1,n)=zsec4(nxfield*(ny-j-1)+i+1)
- if (lsprec(i,j,1,n).lt.0.) lsprec(i,j,1,n)=0.
- endif
- if(isec1(6).eq.143) then !! CONVECTIVE PREC.
- convprec(i,j,1,n)=zsec4(nxfield*(ny-j-1)+i+1)/conversion_factor
- if (convprec(i,j,1,n).lt.0.) convprec(i,j,1,n)=0.
- endif
- if(isec1(6).eq.146) sshf(i,j,1,n)= &!! SENS. HEAT FLUX
- zsec4(nxfield*(ny-j-1)+i+1)
- if((isec1(6).eq.146).and.(zsec4(nxfield*(ny-j-1)+i+1).ne.0.)) &
- hflswitch=.true. ! Heat flux available
- if(isec1(6).eq.176) then !! SOLAR RADIATION
- ssr(i,j,1,n)=zsec4(nxfield*(ny-j-1)+i+1)
- if (ssr(i,j,1,n).lt.0.) ssr(i,j,1,n)=0.
- endif
- if(isec1(6).eq.180) ewss(i,j)= &!! EW SURFACE STRESS
- zsec4(nxfield*(ny-j-1)+i+1)
- if(isec1(6).eq.181) nsss(i,j)= &!! NS SURFACE STRESS
- zsec4(nxfield*(ny-j-1)+i+1)
- if(((isec1(6).eq.180).or.(isec1(6).eq.181)).and. &
- (zsec4(nxfield*(ny-j-1)+i+1).ne.0.)) strswitch=.true. ! stress available
-!sec strswitch=.true.
- if(isec1(6).eq.129) oro(i,j)= &!! ECMWF OROGRAPHY
- zsec4(nxfield*(ny-j-1)+i+1)/ga
- if(isec1(6).eq.160) excessoro(i,j)= &!! STANDARD DEVIATION OF OROGRAPHY
- zsec4(nxfield*(ny-j-1)+i+1)
- if(isec1(6).eq.172) lsm(i,j)= &!! ECMWF LAND SEA MASK
- zsec4(nxfield*(ny-j-1)+i+1)
- if(isec1(6).eq.131) iumax=max(iumax,nlev_ec-k+1)
- if(isec1(6).eq.135) iwmax=max(iwmax,nlev_ec-k+1)
+ k=isec1(8)
+ select case(isec1(6))
+!! TEMPERATURE
+ case(130)
+ do j=0,nymin1
+ do i=0,nxfield-1
+ tth(i,j,nlev_ec-k+2,n) = zsec4(nxfield*(ny-j-1)+i+1)
+ end do
+ end do
+!! U VELOCITY
+ case(131)
+ do j=0,nymin1
+ do i=0,nxfield-1
+ uuh(i,j,nlev_ec-k+2) = zsec4(nxfield*(ny-j-1)+i+1)
+ end do
+ end do
+!$OMP CRITICAL
+ iumax=max(iumax,nlev_ec-k+1)
+!$OMP END CRITICAL
+!! V VELOCITY
+ case(132)
+ do j=0,nymin1
+ do i=0,nxfield-1
+ vvh(i,j,nlev_ec-k+2) = zsec4(nxfield*(ny-j-1)+i+1)
+ end do
+ end do
+!! SPEC. HUMIDITY
+ case(133)
+ do j=0,nymin1
+ do i=0,nxfield-1
+ qvh(i,j,nlev_ec-k+2,n) = zsec4(nxfield*(ny-j-1)+i+1)
+ if (qvh(i,j,nlev_ec-k+2,n) .lt. 0.) &
+ qvh(i,j,nlev_ec-k+2,n) = 0.
+ ! this is necessary because the gridded data may contain
+ ! spurious negative values
+ end do
+ end do
+!! SURF. PRESS.
+ case(134)
+ do j=0,nymin1
+ do i=0,nxfield-1
+ ps(i,j,1,n) = zsec4(nxfield*(ny-j-1)+i+1)
+ end do
+ end do
+!! W VELOCITY
+ case(135)
+ do j=0,nymin1
+ do i=0,nxfield-1
+ wwh(i,j,nlev_ec-k+1) = zsec4(nxfield*(ny-j-1)+i+1)
+ end do
+ end do
+!$OMP CRITICAL
+ iwmax=max(iwmax,nlev_ec-k+1)
+!$OMP END CRITICAL
+!! SNOW DEPTH
+ case(141)
+ do j=0,nymin1
+ do i=0,nxfield-1
+ sd(i,j,1,n)= zsec4(nxfield*(ny-j-1)+i+1)/conversion_factor
+ end do
+ end do
+!! SEA LEVEL PRESS.
+ case(151)
+ do j=0,nymin1
+ do i=0,nxfield-1
+ msl(i,j,1,n) = zsec4(nxfield*(ny-j-1)+i+1)
+ end do
+ end do
+!! CLOUD COVER
+ case(164)
+ do j=0,nymin1
+ do i=0,nxfield-1
+ tcc(i,j,1,n) = zsec4(nxfield*(ny-j-1)+i+1)
+ end do
+ end do
+!! 10 M U VELOCITY
+ case(165)
+ do j=0,nymin1
+ do i=0,nxfield-1
+ u10(i,j,1,n)= zsec4(nxfield*(ny-j-1)+i+1)
+ end do
+ end do
+!! 10 M V VELOCITY
+ case(166)
+ do j=0,nymin1
+ do i=0,nxfield-1
+ v10(i,j,1,n) = zsec4(nxfield*(ny-j-1)+i+1)
+ end do
+ end do
+!! 2 M TEMPERATURE
+ case(167)
+ do j=0,nymin1
+ do i=0,nxfield-1
+ tt2(i,j,1,n) = zsec4(nxfield*(ny-j-1)+i+1)
+ end do
+ end do
+!! 2 M DEW POINT
+ case(168)
+ do j=0,nymin1
+ do i=0,nxfield-1
+ td2(i,j,1,n) = zsec4(nxfield*(ny-j-1)+i+1)
+ end do
+ end do
+!! LARGE SCALE PREC.
+ case(142)
+ do j=0,nymin1
+ do i=0,nxfield-1
+ lsprec(i,j,1,n)=zsec4(nxfield*(ny-j-1)+i+1)
+ if (lsprec(i,j,1,n).lt.0.) lsprec(i,j,1,n)=0.
+ end do
+ end do
+!! CONVECTIVE PREC.
+ case(143)
+ do j=0,nymin1
+ do i=0,nxfield-1
+ convprec(i,j,1,n)=zsec4(nxfield*(ny-j-1)+i+1)/conversion_factor
+ if (convprec(i,j,1,n).lt.0.) convprec(i,j,1,n)=0.
+ end do
+ end do
+!! SENS. HEAT FLUX
+ case(146)
+ do j=0,nymin1
+ do i=0,nxfield-1
+ sshf(i,j,1,n) = zsec4(nxfield*(ny-j-1)+i+1)
+!$OMP CRITICAL
+ if(zsec4(nxfield*(ny-j-1)+i+1).ne.0.) &
+ hflswitch=.true. ! Heat flux available
+!$OMP END CRITICAL
+ end do
+ end do
+!! SOLAR RADIATION
+ case(176)
+ do j=0,nymin1
+ do i=0,nxfield-1
+ ssr(i,j,1,n)=zsec4(nxfield*(ny-j-1)+i+1)
+ if (ssr(i,j,1,n).lt.0.) ssr(i,j,1,n)=0.
+ end do
+ end do
+!! EW SURFACE STRESS
+ case(180)
+ do j=0,nymin1
+ do i=0,nxfield-1
+ ewss(i,j) = zsec4(nxfield*(ny-j-1)+i+1)
+!$OMP CRITICAL
+ if (zsec4(nxfield*(ny-j-1)+i+1).ne.0.) strswitch=.true. ! stress available
+!$OMP END CRITICAL
+ end do
+ end do
+!! NS SURFACE STRESS
+ case(181)
+ do j=0,nymin1
+ do i=0,nxfield-1
+ nsss(i,j) = zsec4(nxfield*(ny-j-1)+i+1)
+!$OMP CRITICAL
+ if (zsec4(nxfield*(ny-j-1)+i+1).ne.0.) strswitch=.true. ! stress available
+!$OMP END CRITICAL
+ end do
+ end do
+!! ECMWF OROGRAPHY
+ case(129)
+ do j=0,nymin1
+ do i=0,nxfield-1
+ oro(i,j) = zsec4(nxfield*(ny-j-1)+i+1)/ga
+ end do
+ end do
+!! STANDARD DEVIATION OF OROGRAPHY
+ case(160)
+ do j=0,nymin1
+ do i=0,nxfield-1
+ excessoro(i,j) = zsec4(nxfield*(ny-j-1)+i+1)
+ end do
+ end do
+!! ECMWF LAND SEA MASK
+ case(172)
+ do j=0,nymin1
+ do i=0,nxfield-1
+ lsm(i,j) = zsec4(nxfield*(ny-j-1)+i+1)
+ end do
+ end do
+!! CLWC Cloud liquid water content [kg/kg]
+ case(246)
+ do j=0,nymin1
+ do i=0,nxfield-1
+ clwch(i,j,nlev_ec-k+2,n)=zsec4(nxfield*(ny-j-1)+i+1)
+ end do
+ end do
+!$OMP CRITICAL
+ readclouds=.true.
+ sumclouds=.false.
+!$OMP END CRITICAL
+!! CIWC Cloud ice water content
+ case(247)
+ do j=0,nymin1
+ do i=0,nxfield-1
+ ciwch(i,j,nlev_ec-k+2,n)=zsec4(nxfield*(ny-j-1)+i+1)
+ end do
+ end do
+!ZHG end
+!ESO read qc (=clwc+ciwc)
+!! QC Cloud liquid water content [kg/kg]
+ case(201031)
+ do j=0,nymin1
+ do i=0,nxfield-1
+ clwch(i,j,nlev_ec-k+2,n)=zsec4(nxfield*(ny-j-1)+i+1)
+ end do
+ end do
+!$OMP CRITICAL
+ readclouds=.true.
+ sumclouds=.false.
+!$OMP END CRITICAL
+
+ end select
+ ! do j=0,nymin1
+ ! do i=0,nxfield-1
+ ! k=isec1(8)
+ ! if(isec1(6).eq.130) tth(i,j,nlev_ec-k+2,n)= &!! TEMPERATURE
+ ! zsec4(nxfield*(ny-j-1)+i+1)
+ ! if(isec1(6).eq.131) uuh(i,j,nlev_ec-k+2)= &!! U VELOCITY
+ ! zsec4(nxfield*(ny-j-1)+i+1)
+ ! if(isec1(6).eq.132) vvh(i,j,nlev_ec-k+2)= &!! V VELOCITY
+ ! zsec4(nxfield*(ny-j-1)+i+1)
+! if(isec1(6).eq.133) then !! SPEC. HUMIDITY
+! qvh(i,j,nlev_ec-k+2,n)=zsec4(nxfield*(ny-j-1)+i+1)
+! if (qvh(i,j,nlev_ec-k+2,n) .lt. 0.) &
+! qvh(i,j,nlev_ec-k+2,n) = 0.
+! ! this is necessary because the gridded data may contain
+! ! spurious negative values
+! endif
+ ! if(isec1(6).eq.134) ps(i,j,1,n)= &!! SURF. PRESS.
+ ! zsec4(nxfield*(ny-j-1)+i+1)
+
+ ! if(isec1(6).eq.135) wwh(i,j,nlev_ec-k+1)= &!! W VELOCITY
+ ! zsec4(nxfield*(ny-j-1)+i+1)
+ ! if(isec1(6).eq.141) sd(i,j,1,n)= &!! SNOW DEPTH
+ ! zsec4(nxfield*(ny-j-1)+i+1)/conversion_factor
+ ! if(isec1(6).eq.151) msl(i,j,1,n)= &!! SEA LEVEL PRESS.
+ ! zsec4(nxfield*(ny-j-1)+i+1)
+ ! if(isec1(6).eq.164) tcc(i,j,1,n)= &!! CLOUD COVER
+ ! zsec4(nxfield*(ny-j-1)+i+1)
+ ! if(isec1(6).eq.165) u10(i,j,1,n)= &!! 10 M U VELOCITY
+ ! zsec4(nxfield*(ny-j-1)+i+1)
+ ! if(isec1(6).eq.166) v10(i,j,1,n)= &!! 10 M V VELOCITY
+ ! zsec4(nxfield*(ny-j-1)+i+1)
+ ! if(isec1(6).eq.167) tt2(i,j,1,n)= &!! 2 M TEMPERATURE
+ ! zsec4(nxfield*(ny-j-1)+i+1)
+ ! if(isec1(6).eq.168) td2(i,j,1,n)= &!! 2 M DEW POINT
+ ! zsec4(nxfield*(ny-j-1)+i+1)
+ ! if(isec1(6).eq.142) then !! LARGE SCALE PREC.
+ ! lsprec(i,j,1,n)=zsec4(nxfield*(ny-j-1)+i+1)
+ ! if (lsprec(i,j,1,n).lt.0.) lsprec(i,j,1,n)=0.
+ ! endif
+ ! if(isec1(6).eq.143) then !! CONVECTIVE PREC.
+ ! convprec(i,j,1,n)=zsec4(nxfield*(ny-j-1)+i+1)/conversion_factor
+ ! if (convprec(i,j,1,n).lt.0.) convprec(i,j,1,n)=0.
+ ! endif
+ ! if(isec1(6).eq.146) sshf(i,j,1,n)= &!! SENS. HEAT FLUX
+ ! zsec4(nxfield*(ny-j-1)+i+1)
+ ! if((isec1(6).eq.146).and.(zsec4(nxfield*(ny-j-1)+i+1).ne.0.)) &
+ ! hflswitch=.true. ! Heat flux available
+ ! if(isec1(6).eq.176) then !! SOLAR RADIATION
+ ! ssr(i,j,1,n)=zsec4(nxfield*(ny-j-1)+i+1)
+ ! if (ssr(i,j,1,n).lt.0.) ssr(i,j,1,n)=0.
+ ! endif
+! if(isec1(6).eq.180) ewss(i,j)= &!! EW SURFACE STRESS
+! zsec4(nxfield*(ny-j-1)+i+1)
+! if(isec1(6).eq.181) nsss(i,j)= &!! NS SURFACE STRESS
+! zsec4(nxfield*(ny-j-1)+i+1)
+! if(((isec1(6).eq.180).or.(isec1(6).eq.181)).and. &
+! (zsec4(nxfield*(ny-j-1)+i+1).ne.0.)) strswitch=.true. ! stress available
+! !sec strswitch=.true.
+ ! if(isec1(6).eq.129) oro(i,j)= &!! ECMWF OROGRAPHY
+ ! zsec4(nxfield*(ny-j-1)+i+1)/ga
+ ! if(isec1(6).eq.160) excessoro(i,j)= &!! STANDARD DEVIATION OF OROGRAPHY
+ ! zsec4(nxfield*(ny-j-1)+i+1)
+ ! if(isec1(6).eq.172) lsm(i,j)= &!! ECMWF LAND SEA MASK
+ ! zsec4(nxfield*(ny-j-1)+i+1)
+ ! if(isec1(6).eq.131) iumax=max(iumax,nlev_ec-k+1)
+ ! if(isec1(6).eq.135) iwmax=max(iwmax,nlev_ec-k+1)
!ZHG READING CLOUD FIELDS ASWELL
! ESO TODO: add check for if one of clwc/ciwc missing (error),
! also if all 3 cw fields present, use qc and disregard the others
- if(isec1(6).eq.246) then !! CLWC Cloud liquid water content [kg/kg]
- clwch(i,j,nlev_ec-k+2,n)=zsec4(nxfield*(ny-j-1)+i+1)
- readclouds=.true.
- sumclouds=.false.
- endif
- if(isec1(6).eq.247) then !! CIWC Cloud ice water content
- ciwch(i,j,nlev_ec-k+2,n)=zsec4(nxfield*(ny-j-1)+i+1)
- endif
-!ZHG end
-!ESO read qc (=clwc+ciwc)
- if(isec1(6).eq.201031) then !! QC Cloud liquid water content [kg/kg]
- clwch(i,j,nlev_ec-k+2,n)=zsec4(nxfield*(ny-j-1)+i+1)
- readclouds=.true.
- sumclouds=.true.
- endif
-
- end do
- end do
-
- call grib_release(igrib)
- goto 10 !! READ NEXT LEVEL OR PARAMETER
+! if(isec1(6).eq.246) then !! CLWC Cloud liquid water content [kg/kg]
+! clwch(i,j,nlev_ec-k+2,n)=zsec4(nxfield*(ny-j-1)+i+1)
+! readclouds=.true.
+! sumclouds=.false.
+! endif
+! if(isec1(6).eq.247) then !! CIWC Cloud ice water content
+! ciwch(i,j,nlev_ec-k+2,n)=zsec4(nxfield*(ny-j-1)+i+1)
+! endif
+! !ZHG end
+! !ESO read qc (=clwc+ciwc)
+! if(isec1(6).eq.201031) then !! QC Cloud liquid water content [kg/kg]
+! clwch(i,j,nlev_ec-k+2,n)=zsec4(nxfield*(ny-j-1)+i+1)
+! readclouds=.true.
+! sumclouds=.true.
+! endif
+
+! end do
+! end do
+
+ call grib_release(igrib(ii))
+
+ end do fieldloop
+!$OMP END DO
+ deallocate(zsec4)
+!$OMP END PARALLEL
+
+ deallocate(igrib)
!
! CLOSING OF INPUT DATA FILE
!
-50 call grib_close_file(ifile)
+! 50 call grib_close_file(ifile)
!error message if no fields found with correct first longitude in it
if (gotGrid.eq.0) then
diff --git a/src/readwind_ecmwf_mpi.f90 b/src/redundant/readwind_ecmwf_mpi.f90
similarity index 100%
rename from src/readwind_ecmwf_mpi.f90
rename to src/redundant/readwind_ecmwf_mpi.f90
diff --git a/src/readwind_emos.f90 b/src/redundant/readwind_emos.f90
similarity index 100%
rename from src/readwind_emos.f90
rename to src/redundant/readwind_emos.f90
diff --git a/src/readwind_gfs.f90 b/src/redundant/readwind_gfs.f90
similarity index 100%
rename from src/readwind_gfs.f90
rename to src/redundant/readwind_gfs.f90
diff --git a/src/readwind_nests.f90 b/src/redundant/readwind_nests.f90
similarity index 100%
rename from src/readwind_nests.f90
rename to src/redundant/readwind_nests.f90
diff --git a/src/redundant/redist.f90 b/src/redundant/redist.f90
new file mode 100644
index 00000000..4893a34a
--- /dev/null
+++ b/src/redundant/redist.f90
@@ -0,0 +1,327 @@
+! SPDX-FileCopyrightText: FLEXPART 1998-2019, see flexpart_license.txt
+! SPDX-License-Identifier: GPL-3.0-or-later
+
+subroutine redist (itime,ipart,ktop,ipconv)
+
+ !**************************************************************************
+ ! Do the redistribution of particles due to convection
+ ! This subroutine is called for each particle which is assigned
+ ! a new vertical position randomly, based on the convective redistribution
+ ! matrix
+ !**************************************************************************
+
+ ! Petra Seibert, Feb 2001, Apr 2001, May 2001, Jan 2002, Nov 2002 and
+ ! Andreas Frank, Nov 2002
+
+ ! Caroline Forster: November 2004 - February 2005
+
+ use par_mod
+ use com_mod
+ use conv_mod
+ use random_mod
+ use omp_lib
+ use interpol_mod
+ use coordinates_ecmwf
+ use particle_mod
+
+ implicit none
+
+ real,parameter :: const=r_air/ga
+ integer :: ipart, ktop,ipconv,itime
+ integer :: k, kz, levnew, levold
+ real :: uvzlev(nuvzmax)
+ real :: wsub(nuvzmax)
+ real :: totlevmass, wsubpart
+ real :: temp_levold,temp_levold1
+ real :: sub_levold,sub_levold1
+ real :: pint, pold, rn, tv, tvold, dlevfrac
+ real :: ew,ztold,ffraction
+ real :: tv1, tv2, dlogp, dz, dz1, dz2
+ save :: iseed, uvzlev
+ integer :: iseed = -88
+
+!$OMP THREADPRIVATE(iseed,uvzlev)
+!$ if (iseed.eq.-88) then
+!$ iseed = iseed - OMP_GET_THREAD_NUM()
+!$ endif
+
+ ! ipart ... number of particle to be treated
+
+ ipconv=1
+
+ ! determine vertical grid position of particle in the eta system
+ !****************************************************************
+ select case (wind_coord_type)
+
+ case ('ETA')
+ ztold = part(abs(ipart))%zeta
+ ! find old particle grid position
+ levold = nconvtop
+ do kz = 2, nconvtop
+ if (uvheight(kz) .le. ztold ) then
+ levold = kz-1
+ exit
+ endif
+ end do
+
+ case ('METER')
+
+ ! determine height of the eta half-levels (uvzlev)
+ ! do that only once for each grid column
+ ! i.e. when ktop.eq.1
+ !**************************************************************
+
+ if (ktop .le. 1) then
+
+ tvold=tt2conv*(1.+0.378*ew(td2conv,psconv)/psconv)
+ pold=psconv
+ uvzlev(1)=0.
+
+ pint = phconv(2)
+ ! determine next virtual temperatures
+ tv1 = tconv(1)*(1.+0.608*qconv(1))
+ tv2 = tconv(2)*(1.+0.608*qconv(2))
+ ! interpolate virtual temperature to half-level
+ tv = tv1 + (tv2-tv1)*(pconv(1)-phconv(2))/(pconv(1)-pconv(2))
+ tv = tv1 + (tv2-tv1)*(pconv(1)-phconv(2))/(pconv(1)-pconv(2))
+ if (abs(tv-tvold).gt.0.2) then
+ uvzlev(2) = uvzlev(1) + &
+ const*log(pold/pint)* &
+ (tv-tvold)/log(tv/tvold)
+ else
+ uvzlev(2) = uvzlev(1)+ &
+ const*log(pold/pint)*tv
+ endif
+ tvold=tv
+ tv1=tv2
+ pold=pint
+
+ ! integrate profile (calculation of height agl of eta layers) as required
+ do kz = 3, nconvtop+1
+ ! note that variables defined in calcmatrix.f (pconv,tconv,qconv)
+ ! start at the first real ECMWF model level whereas kz and
+ ! thus uvzlev(kz) starts at the surface. uvzlev is defined at the
+ ! half-levels (between the tconv, qconv etc. values !)
+ ! Thus, uvzlev(kz) is the lower boundary of the tconv(kz) cell.
+ pint = phconv(kz)
+ ! determine next virtual temperatures
+ tv2 = tconv(kz)*(1.+0.608*qconv(kz))
+ ! interpolate virtual temperature to half-level
+ tv = tv1 + (tv2-tv1)*(pconv(kz-1)-phconv(kz))/ &
+ (pconv(kz-1)-pconv(kz))
+ tv = tv1 + (tv2-tv1)*(pconv(kz-1)-phconv(kz))/ &
+ (pconv(kz-1)-pconv(kz))
+ if (abs(tv-tvold).gt.0.2) then
+ uvzlev(kz) = uvzlev(kz-1) + &
+ const*log(pold/pint)* &
+ (tv-tvold)/log(tv/tvold)
+ else
+ uvzlev(kz) = uvzlev(kz-1)+ &
+ const*log(pold/pint)*tv
+ endif
+ tvold=tv
+ tv1=tv2
+ pold=pint
+
+
+ end do
+
+ ktop = 2
+
+ endif
+
+ ztold = part(abs(ipart))%z
+ ! find old particle grid position
+ levold = nconvtop
+ do kz = 2, nconvtop
+ if (uvzlev(kz) .ge. ztold ) then
+ levold = kz-1
+ exit
+ endif
+ end do
+
+ case default
+ write(*,*) 'The wind_coord_type is not defined in redist.f90'
+ stop
+
+ end select
+
+ ! If the particle is above the potentially convective domain, it will be skipped
+ if (levold.ne.nconvtop) then
+
+ ! now redistribute particles
+ !****************************
+
+ ! Choose a random number and find corresponding level of destination
+ ! Random numbers to be evenly distributed in [0,1]
+
+ rn = ran3(iseed)
+
+ ! initialize levnew
+
+ levnew = levold
+
+ ffraction = 0.
+ totlevmass=dpr(levold)/ga
+ loop1: do k = 1,nconvtop
+ ! for backward runs use the transposed matrix
+ if (ldirect.eq.1) then
+ ffraction=ffraction+fmassfrac(levold,k) &
+ /totlevmass
+ else
+ ffraction=ffraction+fmassfrac(k,levold) &
+ /totlevmass
+ endif
+ if (rn.le.ffraction) then
+ levnew=k
+ ! avoid division by zero or a too small number
+ ! if division by zero or a too small number happens the
+ ! particle is assigned to the center of the grid cell
+ if (ffraction.gt.1.e-20) then
+ if (ldirect.eq.1) then
+ dlevfrac = (ffraction-rn) / fmassfrac(levold,k) * totlevmass
+ else
+ dlevfrac = (ffraction-rn) / fmassfrac(k,levold) * totlevmass
+ endif
+ else
+ dlevfrac = 0.5
+ endif
+ exit loop1
+ endif
+ end do loop1
+
+ ! now assign new position to particle
+ select case (wind_coord_type)
+
+ case ('ETA')
+ if (levnew.le.nconvtop) then
+ if (levnew.eq.levold) then
+ part(abs(ipart))%zeta = ztold
+ else
+ dlogp = (1.-dlevfrac)* &
+ (uvheight(levnew+1)-uvheight(levnew))
+ part(abs(ipart))%zeta = uvheight(levnew)+dlogp
+ if (part(abs(ipart))%zeta.ge.1.) part(abs(ipart))%zeta=1.-(part(abs(ipart))%zeta-1.)
+ if (part(abs(ipart))%zeta.eq.1.) part(abs(ipart))%zeta=part(abs(ipart))%zeta-1.e-4
+ if (ipconv.gt.0) ipconv=-1
+ endif
+ endif
+
+ case ('METER')
+ if (levnew.le.nconvtop) then
+ if (levnew.eq.levold) then
+ part(abs(ipart))%z = ztold
+ else
+ dlogp = (1.-dlevfrac)* &
+ (log(phconv(levnew+1))-log(phconv(levnew)))
+ pint = log(phconv(levnew))+dlogp
+ dz1 = pint - log(phconv(levnew))
+ dz2 = log(phconv(levnew+1)) - pint
+ dz = dz1 + dz2
+ part(abs(ipart))%z = (uvzlev(levnew)*dz2+uvzlev(levnew+1)*dz1)/dz
+ if (part(abs(ipart))%z.lt.0.) &
+ part(abs(ipart))%z=-1.*part(abs(ipart))%z
+ if (ipconv.gt.0) ipconv=-1
+ endif
+ endif
+
+ case default
+ write(*,*) 'The wind_coord_type is not defined in redist.f90'
+ stop
+
+ end select
+
+ ! displace particle according to compensating subsidence
+ ! this is done to those particles, that were not redistributed
+ ! by the matrix
+ !**************************************************************
+
+ if (levnew.le.nconvtop.and.levnew.eq.levold) then
+
+ ! determine compensating vertical velocity at the levels
+ ! above and below the particel position
+ ! increase compensating subsidence by the fraction that
+ ! is displaced by convection to this level
+
+ if (levold.gt.1) then
+ temp_levold = tconv(levold-1) + &
+ (tconv(levold)-tconv(levold-1)) &
+ *(pconv(levold-1)-phconv(levold))/ &
+ (pconv(levold-1)-pconv(levold))
+ sub_levold = sub(levold)/(1.-ga*sub(levold)/dpr(levold))
+ wsub(levold)=-1.*sub_levold*r_air*temp_levold/(phconv(levold))
+ else
+ wsub(levold)=0.
+ endif
+
+ temp_levold1 = tconv(levold) + &
+ (tconv(levold+1)-tconv(levold)) &
+ *(pconv(levold)-phconv(levold+1))/ &
+ (pconv(levold)-pconv(levold+1))
+ sub_levold1 = sub(levold+1)/(1.-ga*sub(levold+1)/dpr(levold+1))
+ wsub(levold+1)=-1.*sub_levold1*r_air*temp_levold1/ &
+ (phconv(levold+1))
+
+ ! interpolate wsub to the vertical particle position
+ select case (wind_coord_type)
+ case ('ETA')
+ ztold = part(abs(ipart))%zeta
+ dz1 = ztold - uvheight(levold)
+ dz2 = uvheight(levold+1) - ztold
+ dz = dz1 + dz2
+
+ ! Convert z(eta) to z(m) in order to add subsidence
+ call zeta_to_z(itime,part(abs(ipart))%xlon,part(abs(ipart))%ylat, &
+ part(abs(ipart))%zeta,part(abs(ipart))%z)
+
+ ztold=part(abs(ipart))%z
+ wsubpart = (dz2*wsub(levold)+dz1*wsub(levold+1))/dz
+
+ part(abs(ipart))%z = ztold+wsubpart*real(lsynctime)
+
+ if (part(abs(ipart))%z.lt.0.) then
+ part(abs(ipart))%z=-1.*part(abs(ipart))%z
+ endif
+
+ ! Convert new z(m) back to z(eta)
+ call update_z_to_zeta(itime, ipart)
+
+ case ('METER')
+ ztold = part(abs(ipart))%z
+ dz1 = ztold - uvzlev(levold)
+ dz2 = uvzlev(levold+1) - ztold
+ dz = dz1 + dz2
+
+ wsubpart = (dz2*wsub(levold)+dz1*wsub(levold+1))/dz
+ part(abs(ipart))%z = ztold+wsubpart*real(lsynctime)
+ if (part(abs(ipart))%z.lt.0.) then
+ part(abs(ipart))%z=-1.*part(abs(ipart))%z
+ endif
+
+ case default
+ write(*,*) 'The wind_coord_type is not defined in redist.f90'
+ stop
+ end select
+ endif !(levnew.le.nconvtop.and.levnew.eq.levold)
+ endif
+ ! Maximum altitude .5 meter below uppermost model level
+ !*******************************************************
+
+ select case (wind_coord_type)
+ case ('ETA')
+ if (part(abs(ipart))%z .gt. height(nz)-0.5) &
+ part(abs(ipart))%z = height(nz)-0.5
+
+ if (part(abs(ipart))%zeta .lt. uvheight(nz)) &
+ part(abs(ipart))%zeta = uvheight(nz)+1.e-4
+ if (part(abs(ipart))%zeta.ge.1.) part(abs(ipart))%zeta=1.-(part(abs(ipart))%zeta-1.)
+ if (part(abs(ipart))%zeta.eq.1.) part(abs(ipart))%zeta=part(abs(ipart))%zeta-1.e-4
+ case ('METER')
+ if (part(abs(ipart))%z .gt. height(nz)-0.5) &
+ part(abs(ipart))%z = height(nz)-0.5
+ case default
+ write(*,*) 'The wind_coord_type is not defined in redist.f90'
+ stop
+ end select
+
+end subroutine redist
diff --git a/src/redist_mpi.f90 b/src/redundant/redist_mpi.f90
similarity index 100%
rename from src/redist_mpi.f90
rename to src/redundant/redist_mpi.f90
diff --git a/src/releaseparticles.f90 b/src/redundant/releaseparticles.f90
similarity index 60%
rename from src/releaseparticles.f90
rename to src/redundant/releaseparticles.f90
index d2a1eaf9..175875d5 100644
--- a/src/releaseparticles.f90
+++ b/src/redundant/releaseparticles.f90
@@ -31,17 +31,21 @@ subroutine releaseparticles(itime)
use xmass_mod
use par_mod
use com_mod
+ use windfields_mod
use random_mod, only: ran1
+ use interpol_mod
+ use coordinates_ecmwf
+ use netcdf_output_mod
implicit none
!real xaux,yaux,zaux,ran1,rfraction,xmasssave(maxpoint)
real :: xaux,yaux,zaux,rfraction
- real :: topo,rhoaux(2),r,t,rhoout,ddx,ddy,rddx,rddy,p1,p2,p3,p4
- real :: dz1,dz2,dz,xtn,ytn,xlonav,timecorrect(maxspec),press,pressold
+ real :: topo,rhoaux(2),r,t,rhoout
+ real :: dz1,dz2,dz,xlonav,timecorrect(maxspec),press,pressold
real :: presspart,average_timecorrect
- integer :: itime,numrel,i,j,k,n,ix,jy,ixp,jyp,ipart,minpart,ii
- integer :: indz,indzp,kz,ngrid
+ integer :: itime,numrel,i,j,k,n,ipart,minpart,ii
+ integer :: kz,istart,iend
integer :: nweeks,ndayofweek,nhour,jjjjmmdd,ihmmss,mm
real(kind=dp) :: juldate,julmonday,jul,jullocal,juldiff
real,parameter :: eps=nxmax/3.e5,eps2=1.e-6
@@ -50,6 +54,7 @@ subroutine releaseparticles(itime)
!save idummy,xmasssave
!data idummy/-7/,xmasssave/maxpoint*0./
+ real :: frac,psint,zzlev,zzlev2,ttemp
! Determine the actual date and time in Greenwich (i.e., UTC + correction for daylight savings time)
@@ -64,7 +69,14 @@ subroutine releaseparticles(itime)
! For every release point, check whether we are in the release time interval
!***************************************************************************
-
+ ! First allocate all particles that are going to be in the simulation (this could be done differently...)
+ if (itime.eq.0) then
+ do i=1,numpoint
+ call allocate_particles(npart(i))
+ end do
+ end if
+
+ call get_total_part_num(istart)
minpart=1
do i=1,numpoint
if ((itime.ge.ireleasestart(i)).and. &! are we within release interval?
@@ -130,28 +142,24 @@ subroutine releaseparticles(itime)
xaux=xpoint2(i)-xpoint1(i)
yaux=ypoint2(i)-ypoint1(i)
zaux=zpoint2(i)-zpoint1(i)
- do j=1,numrel ! loop over particles to be released this time
- do ipart=minpart,maxpart ! search for free storage space
-
- ! If a free storage space is found, attribute everything to this array element
- !*****************************************************************************
- if (itra1(ipart).ne.itime) then
+ do j=1,numrel ! loop over particles to be released this time
+ call get_new_part_index(ipart)
+ call spawn_particle(itime, ipart)
! Particle coordinates are determined by using a random position within the release volume
!*****************************************************************************
! Determine horizontal particle position
!***************************************
-
- xtra1(ipart)=xpoint1(i)+ran1(idummy)*xaux
- if (xglobal) then
- if (xtra1(ipart).gt.real(nxmin1)) xtra1(ipart)= &
- xtra1(ipart)-real(nxmin1)
- if (xtra1(ipart).lt.0.) xtra1(ipart)= &
- xtra1(ipart)+real(nxmin1)
- endif
- ytra1(ipart)=ypoint1(i)+ran1(idummy)*yaux
+ call set_xlon(ipart,real(xpoint1(i)+ran1(idummy)*xaux,kind=dp))
+ if (xglobal) then
+ if (part(ipart)%xlon.gt.real(nxmin1,kind=dp)) &
+ call set_xlon(ipart,-real(nxmin1,kind=dp))
+ if (part(ipart)%xlon.lt.0.) &
+ call set_xlon(ipart,real(nxmin1,kind=dp))
+ endif
+ call set_ylat(ipart,real(ypoint1(i)+ran1(idummy)*yaux,kind=dp))
! Assign mass to particle: Total mass divided by total number of particles.
! Time variation has partly been taken into account already by a species-average
@@ -161,144 +169,141 @@ subroutine releaseparticles(itime)
! for the scavenging calculation the mass needs to be multiplied with rho of the particle layer and
! divided by the sum of rho of all particles.
!*****************************************************************************
- do k=1,nspec
- xmass1(ipart,k)=xmass(i,k)/real(npart(i)) &
- *timecorrect(k)/average_timecorrect
- if (DRYBKDEP.or.WETBKDEP) then ! if there is no scavenging in wetdepo it will be set to 0
+ do k=1,nspec
+ part(ipart)%mass(k)=xmass(i,k)/real(npart(i)) &
+ *timecorrect(k)/average_timecorrect
+ if (DRYBKDEP.or.WETBKDEP) then ! if there is no scavenging in wetdepo it will be set to 0
! if ( henry(k).gt.0 .or. &
! crain_aero(k).gt.0. .or. csnow_aero(k).gt.0. .or. &
! ccn_aero(k).gt.0. .or. in_aero(k).gt.0. ) then
- xscav_frac1(ipart,k)=-1.
- endif
+ xscav_frac1(ipart,k)=-1.
+ endif
! Assign certain properties to particle
!**************************************
- end do
- nclass(ipart)=min(int(ran1(idummy)*real(nclassunc))+1, &
- nclassunc)
- numparticlecount=numparticlecount+1
- if (mquasilag.eq.0) then
- npoint(ipart)=i
- else
- npoint(ipart)=numparticlecount
- endif
- idt(ipart)=mintime ! first time step
- itra1(ipart)=itime
- itramem(ipart)=itra1(ipart)
- itrasplit(ipart)=itra1(ipart)+ldirect*itsplit
-
+ end do
+ part(ipart)%nclass=min(int(ran1(idummy)*real(nclassunc))+1, &
+ nclassunc)
+ numparticlecount=numparticlecount+1
+ if (mquasilag.eq.0) then
+ part(ipart)%npoint=i
+ else
+ part(ipart)%npoint=numparticlecount
+ endif
+ part(ipart)%idt=mintime ! first time step
! Determine vertical particle position
!*************************************
-
- ztra1(ipart)=zpoint1(i)+ran1(idummy)*zaux
+ call set_z(ipart,zpoint1(i)+ran1(idummy)*zaux)
! Interpolation of topography and density
!****************************************
! Determine the nest we are in
!*****************************
- ngrid=0
- do k=numbnests,1,-1
- if ((xtra1(ipart).gt.xln(k)+eps).and. &
- (xtra1(ipart).lt.xrn(k)-eps).and. &
- (ytra1(ipart).gt.yln(k)+eps).and. &
- (ytra1(ipart).lt.yrn(k)-eps)) then
- ngrid=k
- goto 43
- endif
- end do
-43 continue
+ ngrid=0
+ do k=numbnests,1,-1
+ if ((part(ipart)%xlon.gt.xln(k)+eps).and. &
+ (part(ipart)%xlon.lt.xrn(k)-eps).and. &
+ (part(ipart)%xlon.gt.yln(k)+eps).and. &
+ (part(ipart)%xlon.lt.yrn(k)-eps)) then
+ ngrid=k
+ exit
+ endif
+ end do
! Determine (nested) grid coordinates and auxiliary parameters used for interpolation
!*****************************************************************************
- if (ngrid.gt.0) then
- xtn=(xtra1(ipart)-xln(ngrid))*xresoln(ngrid)
- ytn=(ytra1(ipart)-yln(ngrid))*yresoln(ngrid)
- ix=int(xtn)
- jy=int(ytn)
- ddy=ytn-real(jy)
- ddx=xtn-real(ix)
- else
- ix=int(xtra1(ipart))
- jy=int(ytra1(ipart))
- ddy=ytra1(ipart)-real(jy)
- ddx=xtra1(ipart)-real(ix)
- endif
- ixp=ix+1
- jyp=jy+1
- rddx=1.-ddx
- rddy=1.-ddy
- p1=rddx*rddy
- p2=ddx*rddy
- p3=rddx*ddy
- p4=ddx*ddy
+ if (ngrid.gt.0) then
+ xtn=(part(ipart)%xlon-xln(ngrid))*xresoln(ngrid)
+ ytn=(part(ipart)%ylat-yln(ngrid))*yresoln(ngrid)
+ ix=int(xtn)
+ jy=int(ytn)
+ ddy=ytn-real(jy)
+ ddx=xtn-real(ix)
+ else
+ ix=int(part(ipart)%xlon)
+ jy=int(part(ipart)%ylat)
+ ddy=part(ipart)%ylat-real(jy)
+ ddx=part(ipart)%xlon-real(ix)
+ endif
+ ixp=ix+1
+ jyp=jy+1
+ rddx=1.-ddx
+ rddy=1.-ddy
+ p1=rddx*rddy
+ p2=ddx*rddy
+ p3=rddx*ddy
+ p4=ddx*ddy
+
+ if (ngrid.gt.0) then
+ topo=p1*oron(ix ,jy ,ngrid) &
+ + p2*oron(ixp,jy ,ngrid) &
+ + p3*oron(ix ,jyp,ngrid) &
+ + p4*oron(ixp,jyp,ngrid)
+ else
+ topo=p1*oro(ix ,jy) &
+ + p2*oro(ixp,jy) &
+ + p3*oro(ix ,jyp) &
+ + p4*oro(ixp,jyp)
+ endif
+ ! If starting height is in pressure coordinates, retrieve pressure profile and convert zpart1 to meters
+ !*****************************************************************************
+ if (kindz(i).eq.3) then
+ presspart=part(ipart)%z
+ do kz=1,nz
if (ngrid.gt.0) then
- topo=p1*oron(ix ,jy ,ngrid) &
- + p2*oron(ixp,jy ,ngrid) &
- + p3*oron(ix ,jyp,ngrid) &
- + p4*oron(ixp,jyp,ngrid)
+ r=p1*rhon(ix ,jy ,kz,2,ngrid) &
+ +p2*rhon(ixp,jy ,kz,2,ngrid) &
+ +p3*rhon(ix ,jyp,kz,2,ngrid) &
+ +p4*rhon(ixp,jyp,kz,2,ngrid)
+ t=p1*ttn(ix ,jy ,kz,2,ngrid) &
+ +p2*ttn(ixp,jy ,kz,2,ngrid) &
+ +p3*ttn(ix ,jyp,kz,2,ngrid) &
+ +p4*ttn(ixp,jyp,kz,2,ngrid)
else
- topo=p1*oro(ix ,jy) &
- + p2*oro(ixp,jy) &
- + p3*oro(ix ,jyp) &
- + p4*oro(ixp,jyp)
+ r=p1*rho(ix ,jy ,kz,2) &
+ +p2*rho(ixp,jy ,kz,2) &
+ +p3*rho(ix ,jyp,kz,2) &
+ +p4*rho(ixp,jyp,kz,2)
+ t=p1*tt(ix ,jy ,kz,2) &
+ +p2*tt(ixp,jy ,kz,2) &
+ +p3*tt(ix ,jyp,kz,2) &
+ +p4*tt(ixp,jyp,kz,2)
endif
+ press=r*r_air*t/100.
+ if (kz.eq.1) pressold=press
- ! If starting height is in pressure coordinates, retrieve pressure profile and convert zpart1 to meters
- !*****************************************************************************
- if (kindz(i).eq.3) then
- presspart=ztra1(ipart)
- do kz=1,nz
- if (ngrid.gt.0) then
- r=p1*rhon(ix ,jy ,kz,2,ngrid) &
- +p2*rhon(ixp,jy ,kz,2,ngrid) &
- +p3*rhon(ix ,jyp,kz,2,ngrid) &
- +p4*rhon(ixp,jyp,kz,2,ngrid)
- t=p1*ttn(ix ,jy ,kz,2,ngrid) &
- +p2*ttn(ixp,jy ,kz,2,ngrid) &
- +p3*ttn(ix ,jyp,kz,2,ngrid) &
- +p4*ttn(ixp,jyp,kz,2,ngrid)
- else
- r=p1*rho(ix ,jy ,kz,2) &
- +p2*rho(ixp,jy ,kz,2) &
- +p3*rho(ix ,jyp,kz,2) &
- +p4*rho(ixp,jyp,kz,2)
- t=p1*tt(ix ,jy ,kz,2) &
- +p2*tt(ixp,jy ,kz,2) &
- +p3*tt(ix ,jyp,kz,2) &
- +p4*tt(ixp,jyp,kz,2)
- endif
- press=r*r_air*t/100.
- if (kz.eq.1) pressold=press
-
- if (press.lt.presspart) then
- if (kz.eq.1) then
- ztra1(ipart)=height(1)/2.
- else
- dz1=pressold-presspart
- dz2=presspart-press
- ztra1(ipart)=(height(kz-1)*dz2+height(kz)*dz1) &
- /(dz1+dz2)
- endif
- goto 71
- endif
- pressold=press
- end do
-71 continue
+ if (press.lt.presspart) then
+ if (kz.eq.1) then
+ call set_z(ipart,height(1)/2.)
+ else
+ dz1=pressold-presspart
+ dz2=presspart-press
+ call set_z(ipart,(height(kz-1)*dz2+height(kz)*dz1) &
+ /(dz1+dz2))
+ endif
+ exit
endif
+ pressold=press
+ end do
+ endif
+
! If release positions are given in meters above sea level, subtract the
! topography from the starting height
!***********************************************************************
- if (kindz(i).eq.2) ztra1(ipart)=ztra1(ipart)-topo
- if (ztra1(ipart).lt.eps2) ztra1(ipart)=eps2 ! Minimum starting height is eps2
- if (ztra1(ipart).gt.height(nz)-0.5) ztra1(ipart)= &
- height(nz)-0.5 ! Maximum starting height is uppermost level - 0.5 meters
-
+ if (kindz(i).eq.2) call update_z(ipart,-topo)
+ if (part(ipart)%z.lt.eps2) call set_z(ipart,eps2) ! Minimum starting height is eps2
+ if (part(ipart)%z.gt.height(nz)-0.5) &
+ call set_z(ipart,height(nz)-0.5) ! Maximum starting height is uppermost level - 0.5 meters
+ if (wind_coord_type.eq.'ETA') then
+ call z_to_zeta(itime,part(ipart)%xlon,part(ipart)%ylat,part(ipart)%z,part(ipart)%zeta)
+ part(ipart)%etaupdate = .true. ! The z(meter) coordinate is up to date
+ end if
! For special simulations, multiply particle concentration air density;
! Simply take the 2nd field in memory to do this (accurate enough)
@@ -318,63 +323,58 @@ subroutine releaseparticles(itime)
!Af ind_rel is defined in readcommand.f
- if ((ind_rel .eq. 1).or.(ind_rel .eq. 3).or.(ind_rel .eq. 4)) then
+ if ((ind_rel .eq. 1).or.(ind_rel .eq. 3).or.(ind_rel .eq. 4)) then
! Interpolate the air density
!****************************
- do ii=2,nz
- if (height(ii).gt.ztra1(ipart)) then
- indz=ii-1
- indzp=ii
- goto 6
- endif
- end do
-6 continue
-
- dz1=ztra1(ipart)-height(indz)
- dz2=height(indzp)-ztra1(ipart)
- dz=1./(dz1+dz2)
-
- if (ngrid.gt.0) then
- do n=1,2
- rhoaux(n)=p1*rhon(ix ,jy ,indz+n-1,2,ngrid) &
- +p2*rhon(ixp,jy ,indz+n-1,2,ngrid) &
- +p3*rhon(ix ,jyp,indz+n-1,2,ngrid) &
- +p4*rhon(ixp,jyp,indz+n-1,2,ngrid)
- end do
- else
- do n=1,2
- rhoaux(n)=p1*rho(ix ,jy ,indz+n-1,2) &
- +p2*rho(ixp,jy ,indz+n-1,2) &
- +p3*rho(ix ,jyp,indz+n-1,2) &
- +p4*rho(ixp,jyp,indz+n-1,2)
- end do
- endif
- rhoout=(dz2*rhoaux(1)+dz1*rhoaux(2))*dz
- rho_rel(i)=rhoout
+ do ii=2,nz
+ if (height(ii).gt.part(ipart)%z) then
+ indz=ii-1
+ indzp=ii
+ exit
+ endif
+ end do
+
+ dz1=part(ipart)%z-height(indz)
+ dz2=height(indzp)-part(ipart)%z
+ dz=1./(dz1+dz2)
+
+ if (ngrid.gt.0) then
+ do n=1,2
+ rhoaux(n)=p1*rhon(ix ,jy ,indz+n-1,2,ngrid) &
+ +p2*rhon(ixp,jy ,indz+n-1,2,ngrid) &
+ +p3*rhon(ix ,jyp,indz+n-1,2,ngrid) &
+ +p4*rhon(ixp,jyp,indz+n-1,2,ngrid)
+ end do
+ else
+ do n=1,2
+ rhoaux(n)=p1*rho(ix ,jy ,indz+n-1,2) &
+ +p2*rho(ixp,jy ,indz+n-1,2) &
+ +p3*rho(ix ,jyp,indz+n-1,2) &
+ +p4*rho(ixp,jyp,indz+n-1,2)
+ end do
+ endif
+ rhoout=(dz2*rhoaux(1)+dz1*rhoaux(2))*dz
+ rho_rel(i)=rhoout
! Multiply "mass" (i.e., mass mixing ratio in forward runs) with density
!********************************************************************
- do k=1,nspec
- xmass1(ipart,k)=xmass1(ipart,k)*rhoout
- end do
- endif
-
- numpart=max(numpart,ipart)
- goto 34 ! Storage space has been found, stop searching
- endif
- end do ! i=1:numpoint
- if (ipart.gt.maxpart) goto 996
+ do k=1,nspec
+ part(ipart)%mass(k)=part(ipart)%mass(k)*rhoout
+ end do
+ endif
-34 minpart=ipart+1
- end do ! ipart=minpart,maxpart
- endif ! j=1,numrel
- end do
+ call get_total_part_num(numpart)
+ end do ! numrel
+ endif ! releasepoint
+ end do ! numpoint
+ call get_total_part_num(iend)
+ if (iend-istart.gt.0) call write_particles_initialoutput(itime,istart,iend)
return
996 continue
diff --git a/src/releaseparticles_mpi.f90 b/src/redundant/releaseparticles_mpi.f90
similarity index 100%
rename from src/releaseparticles_mpi.f90
rename to src/redundant/releaseparticles_mpi.f90
diff --git a/src/richardson.f90 b/src/redundant/richardson.f90
similarity index 98%
rename from src/richardson.f90
rename to src/redundant/richardson.f90
index 0440f433..073e7e3c 100644
--- a/src/richardson.f90
+++ b/src/redundant/richardson.f90
@@ -93,10 +93,10 @@ subroutine richardson(psurf,ust,ttlev,qvlev,ulev,vlev,nuvz, &
30 iter=iter+1
pold=psurf
- tvold=tt2*(1.+0.378*ew(td2)/psurf)
+ tvold=tt2*(1.+0.378*ew(td2,psurf)/psurf)
zold=2.0
zref=zold
- rhold=ew(td2)/ew(tt2)
+ rhold=ew(td2,psurf)/ew(tt2,psurf)
thetaref=tvold*(100000./pold)**(r_air/cpa)+excess
thetaold=thetaref
diff --git a/src/scalev.f90 b/src/redundant/scalev.f90
similarity index 97%
rename from src/scalev.f90
rename to src/redundant/scalev.f90
index 716961d1..cb182bfa 100644
--- a/src/scalev.f90
+++ b/src/redundant/scalev.f90
@@ -31,7 +31,7 @@ real function scalev(ps,t,td,stress)
real :: ps,t,td,e,ew,tv,rhoa,stress
- e=ew(td) ! vapor pressure
+ e=ew(td,ps) ! vapor pressure
tv=t*(1.+0.378*e/ps) ! virtual temperature
rhoa=ps/(r_air*tv) ! air density
scalev=sqrt(abs(stress)/rhoa)
diff --git a/src/shift_field.f90 b/src/redundant/shift_field.f90
similarity index 100%
rename from src/shift_field.f90
rename to src/redundant/shift_field.f90
diff --git a/src/shift_field_0.f90 b/src/redundant/shift_field_0.f90
similarity index 100%
rename from src/shift_field_0.f90
rename to src/redundant/shift_field_0.f90
diff --git a/src/skplin.f90 b/src/redundant/skplin.f90
similarity index 100%
rename from src/skplin.f90
rename to src/redundant/skplin.f90
diff --git a/src/sort2.f90 b/src/redundant/sort2.f90
similarity index 100%
rename from src/sort2.f90
rename to src/redundant/sort2.f90
diff --git a/src/redundant/timemanager.f90 b/src/redundant/timemanager.f90
new file mode 100644
index 00000000..7f5606a1
--- /dev/null
+++ b/src/redundant/timemanager.f90
@@ -0,0 +1,627 @@
+! SPDX-FileCopyrightText: FLEXPART 1998-2019, see flexpart_license.txt
+! SPDX-License-Identifier: GPL-3.0-or-later
+
+subroutine timemanager(metdata_format)
+
+ !*****************************************************************************
+ ! *
+ ! Handles the computation of trajectories, i.e. determines which *
+ ! trajectories have to be computed at what time. *
+ ! Manages dry+wet deposition routines, radioactive decay and the computation *
+ ! of concentrations. *
+ ! *
+ ! Author: A. Stohl *
+ ! *
+ ! 20 May 1996 *
+ ! *
+ !*****************************************************************************
+ ! Changes, Bernd C. Krueger, Feb. 2001: *
+ ! Call of convmix when new windfield is read *
+ !------------------------------------ *
+ ! Changes Petra Seibert, Sept 2002 *
+ ! fix wet scavenging problem *
+ ! Code may not be correct for decay of deposition! *
+ ! Changes Petra Seibert, Nov 2002 *
+ ! call convection BEFORE new fields are read in BWD mode *
+ ! Changes Caroline Forster, Feb 2005 *
+ ! new interface between flexpart and convection scheme *
+ ! Emanuel's latest subroutine convect43c.f is used *
+ ! Changes Stefan Henne, Harald Sodemann, 2013-2014 *
+ ! added netcdf output code *
+ ! Changes Espen Sollum 2014 *
+ ! For compatibility with MPI version, *
+ ! variables uap,ucp,uzp,us,vs,ws,cbt now in module com_mod *
+ ! Unified ECMWF and GFS builds *
+ ! Marian Harustak, 12.5.2017 *
+ ! - Added passing of metdata_format as it was needed by called routines *
+ !*****************************************************************************
+ ! *
+ ! Variables: *
+ ! DEP .true. if either wet or dry deposition is switched on *
+ ! decay(maxspec) [1/s] decay constant for radioactive decay *
+ ! DRYDEP .true. if dry deposition is switched on *
+ ! ideltas [s] modelling period *
+ ! itime [s] actual temporal position of calculation *
+ ! ldeltat [s] time since computation of radioact. decay of depositions*
+ ! loutaver [s] averaging period for concentration calculations *
+ ! loutend [s] end of averaging for concentration calculations *
+ ! loutnext [s] next time at which output fields shall be centered *
+ ! loutsample [s] sampling interval for averaging of concentrations *
+ ! loutstart [s] start of averaging for concentration calculations *
+ ! loutstep [s] time interval for which concentrations shall be *
+ ! calculated *
+ ! npoint index, which starting point the trajectory has *
+ ! starting positions of trajectories *
+ ! nstop serves as indicator for fate of particles *
+ ! in the particle loop *
+ ! nstop1 serves as indicator for wind fields (see getfields) *
+ ! outnum number of samples for each concentration calculation *
+ ! prob probability of absorption at ground due to dry *
+ ! deposition *
+ ! WETDEP .true. if wet deposition is switched on *
+ ! weight weight for each concentration sample (1/2 or 1) *
+ ! metdata_format format of metdata (ecmwf/gfs) *
+ ! *
+ !*****************************************************************************
+ ! openmp change
+ use omp_lib
+ ! openmp change end
+ use unc_mod
+ use point_mod
+ use xmass_mod
+ use flux_mod
+ use outg_mod
+ use oh_mod
+ use par_mod
+ use com_mod
+#ifdef USE_NCF
+ use netcdf_output_mod, only: writeheader_partoutput,&
+ create_particles_initialoutput
+#endif
+ use binary_output_mod
+ use coordinates_ecmwf
+ use particle_mod
+ use conv_mod
+ use windfields_mod
+ use advance_mod, only: advance
+ use drydepo_mod
+ use wetdepo_mod
+
+ implicit none
+ real, parameter :: &
+ e_inv = 1.0/exp(1.0)
+ integer, intent(in) :: &
+ metdata_format ! Data type of the windfields
+ integer :: &
+ j,i, & ! loop variable
+ ks, & ! loop variable species
+ kp, & ! loop variable for maxpointspec_act
+ l, & ! loop variable over nclassunc
+ n, & ! loop variable over particles
+ itime=0, & ! time index
+ nstop1, & ! windfield existence flag
+ loutnext, & ! following timestep
+ loutstart,loutend, & ! concentration calculation starting and ending time
+ ix,jy, & ! gridcell indices
+ ldeltat, & ! radioactive decay time
+ itage,nage, & ! related to age classes
+ idummy, & ! used for the random routines
+ i_nan=0,ii_nan,total_nan_intl=0, & !added by mc to check instability in CBL scheme
+ thread ! openmp change (not sure if necessary)
+ ! logical :: &
+ ! active_per_rel(maxpoint) ! are there particles active in each release
+#ifdef USE_NCF
+ real :: &
+ filesize!(maxpoint) ! Keeping track of the size of the particledump output, so it can be splitted
+ real(kind=dp) :: &
+ jul
+ integer :: &
+ jjjjmmdd,ihmmss
+#endif
+ real :: &
+ outnum, & ! concentration calculation sample number
+ prob_rec(maxspec), & ! dry deposition related
+ decfact, & ! radioactive decay factor
+ wetscav, & ! wet scavenging
+ xmassfract, & ! dry deposition related
+ grfraction(3) ! wet deposition related
+ real(dep_prec) :: &
+ drydeposit(maxspec) ! dry deposition related
+
+ integer :: npart_alive=0
+
+ ! First output for time 0
+ !************************
+
+ loutnext=loutstep/2
+ outnum=0.
+ loutstart=loutnext-loutaver/2
+ loutend=loutnext+loutaver/2
+
+ !**********************************************************************
+ ! Loop over the whole modelling period in time steps of mintime seconds
+ !**********************************************************************
+
+ write(*,46) float(itime)/3600,itime,numpart
+46 format(' Simulated ',f7.1,' hours (',i13,' s), ',i13, ' particles')
+
+#ifdef USE_NCF
+ filesize=0.
+ ! active_per_rel=.false.
+#endif
+
+ do itime=0,ideltas,lsynctime
+
+ ! Computation of wet deposition, OH reaction and mass transfer
+ ! between two species every lsynctime seconds
+ ! maybe wet depo frequency can be relaxed later but better be on safe side
+ ! wetdepo must be called BEFORE new fields are read in but should not
+ ! be called in the very beginning before any fields are loaded, or
+ ! before particles are in the system
+ ! Code may not be correct for decay of deposition
+ ! changed by Petra Seibert 9/02
+ !********************************************************************
+
+ if (WETDEP .and. itime .ne. 0 .and. numpart .gt. 0) then
+ call wetdepo(itime,lsynctime,loutnext)
+ endif
+
+ if (OHREA .and. itime .ne. 0 .and. numpart .gt. 0) &
+ call ohreaction(itime,lsynctime,loutnext)
+
+ ! compute convection for backward runs
+ !*************************************
+
+ if ((ldirect.eq.-1).and.(lconvection.eq.1).and.(itime.lt.0)) then
+ call convmix(itime,metdata_format)
+ endif
+
+ ! Get necessary wind fields if not available
+ !*******************************************
+ call getfields(itime,nstop1,metdata_format)
+ if (nstop1.gt.1) stop 'NO METEO FIELDS AVAILABLE'
+
+ ! In case of ETA coordinates being read from file, convert the z positions
+ !*************************************************************************
+ if ((ipin.eq.1).and.(itime.eq.0).and.(wind_coord_type.eq.'ETA')) then
+ if (numpart.le.0) stop 'Something is going wrong reading the old particle file!'
+!$OMP PARALLEL PRIVATE(i)
+!$OMP DO
+ do i=1,numpart
+ call update_z_to_zeta(itime, i)
+ end do
+!$OMP END DO
+!$OMP END PARALLEL
+ endif
+
+ ! Get hourly OH fields if not available
+ !****************************************************
+ if (OHREA) then
+ call gethourlyOH(itime)
+ endif
+
+ ! Release particles
+ !******************
+ if (mdomainfill.ge.1) then
+ if (itime.eq.0) then
+ call init_domainfill
+ else
+ call boundcond_domainfill(itime,loutend)
+ endif
+ else
+ if (itime.eq.0) then
+ if (ldirect.eq.1) then
+ call create_particles_initialoutput(ibtime,ibdate,ibtime,ibdate)
+ else
+ call create_particles_initialoutput(ietime,iedate,ietime,iedate)
+ endif
+ endif
+ call releaseparticles(itime)
+ endif
+
+#ifdef USE_NCF
+ if (ipout.ge.1) then
+ if (itime.eq.0) then
+ if (ldirect.eq.1) then
+ call writeheader_partoutput(ibtime,ibdate,ibtime,ibdate)
+ else
+ call writeheader_partoutput(ietime,iedate,ietime,iedate)
+ endif
+ else if (mod(itime,ipoutfac*loutstep).eq.0) then
+ if (filesize.ge.max_partoutput_filesize) then
+ jul=bdate+real(itime,kind=dp)/86400._dp
+ call caldate(jul,jjjjmmdd,ihmmss)
+ if (ldirect.eq.1) then
+ call writeheader_partoutput(ihmmss,jjjjmmdd,ibtime,ibdate)
+ else
+ call writeheader_partoutput(ihmmss,jjjjmmdd,ietime,iedate)
+ endif
+ filesize = 0.
+ endif
+ do i=1,numpoint
+ filesize = filesize + npart(i)*13.*4./1000000.
+ end do
+ endif
+ endif
+#endif
+
+ ! Compute convective mixing for forward runs
+ ! for backward runs it is done before next windfield is read in
+ !**************************************************************
+ if ((ldirect.eq.1).and.(lconvection.eq.1)) then
+ call convmix(itime,metdata_format)
+ endif
+
+ ! If middle of averaging period of output fields is reached, accumulated
+ ! deposited mass radioactively decays
+ !***********************************************************************
+ if (DEP.and.(itime.eq.loutnext).and.(ldirect.gt.0)) call radioactive_decay()
+
+
+ ! Is the time within the computation interval, if not, skip
+ !************************************************************
+ if ((ldirect*itime.ge.ldirect*loutstart).and.(ldirect*itime.le.ldirect*loutend)) then
+ ! If it is not time yet to write outputs, skip
+ !***********************************************
+ if ((itime.eq.loutend).and.(outnum.gt.0)) then
+
+ if ((iout.eq.4).or.(iout.eq.5)) call plumetraj(itime)
+ if (iflux.eq.1) call fluxoutput(itime)
+
+ if (ipout.ge.1) then
+ if (mod(itime,ipoutfac*loutstep).eq.0) then
+ call SYSTEM_CLOCK(count_clock, count_rate, count_max)
+ s_temp = (count_clock - count_clock0)/real(count_rate)
+ call partoutput(itime)!,active_per_rel) ! dump particle positions
+ call SYSTEM_CLOCK(count_clock, count_rate, count_max)
+ s_writepart = s_writepart + ((count_clock - count_clock0)/real(count_rate)-s_temp)
+ endif
+ endif
+ endif
+ ! Check whether concentrations are to be calculated and outputted
+ !****************************************************************
+ call timemanager_concentrations(itime,loutstart,loutend,loutnext,outnum)
+ endif
+
+ if (itime.eq.ideltas) exit ! almost finished
+
+ ! Compute interval since radioactive decay of deposited mass was computed
+ !************************************************************************
+
+ if (itime.lt.loutnext) then
+ ldeltat=itime-(loutnext-loutstep)
+ else ! first half of next interval
+ ldeltat=itime-loutnext
+ endif
+
+
+ ! Loop over all particles
+ !************************
+ ! Various variables for testing reason of CBL scheme, by mc
+ well_mixed_vector=0. !erase vector to test well mixed condition: modified by mc
+ well_mixed_norm=0. !erase normalization to test well mixed condition: modified by mc
+ avg_ol=0.
+ avg_wst=0.
+ avg_h=0.
+ avg_air_dens=0. !erase vector to obtain air density at particle positions: modified by mc
+ !-----------------------------------------------------------------------------
+
+ ! openmp change
+ ! LB, openmp following CTM version, need to be very careful due to big differences
+ ! between the openmp loop in this and the CTM version
+!$OMP PARALLEL PRIVATE(prob_rec,ks,thread,j)
+
+#if (defined _OPENMP)
+ thread = OMP_GET_THREAD_NUM()
+#endif
+
+!$OMP DO
+ do j=1,numpart
+
+ ! If integration step is due, do it
+ !**********************************
+ if (.not. part(j)%alive) cycle
+
+ ! Initialize newly released particle
+ !***********************************
+ if ((part(j)%tstart.eq.itime).or.(itime.eq.0)) then
+ call update_zeta_to_z(itime, j)
+ call initialize_particle(itime,j)
+ endif
+
+ ! Memorize particle positions
+ !****************************
+ part(j)%xlon_prev=part(j)%xlon
+ part(j)%ylat_prev=part(j)%ylat
+ part(j)%z_prev=part(j)%z
+
+ ! RECEPTOR: dry/wet depovel
+ !****************************
+ ! Before the particle is moved
+ ! the calculation of the scavenged mass shall only be done once after release
+ ! xscav_frac1 was initialised with a negative value
+
+ if (DRYBKDEP) then
+ do ks=1,nspec
+ if ((xscav_frac1(j,ks).lt.0)) then
+ call update_zeta_to_z(itime,j)
+ call get_vdep_prob(itime,part(j)%xlon,part(j)%ylat,part(j)%z,prob_rec)
+ if (DRYDEPSPEC(ks)) then ! dry deposition
+ xscav_frac1(j,ks)=prob_rec(ks)
+ else
+ part(j)%mass(ks)=0.
+ xscav_frac1(j,ks)=0.
+ endif
+ endif
+ enddo
+ endif
+
+ ! Integrate Lagevin equation for lsynctime seconds
+ !*************************************************
+
+ call advance(itime,j)
+
+ end do
+
+!$OMP END DO
+!$OMP END PARALLEL
+
+ do j=1,numpart
+ ! If integration step is due, do it
+ !**********************************
+ if (.not. part(j)%alive) cycle
+
+ ! Determine age class of the particle
+ itage=abs(itime-part(j)%tstart)
+ do nage=1,nageclass
+ if (itage.lt.lage(nage)) exit
+ end do
+ ! Calculate the gross fluxes across layer interfaces
+ !***************************************************
+
+ if (iflux.eq.1) call calcfluxes(itime,nage,j,real(part(j)%xlon_prev), &
+ real(part(j)%ylat_prev),real(part(j)%z_prev)) !OMP reduction necessary for flux array
+
+
+ ! Determine, when next time step is due
+ ! If trajectory is terminated, mark it
+ !**************************************
+ if (part(j)%nstop) then
+ if (linit_cond.ge.1) call initial_cond_calc(itime,j) !OMP reduction necessary for init_cond
+ call terminate_particle(j)
+ else
+
+ ! Dry deposition and radioactive decay for each species
+ ! Also check maximum (of all species) of initial mass remaining on the particle;
+ ! if it is below a threshold value, terminate particle
+ !*****************************************************************************
+
+ xmassfract=0.
+ do ks=1,nspec
+ if (DRYDEPSPEC(ks)) then ! dry deposition (and radioactive decay)
+ call drydepo_massloss(j,ks,ldeltat,drydeposit(ks))
+ else if (decay(ks).gt.0.) then ! no dry deposition, but radioactive decay
+ part(j)%mass(ks)=part(j)%mass(ks)*exp(-real(abs(lsynctime))*decay(ks))
+ endif
+
+ ! Skip check on mass fraction when npoint represents particle number
+ if (mdomainfill.eq.0.and.mquasilag.eq.0) then
+ if (xmass(part(j)%npoint,ks).gt.0.) then
+ xmassfract=max(xmassfract,real(npart(part(j)%npoint))* &
+ part(j)%mass(ks)/xmass(part(j)%npoint,ks))
+ endif
+
+ else
+ xmassfract=1.0
+ end if
+ end do
+
+ if (xmassfract.lt.minmass) then ! terminate all particles carrying less mass
+ call terminate_particle(j)
+ endif
+
+! Sabine Eckhardt, June 2008
+! don't create depofield for backward runs
+ if (DRYDEP.AND.(ldirect.eq.1)) then !OMP reduction necessary for drygridunc
+
+ if (ioutputforeachrelease.eq.1) then
+ kp=part(j)%npoint
+ else
+ kp=1
+ endif
+
+ call drydepokernel(part(j)%nclass,drydeposit,real(part(j)%xlon), &
+ real(part(j)%ylat),nage,kp)
+ if (nested_output.eq.1) call drydepokernel_nest( &
+ part(j)%nclass,drydeposit,real(part(j)%xlon),real(part(j)%ylat), &
+ nage,kp)
+ endif
+
+ ! Terminate trajectories that are older than maximum allowed age
+ !***************************************************************
+
+ if ((part(j)%alive).and.(abs(itime-part(j)%tstart).ge.lage(nageclass))) then
+ if (linit_cond.ge.1) call initial_cond_calc(itime+lsynctime,j)
+ call terminate_particle(j)
+ endif
+ endif
+
+ end do !loop over particles
+
+ ! openmp change end
+
+ ! Counter of "unstable" particle velocity during a time scale of
+ ! maximumtl=20 minutes (defined in com_mod)
+ !***************************************************************
+
+ total_nan_intl=0
+ i_nan=i_nan+1 ! added by mc to count nan during a time of maxtl (i.e. maximum tl fixed here to 20 minutes, see com_mod)
+ sum_nan_count(i_nan)=nan_count
+ if (i_nan > maxtl/lsynctime) i_nan=1 !lsynctime must be <= maxtl
+ do ii_nan=1, (maxtl/lsynctime)
+ total_nan_intl=total_nan_intl+sum_nan_count(ii_nan)
+ end do
+ ! Output to keep track of the numerical instabilities in CBL simulation and if
+ ! they are compromising the final result (or not)
+ if (cblflag.eq.1) print *,j,itime,'nan_synctime',nan_count,'nan_tl',total_nan_intl
+
+ end do
+
+
+ ! Complete the calculation of initial conditions for particles not yet terminated
+ !*****************************************************************************
+
+ do j=1,numpart
+ if (linit_cond.ge.1) call initial_cond_calc(itime,j)
+ end do
+
+ if (ipout.eq.2) call partoutput(itime)!,active_per_rel) ! dump particle positions
+
+ if (linit_cond.ge.1) then
+ if(linversionout.eq.1) then
+ call initial_cond_output_inversion(itime) ! dump initial cond. field
+ else
+ call initial_cond_output(itime) ! dump initial cond. fielf
+ endif
+ endif
+
+ ! De-allocate memory and end
+ !***************************
+ call deallocate_all_particles()
+ if (iflux.eq.1) then
+ deallocate(flux)
+ endif
+ if (OHREA) then
+ deallocate(OH_field,OH_hourly,lonOH,latOH,altOH)
+ endif
+ if (grid_output.eq.1) then
+ if (ldirect.gt.0) then
+ deallocate(drygridunc,wetgridunc)
+ endif
+ deallocate(gridunc)
+ endif
+ deallocate(xpoint1,xpoint2,ypoint1,ypoint2,zpoint1,zpoint2,xmass)
+ deallocate(ireleasestart,ireleaseend,npart,kindz)
+ deallocate(xmasssave)
+ if (nested_output.eq.1) then
+ deallocate(orooutn, arean, volumen)
+ if (ldirect.gt.0) then
+ deallocate(griduncn,drygriduncn,wetgriduncn)
+ endif
+ endif
+ if (grid_output.eq.1) then
+ deallocate(outheight,outheighthalf)
+ deallocate(oroout, area, volume)
+ endif
+end subroutine timemanager
+
+subroutine timemanager_concentrations(itime,loutstart,loutend,loutnext,outnum)
+ use unc_mod
+ use outg_mod
+ use par_mod
+ use com_mod
+#ifdef USE_NCF
+ use netcdf_output_mod, only: concoutput_netcdf,concoutput_nest_netcdf,&
+ &concoutput_surf_netcdf,concoutput_surf_nest_netcdf
+#endif
+ use binary_output_mod
+
+ implicit none
+
+ integer,intent(in) :: &
+ itime ! time index
+ integer,intent(inout) :: &
+ loutstart,loutend, & ! concentration calculation starting and ending time
+ loutnext
+ real,intent(inout) :: &
+ outnum ! concentration calculation sample number
+ real(sp) :: &
+ gridtotalunc ! concentration calculation related
+ real(dep_prec) :: &
+ wetgridtotalunc, & ! concentration calculation related
+ drygridtotalunc ! concentration calculation related
+ real :: &
+ weight ! concentration calculation sample weight
+
+ ! Is the time within the computation interval, if not, return
+ !************************************************************
+ if ((ldirect*itime.lt.ldirect*loutstart).or.(ldirect*itime.gt.ldirect*loutend)) then
+ return
+ endif
+
+ ! If we are exactly at the start or end of the concentration averaging interval,
+ ! give only half the weight to this sample
+ !*****************************************************************************
+ if (mod(itime-loutstart,loutsample).eq.0) then
+ if ((itime.eq.loutstart).or.(itime.eq.loutend)) then
+ weight=0.5
+ else
+ weight=1.0
+ endif
+ outnum=outnum+weight
+ call conccalc(itime,weight)
+ endif
+
+ ! If it is not time yet to write outputs, return
+ !***********************************************
+ if ((itime.ne.loutend).or.(outnum.le.0)) then
+ return
+ endif
+
+ ! Output and reinitialization of grid
+ ! If necessary, first sample of new grid is also taken
+ !*****************************************************
+ if ((iout.le.3.).or.(iout.eq.5)) then
+ if (surf_only.ne.1) then
+#ifdef USE_NCF
+ call concoutput_netcdf(itime,outnum,gridtotalunc,wetgridtotalunc,drygridtotalunc)
+#else
+ call concoutput(itime,outnum,gridtotalunc,wetgridtotalunc,drygridtotalunc)
+#endif
+ else
+#ifdef USE_NCF
+ call concoutput_surf_netcdf(itime,outnum,gridtotalunc,wetgridtotalunc,drygridtotalunc)
+#else
+ if (linversionout.eq.1) then
+ call concoutput_inversion(itime,outnum,gridtotalunc,wetgridtotalunc,drygridtotalunc)
+ else
+ call concoutput_surf(itime,outnum,gridtotalunc,wetgridtotalunc,drygridtotalunc)
+ endif
+#endif
+ endif
+
+ if (nested_output .eq. 1) then
+#ifdef USE_NCF
+ if (surf_only.ne.1) then
+ call concoutput_nest_netcdf(itime,outnum)
+ else
+ call concoutput_surf_nest_netcdf(itime,outnum)
+ endif
+#else
+ if (surf_only.ne.1) then
+ call concoutput_nest(itime,outnum)
+ else
+ if(linversionout.eq.1) then
+ call concoutput_inversion_nest(itime,outnum)
+ else
+ call concoutput_surf_nest(itime,outnum)
+ endif
+ endif
+#endif
+ endif
+ outnum=0.
+ endif
+
+ write(*,45) itime,numpart,gridtotalunc,wetgridtotalunc,drygridtotalunc
+
+45 format(i13,' Seconds simulated: ',i13, ' Particles: Uncertainty: ',3f7.3)
+
+ loutnext=loutnext+loutstep
+ loutstart=loutnext-loutaver/2
+ loutend=loutnext+loutaver/2
+ if (itime.eq.loutstart) then
+ weight=0.5
+ outnum=outnum+weight
+ call conccalc(itime,weight)
+ endif
+end subroutine timemanager_concentrations
\ No newline at end of file
diff --git a/src/timemanager_mpi.f90 b/src/redundant/timemanager_mpi.f90
similarity index 99%
rename from src/timemanager_mpi.f90
rename to src/redundant/timemanager_mpi.f90
index 2cedc2b4..b60bee38 100644
--- a/src/timemanager_mpi.f90
+++ b/src/redundant/timemanager_mpi.f90
@@ -579,7 +579,7 @@ subroutine timemanager(metdata_format)
irec=0
do ip=0, mp_partgroup_np-1
if (ip.eq.mp_partid) then
- if (mod(itime,ipoutfac*loutstep).eq.0) call partoutput(itime) ! dump particle positions
+ if (mod(itime,27000).eq.0) call partoutput(itime) ! dump particle positions
if (ipout.eq.3) call partoutput_average(itime,irec) ! dump particle positions
endif
if (ipout.eq.3) irec=irec+npart_per_process(ip)
diff --git a/src/verttransform_ecmwf.f90 b/src/redundant/verttransform_ecmwf.f90
similarity index 82%
rename from src/verttransform_ecmwf.f90
rename to src/redundant/verttransform_ecmwf.f90
index b209bc34..a771ef02 100644
--- a/src/verttransform_ecmwf.f90
+++ b/src/redundant/verttransform_ecmwf.f90
@@ -2,7 +2,7 @@
! SPDX-License-Identifier: GPL-3.0-or-later
subroutine verttransform_ecmwf(n,uuh,vvh,wwh,pvh)
-! i i i i i
+! i i i i i
!*****************************************************************************
! *
! This subroutine transforms temperature, dew point temperature and *
@@ -64,7 +64,7 @@ subroutine verttransform_ecmwf(n,uuh,vvh,wwh,pvh)
real,dimension(0:nxmax-1,0:nymax-1,nzmax) :: pinmconv
! RLT added pressure
real,dimension(0:nxmax-1,0:nymax-1,nuvzmax) :: prsh
- real,dimension(0:nxmax-1,0:nymax-1) :: tvold,pold,pint,tv
+ real,dimension(0:nxmax-1,0:nymax-1) :: tvold,pold,pint,tv,dpdeta
real,dimension(0:nymax-1) :: cosf
integer,dimension(0:nxmax-1,0:nymax-1) :: rain_cloud_above,idx
@@ -144,7 +144,7 @@ subroutine verttransform_ecmwf(n,uuh,vvh,wwh,pvh)
3 continue
- tvold(ixm,jym)=tt2(ixm,jym,1,n)*(1.+0.378*ew(td2(ixm,jym,1,n))/ &
+ tvold(ixm,jym)=tt2(ixm,jym,1,n)*(1.+0.378*ew(td2(ixm,jym,1,n),ps(ixm,jym,1,n))/ &
ps(ixm,jym,1,n))
pold(ixm,jym)=ps(ixm,jym,1,n)
height(1)=0.
@@ -183,10 +183,9 @@ subroutine verttransform_ecmwf(n,uuh,vvh,wwh,pvh)
do kz=1,nz
if (height(kz).gt.hmixmax) then
nmixz=kz
- goto 9
+ exit
endif
end do
-9 continue
! Do not repeat initialization of the Cartesian z grid
!*****************************************************
@@ -203,7 +202,7 @@ subroutine verttransform_ecmwf(n,uuh,vvh,wwh,pvh)
do jy=0,nymin1
do ix=0,nxmin1
- tvold(ix,jy)=tt2(ix,jy,1,n)*(1.+0.378*ew(td2(ix,jy,1,n))/ &
+ tvold(ix,jy)=tt2(ix,jy,1,n)*(1.+0.378*ew(td2(ix,jy,1,n),ps(ix,jy,1,n))/ &
ps(ix,jy,1,n))
enddo
enddo
@@ -449,6 +448,48 @@ subroutine verttransform_ecmwf(n,uuh,vvh,wwh,pvh)
end do
end do
+! Keep original fields if wind_coord_type==ETA
+ if (wind_coord_type.eq.'ETA') then
+ uueta(:,:,:,n) = uuh(:,:,:)
+ vveta(:,:,:,n) = vvh(:,:,:)
+ tteta(:,:,:,n) = tth(:,:,:,n)
+ qveta(:,:,:,n) = qvh(:,:,:,n)
+ pveta(:,:,:,n) = pvh(:,:,:)
+ rhoeta(:,:,:,n) = rhoh(:,:,:)
+ drhodzeta(:,:,1,n)=(rhoeta(:,:,2,n)-rhoeta(:,:,1,n))/ &
+ (height(2)-height(1))
+ do kz=2,nz-1
+ drhodzeta(:,:,kz,n)=(rhoeta(:,:,kz+1,n)-rhoeta(:,:,kz-1,n))/ &
+ (height(kz+1)-height(kz-1)) ! Note that this is still in SI units and not in eta
+ end do
+ drhodzeta(:,:,nz,n)=drhodzeta(:,:,nz-1,n)
+ tvirtual(:,:,:,n)=tteta(:,:,:,n)* &
+ ((qveta(:,:,:,n)+0.622)/(0.622*qveta(:,:,:,n)+0.622)) ! eq A11 from Mid-latitude atmospheric dynamics by Jonathan E. Martin
+ !tvirtual(:,:,:,n)=tteta(:,:,:,n)*(1.+0.608*qveta(:,:,:,n))
+ do jy=0,ny-1
+ do ix=0,nx-1
+ tvirtual(ix,jy,1,n)=tt2(ix,jy,1,n)*(1.+0.378*ew(td2(ix,jy,1,n),ps(ix,jy,1,n))/ps(ix,jy,1,n))
+ end do
+ end do
+
+
+ ! Convert w from Pa/s to eta/s, following FLEXTRA
+ !************************************************
+ do kz=1,nuvz-1
+ if (kz.eq.1) then
+ dpdeta=(akz(kz+1)-akz(kz)+(bkz(kz+1)-bkz(kz))*ps(:,:,1,n))/ &
+ (uvheight(kz+1)-uvheight(kz))
+ else if (kz.eq.nuvz-1) then
+ dpdeta=(akz(kz)-akz(kz-1)+(bkz(kz)-bkz(kz-1))*ps(:,:,1,n))/ &
+ (uvheight(kz)-uvheight(kz-1))
+ else
+ dpdeta=(akz(kz+1)-akz(kz)+(bkz(kz+1)-bkz(kz))*ps(:,:,1,n))/ &
+ (uvheight(kz+1)-uvheight(kz))
+ endif
+ wweta(:,:,kz,n)=wwh(:,:,kz)/dpdeta
+ end do
+ endif
+
! If north pole is in the domain, calculate wind velocities in polar
! stereographic coordinates
!*******************************************************************
@@ -462,6 +503,11 @@ subroutine verttransform_ecmwf(n,uuh,vvh,wwh,pvh)
call cc2gll(northpolemap,ylat,xlon,uu(ix,jy,iz,n), &
vv(ix,jy,iz,n),uupol(ix,jy,iz,n), &
vvpol(ix,jy,iz,n))
+ if (wind_coord_type.eq.'ETA') then
+ call cc2gll(northpolemap,ylat,xlon,uueta(ix,jy,iz,n), &
+ vveta(ix,jy,iz,n),uupoleta(ix,jy,iz,n), &
+ vvpoleta(ix,jy,iz,n))
+ endif
end do
end do
end do
@@ -505,6 +551,42 @@ subroutine verttransform_ecmwf(n,uuh,vvh,wwh,pvh)
end do
end do
+ if (wind_coord_type.eq.'ETA') then
+ do iz=1,nz
+
+ xlon=xlon0+real(nx/2-1)*dx
+ xlonr=xlon*pi/180.
+ ffpol=sqrt(uueta(nx/2-1,nymin1,iz,n)**2+ &
+ vveta(nx/2-1,nymin1,iz,n)**2)
+ if (vveta(nx/2-1,nymin1,iz,n).lt.0.) then
+ ddpol=atan(uueta(nx/2-1,nymin1,iz,n)/ &
+ vveta(nx/2-1,nymin1,iz,n))-xlonr
+ else if (vveta(nx/2-1,nymin1,iz,n).gt.0.) then
+ ddpol=pi+atan(uueta(nx/2-1,nymin1,iz,n)/ &
+ vveta(nx/2-1,nymin1,iz,n))-xlonr
+ else
+ ddpol=pi/2-xlonr
+ endif
+ if(ddpol.lt.0.) ddpol=2.0*pi+ddpol
+ if(ddpol.gt.2.0*pi) ddpol=ddpol-2.0*pi
+
+ ! CALCULATE U,V FOR 180 DEG, TRANSFORM TO POLAR STEREOGRAPHIC GRID
+ xlon=180.0
+ xlonr=xlon*pi/180.
+ ylat=90.0
+ uuaux=-ffpol*sin(xlonr+ddpol)
+ vvaux=-ffpol*cos(xlonr+ddpol)
+ call cc2gll(northpolemap,ylat,xlon,uuaux,vvaux,uupolaux, &
+ vvpolaux)
+
+ jy=nymin1
+ do ix=0,nxmin1
+ uupoleta(ix,jy,iz,n)=uupolaux
+ vvpoleta(ix,jy,iz,n)=vvpolaux
+ end do
+ end do
+ endif
+
! Fix: Set W at pole to the zonally averaged W of the next equator-
! ward parallel of latitude
@@ -522,6 +604,21 @@ subroutine verttransform_ecmwf(n,uuh,vvh,wwh,pvh)
end do
end do
+ if (wind_coord_type.eq.'ETA') then
+ do iz=1,nz
+ wdummy=0.
+ jy=ny-2
+ do ix=0,nxmin1
+ wdummy=wdummy+wweta(ix,jy,iz,n)
+ end do
+ wdummy=wdummy/real(nx)
+ jy=nymin1
+ do ix=0,nxmin1
+ wweta(ix,jy,iz,n)=wdummy
+ end do
+ end do
+ endif
+
endif
@@ -538,6 +635,11 @@ subroutine verttransform_ecmwf(n,uuh,vvh,wwh,pvh)
call cc2gll(southpolemap,ylat,xlon,uu(ix,jy,iz,n), &
vv(ix,jy,iz,n),uupol(ix,jy,iz,n), &
vvpol(ix,jy,iz,n))
+ if (wind_coord_type.eq.'ETA') then
+ call cc2gll(southpolemap,ylat,xlon,uueta(ix,jy,iz,n), &
+ vveta(ix,jy,iz,n),uupoleta(ix,jy,iz,n), &
+ vvpoleta(ix,jy,iz,n))
+ endif
end do
end do
end do
@@ -580,6 +682,44 @@ subroutine verttransform_ecmwf(n,uuh,vvh,wwh,pvh)
end do
end do
+ if (wind_coord_type.eq.'ETA') then
+ do iz=1,nz
+ ! CALCULATE FFPOL, DDPOL FOR CENTRAL GRID POINT
+ !
+ ! AMSnauffer Nov 18 2004 Added check for case vv=0
+ !
+ xlon=xlon0+real(nx/2-1)*dx
+ xlonr=xlon*pi/180.
+ ffpol=sqrt(uueta(nx/2-1,0,iz,n)**2+ &
+ vveta(nx/2-1,0,iz,n)**2)
+ if (vveta(nx/2-1,0,iz,n).lt.0.) then
+ ddpol=atan(uueta(nx/2-1,0,iz,n)/ &
+ vveta(nx/2-1,0,iz,n))+xlonr
+ else if (vveta(nx/2-1,0,iz,n).gt.0.) then
+ ddpol=pi+atan(uueta(nx/2-1,0,iz,n)/ &
+ vveta(nx/2-1,0,iz,n))+xlonr
+ else
+ ddpol=pi/2-xlonr
+ endif
+ if(ddpol.lt.0.) ddpol=2.0*pi+ddpol
+ if(ddpol.gt.2.0*pi) ddpol=ddpol-2.0*pi
+
+ ! CALCULATE U,V FOR 180 DEG, TRANSFORM TO POLAR STEREOGRAPHIC GRID
+ xlon=180.0
+ xlonr=xlon*pi/180.
+ ylat=-90.0
+ uuaux=+ffpol*sin(xlonr-ddpol)
+ vvaux=-ffpol*cos(xlonr-ddpol)
+ call cc2gll(northpolemap,ylat,xlon,uuaux,vvaux,uupolaux, &
+ vvpolaux)
+
+ jy=0
+ do ix=0,nxmin1
+ uupoleta(ix,jy,iz,n)=uupolaux
+ vvpoleta(ix,jy,iz,n)=vvpolaux
+ end do
+ end do
+ endif
! Fix: Set W at pole to the zonally averaged W of the next equator-
! ward parallel of latitude
@@ -596,6 +736,21 @@ subroutine verttransform_ecmwf(n,uuh,vvh,wwh,pvh)
ww(ix,jy,iz,n)=wdummy
end do
end do
+
+ if (wind_coord_type.eq.'ETA') then
+ do iz=1,nz
+ wdummy=0.
+ jy=1
+ do ix=0,nxmin1
+ wdummy=wdummy+wweta(ix,jy,iz,n)
+ end do
+ wdummy=wdummy/real(nx)
+ jy=0
+ do ix=0,nxmin1
+ wweta(ix,jy,iz,n)=wdummy
+ end do
+ end do
+ endif
endif
@@ -724,170 +879,28 @@ subroutine verttransform_ecmwf(n,uuh,vvh,wwh,pvh)
!********* TEST ***************
! WRITE OUT SOME TEST VARIABLES
!********* TEST ************'**
-!teller(:)=0
virr=virr+1
-WRITE(aspec, '(i3.3)'), virr
+WRITE(aspec, '(i3.3)') virr
-!if (readclouds) then
-!fnameH=trim(zhgpath)//trim(aspec)//'Vertical_placement.txt'
-!else
-!fnameH=trim(zhgpath)//trim(aspec)//'Vertical_placement_old.txt'
-!endif
-!
-!OPEN(UNIT=118, FILE=fnameH,FORM='FORMATTED',STATUS = 'UNKNOWN')
-!do kz_inv=1,nz-1
-! kz=nz-kz_inv+1
-! !kz=91
-! do jy=0,nymin1
-! do ix=0,nxmin1
-! if (clouds(ix,jy,kz,n).eq.1) teller(1)=teller(1)+1 ! no precipitation cloud
-! if (clouds(ix,jy,kz,n).eq.2) teller(2)=teller(2)+1 ! convp dominated rainout
-! if (clouds(ix,jy,kz,n).eq.3) teller(3)=teller(3)+1 ! lsp dominated rainout
-! if (clouds(ix,jy,kz,n).eq.4) teller(4)=teller(4)+1 ! convp dominated washout
-! if (clouds(ix,jy,kz,n).eq.5) teller(5)=teller(5)+1 ! lsp dominated washout
-!
-! ! write(*,*) height(kz),teller
-! end do
-! end do
-! write(118,*) height(kz),teller
-! teller(:)=0
-!end do
-!teller(:)=0
-!write(*,*) teller
-!write(*,*) aspec
-!
-!fnameA=trim(zhgpath)//trim(aspec)//'cloudV.txt'
-!fnameB=trim(zhgpath)//trim(aspec)//'cloudT.txt'
-!fnameC=trim(zhgpath)//trim(aspec)//'cloudB.txt'
-!fnameD=trim(zhgpath)//trim(aspec)//'cloudW.txt'
-!fnameE=trim(zhgpath)//trim(aspec)//'old_cloudV.txt'
-!fnameF=trim(zhgpath)//trim(aspec)//'lsp.txt'
-!fnameG=trim(zhgpath)//trim(aspec)//'convp.txt'
if (1.eq.2) then
fnameH=trim(zhgpath)//trim(aspec)//'tcwc.txt'
fnameI=trim(zhgpath)//trim(aspec)//'prec.txt'
fnameJ=trim(zhgpath)//trim(aspec)//'cloudsh.txt'
write(*,*) 'Writing data to file: ',fnameH
-!if (readclouds) then
-!OPEN(UNIT=111, FILE=fnameA,FORM='FORMATTED',STATUS = 'UNKNOWN')
-!OPEN(UNIT=112, FILE=fnameB,FORM='FORMATTED',STATUS = 'UNKNOWN')
-!OPEN(UNIT=113, FILE=fnameC,FORM='FORMATTED',STATUS = 'UNKNOWN')
-!OPEN(UNIT=114, FILE=fnameD,FORM='FORMATTED',STATUS = 'UNKNOWN')
-!else
+
OPEN(UNIT=115, FILE=fnameH,FORM='FORMATTED',STATUS = 'UNKNOWN')
OPEN(UNIT=116, FILE=fnameI,FORM='FORMATTED',STATUS = 'UNKNOWN')
OPEN(UNIT=117, FILE=fnameJ,FORM='FORMATTED',STATUS = 'UNKNOWN')
-!endif
-!
+
do ix=0,nxmin1
-!if (readclouds) then
-!write(111,*) (icloud_stats(ix,jy,1,n),jy=0,nymin1)
-!write(112,*) (icloud_stats(ix,jy,2,n),jy=0,nymin1)
-!write(113,*) (icloud_stats(ix,jy,3,n),jy=0,nymin1)
-!write(114,*) (icloud_stats(ix,jy,4,n),jy=0,nymin1)
-!else
write(115,*) (ctwc(ix,jy,n),jy=0,nymin1)
write(116,*) (lsprec(ix,jy,1,n)+convprec(ix,jy,1,n),jy=0,nymin1)
write(117,*) (cloudsh(ix,jy,n),jy=0,nymin1)
-!endif
end do
-!
-!if (readclouds) then
-!CLOSE(111)
-!CLOSE(112)
-!CLOSE(113)
-!CLOSE(114)
-!else
CLOSE(115)
CLOSE(116)
CLOSE(117)
endif
-!endif
-!
-!END ********* TEST *************** END
-! WRITE OUT SOME TEST VARIABLES
-!END ********* TEST *************** END
-
-
-! PS 2012
-! lsp=lsprec(ix,jy,1,n)
-! convp=convprec(ix,jy,1,n)
-! prec=lsp+convp
-! if (lsp.gt.convp) then ! prectype='lsp'
-! lconvectprec = .false.
-! else ! prectype='cp'
-! lconvectprec = .true.
-! endif
-! else ! windfields does not contain cloud data
-! rhmin = 0.90 ! standard condition for presence of clouds
-!PS note that original by Sabine Eckhart was 80%
-!PS however, for T<-20 C we consider saturation over ice
-!PS so I think 90% should be enough
-! icloudbot(ix,jy,n)=icmv
-! icloudtop=icmv ! this is just a local variable
-!98 do kz=1,nz
-! pressure=rho(ix,jy,kz,n)*r_air*tt(ix,jy,kz,n)
-! rh=qv(ix,jy,kz,n)/f_qvsat(pressure,tt(ix,jy,kz,n))
-!ps if (prec.gt.0.01) print*,'relhum',prec,kz,rh,height(kz)
-! if (rh .gt. rhmin) then
-! if (icloudbot(ix,jy,n) .eq. icmv) then
-! icloudbot(ix,jy,n)=nint(height(kz))
-! endif
-! icloudtop=nint(height(kz)) ! use int to save memory
-! endif
- ! end do
-!PS try to get a cloud thicker than 50 m
-!PS if there is at least .01 mm/h - changed to 0.002 and put into
-!PS parameter precpmin
-! if ((icloudbot(ix,jy,n) .eq. icmv .or. &
-! icloudtop-icloudbot(ix,jy,n) .lt. 50) .and. &
-! prec .gt. precmin) then
-! rhmin = rhmin - 0.05
-! if (rhmin .ge. 0.30) goto 98 ! give up for <= 25% rel.hum.
-! end if
-
-!PS is based on looking at a limited set of comparison data
-! if (lconvectprec .and. icloudtop .lt. 6000 .and. &
-! prec .gt. precmin) then
-!
-! if (convp .lt. 0.1) then
-! icloudbot(ix,jy,n) = 500
-! icloudtop = 8000
-! else
-! icloudbot(ix,jy,n) = 0
-! icloudtop = 10000
-! endif
-! endif
-! if (icloudtop .ne. icmv) then
-! icloudthck(ix,jy,n) = icloudtop-icloudbot(ix,jy,n)
-! else
-! icloudthck(ix,jy,n) = icmv
-! endif
-!PS get rid of too thin clouds
-! if (icloudthck(ix,jy,n) .lt. 50) then
-! icloudbot(ix,jy,n)=icmv
-! icloudthck(ix,jy,n)=icmv
-! endif
-!hg__________________________________
-! rcw(ix,jy)=2E-7*prec**0.36
-! rpc(ix,jy)=prec
-!hg end______________________________
-
-! endif !hg read clouds
-
-
-
-!eso measure CPU time
-! call mpif_mtime('verttransform',1)
-
-!eso print out the same measure as in Leo's routine
- ! write(*,*) 'verttransform: ', &
- ! sum(tt(:,:,:,n)*tt(:,:,:,n)), &
- ! sum(uu(:,:,:,n)*uu(:,:,:,n)),sum(vv(:,:,:,n)*vv(:,:,:,n)),&
- ! sum(qv(:,:,:,n)*qv(:,:,:,n)),sum(pv(:,:,:,n)*pv(:,:,:,n)),&
- ! sum(rho(:,:,:,n)*rho(:,:,:,n)),sum(drhodz(:,:,:,n)*drhodz(:,:,:,n)),&
- ! sum(ww(:,:,:,n)*ww(:,:,:,n)), &
- ! sum(clouds(:,:,:,n)), sum(cloudsh(:,:,n)),sum(idx),sum(pinmconv)
end subroutine verttransform_ecmwf
diff --git a/src/verttransform_gfs.f90 b/src/redundant/verttransform_gfs.f90
similarity index 100%
rename from src/verttransform_gfs.f90
rename to src/redundant/verttransform_gfs.f90
diff --git a/src/verttransform_nests.f90 b/src/redundant/verttransform_nests.f90
similarity index 100%
rename from src/verttransform_nests.f90
rename to src/redundant/verttransform_nests.f90
diff --git a/src/wetdepo.f90 b/src/redundant/wetdepo.f90
similarity index 70%
rename from src/wetdepo.f90
rename to src/redundant/wetdepo.f90
index 7c98cc56..720fb872 100644
--- a/src/wetdepo.f90
+++ b/src/redundant/wetdepo.f90
@@ -41,6 +41,8 @@ subroutine wetdepo(itime,ltsample,loutnext)
use point_mod
use par_mod
use com_mod
+ use unc_mod, only:wetgridunc
+ use particle_mod
implicit none
@@ -67,22 +69,21 @@ subroutine wetdepo(itime,ltsample,loutnext)
blc_count(:)=0
inc_count(:)=0
+! OMP doesn't work yet, a reduction is necessary for the kernel function
do jpart=1,numpart
- if (itra1(jpart).eq.-999999999) goto 20
- if(ldirect.eq.1)then
- if (itra1(jpart).gt.itime) goto 20
- else
- if (itra1(jpart).lt.itime) goto 20
- endif
+ ! Check if memory has been deallocated
+ if (.not. is_particle_allocated(jpart)) cycle
+
+ ! Check if particle is still allive
+ if (.not. part(jpart)%alive) cycle
! Determine age class of the particle - nage is used for the kernel
!******************************************************************
- itage=abs(itra1(jpart)-itramem(jpart))
+ itage=abs(itime-part(jpart)%tstart)
do nage=1,nageclass
- if (itage.lt.lage(nage)) goto 33
+ if (itage.lt.lage(nage)) exit
end do
- 33 continue
do ks=1,nspec ! loop over species
@@ -99,29 +100,56 @@ subroutine wetdepo(itime,ltsample,loutnext)
! ((dquer(ks).gt.0.).and.(crain_aero(ks).gt.0..or.csnow_aero(ks).gt.0.).or. &
! (ccn_aero(ks).gt0) .or. (in_aero(ks).gt.0) .or. (henry(ks).gt.0))) then
- call get_wetscav(itime,ltsample,loutnext,jpart,ks,grfraction,inc_count,blc_count,wetscav)
-
+ call get_wetscav(itime,ltsample,loutnext,jpart,ks,grfraction,inc_count,blc_count,wetscav) ! OMP carefully check
+
+ ! WETBKDEP moved here from timemanager.f90
+ ! xscav_frac1...factor used to weight the wet depostion along the back-trajectory
+ ! (based on wetdepo at receptor)
+ ! jpart...particle index
+ ! ks...species index
+ ! grfraction(1)...fraction of grid, for which precipitation occurs; set in get_wetscav
+ ! zpoint2(npoint(jpart))...forced to be 20000m for wetdepo backward
+ ! zpoint1(npoint(jpart))...forced to be 0m for wetdepo backward
+ ! zpoint1,zpoint2...height range, over which release takes place; set in RELEASE file
+ ! as z1 and z2 => but for wetdepo backward always set to 0 and 20000m
+ if (WETBKDEP) then
+ if ((xscav_frac1(jpart,ks).lt.-0.1)) then ! particle marked as starting particle
+ if (wetscav.gt.0.) then
+ xscav_frac1(jpart,ks)=wetscav*(zpoint2(part(jpart)%npoint)-&
+ zpoint1(part(jpart)%npoint))*grfraction(1)
+ ! apl3 => print out particle number, wetscav, xscav_frac1
+! ! apl_8
+! if (ks.eq.1) write(*,924) 'wetdepo:',itime,jpart,wetscav,&
+! zpoint2(npoint(jpart)),zpoint1(npoint(jpart)),&
+! grfraction(1),xscav_frac1(jpart,ks)
+! 924 format(a,1x,2i9,5es13.5)
+ else
+ part(jpart)%mass(ks)=0.
+ xscav_frac1(jpart,ks)=0.
+ endif
+ endif
+ endif
if (wetscav.gt.0.) then
- wetdeposit(ks)=xmass1(jpart,ks)* &
+ wetdeposit(ks)=part(jpart)%mass(ks)* &
(1.-exp(-wetscav*abs(ltsample)))*grfraction(1) ! wet deposition
else ! if no scavenging
wetdeposit(ks)=0.
endif
- restmass = xmass1(jpart,ks)-wetdeposit(ks)
+ restmass = part(jpart)%mass(ks)-wetdeposit(ks)
if (ioutputforeachrelease.eq.1) then
- kp=npoint(jpart)
+ kp=part(jpart)%npoint
else
kp=1
endif
if (restmass .gt. smallnum) then
- xmass1(jpart,ks)=restmass
+ part(jpart)%mass(ks)=restmass
! depostatistic
! wetdepo_sum(ks,kp)=wetdepo_sum(ks,kp)+wetdeposit(ks)
! depostatistic
else
- xmass1(jpart,ks)=0.
+ part(jpart)%mass(ks)=0.
endif
! Correct deposited mass to the last time step when radioactive decay of
! gridded deposited mass was calculated
@@ -136,18 +164,17 @@ subroutine wetdepo(itime,ltsample,loutnext)
! Add the wet deposition to accumulated amount on output grid and nested output grid
!*****************************************************************************
- if (ldirect.eq.1) then
- call wetdepokernel(nclass(jpart),wetdeposit,real(xtra1(jpart)), &
- real(ytra1(jpart)),nage,kp)
- if (nested_output.eq.1) call wetdepokernel_nest(nclass(jpart), &
- wetdeposit,real(xtra1(jpart)),real(ytra1(jpart)),nage,kp)
+ if (ldirect.eq.1) then !OMP reduction necessary for wetgridunc
+ call wetdepokernel(part(jpart)%nclass,wetdeposit,real(part(jpart)%xlon), &
+ real(part(jpart)%ylat),nage,kp)
+ if (nested_output.eq.1) call wetdepokernel_nest(part(jpart)%nclass, &
+ wetdeposit,real(part(jpart)%xlon),real(part(jpart)%ylat),nage,kp)
endif
-20 continue
end do ! all particles
! count the total number of below-cloud and in-cloud occurences:
tot_blc_count(1:nspec)=tot_blc_count(1:nspec)+blc_count(1:nspec)
tot_inc_count(1:nspec)=tot_inc_count(1:nspec)+inc_count(1:nspec)
-end subroutine wetdepo
+end subroutine wetdepo
\ No newline at end of file
diff --git a/src/wetdepokernel.f90 b/src/redundant/wetdepokernel.f90
similarity index 100%
rename from src/wetdepokernel.f90
rename to src/redundant/wetdepokernel.f90
diff --git a/src/wetdepokernel_nest.f90 b/src/redundant/wetdepokernel_nest.f90
similarity index 100%
rename from src/wetdepokernel_nest.f90
rename to src/redundant/wetdepokernel_nest.f90
diff --git a/src/windalign.f90 b/src/redundant/windalign.f90
similarity index 100%
rename from src/windalign.f90
rename to src/redundant/windalign.f90
diff --git a/src/writeheader.f90 b/src/redundant/writeheader.f90
similarity index 100%
rename from src/writeheader.f90
rename to src/redundant/writeheader.f90
diff --git a/src/writeheader_nest.f90 b/src/redundant/writeheader_nest.f90
similarity index 100%
rename from src/writeheader_nest.f90
rename to src/redundant/writeheader_nest.f90
diff --git a/src/writeheader_nest_surf.f90 b/src/redundant/writeheader_nest_surf.f90
similarity index 100%
rename from src/writeheader_nest_surf.f90
rename to src/redundant/writeheader_nest_surf.f90
diff --git a/src/writeheader_surf.f90 b/src/redundant/writeheader_surf.f90
similarity index 100%
rename from src/writeheader_surf.f90
rename to src/redundant/writeheader_surf.f90
diff --git a/src/writeheader_txt.f90 b/src/redundant/writeheader_txt.f90
similarity index 100%
rename from src/writeheader_txt.f90
rename to src/redundant/writeheader_txt.f90
diff --git a/src/writeprecip.f90 b/src/redundant/writeprecip.f90
similarity index 100%
rename from src/writeprecip.f90
rename to src/redundant/writeprecip.f90
diff --git a/src/redundant/z_to_zeta.f90 b/src/redundant/z_to_zeta.f90
new file mode 100644
index 00000000..1ced3aa0
--- /dev/null
+++ b/src/redundant/z_to_zeta.f90
@@ -0,0 +1,82 @@
+! SPDX-FileCopyrightText: FLEXPART 1998-2019, see flexpart_license.txt
+! SPDX-License-Identifier: GPL-3.0-or-later
+
+subroutine z_to_zeta(itime,xt,yt,zold,zteta)
+ ! i i o o o
+ ! o o o i i i o
+ !*****************************************************************************
+ ! Converting z from eta coordinates to meters *
+ ! *
+ !*****************************************************************************
+ ! *
+ ! Variables: *
+ ! itime [s] current temporal position *
+ ! xteta,yteta,zteta spatial position of trajectory *
+ ! *
+ ! *
+ ! Constants: *
+ ! *
+ !*****************************************************************************
+
+ use par_mod
+ use com_mod
+ use interpol_mod
+
+ implicit none
+ integer, intent(in) :: &
+ itime ! time index
+ integer :: &
+ i,m,indexh ! loop indices
+ real(kind=dp), intent(in) :: &
+ xt,yt ! particle position
+ real, intent(in) :: &
+ zold ! particle verticle position in eta coordinates
+ real, intent(inout) :: &
+ zteta ! converted output z in meters
+ real :: &
+ ttemp_old,ttemp1(2),ttemp_new,& ! storing virtual temperature
+ ew, & ! why does this function need to be declared here?
+ ztemp1,ztemp2, & ! z positions of the two encompassing levels
+ frac, & ! fraction between z levels
+ psint1(2),psint ! pressure of encompassing levels
+
+ call determine_grid_coordinates(real(xt),real(yt))
+ call find_grid_distances(real(xt),real(yt))
+ call find_time_variables(itime)
+
+ call bilinear_horizontal_interpolation(ps,psint1,1,1)
+ call temporal_interpolation(psint1(1),psint1(2),psint)
+
+ call bilinear_horizontal_interpolation(tvirtual,ttemp1,1,nzmax)
+ call temporal_interpolation(ttemp1(1),ttemp1(2),ttemp_old)
+
+ ! Integration method as used in the original verttransform_ecmwf.f90
+ !+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+
+ ztemp1 = 0.
+ do i=2,nz-1
+
+ call bilinear_horizontal_interpolation(tvirtual,ttemp1,i,nzmax)
+ call temporal_interpolation(ttemp1(1),ttemp1(2),ttemp_new)
+
+ if (abs(ttemp_new-ttemp_old).gt.0.2) then
+ ztemp2=ztemp1+r_air/ga*log((akz(i-1)+bkz(i-1)*psint)/(akz(i)+bkz(i)*psint))* &
+ (ttemp_new-ttemp_old)/log(ttemp_new/ttemp_old)
+ else
+ ztemp2=ztemp1+r_air/ga*log((akz(i-1)+bkz(i-1)*psint)/(akz(i)+bkz(i)*psint))*ttemp_new
+ endif
+
+ if (ztemp2.gt.zold) then
+ frac = (zold-ztemp1)/(ztemp2-ztemp1)
+ exit
+ else if (i.eq.nz-1) then
+ frac = 1.
+ exit
+ endif
+ ttemp_old=ttemp_new
+ ztemp1=ztemp2
+ end do
+
+ zteta=uvheight(i-1)*(1.-frac)+uvheight(i)*frac
+
+end subroutine z_to_zeta
\ No newline at end of file
diff --git a/src/zenithangle.f90 b/src/redundant/zenithangle.f90
similarity index 100%
rename from src/zenithangle.f90
rename to src/redundant/zenithangle.f90
diff --git a/src/redundant/zeta_to_z.f90 b/src/redundant/zeta_to_z.f90
new file mode 100644
index 00000000..faeca1be
--- /dev/null
+++ b/src/redundant/zeta_to_z.f90
@@ -0,0 +1,93 @@
+! SPDX-FileCopyrightText: FLEXPART 1998-2019, see flexpart_license.txt
+! SPDX-License-Identifier: GPL-3.0-or-later
+
+subroutine zeta_to_z(itime,xt,yt,zteta,ztout)
+ ! i i o o o
+ ! o o o i i i o
+ !*****************************************************************************
+ ! Converting z from eta coordinates to meters *
+ ! *
+ !*****************************************************************************
+ ! *
+ ! Variables: *
+ ! itime [s] current temporal position *
+ ! xt,yt,zteta spatial position of trajectory *
+ ! *
+ ! *
+ ! *
+ !*****************************************************************************
+
+ use par_mod
+ use com_mod
+ use interpol_mod
+
+ implicit none
+ integer, intent(in) :: &
+ itime ! time index
+ integer :: &
+ i,j,k,m,indexh ! loop indices
+ real(kind=dp), intent(in) :: &
+ xt,yt ! particle position
+ real, intent(in) :: &
+ zteta ! particle verticle position in eta coordinates
+ real, intent(inout) :: &
+ ztout ! converted output z in meters
+ real :: &
+ ttemp_old,ttemp1(2),ttemp_new,& ! storing virtual temperature
+ ew, & ! why does this function need to be declared here?
+ ztemp1,ztemp2, & ! z positions of the two encompassing levels
+ frac, & ! fraction between z levels
+ psint1(2),psint ! pressure of encompassing levels
+
+
+ ! Convert eta z coordinate to meters
+ !***********************************
+ call determine_grid_coordinates(real(xt),real(yt))
+ call find_grid_distances(real(xt),real(yt))
+ call find_time_variables(itime)
+
+ k=nz-1
+ frac=1.
+ do k=2,nz-1
+ if (zteta.ge.uvheight(k)) then
+ frac=(zteta-uvheight(k-1))/(uvheight(k)-uvheight(k-1))
+ exit
+ endif
+ end do
+
+ call bilinear_horizontal_interpolation(ps,psint1,1,1)
+ call temporal_interpolation(psint1(1),psint1(2),psint)
+
+ call bilinear_horizontal_interpolation(tvirtual,ttemp1,1,nzmax)
+ call temporal_interpolation(ttemp1(1),ttemp1(2),ttemp_old)
+
+ ! ! ! Integration method as used in the original verttransform_ecmwf.f90
+ ! ! !+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+
+ ztemp1 = 0.
+ do i=2,k-1
+
+ call bilinear_horizontal_interpolation(tvirtual,ttemp1,i,nzmax)
+ call temporal_interpolation(ttemp1(1),ttemp1(2),ttemp_new)
+
+ if (abs(ttemp_new-ttemp_old).gt.0.2) then
+ ztemp1=ztemp1+r_air/ga*log((akz(i-1)+bkz(i-1)*psint)/(akz(i)+bkz(i)*psint))* &
+ (ttemp_new-ttemp_old)/log(ttemp_new/ttemp_old)
+ else
+ ztemp1=ztemp1+r_air/ga*log((akz(i-1)+bkz(i-1)*psint)/(akz(i)+bkz(i)*psint))*ttemp_new
+ endif
+ ttemp_old=ttemp_new
+ end do
+
+ call bilinear_horizontal_interpolation(tvirtual,ttemp1,k,nzmax)
+ call temporal_interpolation(ttemp1(1),ttemp1(2),ttemp_new)
+
+ if (abs(ttemp_new-ttemp_old).gt.0.2) then
+ ztemp2=ztemp1+r_air/ga*log((akz(k-1)+bkz(k-1)*psint)/(akz(k)+bkz(k)*psint))* &
+ (ttemp_new-ttemp_old)/log(ttemp_new/ttemp_old)
+ else
+ ztemp2=ztemp1+r_air/ga*log((akz(k-1)+bkz(k-1)*psint)/(akz(k)+bkz(k)*psint))*ttemp_new
+ endif
+ ztout = ztemp1*(1.-frac)+ztemp2*frac
+
+end subroutine zeta_to_z
\ No newline at end of file
diff --git a/src/restart_mod.f90 b/src/restart_mod.f90
new file mode 100644
index 00000000..faadc94e
--- /dev/null
+++ b/src/restart_mod.f90
@@ -0,0 +1,241 @@
+module restart_mod
+ use particle_mod
+ use coordinates_ecmwf_mod
+ use unc_mod
+ use date_mod
+#ifdef USE_NCF
+ use netcdf_output_mod
+#endif
+
+ character(len=256) :: restart_filename1,restart_filename2,restart_filename3
+
+contains
+
+subroutine output_restart(itime,loutnext,outnum)
+
+ implicit none
+
+ integer, intent(in) :: itime,loutnext
+ real, intent(in) :: outnum
+ integer :: i,j,jjjjmmdd,ihmmss,stat
+ integer :: ks,kp,kz,nage,jy,ix,l
+ real(kind=dp) :: jul
+ character :: adate*8,atime*6
+
+
+ jul=bdate+real(itime,kind=dp)/86400._dp
+ call caldate(jul,jjjjmmdd,ihmmss)
+ write(adate,'(i8.8)') jjjjmmdd
+ write(atime,'(i6.6)') ihmmss
+
+ restart_filename3 = restart_filename2
+ restart_filename2 = restart_filename1
+ restart_filename1 = path(2)(1:length(2))//'restart_'//adate//atime
+
+ write(*,*) 'Writing Restart file:', trim(restart_filename1)
+
+ open(unitrestart,file=restart_filename1,form='unformatted')
+
+ ! Write current time to file
+ !***************************
+
+ write(unitrestart) itime
+ write(unitrestart) count%allocated
+ write(unitrestart) loutnext
+ write(unitrestart) outnum
+
+ do i=1,count%allocated
+ if (part(i)%alive) then
+ call update_zeta_to_z(itime,i)
+ call update_z_to_zeta(itime,i)
+ endif
+ write(unitrestart) part(i)%xlon,part(i)%ylat,part(i)%z,part(i)%zeta, &
+ part(i)%npoint,part(i)%nclass,part(i)%idt,part(i)%tend, &
+ part(i)%tstart,part(i)%alive,part(i)%turbvel%u, &
+ part(i)%turbvel%v,part(i)%turbvel%w,part(i)%mesovel%u, &
+ part(i)%mesovel%v,part(i)%mesovel%w,(part(i)%mass(j),j=1,nspec), &
+ (part(i)%mass_init(j),j=1,nspec),(part(i)%wetdepo(j),j=1,nspec), &
+ (part(i)%drydepo(j),j=1,nspec)
+ end do
+ if (iout.gt.0) then
+#ifdef USE_NCF
+ write(unitrestart) tpointer
+#endif
+ do ks=1,nspec
+ do kp=1,maxpointspec_act
+ do nage=1,nageclass
+ do jy=0,numygrid-1
+ do ix=0,numxgrid-1
+ do l=1,nclassunc
+ do kz=1,numzgrid
+ write(unitrestart) gridunc(ix,jy,kz,ks,kp,l,nage)
+ end do
+ if ((wetdep).and.(ldirect.gt.0)) then
+ write(unitrestart) wetgridunc(ix,jy,ks,kp,l,nage)
+ endif
+ if ((drydep).and.(ldirect.gt.0)) then
+ write(unitrestart) drygridunc(ix,jy,ks,kp,l,nage)
+ endif
+ end do
+ end do
+ end do
+ if (nested_output.eq.1) then
+ do jy=0,numygridn-1
+ do ix=0,numxgridn-1
+ do l=1,nclassunc
+ do kz=1,numzgrid
+ write(unitrestart) griduncn(ix,jy,kz,ks,kp,l,nage)
+ end do
+ if ((wetdep).and.(ldirect.gt.0)) then
+ write(unitrestart) wetgriduncn(ix,jy,ks,kp,l,nage)
+ endif
+ if ((drydep).and.(ldirect.gt.0)) then
+ write(unitrestart) drygriduncn(ix,jy,ks,kp,l,nage)
+ endif
+ end do
+ end do
+ end do
+ endif
+ end do
+ end do
+ if ((drybkdep).or.(wetbkdep)) then
+ do i=1,count%allocated
+ write(unitrestart) xscav_frac1(i,ks)
+ end do
+ endif
+ end do
+ endif
+ close(unitrestart)
+
+ open(unit=1234, iostat=stat, file=restart_filename3, status='old')
+ if(stat == 0) close(1234, status='delete')
+end subroutine output_restart
+
+subroutine readrestart
+
+ !*****************************************************************************
+ ! *
+ ! This routine opens the particle dump file and reads all the particle *
+ ! positions and gridded information from a previous run to initialize *
+ ! the current run. *
+ ! *
+ ! Author: L. Bakels 2022 *
+ ! *
+ !*****************************************************************************
+
+ implicit none
+
+ integer :: i,j,ios
+ integer :: id1,id2,it1,it2
+ integer :: ks,kp,kz,nage,jy,ix,l
+ real(kind=dp) :: julin,julpartin
+ integer :: idummy = -8
+
+ numparticlecount=0
+
+
+ open(unitpartin,file=path(2)(1:length(2))//'restart.bin', &
+ form='unformatted',err=9989)
+
+ write(*,*) 'Reading Restart file:', path(2)(1:length(2))//'restart.bin'
+
+ read(unitpartin,iostat=ios) itime_init
+ read(unitpartin) numpart
+ read(unitpartin) loutnext_init
+ read(unitpartin) outnum_init
+ call spawn_particles(itime_init, numpart)
+ do i=1,numpart
+ read(unitpartin) part(i)%xlon,part(i)%ylat,part(i)%z,part(i)%zeta, &
+ part(i)%npoint,part(i)%nclass,part(i)%idt,part(i)%tend, &
+ part(i)%tstart,part(i)%alive,part(i)%turbvel%u, &
+ part(i)%turbvel%v,part(i)%turbvel%w,part(i)%mesovel%u, &
+ part(i)%mesovel%v,part(i)%mesovel%w,(part(i)%mass(j),j=1,nspec), &
+ (part(i)%mass_init(j),j=1,nspec),(part(i)%wetdepo(j),j=1,nspec), &
+ (part(i)%drydepo(j),j=1,nspec)
+ part(i)%etaupdate=.true.
+ part(i)%meterupdate=.true.
+ if (.not. part(i)%alive) then
+ if (part(i)%tstart.le.itime_init) then
+ call terminate_particle(i,part(i)%tend)
+ else ! Particle is not spawned yet (original run with ipin=3)
+ count%alive = count%alive - 1
+ count%spawned = count%spawned -1
+ endif
+ endif
+ end do
+ if (iout.gt.0) then
+#ifdef USE_NCF
+ read(unitpartin) tpointer
+#endif
+ do ks=1,nspec
+ do kp=1,maxpointspec_act
+ do nage=1,nageclass
+ do jy=0,numygrid-1
+ do ix=0,numxgrid-1
+ do l=1,nclassunc
+ do kz=1,numzgrid
+ read(unitpartin) gridunc(ix,jy,kz,ks,kp,l,nage)
+ end do
+ if ((wetdep).and.(ldirect.gt.0)) then
+ read(unitpartin) wetgridunc(ix,jy,ks,kp,l,nage)
+ endif
+ if ((drydep).and.(ldirect.gt.0)) then
+ read(unitpartin) drygridunc(ix,jy,ks,kp,l,nage)
+ endif
+ end do
+ end do
+ end do
+ if (nested_output.eq.1) then
+ do jy=0,numygridn-1
+ do ix=0,numxgridn-1
+ do l=1,nclassunc
+ do kz=1,numzgrid
+ read(unitpartin) griduncn(ix,jy,kz,ks,kp,l,nage)
+ end do
+ if ((wetdep).and.(ldirect.gt.0)) then
+ read(unitpartin) wetgriduncn(ix,jy,ks,kp,l,nage)
+ endif
+ if ((drydep).and.(ldirect.gt.0)) then
+ read(unitpartin) drygriduncn(ix,jy,ks,kp,l,nage)
+ endif
+ end do
+ end do
+ end do
+ endif
+ end do
+ end do
+ if ((drybkdep).or.(wetbkdep)) then
+ do i=1,numpart
+ read(unitpartin) xscav_frac1(i,ks)
+ end do
+ endif
+ end do
+ endif
+ close(unitpartin)
+
+ numpart=count%spawned
+
+ julin=juldate(ibdate,ibtime)+real(itime_init,kind=dp)/86400._dp
+ if (abs(julin-bdate).le.1.e-5) then
+ write(*,*) ' #### FLEXPART ERROR: PLEASE KEEP IBDATE #### '
+ write(*,*) ' #### AND IBTIME INTACT FROM THE INITIAL RUN!#### '
+ stop
+ endif
+ call caldate(julin,id1,it1)
+ call caldate(bdate,id2,it2)
+ write(*,*) ' #### Restarting Flexpart from restart.bin. #### '
+ write(*,*) ' #### Original run started on #### '
+ write(*,*) 'bdate: ',bdate,id2,it2
+ write(*,*) ' #### Restarting run starts on #### '
+ write(*,*) 'julin: ',julin,id1,it1
+
+ return
+
+9989 write(*,*) ' #### FLEXPART MODEL ERROR! THE FILE #### '
+ write(*,*) ' #### '//path(2)(1:length(2))//'restart.bin'//' #### '
+ write(*,*) ' #### CANNOT BE OPENED. IF A FILE WITH THIS #### '
+ write(*,*) ' #### NAME DOES NOT EXISTS, RENAME THE APPROPRIATE #### '
+ write(*,*) ' #### RESTART FILE TO restart.bin. #### '
+end subroutine readrestart
+
+end module restart_mod
\ No newline at end of file
diff --git a/src/settling_mod.f90 b/src/settling_mod.f90
new file mode 100644
index 00000000..910c41bb
--- /dev/null
+++ b/src/settling_mod.f90
@@ -0,0 +1,217 @@
+! SPDX-FileCopyrightText: FLEXPART 1998-2019, see flexpart_license.txt
+! SPDX-License-Identifier: GPL-3.0-or-later
+module settling_mod
+
+ implicit none
+
+ private :: viscosity
+ public :: get_settling
+contains
+
+subroutine get_settling(itime,xt,yt,zt,nsp,settling)
+ ! i i i i i o
+ !*****************************************************************************
+ ! *
+ ! This subroutine calculates particle settling velocity. *
+ ! *
+ ! Author: A. Stohl *
+ ! *
+ ! May 2010 *
+ ! *
+ ! Improvement over traditional settling calculation in FLEXPART: *
+ ! generalize to higher Reynolds numbers and also take into account the *
+ ! temperature dependence of dynamic viscosity. *
+ ! *
+ ! Based on: *
+ ! Naeslund E., and Thaning, L. (1991): On the settling velocity in a *
+ ! nonstationary atmosphere, Aerosol Science and Technology 14, 247-256. *
+ ! *
+ ! Changes *
+ ! Daria Tatsii 2022: implementation of shape factor according to *
+ ! Bagheri & Bonadonna 2016 *
+ !*****************************************************************************
+ ! *
+ ! Variables: *
+ ! itime [s] current temporal position *
+ ! xt,yt,zt coordinates position for which wind data shall be cal- *
+ ! culated *
+ ! *
+ ! Constants: *
+ ! dfdr fluid density/particle density *
+ ! Veq [m^3] equivalent volume of a sphere *
+ ! dcyl [m] diameter of a cylinder (fiber) *
+ ! f flatness parameters, S/I *
+ ! e elongation parameters, I/L *
+ ! Fs Stokes form factor, f e^1.3 *
+ ! Fn Newton's form factor *
+ ! Ks Stokes' drag correction *
+ ! vsp help variable *
+ ! x aspect ratio of cylinder height to its diameter *
+ ! *
+ ! Variables: *
+ ! c_d drag coefficient *
+ ! settling [m/s] settling velocity *
+ !*****************************************************************************
+
+ use par_mod
+ use com_mod
+ use windfields_mod
+
+ implicit none
+
+ integer, intent(in) :: itime, nsp
+ real, intent(in) :: xt, yt, zt
+ real, intent(out) :: settling
+ integer :: indz
+
+ ! Auxiliary variables needed for interpolation
+ real :: dz1,dz2,dz
+ real :: rho1(2),tt1(2),temperature,airdens,vis_dyn,vis_kin
+ real :: settling_old,reynolds,c_d
+ integer :: i,n,nix,njy,indzh
+
+ ! Variables needed for drag coefficient calculation
+ real :: dfdr,f,e,kn,ks,alpha1,alpha2,beta1,beta2,ks1,ks2,kn1,kn2
+
+ !*****************************************************************************
+ ! 1. Interpolate temperature and density: nearest neighbor interpolation sufficient
+ !*****************************************************************************
+
+ nix=int(xt)
+ njy=int(yt)
+
+ ! Determine the level below the current position for u,v
+ !*******************************************************
+ indz=nz-1
+ do i=2,nz
+ if (height(i).gt.zt) then
+ indz=i-1
+ exit
+ endif
+ end do
+
+ ! Vertical distance to the level below and above current position
+ !****************************************************************
+
+ dz=1./(height(indz+1)-height(indz))
+ dz1=(zt-height(indz))*dz
+ dz2=(height(indz+1)-zt)*dz
+
+
+ ! Bilinear horizontal interpolation
+ !**********************************
+
+ ! Loop over 2 levels
+ !*******************
+
+ do n=1,2
+ indzh=indz+n-1
+ rho1(n)=rho(nix,njy,indzh,1)
+ tt1(n)=tt(nix,njy,indzh,1)
+ end do
+
+
+ ! Linear vertical interpolation
+ !******************************
+
+ temperature=dz2*tt1(1)+dz1*tt1(2)
+ airdens=dz2*rho1(1)+dz1*rho1(2)
+
+ vis_dyn=viscosity(temperature)
+ vis_kin=vis_dyn/airdens
+
+ reynolds=dquer(nsp)/1.e6*abs(vsetaver(nsp))/vis_kin
+
+ ! Iteration to determine both Reynolds number and settling velocity
+ !******************************************************************
+
+ settling_old=vsetaver(nsp) ! initialize iteration with Stokes' law to define settling velocity of a sphere, constant viscosity estimate
+
+ if (shape(nsp).eq.0) then
+ do i=1,20 ! do a few iterations Why 20???
+
+ ! if (reynolds.lt.1.917) then
+ ! c_d=24./reynolds
+ ! else if (reynolds.lt.500.) then
+ ! c_d=18.5/(reynolds**0.6)
+ ! else
+ ! c_d=0.44
+ ! endif
+
+ ! Clift and Guavin 1971 model
+
+ c_d=(24.0/reynolds)*(1+0.15*(reynolds**0.687))+ &
+ 0.42/(1.0+42500.0/(reynolds**1.16))
+
+ settling=-1.* &
+ sqrt(4*ga*dquer(nsp)/1.e6*density(nsp)*cunningham(nsp)/ &
+ (3.*c_d*airdens))
+
+ if (abs((settling-settling_old)/settling).lt.0.01) exit ! stop iteration
+
+ reynolds=dquer(nsp)/1.e6*abs(settling)/vis_kin
+ settling_old=settling
+ end do
+
+ else ! Drag coefficient scheme by Bagheri & Bonadonna, 2016 to define settling velocities of other shapes (by D.Tatsii)
+ dfdr=density(nsp)/airdens
+
+ ! Orientation of particles
+ !*************************
+ if (orient(nsp).eq.0) then
+ ! Horizontal orientation
+ alpha2=0.77 ! B&B: eq. 32
+ beta2=0.63
+ ks=0.5*((Fs(nsp)**0.05)+(Fs(nsp)**(-0.36))) ! B&B Figure 12 k_(s,max)
+ kn=10.**(alpha2*(-log10(Fn(nsp)))**beta2)
+ else if (orient(nsp).eq.1) then
+ ! Random orientation
+ alpha1=0.45+10.0/(exp(2.5*log10(dfdr))+30.0)
+ beta1=1.-37.0/(exp(3.0*log10(dfdr))+100.0)
+ ks=(Fs(nsp)**(1./3.) + Fs(nsp)**(-1./3))/2.
+ kn=10.**(alpha1*(-log10(Fn(nsp)))**beta1)
+ else
+ ! The average of random and horizontal orientation
+ alpha1=0.45+10.0/(exp(2.5*log10(dfdr))+30.0)
+ beta1=1.-37.0/(exp(3.0*log10(dfdr))+100.0)
+ alpha2=0.77 ! B&B: eq. 32
+ beta2=0.63
+ ks1=(Fs(nsp)**(1./3.) + Fs(nsp)**(-1./3))/2.
+ kn1=10.**(alpha1*(-log10(Fn(nsp)))**beta1)
+ ks2=0.5*((Fs(nsp)**0.05)+(Fs(nsp)**(-0.36))) ! B&B Figure 12 k_(s,max)
+ kn2=10.**(alpha2*(-log10(Fn(nsp)))**beta2)
+ ks=(ks1+ks2)/2.
+ kn=(kn1+kn2)/2.
+ endif
+
+ do i=1,20
+ c_d=(24.*ks/reynolds)*(1.+0.125*((reynolds*kn/ks)**(2./3.)))+ &
+ (0.46*kn/(1.+5330./(reynolds*kn/ks)))
+
+ settling=-1.* &
+ sqrt(4.*ga*dquer(nsp)/1.e6*density(nsp)*cunningham(nsp)/ &
+ (3.*c_d*airdens))
+
+ if (abs((settling-settling_old)/settling).lt.0.01) exit
+
+ reynolds=dquer(nsp)/1.e6*abs(settling)/vis_kin
+ settling_old=settling
+ end do
+ endif
+end subroutine get_settling
+
+real function viscosity(t)
+ ! Function calculates dynamic viscosity of air (kg/m/s) as function of
+ ! temperature (K) using Sutherland's formula
+ implicit none
+
+ real :: t
+ real,parameter :: c=120.,t_0=291.15,eta_0=1.827e-5
+
+ viscosity=eta_0*(t_0+c)/(t+c)*(t/t_0)**1.5
+
+ return
+
+end function viscosity
+
+end module settling_mod
diff --git a/src/timemanager.f90 b/src/timemanager.f90
deleted file mode 100644
index c5c63e82..00000000
--- a/src/timemanager.f90
+++ /dev/null
@@ -1,772 +0,0 @@
-! SPDX-FileCopyrightText: FLEXPART 1998-2019, see flexpart_license.txt
-! SPDX-License-Identifier: GPL-3.0-or-later
-
-subroutine timemanager(metdata_format)
-
- !*****************************************************************************
- ! *
- ! Handles the computation of trajectories, i.e. determines which *
- ! trajectories have to be computed at what time. *
- ! Manages dry+wet deposition routines, radioactive decay and the computation *
- ! of concentrations. *
- ! *
- ! Author: A. Stohl *
- ! *
- ! 20 May 1996 *
- ! *
- !*****************************************************************************
- ! Changes, Bernd C. Krueger, Feb. 2001: *
- ! Call of convmix when new windfield is read *
- !------------------------------------ *
- ! Changes Petra Seibert, Sept 2002 *
- ! fix wet scavenging problem *
- ! Code may not be correct for decay of deposition! *
- ! Changes Petra Seibert, Nov 2002 *
- ! call convection BEFORE new fields are read in BWD mode *
- ! Changes Caroline Forster, Feb 2005 *
- ! new interface between flexpart and convection scheme *
- ! Emanuel's latest subroutine convect43c.f is used *
- ! Changes Stefan Henne, Harald Sodemann, 2013-2014 *
- ! added netcdf output code *
- ! Changes Espen Sollum 2014 *
- ! For compatibility with MPI version, *
- ! variables uap,ucp,uzp,us,vs,ws,cbt now in module com_mod *
- ! Unified ECMWF and GFS builds *
- ! Marian Harustak, 12.5.2017 *
- ! - Added passing of metdata_format as it was needed by called routines *
- !*****************************************************************************
- ! *
- ! Variables: *
- ! DEP .true. if either wet or dry deposition is switched on *
- ! decay(maxspec) [1/s] decay constant for radioactive decay *
- ! DRYDEP .true. if dry deposition is switched on *
- ! ideltas [s] modelling period *
- ! itime [s] actual temporal position of calculation *
- ! ldeltat [s] time since computation of radioact. decay of depositions*
- ! loutaver [s] averaging period for concentration calculations *
- ! loutend [s] end of averaging for concentration calculations *
- ! loutnext [s] next time at which output fields shall be centered *
- ! loutsample [s] sampling interval for averaging of concentrations *
- ! loutstart [s] start of averaging for concentration calculations *
- ! loutstep [s] time interval for which concentrations shall be *
- ! calculated *
- ! npoint(maxpart) index, which starting point the trajectory has *
- ! starting positions of trajectories *
- ! nstop serves as indicator for fate of particles *
- ! in the particle loop *
- ! nstop1 serves as indicator for wind fields (see getfields) *
- ! outnum number of samples for each concentration calculation *
- ! outnum number of samples for each concentration calculation *
- ! prob probability of absorption at ground due to dry *
- ! deposition *
- ! WETDEP .true. if wet deposition is switched on *
- ! weight weight for each concentration sample (1/2 or 1) *
- ! uap(maxpart),ucp(maxpart),uzp(maxpart) = random velocities due to *
- ! turbulence *
- ! us(maxpart),vs(maxpart),ws(maxpart) = random velocities due to inter- *
- ! polation *
- ! xtra1(maxpart), ytra1(maxpart), ztra1(maxpart) = *
- ! spatial positions of trajectories *
- ! metdata_format format of metdata (ecmwf/gfs) *
- ! *
- ! Constants: *
- ! maxpart maximum number of trajectories *
- ! *
- !*****************************************************************************
-
- use unc_mod
- use point_mod
- use xmass_mod
- use flux_mod
- use outg_mod
- use oh_mod
- use par_mod
- use com_mod
-#ifdef USE_NCF
- use netcdf_output_mod, only: concoutput_netcdf,concoutput_nest_netcdf,&
- &concoutput_surf_netcdf,concoutput_surf_nest_netcdf
-#endif
-
- implicit none
-
- integer :: metdata_format
- integer :: j,ks,kp,l,n,itime=0,nstop,nstop1
-! integer :: ksp
- integer :: loutnext,loutstart,loutend
- integer :: ix,jy,ldeltat,itage,nage,idummy
- integer :: i_nan=0,ii_nan,total_nan_intl=0 !added by mc to check instability in CBL scheme
- real :: outnum,weight,prob_rec(maxspec),prob(maxspec),decfact,wetscav
- ! real :: uap(maxpart),ucp(maxpart),uzp(maxpart)
- ! real :: us(maxpart),vs(maxpart),ws(maxpart)
- ! integer(kind=2) :: cbt(maxpart)
- real(sp) :: gridtotalunc
- real(dep_prec) :: drydeposit(maxspec),wetgridtotalunc,drygridtotalunc
- real :: xold,yold,zold,xmassfract
- real :: grfraction(3)
- real, parameter :: e_inv = 1.0/exp(1.0)
-
- !double precision xm(maxspec,maxpointspec_act),
- ! + xm_depw(maxspec,maxpointspec_act),
- ! + xm_depd(maxspec,maxpointspec_act)
-
-
- !open(88,file='TEST.dat')
-
- ! First output for time 0
- !************************
-
- loutnext=loutstep/2
- outnum=0.
- loutstart=loutnext-loutaver/2
- loutend=loutnext+loutaver/2
-
- ! open(127,file=path(2)(1:length(2))//'depostat.dat'
- ! + ,form='unformatted')
- !write (*,*) 'writing deposition statistics depostat.dat!'
-
- !**********************************************************************
- ! Loop over the whole modelling period in time steps of mintime seconds
- !**********************************************************************
-
-!ZHG 2015
-!CGZ-lifetime: set lifetime to 0
- ! checklifetime(:,:)=0
- ! species_lifetime(:,:)=0
- ! print*, 'Initialized lifetime'
-!CGZ-lifetime: set lifetime to 0
-
- if (.not.lusekerneloutput) write(*,*) 'Not using the kernel'
- if (turboff) write(*,*) 'Turbulence switched off'
-
- write(*,46) float(itime)/3600,itime,numpart
-
- if (verbosity.gt.0) then
- write (*,*) 'timemanager> starting simulation'
- if (verbosity.gt.1) then
- CALL SYSTEM_CLOCK(count_clock)
- WRITE(*,*) 'timemanager> SYSTEM CLOCK',(count_clock - count_clock0)/real(count_rate)
- endif
- endif
-
- do itime=0,ideltas,lsynctime
-
- ! Computation of wet deposition, OH reaction and mass transfer
- ! between two species every lsynctime seconds
- ! maybe wet depo frequency can be relaxed later but better be on safe side
- ! wetdepo must be called BEFORE new fields are read in but should not
- ! be called in the very beginning before any fields are loaded, or
- ! before particles are in the system
- ! Code may not be correct for decay of deposition
- ! changed by Petra Seibert 9/02
- !********************************************************************
-
- if (WETDEP .and. itime .ne. 0 .and. numpart .gt. 0) then
- if (verbosity.gt.0) then
- write (*,*) 'timemanager> call wetdepo'
- endif
- call wetdepo(itime,lsynctime,loutnext)
- endif
-
- if (OHREA .and. itime .ne. 0 .and. numpart .gt. 0) &
- call ohreaction(itime,lsynctime,loutnext)
-
- if (ASSSPEC .and. itime .ne. 0 .and. numpart .gt. 0) then
- stop 'associated species not yet implemented!'
- ! call transferspec(itime,lsynctime,loutnext)
- endif
-
- ! compute convection for backward runs
- !*************************************
-
- if ((ldirect.eq.-1).and.(lconvection.eq.1).and.(itime.lt.0)) then
- if (verbosity.gt.0) then
- write (*,*) 'timemanager> call convmix -- backward'
- endif
- call convmix(itime,metdata_format)
- if (verbosity.gt.1) then
- !CALL SYSTEM_CLOCK(count_clock, count_rate, count_max)
- CALL SYSTEM_CLOCK(count_clock)
- WRITE(*,*) 'timemanager> SYSTEM CLOCK',(count_clock - count_clock0)/real(count_rate)
- endif
- endif
-
- ! Get necessary wind fields if not available
- !*******************************************
- if (verbosity.gt.0) then
- write (*,*) 'timemanager> call getfields'
- endif
- call getfields(itime,nstop1,metdata_format)
- if (verbosity.gt.1) then
- CALL SYSTEM_CLOCK(count_clock)
- WRITE(*,*) 'timemanager> SYSTEM CLOCK',(count_clock - count_clock0)/real(count_rate)
- endif
- if (nstop1.gt.1) stop 'NO METEO FIELDS AVAILABLE'
-
- ! Get hourly OH fields if not available
- !****************************************************
- if (OHREA) then
- if (verbosity.gt.0) then
- write (*,*) 'timemanager> call gethourlyOH'
- endif
- call gethourlyOH(itime)
- if (verbosity.gt.1) then
- CALL SYSTEM_CLOCK(count_clock)
- WRITE(*,*) 'timemanager> SYSTEM CLOCK',(count_clock - count_clock0)/real(count_rate)
- endif
- endif
-
- ! Release particles
- !******************
-
- if (verbosity.gt.0) then
- write (*,*) 'timemanager> Release particles'
- endif
-
- if (mdomainfill.ge.1) then
- if (itime.eq.0) then
- if (verbosity.gt.0) then
- write (*,*) 'timemanager> call init_domainfill'
- endif
- call init_domainfill
- else
- if (verbosity.gt.0) then
- write (*,*) 'timemanager> call boundcond_domainfill'
- endif
- call boundcond_domainfill(itime,loutend)
- endif
- else
- if (verbosity.gt.0) then
- print*,'call releaseparticles'
- endif
- call releaseparticles(itime)
- if (verbosity.gt.1) then
- CALL SYSTEM_CLOCK(count_clock)
- WRITE(*,*) 'timemanager> SYSTEM CLOCK',(count_clock - count_clock0)/real(count_rate)
- endif
- endif
-
-
- ! Compute convective mixing for forward runs
- ! for backward runs it is done before next windfield is read in
- !**************************************************************
-
- if ((ldirect.eq.1).and.(lconvection.eq.1)) then
- if (verbosity.gt.0) then
- write (*,*) 'timemanager> call convmix -- forward'
- endif
- call convmix(itime,metdata_format)
- endif
-
- ! If middle of averaging period of output fields is reached, accumulated
- ! deposited mass radioactively decays
- !***********************************************************************
-
- if (DEP.and.(itime.eq.loutnext).and.(ldirect.gt.0)) then
- do ks=1,nspec
- do kp=1,maxpointspec_act
- if (decay(ks).gt.0.) then
- do nage=1,nageclass
- do l=1,nclassunc
- ! Mother output grid
- do jy=0,numygrid-1
- do ix=0,numxgrid-1
- wetgridunc(ix,jy,ks,kp,l,nage)= &
- wetgridunc(ix,jy,ks,kp,l,nage)* &
- exp(-1.*outstep*decay(ks))
- drygridunc(ix,jy,ks,kp,l,nage)= &
- drygridunc(ix,jy,ks,kp,l,nage)* &
- exp(-1.*outstep*decay(ks))
- end do
- end do
- ! Nested output grid
- if (nested_output.eq.1) then
- do jy=0,numygridn-1
- do ix=0,numxgridn-1
- wetgriduncn(ix,jy,ks,kp,l,nage)= &
- wetgriduncn(ix,jy,ks,kp,l,nage)* &
- exp(-1.*outstep*decay(ks))
- drygriduncn(ix,jy,ks,kp,l,nage)= &
- drygriduncn(ix,jy,ks,kp,l,nage)* &
- exp(-1.*outstep*decay(ks))
- end do
- end do
- endif
- end do
- end do
- endif
- end do
- end do
- endif
-
- !!! CHANGE: These lines may be switched on to check the conservation
- !!! of mass within FLEXPART
- ! if (itime.eq.loutnext) then
- ! do 247 ksp=1, nspec
- ! do 247 kp=1, maxpointspec_act
- !47 xm(ksp,kp)=0.
-
- ! do 249 ksp=1, nspec
- ! do 249 j=1,numpart
- ! if (ioutputforeachrelease.eq.1) then
- ! kp=npoint(j)
- ! else
- ! kp=1
- ! endif
- ! if (itra1(j).eq.itime) then
- ! xm(ksp,kp)=xm(ksp,kp)+xmass1(j,ksp)
- ! write(*,*) 'xmass: ',xmass1(j,ksp),j,ksp,nspec
- ! endif
- !49 continue
- ! do 248 ksp=1,nspec
- ! do 248 kp=1,maxpointspec_act
- ! xm_depw(ksp,kp)=0.
- ! xm_depd(ksp,kp)=0.
- ! do 248 nage=1,nageclass
- ! do 248 ix=0,numxgrid-1
- ! do 248 jy=0,numygrid-1
- ! do 248 l=1,nclassunc
- ! xm_depw(ksp,kp)=xm_depw(ksp,kp)
- ! + +wetgridunc(ix,jy,ksp,kp,l,nage)
- !48 xm_depd(ksp,kp)=xm_depd(ksp,kp)
- ! + +drygridunc(ix,jy,ksp,kp,l,nage)
- ! do 246 ksp=1,nspec
- !46 write(88,'(2i10,3e12.3)')
- ! + itime,ksp,(xm(ksp,kp),kp=1,maxpointspec_act),
- ! + (xm_depw(ksp,kp),kp=1,maxpointspec_act),
- ! + (xm_depd(ksp,kp),kp=1,maxpointspec_act)
- ! endif
- !!! CHANGE
-
-
-
- ! Check whether concentrations are to be calculated
- !**************************************************
-
- if ((ldirect*itime.ge.ldirect*loutstart).and. &
- (ldirect*itime.le.ldirect*loutend)) then ! add to grid
- if (mod(itime-loutstart,loutsample).eq.0) then
-
- ! If we are exactly at the start or end of the concentration averaging interval,
- ! give only half the weight to this sample
- !*****************************************************************************
-
- if ((itime.eq.loutstart).or.(itime.eq.loutend)) then
- weight=0.5
- else
- weight=1.0
- endif
- outnum=outnum+weight
- call conccalc(itime,weight)
- endif
-
-
- if ((mquasilag.eq.1).and.(itime.eq.(loutstart+loutend)/2)) &
- call partoutput_short(itime) ! dump particle positions in extremely compressed format
-
-
- ! Output and reinitialization of grid
- ! If necessary, first sample of new grid is also taken
- !*****************************************************
-
- if ((itime.eq.loutend).and.(outnum.gt.0.)) then
- if ((iout.le.3.).or.(iout.eq.5)) then
- if (surf_only.ne.1) then
- if (lnetcdfout.eq.1) then
-#ifdef USE_NCF
- call concoutput_netcdf(itime,outnum,gridtotalunc,wetgridtotalunc,drygridtotalunc)
-#endif
- else
- call concoutput(itime,outnum,gridtotalunc,wetgridtotalunc,drygridtotalunc)
- endif
- else
- if (verbosity.eq.1) then
- print*,'call concoutput_surf '
- call system_clock(count_clock)
- write(*,*) 'system clock',count_clock - count_clock0
- endif
- if (lnetcdfout.eq.1) then
-#ifdef USE_NCF
- call concoutput_surf_netcdf(itime,outnum,gridtotalunc,wetgridtotalunc,drygridtotalunc)
-#endif
- else
- if (linversionout.eq.1) then
- call concoutput_inversion(itime,outnum,gridtotalunc,wetgridtotalunc,drygridtotalunc)
- if (verbosity.eq.1) then
- print*,'called concoutput_inversion'
- call system_clock(count_clock)
- write(*,*) 'system clock',count_clock - count_clock0
- endif
- else
- call concoutput_surf(itime,outnum,gridtotalunc,wetgridtotalunc,drygridtotalunc)
- endif
- if (verbosity.eq.1) then
- print*,'called concoutput_surf '
- call system_clock(count_clock)
- write(*,*) 'system clock',count_clock - count_clock0
- endif
- endif
- endif
-
- if (nested_output .eq. 1) then
- if (lnetcdfout.eq.0) then
- if (surf_only.ne.1) then
- call concoutput_nest(itime,outnum)
- else
- if(linversionout.eq.1) then
- call concoutput_inversion_nest(itime,outnum)
- else
- call concoutput_surf_nest(itime,outnum)
- endif
- endif
- else
-#ifdef USE_NCF
- if (surf_only.ne.1) then
- call concoutput_nest_netcdf(itime,outnum)
- else
- call concoutput_surf_nest_netcdf(itime,outnum)
- endif
-#endif
- endif
- endif
- outnum=0.
- endif
- if ((iout.eq.4).or.(iout.eq.5)) call plumetraj(itime)
- if (iflux.eq.1) call fluxoutput(itime)
- write(*,45) itime,numpart,gridtotalunc,wetgridtotalunc,drygridtotalunc
-
- !CGZ-lifetime: output species lifetime
-!ZHG
- ! write(*,*) 'Overview species lifetime in days', &
- ! real((species_lifetime(:,1)/species_lifetime(:,2))/real(3600.0*24.0))
- ! write(*,*) 'all info:',species_lifetime
-!ZHG
- !CGZ-lifetime: output species lifetime
-
- !write(*,46) float(itime)/3600,itime,numpart
-45 format(i13,' Seconds simulated: ',i13, ' Particles: Uncertainty: ',3f7.3)
-46 format(' Simulated ',f7.1,' hours (',i13,' s), ',i13, ' particles')
- if (ipout.ge.1) then
- if (mod(itime,ipoutfac*loutstep).eq.0) call partoutput(itime) ! dump particle positions
- if (ipout.eq.3) call partoutput_average(itime) ! dump particle positions
- endif
- loutnext=loutnext+loutstep
- loutstart=loutnext-loutaver/2
- loutend=loutnext+loutaver/2
- if (itime.eq.loutstart) then
- weight=0.5
- outnum=outnum+weight
- call conccalc(itime,weight)
- endif
-
-
- ! Check, whether particles are to be split:
- ! If so, create new particles and attribute all information from the old
- ! particles also to the new ones; old and new particles both get half the
- ! mass of the old ones
- !************************************************************************
-
- if (ldirect*itime.ge.ldirect*itsplit) then
- n=numpart
- do j=1,numpart
- if (ldirect*itime.ge.ldirect*itrasplit(j)) then
- if (n.lt.maxpart) then
- n=n+1
- itrasplit(j)=2*(itrasplit(j)-itramem(j))+itramem(j)
- itrasplit(n)=itrasplit(j)
- itramem(n)=itramem(j)
- itra1(n)=itra1(j)
- idt(n)=idt(j)
- npoint(n)=npoint(j)
- nclass(n)=nclass(j)
- xtra1(n)=xtra1(j)
- ytra1(n)=ytra1(j)
- ztra1(n)=ztra1(j)
- uap(n)=uap(j)
- ucp(n)=ucp(j)
- uzp(n)=uzp(j)
- us(n)=us(j)
- vs(n)=vs(j)
- ws(n)=ws(j)
- cbt(n)=cbt(j)
- do ks=1,nspec
- xmass1(j,ks)=xmass1(j,ks)/2.
- xmass1(n,ks)=xmass1(j,ks)
- end do
- endif
- endif
- end do
- numpart=n
- endif
- endif
- endif
-
-
- if (itime.eq.ideltas) exit ! almost finished
-
- ! Compute interval since radioactive decay of deposited mass was computed
- !************************************************************************
-
- if (itime.lt.loutnext) then
- ldeltat=itime-(loutnext-loutstep)
- else ! first half of next interval
- ldeltat=itime-loutnext
- endif
-
-
- ! Loop over all particles
- !************************
- ! Various variables for testing reason of CBL scheme, by mc
- well_mixed_vector=0. !erase vector to test well mixed condition: modified by mc
- well_mixed_norm=0. !erase normalization to test well mixed condition: modified by mc
- avg_ol=0.
- avg_wst=0.
- avg_h=0.
- avg_air_dens=0. !erase vector to obtain air density at particle positions: modified by mc
- !-----------------------------------------------------------------------------
- do j=1,numpart
-
-
- ! If integration step is due, do it
- !**********************************
-
- if (itra1(j).eq.itime) then
-
- if (ioutputforeachrelease.eq.1) then
- kp=npoint(j)
- else
- kp=1
- endif
- ! Determine age class of the particle
- itage=abs(itra1(j)-itramem(j))
- do nage=1,nageclass
- if (itage.lt.lage(nage)) exit
- end do
-
- ! Initialize newly released particle
- !***********************************
-
- if ((itramem(j).eq.itime).or.(itime.eq.0)) &
- call initialize(itime,idt(j),uap(j),ucp(j),uzp(j), &
- us(j),vs(j),ws(j),xtra1(j),ytra1(j),ztra1(j),cbt(j))
-
- ! Memorize particle positions
- !****************************
-
- xold=xtra1(j)
- yold=ytra1(j)
- zold=ztra1(j)
-
-
- ! RECEPTOR: dry/wet depovel
- !****************************
- ! Before the particle is moved
- ! the calculation of the scavenged mass shall only be done once after release
- ! xscav_frac1 was initialised with a negative value
-
- if (DRYBKDEP) then
- do ks=1,nspec
- if ((xscav_frac1(j,ks).lt.0)) then
- call get_vdep_prob(itime,xtra1(j),ytra1(j),ztra1(j),prob_rec)
- if (DRYDEPSPEC(ks)) then ! dry deposition
- xscav_frac1(j,ks)=prob_rec(ks)
- else
- xmass1(j,ks)=0.
- xscav_frac1(j,ks)=0.
- endif
- endif
- enddo
- endif
-
- if (WETBKDEP) then
- do ks=1,nspec
- if ((xscav_frac1(j,ks).lt.0)) then
- call get_wetscav(itime,lsynctime,loutnext,j,ks,grfraction,idummy,idummy,wetscav)
- if (wetscav.gt.0) then
- xscav_frac1(j,ks)=wetscav* &
- (zpoint2(npoint(j))-zpoint1(npoint(j)))*grfraction(1)
- else
- xmass1(j,ks)=0.
- xscav_frac1(j,ks)=0.
- endif
- endif
- enddo
- endif
-
- ! Integrate Lagevin equation for lsynctime seconds
- !*************************************************
-
- if (verbosity.gt.0) then
- if (j.eq.1) then
- write (*,*) 'timemanager> call advance'
- endif
- endif
-
- call advance(itime,npoint(j),idt(j),uap(j),ucp(j),uzp(j), &
- us(j),vs(j),ws(j),nstop,xtra1(j),ytra1(j),ztra1(j),prob, &
- cbt(j))
-! write (*,*) 'advance: ',prob(1),xmass1(j,1),ztra1(j)
-
- ! Calculate average position for particle dump output
- !****************************************************
-
- if (ipout.eq.3) call partpos_average(itime,j)
-
-
- ! Calculate the gross fluxes across layer interfaces
- !***************************************************
-
- if (iflux.eq.1) call calcfluxes(nage,j,xold,yold,zold)
-
-
- ! Determine, when next time step is due
- ! If trajectory is terminated, mark it
- !**************************************
-
- if (nstop.gt.1) then
- if (linit_cond.ge.1) call initial_cond_calc(itime,j)
- itra1(j)=-999999999
- else
- itra1(j)=itime+lsynctime
-
-
- ! Dry deposition and radioactive decay for each species
- ! Also check maximum (of all species) of initial mass remaining on the particle;
- ! if it is below a threshold value, terminate particle
- !*****************************************************************************
-
- xmassfract=0.
- do ks=1,nspec
- if (decay(ks).gt.0.) then ! radioactive decay
- decfact=exp(-real(abs(lsynctime))*decay(ks))
- else
- decfact=1.
- endif
-
- if (DRYDEPSPEC(ks)) then ! dry deposition
- drydeposit(ks)=xmass1(j,ks)*prob(ks)*decfact
- xmass1(j,ks)=xmass1(j,ks)*(1.-prob(ks))*decfact
- if (decay(ks).gt.0.) then ! correct for decay (see wetdepo)
- drydeposit(ks)=drydeposit(ks)* &
- exp(real(abs(ldeltat))*decay(ks))
- endif
- else ! no dry deposition
- xmass1(j,ks)=xmass1(j,ks)*decfact
- endif
-
-! Skip check on mass fraction when npoint represents particle number
- if (mdomainfill.eq.0.and.mquasilag.eq.0) then
- if (xmass(npoint(j),ks).gt.0.) &
- xmassfract=max(xmassfract,real(npart(npoint(j)))* &
- xmass1(j,ks)/xmass(npoint(j),ks))
-!ZHG 2015
- !CGZ-lifetime: Check mass fraction left/save lifetime
- ! if(real(npart(npoint(j)))*xmass1(j,ks)/xmass(npoint(j),ks).lt.e_inv.and.checklifetime(j,ks).eq.0.)then
- !Mass below 1% of initial >register lifetime
- ! checklifetime(j,ks)=abs(itra1(j)-itramem(j))
- ! species_lifetime(ks,1)=species_lifetime(ks,1)+abs(itra1(j)-itramem(j))
- ! species_lifetime(ks,2)= species_lifetime(ks,2)+1
- ! endif
- !CGZ-lifetime: Check mass fraction left/save lifetime
-!ZHG 2015
- else
- xmassfract=1.0
- end if
- end do
-
- if (xmassfract.lt.minmass) then ! terminate all particles carrying less mass
- itra1(j)=-999999999
- if (verbosity.gt.0) then
- print*,'terminated particle ',j,' for small mass'
- endif
- endif
-
- ! Sabine Eckhardt, June 2008
- ! don't create depofield for backward runs
- if (DRYDEP.AND.(ldirect.eq.1)) then
- call drydepokernel(nclass(j),drydeposit,real(xtra1(j)), &
- real(ytra1(j)),nage,kp)
- if (nested_output.eq.1) call drydepokernel_nest( &
- nclass(j),drydeposit,real(xtra1(j)),real(ytra1(j)), &
- nage,kp)
- endif
-
- ! Terminate trajectories that are older than maximum allowed age
- !***************************************************************
-
- if (abs(itra1(j)-itramem(j)).ge.lage(nageclass)) then
- if (linit_cond.ge.1) call initial_cond_calc(itime+lsynctime,j)
- itra1(j)=-999999999
- if (verbosity.gt.0) then
- print*,'terminated particle ',j,' for age'
- endif
- endif
- endif
-
- endif
-
- end do !loop over particles
-
- ! Counter of "unstable" particle velocity during a time scale of
- ! maximumtl=20 minutes (defined in com_mod)
- !***************************************************************
-
- total_nan_intl=0
- i_nan=i_nan+1 ! added by mc to count nan during a time of maxtl (i.e. maximum tl fixed here to 20 minutes, see com_mod)
- sum_nan_count(i_nan)=nan_count
- if (i_nan > maxtl/lsynctime) i_nan=1 !lsynctime must be <= maxtl
- do ii_nan=1, (maxtl/lsynctime)
- total_nan_intl=total_nan_intl+sum_nan_count(ii_nan)
- end do
- ! Output to keep track of the numerical instabilities in CBL simulation and if
- ! they are compromising the final result (or not)
- if (cblflag.eq.1) print *,j,itime,'nan_synctime',nan_count,'nan_tl',total_nan_intl
-
- end do
-
-
- ! Complete the calculation of initial conditions for particles not yet terminated
- !*****************************************************************************
-
- do j=1,numpart
- if (linit_cond.ge.1) call initial_cond_calc(itime,j)
- end do
-
- if (ipout.eq.2) call partoutput(itime) ! dump particle positions
-
- if (linit_cond.ge.1) then
- if(linversionout.eq.1) then
- call initial_cond_output_inversion(itime) ! dump initial cond. field
- else
- call initial_cond_output(itime) ! dump initial cond. fielf
- endif
- endif
-
- !close(104)
-
- ! De-allocate memory and end
- !***************************
-
- if (iflux.eq.1) then
- deallocate(flux)
- endif
- if (OHREA) then
- deallocate(OH_field,OH_hourly,lonOH,latOH,altOH)
- endif
- if (ldirect.gt.0) then
- deallocate(drygridunc,wetgridunc)
- endif
- deallocate(gridunc)
- deallocate(xpoint1,xpoint2,ypoint1,ypoint2,zpoint1,zpoint2,xmass)
- deallocate(ireleasestart,ireleaseend,npart,kindz)
- deallocate(xmasssave)
- if (nested_output.eq.1) then
- deallocate(orooutn, arean, volumen)
- if (ldirect.gt.0) then
- deallocate(griduncn,drygriduncn,wetgriduncn)
- endif
- endif
- deallocate(outheight,outheighthalf)
- deallocate(oroout, area, volume)
-
-end subroutine timemanager
-
diff --git a/src/timemanager_mod.f90 b/src/timemanager_mod.f90
new file mode 100644
index 00000000..46c18706
--- /dev/null
+++ b/src/timemanager_mod.f90
@@ -0,0 +1,666 @@
+! SPDX-FileCopyrightText: FLEXPART 1998-2019, see flexpart_license.txt
+! SPDX-License-Identifier: GPL-3.0-or-later
+
+ !*****************************************************************************
+ ! *
+ ! L. Bakels 2022: This module contains the timemanager *
+ ! *
+ !*****************************************************************************
+
+module timemanager_mod
+
+implicit none
+
+contains
+
+subroutine timemanager
+
+ !*****************************************************************************
+ ! *
+ ! Handles the computation of trajectories, i.e. determines which *
+ ! trajectories have to be computed at what time. *
+ ! Manages dry+wet deposition routines, radioactive decay and the computation *
+ ! of concentrations. *
+ ! *
+ ! Author: A. Stohl *
+ ! *
+ ! 20 May 1996 *
+ ! *
+ !*****************************************************************************
+ ! Changes, Bernd C. Krueger, Feb. 2001: *
+ ! Call of convmix when new windfield is read *
+ !------------------------------------ *
+ ! Changes Petra Seibert, Sept 2002 *
+ ! fix wet scavenging problem *
+ ! Code may not be correct for decay of deposition! *
+ ! Changes Petra Seibert, Nov 2002 *
+ ! call convection BEFORE new fields are read in BWD mode *
+ ! Changes Caroline Forster, Feb 2005 *
+ ! new interface between flexpart and convection scheme *
+ ! Emanuel's latest subroutine convect43c.f is used *
+ ! Changes Stefan Henne, Harald Sodemann, 2013-2014 *
+ ! added netcdf output code *
+ ! Changes Espen Sollum 2014 *
+ ! For compatibility with MPI version, *
+ ! variables uap,ucp,uzp,us,vs,ws,cbt now in module com_mod *
+ ! Unified ECMWF and GFS builds *
+ ! Marian Harustak, 12.5.2017 *
+ ! Changes L Bakels 2022: - OpenMP parallelisation *
+ ! - converting input to ETA coordinates *
+ ! - spawning particles from part_ic.nc *
+ !*****************************************************************************
+ ! *
+ ! Variables: *
+ ! DEP .true. if either wet or dry deposition is switched on *
+ ! decay(maxspec) [1/s] decay constant for radioactive decay *
+ ! DRYDEP .true. if dry deposition is switched on *
+ ! ideltas [s] modelling period *
+ ! itime [s] actual temporal position of calculation *
+ ! ldeltat [s] time since computation of radioact. decay of depositions*
+ ! loutaver [s] averaging period for concentration calculations *
+ ! loutend [s] end of averaging for concentration calculations *
+ ! loutnext [s] next time at which output fields shall be centered *
+ ! loutsample [s] sampling interval for averaging of concentrations *
+ ! loutstart [s] start of averaging for concentration calculations *
+ ! loutstep [s] time interval for which concentrations shall be *
+ ! calculated *
+ ! loutrestart [s] time interval for which restart files will be produced *
+ ! npoint index, which starting point the trajectory has *
+ ! starting positions of trajectories *
+ ! nstop serves as indicator for fate of particles *
+ ! in the particle loop *
+ ! nstop1 serves as indicator for wind fields (see getfields) *
+ ! outnum number of samples for each concentration calculation *
+ ! prob probability of absorption at ground due to dry *
+ ! deposition *
+ ! WETDEP .true. if wet deposition is switched on *
+ ! weight weight for each concentration sample (1/2 or 1) *
+ ! *
+ !*****************************************************************************
+ ! openmp change
+ use omp_lib
+ ! openmp change end
+ use unc_mod
+ use point_mod
+ use xmass_mod
+ use flux_mod
+ use outg_mod
+ use oh_mod
+ use par_mod
+ use com_mod
+ use coordinates_ecmwf_mod
+ use particle_mod
+ use conv_mod
+ use windfields_mod
+ use advance_mod, only: advance
+ use drydepo_mod
+ use wetdepo_mod
+ use plume_mod
+ use initialise_mod
+ use getfields_mod
+ use output_mod
+ use restart_mod
+ use interpol_mod, only: interpol_allocate,interpol_deallocate
+
+ implicit none
+ real, parameter :: &
+ e_inv = 1.0/exp(1.0)
+ integer :: &
+ j,i, & ! loop variable
+ ks, & ! loop variable species
+ kp, & ! loop variable for maxpointspec_act
+ l, & ! loop variable over nclassunc
+ n, & ! loop variable over particles
+ itime=0, & ! time index
+ nstop1, & ! windfield existence flag
+ loutnext, & ! following timestep
+ loutstart,loutend, & ! concentration calculation starting and ending time
+ ix,jy, & ! gridcell indices
+ ldeltat, & ! radioactive decay time
+ itage,nage,inage, & ! related to age classes
+ idummy, & ! used for the random routines
+ i_nan=0,ii_nan,total_nan_intl=0, & !added by mc to check instability in CBL scheme
+ thread ! openmp change (not sure if necessary)
+ ! logical :: &
+ ! active_per_rel(maxpoint) ! are there particles active in each release
+ real :: &
+ filesize!(maxpoint) ! Keeping track of the size of the particledump output, so it can be splitted
+ ! real(kind=dp) :: &
+ ! jul
+ ! integer :: &
+ ! jjjjmmdd,ihmmss
+ real :: &
+ outnum, & ! concentration calculation sample number
+ prob_rec(maxspec), & ! dry deposition related
+ decfact, & ! radioactive decay factor
+ wetscav, & ! wet scavenging
+ xmassfract, & ! dry deposition related
+ grfraction(3) ! wet deposition related
+ real(dep_prec) :: &
+ drydeposit(maxspec) ! dry deposition related
+ real(kind=dp) :: zhier,zetahier
+ integer :: npart_alive=0,alive_tmp,spawned_tmp,terminated_tmp
+
+ ! First output for time 0
+ !************************
+ if (itime_init.ne.0) then
+ loutnext=loutnext_init
+ outnum=outnum_init
+ else
+ loutnext=loutstep/2
+ outnum=0.
+ endif
+ loutstart=loutnext-loutaver/2
+ loutend=loutnext+loutaver/2
+
+ ! Initialise the nan count for CBL option
+ !****************************************
+ sum_nan_count(:) = 0
+ nan_count(:) = 0
+
+ !**********************************************************************
+ ! Loop over the whole modelling period in time steps of mintime seconds
+ !**********************************************************************
+
+ write(*,46) float(itime)/3600,itime,numpart
+46 format(' Simulated ',f7.1,' hours (',i13,' s), ',i13, ' particles')
+
+ filesize=0.
+ ! active_per_rel=.false.
+
+ ! ! Allocate memory for windfields
+ ! !*******************************
+ ! call windfields_allocate
+
+ do itime=itime_init,ideltas,lsynctime
+
+ ! Computation of wet deposition, OH reaction and mass transfer
+ ! between two species every lsynctime seconds
+ ! maybe wet depo frequency can be relaxed later but better be on safe side
+ ! wetdepo must be called BEFORE new fields are read in but should not
+ ! be called in the very beginning before any fields are loaded, or
+ ! before particles are in the system
+ ! Code may not be correct for decay of deposition
+ ! changed by Petra Seibert 9/02
+ !********************************************************************
+
+ ! Write basic information on the simulation to a file "header" for the
+ ! first time step and open files that are to be kept open throughout
+ ! the simulation.
+ ! In addition, open new particle dump files if required and keep track
+ ! of the size of these files.
+ !*********************************************************************
+
+ write(*,*) 'Time: ', itime, 'seconds.'
+
+ if (itime.eq.itime_init) then
+ call SYSTEM_CLOCK(count_clock, count_rate, count_max)
+ s_firstt = real(count_clock)/real(count_rate)
+ endif
+
+ ! Writing restart file
+ !*********************
+ if ((itime.ne.itime_init).and.(loutrestart.ne.-1).and.(mod(itime,loutrestart).eq.0)) then
+ call output_restart(itime,loutnext,outnum)
+ endif
+
+ if (itime.ne.0) write(*,*) part(1)%xlon,part(1)%ylat,part(1)%z,part(1)%zeta
+ call initialise_output(itime,filesize)
+
+ ! Get necessary wind fields if not available
+ !*******************************************
+ call getfields(itime,nstop1) !OMP on verttransform_ecmwf and readwind_ecmwf, getfields_mod.f90
+ if (nstop1.gt.1) stop 'NO METEO FIELDS AVAILABLE'
+
+ ! In case of ETA coordinates being read from file, convert the z positions
+ !*************************************************************************
+ if (((ipin.eq.1).or.(ipin.eq.4)).and.(itime.eq.itime_init).and.(wind_coord_type.eq.'ETA')) then
+ if (numpart.le.0) stop 'Something is going wrong reading the old particle file!'
+!$OMP PARALLEL PRIVATE(i)
+!$OMP DO
+ do i=1,numpart
+ call update_z_to_zeta(itime, i)
+ end do
+!$OMP END DO
+!$OMP END PARALLEL
+ endif
+
+ if ((ipin.eq.3).and.(itime.eq.itime_init).and.(wind_coord_type.eq.'ETA')) then
+ do i=1,count%allocated
+ call update_z_to_zeta(itime, i)
+ end do
+ endif
+
+ if (WETDEP .and. (itime.ne.0) .and. (numpart.gt.0)) then
+ call wetdepo(itime,lsynctime,loutnext) !OMP, wetdepo_mod.f90 (needs test)
+ endif
+
+ if (OHREA .and. (itime.ne.0) .and. (numpart.gt.0)) &
+ call ohreaction(itime,lsynctime,loutnext) !OMP, oh_mod.f90 (needs test)
+
+ ! compute convection for backward runs
+ !*************************************
+
+ if ((ldirect.eq.-1).and.(lconvection.eq.1).and.(itime.lt.0)) then
+ call convmix(itime) !OMP, conv_mod.f90
+ endif
+
+ ! Get hourly OH fields if not available
+ !****************************************************
+ if (OHREA) then
+ call gethourlyOH(itime) !OMP, oh_mod.f90 (needs test)
+ endif
+
+ ! Release particles
+ !******************
+ if (mdomainfill.ge.1) then
+ if (itime.eq.itime_init) then
+ call init_domainfill !OMP, initialise_mod.f90 (needs test)
+ else
+ call boundcond_domainfill(itime,loutend) !OMP, initialise_mod.f90 (needs test)
+ endif
+ else if ((ipin.eq.3).or.(ipin.eq.4)) then
+ ! If reading from user defined initial conditions, check which particles are
+ ! to be activated
+ if (count%allocated.le.0) stop 'Something is going wrong reading the part_ic.nc file!'
+
+ alive_tmp=count%alive
+ spawned_tmp=count%spawned
+!$OMP PARALLEL PRIVATE(i) REDUCTION(+:alive_tmp,spawned_tmp)
+!$OMP DO
+ do i=1,count%allocated
+ if (.not. part(i)%alive) then
+ if (ldirect.lt.0) then
+ if ((part(i)%tstart.le.itime).and.(part(i)%tstart.gt.itime+lsynctime)) then
+ call spawn_particle(itime,i)
+ call update_z_to_zeta(itime,i)
+ alive_tmp=alive_tmp+1
+ spawned_tmp=spawned_tmp+1
+ endif
+ else if ((part(i)%tstart.ge.itime).and.(part(i)%tstart.lt.itime+lsynctime)) then
+ call spawn_particle(itime,i)
+ call update_z_to_zeta(itime,i)
+ alive_tmp=alive_tmp+1
+ spawned_tmp=spawned_tmp+1
+ endif
+ endif
+ end do
+!$OMP END DO
+!$OMP END PARALLEL
+ count%alive=alive_tmp
+ count%spawned=spawned_tmp
+ call get_total_part_num(numpart)
+ else
+ call releaseparticles(itime)
+ endif
+
+ ! Compute convective mixing for forward runs
+ ! for backward runs it is done before next windfield is read in
+ !**************************************************************
+ if ((ldirect.eq.1).and.(lconvection.eq.1)) then
+ call convmix(itime) !OMP (not the nested part yet), conv_mod.f90
+ endif
+
+ ! If middle of averaging period of output fields is reached, accumulated
+ ! deposited mass radioactively decays
+ !***********************************************************************
+ if (DEP.and.(itime.eq.loutnext).and.(ldirect.gt.0)) call radioactive_decay() !OMP, unc_mod.f90 (needs test)
+
+
+ ! Is the time within the computation interval, if not, skip
+ !************************************************************
+ if ((ldirect*itime.ge.ldirect*loutstart).and.(ldirect*itime.le.ldirect*loutend)) then
+ call SYSTEM_CLOCK(count_clock, count_rate, count_max)
+ s_temp = (count_clock - count_clock0)/real(count_rate)
+ ! If it is not time yet to write outputs, skip
+ !***********************************************
+ if ((itime.eq.loutend).and.(outnum.gt.0).and.(itime.ne.0)) then
+
+ if ((iout.eq.4).or.(iout.eq.5)) call plumetraj(itime)
+ if (iflux.eq.1) call fluxoutput(itime)
+ if (ipout.ge.1) then
+ if (mod(itime,ipoutfac*loutstep).eq.0) then
+
+ call output_particles(itime)!,active_per_rel) ! dump particle positions
+ endif
+ endif
+ endif
+ ! Check whether concentrations are to be calculated and outputted
+ !****************************************************************
+ call output_concentrations(itime,loutstart,loutend,loutnext,outnum)
+ call SYSTEM_CLOCK(count_clock, count_rate, count_max)
+ s_writepart = s_writepart + ((count_clock - count_clock0)/real(count_rate)-s_temp)
+ endif
+
+ if (itime.eq.ideltas) exit ! almost finished
+
+ ! Compute interval since radioactive decay of deposited mass was computed
+ !************************************************************************
+
+ if (itime.lt.loutnext) then
+ ldeltat=itime-(loutnext-loutstep)
+ else ! first half of next interval
+ ldeltat=itime-loutnext
+ endif
+
+
+ ! Loop over all particles
+ !************************
+ ! Various variables for testing reason of CBL scheme, by mc
+ well_mixed_vector=0. !erase vector to test well mixed condition: modified by mc
+ well_mixed_norm=0. !erase normalization to test well mixed condition: modified by mc
+ avg_ol=0.
+ avg_wst=0.
+ avg_h=0.
+ avg_air_dens=0. !erase vector to obtain air density at particle positions: modified by mc
+ !-----------------------------------------------------------------------------
+
+ ! openmp change
+ ! LB, openmp following CTM version, need to be very careful due to big differences
+ ! between the openmp loop in this and the CTM version
+!$OMP PARALLEL PRIVATE(prob_rec,inage,nage,itage,ks,kp,thread,j,xmassfract,drydeposit)
+
+#if (defined _OPENMP)
+ thread = OMP_GET_THREAD_NUM() ! Starts with 0
+#else
+ thread = 0
+#endif
+
+!$OMP DO
+! SCHEDULE(dynamic, max(1,numpart/1000))
+!max(1,int(real(numpart)/numthreads/20.)))
+ do j=1,numpart
+
+ ! If integration step is due, do it
+ !**********************************
+ if (.not. part(j)%alive) cycle
+
+ ! Determine age class of the particle
+ !************************************
+ itage=abs(itime-part(j)%tstart)
+ nage=1
+ do inage=1,nageclass
+ nage=inage
+ if (itage.lt.lage(nage)) exit
+ end do
+
+ ! Initialize newly released particle
+ !***********************************
+ if ((part(j)%tstart.eq.itime).or.(itime.eq.0)) then
+ call update_zeta_to_z(itime, j)
+ call initialize_particle(itime,j)
+ endif
+
+ ! Memorize particle positions
+ !****************************
+ part(j)%xlon_prev=part(j)%xlon
+ part(j)%ylat_prev=part(j)%ylat
+ part(j)%z_prev=part(j)%z
+ part(j)%zeta_prev=part(j)%zeta
+
+ ! RECEPTOR: dry/wet depovel
+ !****************************
+ ! Before the particle is moved
+ ! the calculation of the scavenged mass shall only be done once after release
+ ! xscav_frac1 was initialised with a negative value
+
+ if (DRYBKDEP) then
+ do ks=1,nspec
+ if ((xscav_frac1(j,ks).lt.0)) then
+ call update_zeta_to_z(itime,j)
+ call get_vdep_prob(itime,real(part(j)%xlon),real(part(j)%ylat), &
+ real(part(j)%z),prob_rec)
+ if (DRYDEPSPEC(ks)) then ! dry deposition
+ xscav_frac1(j,ks)=prob_rec(ks)
+ else
+ part(j)%mass(ks)=0.
+ xscav_frac1(j,ks)=0.
+ endif
+ endif
+ enddo
+ endif
+
+ ! Integrate Langevin equation for lsynctime seconds
+ !*************************************************
+
+ call advance(itime,j,thread)
+
+ if (part(j)%nstop.eqv..true.) cycle
+ if (n_average.gt.0) call partpos_average(itime,j)
+
+ ! Calculate the gross fluxes across layer interfaces
+ !***************************************************
+ if (iflux.eq.1) call calcfluxes(itime,nage,j,real(part(j)%xlon_prev), &
+ real(part(j)%ylat_prev),real(part(j)%z_prev),thread+1)
+ end do
+!$OMP END DO
+!$OMP END PARALLEL
+
+#ifdef _OPENMP
+ call omp_set_num_threads(numthreads_grid)
+#endif
+
+ alive_tmp=count%alive
+ terminated_tmp=count%terminated
+
+!$OMP PARALLEL PRIVATE(prob_rec,nage,inage,itage,ks,kp,thread,j,xmassfract,drydeposit) &
+!$OMP REDUCTION(+:alive_tmp,terminated_tmp)
+
+!num_threads(numthreads_grid)
+
+#if (defined _OPENMP)
+ thread = OMP_GET_THREAD_NUM() ! Starts with 0
+#else
+ thread = 0
+#endif
+
+!$OMP DO
+! SCHEDULE(dynamic, max(1,numpart/1000))
+!max(1,int(real(numpart)/numthreads/20.)))
+ do j=1,numpart
+
+ ! If integration step is due, do it
+ !**********************************
+ if (.not. part(j)%alive) cycle
+
+ ! Determine age class of the particle
+ !************************************
+ itage=abs(itime-part(j)%tstart)
+ nage=1
+ do inage=1,nageclass
+ nage=inage
+ if (itage.lt.lage(nage)) exit
+ end do
+
+ ! Determine, when next time step is due
+ ! If trajectory is terminated, mark it
+ !**************************************
+ if (part(j)%nstop) then
+ if (linit_cond.ge.1) call initial_cond_calc(itime,j,thread+1)
+ call terminate_particle(j,itime)
+ alive_tmp=alive_tmp-1
+ terminated_tmp=terminated_tmp+1
+ else
+
+ ! Dry deposition and radioactive decay for each species
+ ! Also check maximum (of all species) of initial mass remaining on the particle;
+ ! if it is below a threshold value, terminate particle
+ !*****************************************************************************
+
+ xmassfract=0.
+ do ks=1,nspec
+ if (DRYDEPSPEC(ks)) then ! dry deposition (and radioactive decay)
+ call drydepo_massloss(j,ks,ldeltat,drydeposit(ks))
+ else if (decay(ks).gt.0.) then ! no dry deposition, but radioactive decay
+ part(j)%mass(ks)=part(j)%mass(ks)*exp(-real(abs(lsynctime))*decay(ks))
+ endif
+ ! Skip check on mass fraction when npoint represents particle number
+ if (mdomainfill.eq.0.and.mquasilag.eq.0) then
+ if ((ipin.eq.3).or.(ipin.eq.4)) then
+ if (part(j)%mass_init(ks).gt.0) then
+ xmassfract=max(xmassfract,part(j)%mass(ks)/part(j)%mass_init(ks))
+ endif
+ else if (xmass(part(j)%npoint,ks).gt.0.) then
+ xmassfract=max(xmassfract,real(npart(part(j)%npoint))* &
+ part(j)%mass(ks)/xmass(part(j)%npoint,ks))
+ endif
+ else
+ xmassfract=1.0
+ end if
+ end do
+
+ if (xmassfract.le.minmassfrac) then ! terminate all particles carrying less mass
+ call terminate_particle(j,itime)
+ alive_tmp=alive_tmp-1
+ terminated_tmp=terminated_tmp+1
+ endif
+
+! Sabine Eckhardt, June 2008
+! don't create depofield for backward runs
+ if (DRYDEP.AND.(ldirect.eq.1).and.(iout.ne.0)) then
+
+ if (ioutputforeachrelease.eq.1) then
+ kp=part(j)%npoint
+ else
+ kp=1
+ endif
+
+ call drydepokernel(part(j)%nclass,drydeposit,real(part(j)%xlon), &
+ real(part(j)%ylat),nage,kp,thread+1)
+ if (nested_output.eq.1) call drydepokernel_nest( &
+ part(j)%nclass,drydeposit,real(part(j)%xlon),real(part(j)%ylat), &
+ nage,kp,thread+1)
+ endif
+
+ ! Terminate trajectories that are older than maximum allowed age
+ !***************************************************************
+
+ if ((part(j)%alive).and.(abs(itime-part(j)%tstart).ge.lage(nageclass))) then
+ if (linit_cond.ge.1) call initial_cond_calc(itime+lsynctime,j,thread+1)
+ call terminate_particle(j,itime)
+ alive_tmp=alive_tmp-1
+ terminated_tmp=terminated_tmp+1
+ endif
+ endif
+
+ end do !loop over particles
+
+!$OMP END DO
+!$OMP END PARALLEL
+
+ count%alive=alive_tmp
+ count%terminated=terminated_tmp
+
+#ifdef _OPENMP
+ call omp_set_num_threads(numthreads)
+#endif
+ ! OpenMP Reduction for dynamically allocated arrays. This is done manually since this
+ ! is not yet supported in most OpenMP versions
+ !************************************************************************************
+#ifdef _OPENMP
+ if (iflux.eq.1) then
+ do i=1,numthreads
+ flux(:,:,:,:,:,:,:)=flux(:,:,:,:,:,:,:)+flux_omp(:,:,:,:,:,:,:,i)
+ flux_omp(:,:,:,:,:,:,:,i)=0.
+ end do
+ endif
+ if (linit_cond.ge.1) then
+ do i=1,numthreads_grid
+ init_cond(:,:,:,:,:)=init_cond(:,:,:,:,:)+init_cond_omp(:,:,:,:,:,i)
+ init_cond_omp(:,:,:,:,:,i)=0.
+ end do
+ endif
+ if (DRYDEP.AND.(ldirect.eq.1).and.(iout.ne.0)) then
+ do i=1,numthreads_grid
+ drygridunc(:,:,:,:,:,:)=drygridunc(:,:,:,:,:,:)+gridunc_omp(:,:,1,:,:,:,:,i)
+ gridunc_omp(:,:,1,:,:,:,:,i)=0.
+ end do
+ if (nested_output.eq.1) then
+ do i=1,numthreads_grid
+ drygriduncn(:,:,:,:,:,:)=drygriduncn(:,:,:,:,:,:)+griduncn_omp(:,:,1,:,:,:,:,i)
+ griduncn_omp(:,:,1,:,:,:,:,i)=0.
+ end do
+ endif
+ endif
+#endif
+ ! write(*,*) 'DRYGRIDUNC:',sum(drygridunc),drygridunc(20,270,1,1,1,1),drygridunc(19,269,1,1,1,1)
+ ! Counter of "unstable" particle velocity during a time scale of
+ ! maximumtl=20 minutes (defined in com_mod)
+ !***************************************************************
+
+ total_nan_intl=0
+ i_nan=i_nan+1 ! added by mc to count nan during a time of maxtl (i.e. maximum tl fixed here to 20 minutes, see com_mod)
+ do i=1,numthreads
+ sum_nan_count(i_nan)=sum_nan_count(i_nan)+nan_count(i)
+ end do
+ if (i_nan > maxtl/lsynctime) i_nan=1 !lsynctime must be <= maxtl
+ do ii_nan=1, (maxtl/lsynctime)
+ total_nan_intl=total_nan_intl+sum_nan_count(ii_nan)
+ end do
+ ! Output to keep track of the numerical instabilities in CBL simulation and if
+ ! they are compromising the final result (or not)
+ if (cblflag.eq.1) print *,j,itime,'nan_synctime',sum_nan_count(i_nan),'nan_tl',total_nan_intl
+
+ if (itime.eq.itime_init) then
+ call SYSTEM_CLOCK(count_clock, count_rate, count_max)
+ s_firstt = real(count_clock)/real(count_rate) - s_firstt
+ endif
+
+ end do
+
+ ! Complete the calculation of initial conditions for particles not yet terminated
+ !*****************************************************************************
+ call finalise_output(itime)
+
+ ! De-allocate memory and end
+ !***************************
+ call deallocate_all_particles
+ call windfields_deallocate
+ call domainfill_deallocate
+ call drydepo_deallocate
+ call convection_deallocate
+ call getfields_deallocate
+ call interpol_deallocate
+ call deallocate_random
+ if (numbnests.ge.1) call windfields_nest_deallocate
+
+ if (iflux.eq.1) then
+ deallocate(flux)
+ endif
+ if (OHREA) then
+ deallocate(OH_field,OH_hourly,lonOH,latOH,altOH)
+ endif
+
+ if ((ipin.ne.3).and.(ipin.ne.4)) then
+ deallocate(xpoint1,xpoint2,ypoint1,ypoint2,zpoint1,zpoint2,xmasssave)
+ endif
+ deallocate(xmass)
+ deallocate(ireleasestart,ireleaseend,npart,kindz)
+ deallocate(nan_count)
+ if (ipout.ne.0) deallocate( partopt )
+ if (iout.ne.0) then
+ deallocate(outheight,outheighthalf)
+ deallocate(oroout, area, volume)
+ deallocate(gridunc)
+#ifdef _OPENMP
+ deallocate(gridunc_omp)
+#endif
+ if (ldirect.gt.0) then
+ deallocate(drygridunc,wetgridunc)
+#ifdef _OPENMP
+ deallocate(drygridunc_omp,wetgridunc_omp)
+#endif
+ endif
+ if (nested_output.eq.1) then
+ deallocate(orooutn, arean, volumen)
+ if (ldirect.gt.0) then
+ deallocate(griduncn,drygriduncn,wetgriduncn)
+#ifdef _OPENMP
+ deallocate(griduncn_omp,drygriduncn_omp,wetgriduncn_omp)
+#endif
+ endif
+ endif
+ endif
+end subroutine timemanager
+
+end module timemanager_mod
diff --git a/src/turbulence_mod.f90 b/src/turbulence_mod.f90
new file mode 100644
index 00000000..88aeb972
--- /dev/null
+++ b/src/turbulence_mod.f90
@@ -0,0 +1,636 @@
+ !*****************************************************************************
+ ! *
+ ! 2021 L. Bakels: This module contains all turbulence related subroutines *
+ ! 2023 PS: include psih, psim into this module
+ ! *
+ !*****************************************************************************
+
+module turbulence_mod
+ use par_mod
+ use com_mod
+ use particle_mod
+ use pbl_profile_mod
+
+ implicit none
+
+ real :: ust,wst,ol,h,zeta,sigu,sigv,tlu,tlv,tlw
+ real :: sigw,dsigwdz,dsigw2dz
+
+!$OMP THREADPRIVATE(ust,wst,ol,h,zeta,sigu,sigv,tlu,tlv,tlw, &
+!$OMP sigw,dsigwdz,dsigw2dz)
+
+contains
+
+subroutine turbulence_boundarylayer(ipart,nrand,dt,zts,rhoa,rhograd,thread)
+
+ use cbl_mod
+
+ implicit none
+
+ integer, intent(in) :: &
+ ipart, & ! particle index
+ thread ! number of the omp thread
+ integer, intent(inout) ::&
+ nrand ! random number used for turbulence
+ real,intent(in) :: &
+ dt, & ! real(ldt)
+ rhoa, & ! air density, used in CBL
+ rhograd ! vertical gradient of the air density, used in CBL
+ real,intent(inout) :: &
+ zts ! local 'real' copy of the particle position
+ real :: &
+ delz, & ! change in vertical position due to turbulence
+ ru,rv,rw,wp,icbt_r, & ! used for computing turbulence
+ dtf,rhoaux,dtftlw,ath,bth,& ! CBL related
+ ptot_lhh,Q_lhh,phi_lhh, & ! CBL related
+ old_wp_buf,dcas,dcas1, & ! CBL related
+ del_test ! CBL related
+ integer :: &
+ flagrein, & ! flag used in CBL scheme
+ icbt, &
+ i ! loop variable
+
+ ! tlw,dsigwdz and dsigw2dz are defined in hanna
+ if (turbswitch) then
+ call hanna(zts)
+ else
+ call hanna1(zts)
+ endif
+
+ !*****************************************
+ ! Determine the new diffusivity velocities
+ !*****************************************
+
+ ! Horizontal components
+ !**********************
+ if (nrand+1.gt.maxrand) nrand=1
+ if (dt/tlu.lt..5) then
+ part(ipart)%turbvel%u=(1.-dt/tlu)*part(ipart)%turbvel%u+rannumb(nrand)*sigu*sqrt(2.*dt/tlu)
+ else
+ ru=exp(-dt/tlu)
+ part(ipart)%turbvel%u=ru*part(ipart)%turbvel%u+rannumb(nrand)*sigu*sqrt(1.-ru**2)
+ endif
+ if (dt/tlv.lt..5) then
+ part(ipart)%turbvel%v=(1.-dt/tlv)*part(ipart)%turbvel%v+rannumb(nrand+1)*sigv*sqrt(2.*dt/tlv)
+ else
+ rv=exp(-dt/tlv)
+ part(ipart)%turbvel%v=rv*part(ipart)%turbvel%v+rannumb(nrand+1)*sigv*sqrt(1.-rv**2)
+ endif
+ nrand=nrand+2
+
+
+ if (nrand+ifine.gt.maxrand) nrand=1
+ rhoaux=rhograd/rhoa
+ dtf=dt*fine
+
+ dtftlw=dtf/tlw
+
+ ! Loop over ifine short time steps for vertical component
+ !********************************************************
+ wp=part(ipart)%turbvel%w
+ icbt=part(ipart)%icbt
+ do i=1,ifine
+ icbt_r=real(icbt)
+ ! Determine the drift velocity and density correction velocity
+ !*************************************************************
+
+ if (turbswitch) then
+ if (dtftlw.lt..5) then
+ !*************************************************************
+ !************** CBL options added by mc see routine cblf90 ***
+ ! LB needs to be checked if this works with openmp
+ if (cblflag.eq.1) then !modified by mc
+ if (-h/ol.gt.5) then !modified by mc
+ flagrein=0
+ nrand=nrand+1
+ old_wp_buf=wp
+ call cbl(wp,zts,ust,wst,h,rhoa,rhograd,&
+ sigw,dsigwdz,tlw,ptot_lhh,Q_lhh,phi_lhh,ath,bth,ol,flagrein) !inside the routine for inverse time
+ wp=(wp+ath*dtf+&
+ bth*rannumb(nrand)*sqrt(dtf))*icbt_r
+ delz=wp*dtf
+ if ((flagrein.eq.1).or.(wp.ne.wp).or.((wp-1.).eq.wp)) then
+ call re_initialize_particle(zts,ust,wst,h,sigw,old_wp_buf,nrand,ol)
+ wp=old_wp_buf
+ delz=wp*dtf
+ nan_count(thread+1)=nan_count(thread+1)+1
+ end if
+ else
+ nrand=nrand+1
+ old_wp_buf=wp
+ ath=-wp/tlw+sigw*dsigwdz+&
+ wp*wp/sigw*dsigwdz+sigw*sigw/rhoa*rhograd !1-note for inverse time should be -wp/tlw*ldirect+... calculated for wp=-wp
+ !2-but since ldirect =-1 for inverse time and this must be calculated for (-wp) and
+ !3-the gaussian pdf is symmetric (i.e. pdf(w)=pdf(-w) ldirect can be discarded
+ bth=sigw*rannumb(nrand)*sqrt(2.*dtftlw)
+ wp=(wp+ath*dtf+bth)*icbt_r
+ delz=wp*dtf
+ if ((wp.ne.wp).or.((wp-1.).eq.wp)) then ! Catch infinity or NaN
+ nrand=nrand+1
+ wp=sigw*rannumb(nrand)
+ delz=wp*dtf
+ nan_count(thread+1)=nan_count(thread+1)+1
+ end if
+ end if
+ !******************** END CBL option *******************************
+ !*******************************************************************
+ else
+ wp=((1.-dtftlw)*wp+rannumb(nrand+i)*sqrt(2.*dtftlw) &
+ +dtf*(dsigwdz+rhoaux*sigw))*icbt_r
+ delz=wp*sigw*dtf
+ end if
+ else
+ rw=exp(-dtftlw)
+ wp=(rw*wp+rannumb(nrand+i)*sqrt(1.-rw**2) &
+ +tlw*(1.-rw)*(dsigwdz+rhoaux*sigw))*icbt_r
+ delz=wp*sigw*dtf
+ endif
+
+ else
+ rw=exp(-dtftlw)
+ wp=(rw*wp+rannumb(nrand+i)*sqrt(1.-rw**2)*sigw &
+ +tlw*(1.-rw)*(dsigw2dz+rhoaux*sigw**2))*icbt_r
+ delz=wp*dtf
+ endif
+
+ !****************************************************
+ ! Compute turbulent vertical displacement of particle
+ !****************************************************
+
+ if (abs(delz).gt.h) delz=mod(delz,h)
+
+ ! Determine if particle transfers to a "forbidden state" below the ground
+ ! or above the mixing height
+ !************************************************************************
+
+ if (delz.lt.-zts) then ! reflection at ground
+ icbt=-1
+ call set_z(ipart,-zts-delz)
+ else if (delz.gt.(h-zts)) then ! reflection at h
+ icbt=-1
+ call set_z(ipart,-zts-delz+2.*h)
+ else ! no reflection
+ icbt=1
+ call set_z(ipart,zts+delz)
+ endif
+
+ if (i.ne.ifine) then
+ zeta=zts/h
+ call hanna_short(zts)
+ endif
+ zts=real(part(ipart)%z)
+ end do
+ part(ipart)%turbvel%w=wp
+ part(ipart)%icbt=icbt
+ if (cblflag.ne.1) nrand=nrand+i
+end subroutine turbulence_boundarylayer
+
+subroutine turbulence_stratosphere(dt,nrand,ux,vy,wp,tropop,zts)
+
+ implicit none
+
+ integer, intent(inout) :: &
+ nrand ! random number used for turbulence
+ real, intent(inout) :: &
+ ux,vy,wp ! random turbulent velocities above PBL
+ real, intent(in) :: &
+ tropop, & ! height of troposphere
+ zts, & ! height of particle
+ dt ! real(ldt)
+ real :: &
+ uxscale,wpscale, & ! factor used in calculating turbulent perturbations above PBL
+ weight ! transition above the tropopause
+
+ if (zts.lt.tropop) then ! in the troposphere
+ uxscale=sqrt(2.*d_trop/dt)
+ if (nrand+1.gt.maxrand) nrand=1
+ ux=rannumb(nrand)*uxscale
+ vy=rannumb(nrand+1)*uxscale
+ nrand=nrand+2
+ wp=0.
+ else if (zts.lt.tropop+1000.) then ! just above the tropopause: make transition
+ weight=(zts-tropop)/1000.
+ uxscale=sqrt(2.*d_trop/dt*(1.-weight))
+ if (nrand+2.gt.maxrand) nrand=1
+ ux=rannumb(nrand)*uxscale
+ vy=rannumb(nrand+1)*uxscale
+ wpscale=sqrt(2.*d_strat/dt*weight)
+ wp=rannumb(nrand+2)*wpscale+d_strat/1000.
+ nrand=nrand+3
+ else ! in the stratosphere
+ if (nrand.gt.maxrand) nrand=1
+ ux=0.
+ vy=0.
+ wpscale=sqrt(2.*d_strat/dt)
+ wp=rannumb(nrand)*wpscale
+ nrand=nrand+1
+ endif
+end subroutine turbulence_stratosphere
+
+subroutine turbulence_mesoscale(nrand,dxsave,dysave,ipart,usig,vsig,wsig,wsigeta,eps_eta)
+
+ implicit none
+
+ integer, intent(inout) :: &
+ nrand ! random number used for turbulence
+ integer, intent(in) :: &
+ ipart ! particle index
+ real, intent(in) :: &
+ eps_eta,usig,vsig,wsig,wsigeta
+ real, intent(inout) :: &
+ dxsave,dysave ! accumulated displacement in long and lat
+ real :: &
+ r,rs, & ! mesoscale related
+ ux,vy ! random turbulent velocities above PBL
+
+ r=exp(-2.*real(abs(lsynctime))/real(lwindinterv))
+ rs=sqrt(1.-r**2)
+ if (nrand+2.gt.maxrand) nrand=1
+ part(ipart)%mesovel%u=r*part(ipart)%mesovel%u+rs*rannumb(nrand)*usig*turbmesoscale
+ part(ipart)%mesovel%v=r*part(ipart)%mesovel%v+rs*rannumb(nrand+1)*vsig*turbmesoscale
+ dxsave=dxsave+part(ipart)%mesovel%u*real(lsynctime)
+ dysave=dysave+part(ipart)%mesovel%v*real(lsynctime)
+
+ select case (wind_coord_type)
+ case ('ETA')
+ part(ipart)%mesovel%w=r*part(ipart)%mesovel%w+rs*rannumb(nrand+2)*wsigeta*turbmesoscale
+ call update_zeta(ipart,part(ipart)%mesovel%w*real(lsynctime))
+ if (part(ipart)%zeta.ge.1.) call set_zeta(ipart,1.-(part(ipart)%zeta-1.))
+ if (part(ipart)%zeta.eq.1.) call update_zeta(ipart,-eps_eta)
+
+ case ('METER')
+ part(ipart)%mesovel%w=r*part(ipart)%mesovel%w+rs*rannumb(nrand+2)*wsig*turbmesoscale
+ call update_z(ipart,part(ipart)%mesovel%w*real(lsynctime))
+ if (part(ipart)%z.lt.0.) call set_z(ipart,-1.*part(ipart)%z) ! if particle below ground -> refletion
+
+ case default
+ part(ipart)%mesovel%w=r*part(ipart)%mesovel%w+rs*rannumb(nrand+2)*wsig*turbmesoscale
+ call update_z(ipart,part(ipart)%mesovel%w*real(lsynctime))
+ if (part(ipart)%z.lt.0.) call set_z(ipart,-1.*part(ipart)%z) ! if particle below ground -> refletion
+ end select
+end subroutine turbulence_mesoscale
+
+subroutine hanna(z)
+ ! i
+ !*****************************************************************************
+ ! *
+ ! Computation of \sigma_i and \tau_L based on the scheme of Hanna (1982) *
+ ! *
+ ! Author: A. Stohl *
+ ! *
+ ! 4 December 1997 *
+ ! *
+ !*****************************************************************************
+ ! *
+ ! Variables: *
+ ! dsigwdz [1/s] vertical gradient of sigw *
+ ! ol [m] Obukhov length *
+ ! sigu, sigv, sigw standard deviations of turbulent velocity fluctuations *
+ ! tlu [s] Lagrangian time scale for the along wind component. *
+ ! tlv [s] Lagrangian time scale for the cross wind component. *
+ ! tlw [s] Lagrangian time scale for the vertical wind component. *
+ ! ust, ustar [m/s] friction velocity *
+ ! wst, wstar [m/s] convective velocity scale *
+ ! *
+ !*****************************************************************************
+
+ implicit none
+
+ real :: corr,z
+
+
+ !**********************
+ ! 1. Neutral conditions
+ !**********************
+
+ if (h/abs(ol).lt.1.) then
+ ust=max(1.e-4,ust)
+ corr=z/ust
+ sigu=1.e-2+2.0*ust*exp(-3.e-4*corr)
+ sigw=1.3*ust*exp(-2.e-4*corr)
+ dsigwdz=-2.e-4*sigw
+ sigw=sigw+1.e-2
+ sigv=sigw
+ tlu=0.5*z/sigw/(1.+1.5e-3*corr)
+ tlv=tlu
+ tlw=tlu
+
+
+ !***********************
+ ! 2. Unstable conditions
+ !***********************
+
+ else if (ol.lt.0.) then
+
+
+ ! Determine sigmas
+ !*****************
+
+ sigu=1.e-2+ust*(12.-0.5*h/ol)**0.33333
+ sigv=sigu
+ sigw=sqrt(1.2*wst**2*(1.-.9*zeta)*zeta**0.66666+ &
+ (1.8-1.4*zeta)*ust**2)+1.e-2
+ dsigwdz=0.5/sigw/h*(-1.4*ust**2+wst**2* &
+ (0.8*max(zeta,1.e-3)**(-.33333)-1.8*zeta**0.66666))
+
+
+ ! Determine average Lagrangian time scale
+ !****************************************
+
+ tlu=0.15*h/sigu
+ tlv=tlu
+ if (z.lt.abs(ol)) then
+ tlw=0.1*z/(sigw*(0.55-0.38*abs(z/ol)))
+ else if (zeta.lt.0.1) then
+ tlw=0.59*z/sigw
+ else
+ tlw=0.15*h/sigw*(1.-exp(-5*zeta))
+ endif
+
+
+ !*********************
+ ! 3. Stable conditions
+ !*********************
+
+ else
+ sigu=1.e-2+2.*ust*(1.-zeta)
+ sigv=1.e-2+1.3*ust*(1.-zeta)
+ sigw=sigv
+ dsigwdz=-1.3*ust/h
+ tlu=0.15*h/sigu*(sqrt(zeta))
+ tlv=0.467*tlu
+ tlw=0.1*h/sigw*zeta**0.8
+ endif
+
+
+ tlu=max(10.,tlu)
+ tlv=max(10.,tlv)
+ tlw=max(30.,tlw)
+
+ if (dsigwdz.eq.0.) dsigwdz=1.e-10
+end subroutine hanna
+
+subroutine hanna1(z)
+ ! i
+ !*****************************************************************************
+ ! *
+ ! Computation of \sigma_i and \tau_L based on the scheme of Hanna (1982) *
+ ! *
+ ! Author: A. Stohl *
+ ! *
+ ! 4 December 1997 *
+ ! *
+ !*****************************************************************************
+ ! *
+ ! Variables: *
+ ! dsigwdz [1/s] vertical gradient of sigw *
+ ! ol [m] Obukhov length *
+ ! sigu, sigv, sigw standard deviations of turbulent velocity fluctuations *
+ ! tlu [s] Lagrangian time scale for the along wind component. *
+ ! tlv [s] Lagrangian time scale for the cross wind component. *
+ ! tlw [s] Lagrangian time scale for the vertical wind component. *
+ ! ust, ustar [m/s] friction velocity *
+ ! wst, wstar [m/s] convective velocity scale *
+ ! *
+ !*****************************************************************************
+
+ implicit none
+
+ real :: z,s1,s2
+
+
+
+ !**********************
+ ! 1. Neutral conditions
+ !**********************
+
+ if (h/abs(ol).lt.1.) then
+
+ ust=max(1.e-4,ust)
+ sigu=2.0*ust*exp(-3.e-4*z/ust)
+ sigu=max(sigu,1.e-5)
+ sigv=1.3*ust*exp(-2.e-4*z/ust)
+ sigv=max(sigv,1.e-5)
+ sigw=sigv
+ dsigw2dz=-6.76e-4*ust*exp(-4.e-4*z/ust)
+ tlu=0.5*z/sigw/(1.+1.5e-3*z/ust)
+ tlv=tlu
+ tlw=tlu
+
+
+ !***********************
+ ! 2. Unstable conditions
+ !***********************
+
+ else if (ol.lt.0.) then
+
+
+ ! Determine sigmas
+ !*****************
+
+ sigu=ust*(12.-0.5*h/ol)**0.33333
+ sigu=max(sigu,1.e-6)
+ sigv=sigu
+
+ if (zeta.lt.0.03) then
+ sigw=0.96*wst*(3*zeta-ol/h)**0.33333
+ dsigw2dz=1.8432*wst*wst/h*(3*zeta-ol/h)**(-0.33333)
+ else if (zeta.lt.0.4) then
+ s1=0.96*(3*zeta-ol/h)**0.33333
+ s2=0.763*zeta**0.175
+ if (s1.lt.s2) then
+ sigw=wst*s1
+ dsigw2dz=1.8432*wst*wst/h*(3*zeta-ol/h)**(-0.33333)
+ else
+ sigw=wst*s2
+ dsigw2dz=0.203759*wst*wst/h*zeta**(-0.65)
+ endif
+ else if (zeta.lt.0.96) then
+ sigw=0.722*wst*(1-zeta)**0.207
+ dsigw2dz=-.215812*wst*wst/h*(1-zeta)**(-0.586)
+ else if (zeta.lt.1.00) then
+ sigw=0.37*wst
+ dsigw2dz=0.
+ endif
+ sigw=max(sigw,1.e-6)
+
+
+ ! Determine average Lagrangian time scale
+ !****************************************
+
+ tlu=0.15*h/sigu
+ tlv=tlu
+ if (z.lt.abs(ol)) then
+ tlw=0.1*z/(sigw*(0.55-0.38*abs(z/ol)))
+ else if (zeta.lt.0.1) then
+ tlw=0.59*z/sigw
+ else
+ tlw=0.15*h/sigw*(1.-exp(-5*zeta))
+ endif
+
+
+ !*********************
+ ! 3. Stable conditions
+ !*********************
+
+ else
+ sigu=2.*ust*(1.-zeta)
+ sigv=1.3*ust*(1.-zeta)
+ sigu=max(sigu,1.e-6)
+ sigv=max(sigv,1.e-6)
+ sigw=sigv
+ dsigw2dz=3.38*ust*ust*(zeta-1.)/h
+ tlu=0.15*h/sigu*(sqrt(zeta))
+ tlv=0.467*tlu
+ tlw=0.1*h/sigw*zeta**0.8
+ endif
+
+
+
+
+ tlu=max(10.,tlu)
+ tlv=max(10.,tlv)
+ tlw=max(30.,tlw)
+end subroutine hanna1
+
+subroutine hanna_short(z)
+ ! i
+ !*****************************************************************************
+ ! *
+ ! Computation of \sigma_i and \tau_L based on the scheme of Hanna (1982) *
+ ! *
+ ! Author: A. Stohl *
+ ! *
+ ! 4 December 1997 *
+ ! *
+ !*****************************************************************************
+ ! *
+ ! Variables: *
+ ! dsigwdz [1/s] vertical gradient of sigw *
+ ! ol [m] Obukhov length *
+ ! sigu, sigv, sigw standard deviations of turbulent velocity fluctuations *
+ ! tlu [s] Lagrangian time scale for the along wind component. *
+ ! tlv [s] Lagrangian time scale for the cross wind component. *
+ ! tlw [s] Lagrangian time scale for the vertical wind component. *
+ ! ust, ustar [m/s] friction velocity *
+ ! wst, wstar [m/s] convective velocity scale *
+ ! *
+ !*****************************************************************************
+
+ implicit none
+
+ real :: z
+
+
+
+ !**********************
+ ! 1. Neutral conditions
+ !**********************
+
+ if (h/abs(ol).lt.1.) then
+ ust=max(1.e-4,ust)
+ sigw=1.3*exp(-2.e-4*z/ust)
+ dsigwdz=-2.e-4*sigw
+ sigw=sigw*ust+1.e-2
+ tlw=0.5*z/sigw/(1.+1.5e-3*z/ust)
+
+
+ !***********************
+ ! 2. Unstable conditions
+ !***********************
+
+ else if (ol.lt.0.) then
+
+
+ ! Determine sigmas
+ !*****************
+
+ sigw=sqrt(1.2*wst**2*(1.-.9*zeta)*zeta**0.66666+ &
+ (1.8-1.4*zeta)*ust**2)+1.e-2
+ dsigwdz=0.5/sigw/h*(-1.4*ust**2+wst**2* &
+ (0.8*max(zeta,1.e-3)**(-.33333)-1.8*zeta**0.66666))
+
+
+ ! Determine average Lagrangian time scale
+ !****************************************
+
+ if (z.lt.abs(ol)) then
+ tlw=0.1*z/(sigw*(0.55-0.38*abs(z/ol)))
+ else if (zeta.lt.0.1) then
+ tlw=0.59*z/sigw
+ else
+ tlw=0.15*h/sigw*(1.-exp(-5*zeta))
+ endif
+
+
+ !*********************
+ ! 3. Stable conditions
+ !*********************
+
+ else
+ sigw=1.e-2+1.3*ust*(1.-zeta)
+ dsigwdz=-1.3*ust/h
+ tlw=0.1*h/sigw*zeta**0.8
+ endif
+
+
+ tlu=max(10.,tlu)
+ tlv=max(10.,tlv)
+ tlw=max(30.,tlw)
+ if (dsigwdz.eq.0.) dsigwdz=1.e-10
+end subroutine hanna_short
+
+subroutine windalign(u,v,ffap,ffcp,ux,vy)
+ ! i i i i o o
+ !*****************************************************************************
+ ! *
+ ! Transformation from along- and cross-wind components to u and v *
+ ! components. *
+ ! *
+ ! Author: A. Stohl *
+ ! *
+ ! 3 June 1996 *
+ ! *
+ !*****************************************************************************
+ ! *
+ ! Variables: *
+ ! ffap turbulent wind in along wind direction *
+ ! ffcp turbulent wind in cross wind direction *
+ ! u main wind component in x direction *
+ ! ux turbulent wind in x direction *
+ ! v main wind component in y direction *
+ ! vy turbulent wind in y direction *
+ ! *
+ !*****************************************************************************
+
+ implicit none
+
+ real :: u,v,ffap,ffcp,ux,vy,ffinv,ux1,ux2,vy1,vy2,sinphi,cosphi
+ real,parameter :: eps=1.e-30
+
+
+ ! Transform along wind components
+ !********************************
+
+ ffinv=1./max(sqrt(u*u+v*v),eps)
+ sinphi=v*ffinv
+ vy1=sinphi*ffap
+ cosphi=u*ffinv
+ ux1=cosphi*ffap
+
+
+ ! Transform cross wind components
+ !********************************
+
+ ux2=-sinphi*ffcp
+ vy2=cosphi*ffcp
+
+
+ ! Add contributions from along and cross wind components
+ !*******************************************************
+
+ ux=ux1+ux2
+ vy=vy1+vy2
+end subroutine windalign
+
+end module turbulence_mod
diff --git a/src/txt_output_mod.f90 b/src/txt_output_mod.f90
new file mode 100644
index 00000000..b014b82d
--- /dev/null
+++ b/src/txt_output_mod.f90
@@ -0,0 +1,171 @@
+module txt_output_mod
+
+ implicit none
+
+
+contains
+
+subroutine writeheader_txt
+
+ !*****************************************************************************
+ ! *
+ ! This routine produces a file header containing basic information on the *
+ ! settings of the FLEXPART run. *
+ ! The header file is essential and must be read in by any postprocessing *
+ ! program before reading in the output data. *
+ ! *
+ ! Author: A. Stohl *
+ ! *
+ ! 7 August 2002 *
+ ! modified IP 2013 for text output *
+ !*****************************************************************************
+ ! *
+ ! Variables: *
+ ! *
+ ! xlon longitude *
+ ! xl model x coordinate *
+ ! ylat latitude *
+ ! yl model y coordinate *
+ ! *
+ !*****************************************************************************
+
+ use point_mod
+ use outg_mod
+ use par_mod
+ use com_mod
+ use date_mod
+
+ implicit none
+
+ ! integer :: jjjjmmdd,ihmmss,i,ix,jy,j
+ integer :: jjjjmmdd,ihmmss,i,j
+ real :: xp1,yp1,xp2,yp2
+
+
+ !************************
+ ! Open header output file
+ !************************
+
+ open(unitheader,file=path(2)(1:length(2))//'header_txt', &
+ form='formatted',err=998)
+ open(unitheader_txt,file=path(2)(1:length(2))//'header_txt_releases', &
+ form='formatted',err=998)
+
+
+ ! Write the header information
+ !*****************************
+
+ write(unitheader,*) '# ibdate,ibtime, iedate, ietime, flexversion'
+ write(unitheader,*) ibdate, ibtime, iedate, ietime, trim(flexversion) ! 'FLEXPART V9.0'
+ !if (ldirect.eq.1) then
+ ! write(unitheader,*) ibdate,ibtime,trim(flexversion) ! 'FLEXPART V9.0'
+ !else
+ ! write(unitheader,*) iedate,ietime,trim(flexversion) ! 'FLEXPART V9.0'
+ !endif
+
+ ! Write info on output interval, averaging time, sampling time
+ !*************************************************************
+
+ write(unitheader,*) '# interval, averaging time, sampling time'
+ write(unitheader,*) loutstep,loutaver,loutsample
+
+ ! Write information on output grid setup
+ !***************************************
+
+ write(unitheader,*) '# information on grid setup '
+ write(unitheader,*) '#outlon0,outlat0,numxgrid,numygrid,dxout,dyout'
+ write(unitheader,*) outlon0,outlat0,numxgrid,numygrid, &
+ dxout,dyout
+ write(unitheader,*) '# numzgrid, outheight(.) '
+ write(unitheader,*) numzgrid,(outheight(i),i=1,numzgrid)
+
+ write(unitheader,*) '# jjjjmmdd,ihmmss'
+ call caldate(bdate,jjjjmmdd,ihmmss)
+ write(unitheader,*) jjjjmmdd,ihmmss
+
+ ! Write number of species, and name for each species (+extra name for depositions)
+ ! Indicate the vertical dimension of the fields (i.e., 1 for deposition fields, numzgrid for
+ ! concentration fields
+ !*****************************************************************************
+
+ write(unitheader,*) '# information on species'
+ write(unitheader,*) '# 3*nspec,maxpointspec_act'
+ write(unitheader,*) 3*nspec,maxpointspec_act
+ write(unitheader,*) '# for nspec:'
+ write(unitheader,*) '# 1, WD_ '
+ write(unitheader,*) '# 1, DD_ '
+ write(unitheader,*) '# numzgrid,species'
+ do i=1,nspec
+ write(unitheader,*) 1,'WD_'//species(i)(1:7)
+ write(unitheader,*) 1,'DD_'//species(i)(1:7)
+ write(unitheader,*) numzgrid,species(i)
+ end do
+
+ ! Write information on release points: total number, then for each point:
+ ! start, end, coordinates, # of particles, name, mass
+ !************************************************************************
+
+
+ write(unitheader_txt,*) '# information on release points'
+ write(unitheader_txt,*) '# numpoint'
+ write(unitheader_txt,*) numpoint
+ if ((ipin.ne.3).and.(ipin.ne.4)) then
+ write(unitheader_txt,*) '# for numpoint:'
+ do i=1,numpoint
+ write(unitheader_txt,*) ireleasestart(i),ireleaseend(i),kindz(i)
+ xp1=xpoint1(i)*dx+xlon0
+ yp1=ypoint1(i)*dy+ylat0
+ xp2=xpoint2(i)*dx+xlon0
+ yp2=ypoint2(i)*dy+ylat0
+ write(unitheader_txt,*) xp1,yp1,xp2,yp2,zpoint1(i),zpoint2(i)
+ write(unitheader_txt,*) npart(i),1
+ if (numpoint.le.1000) then
+ write(unitheader_txt,*) compoint(i)
+ else
+ write(unitheader_txt,*) compoint(1001)
+ endif
+ do j=1,nspec
+ write(unitheader_txt,*) xmass(i,j)
+ write(unitheader_txt,*) xmass(i,j)
+ write(unitheader_txt,*) xmass(i,j)
+ end do
+ end do
+ endif
+
+ ! Write information on model switches
+ !*****************************************
+
+ write(unitheader,*) '# information on model switches'
+ write(unitheader,*) '# method,lsubgrid,lconvection, ind_source,ind_receptor'
+ write(unitheader,*) method,lsubgrid,lconvection, &
+ ind_source,ind_receptor
+
+ ! Write age class information
+ !****************************
+
+ write(unitheader,*) '# information on age class '
+ write(unitheader,*) nageclass,(lage(i),i=1,nageclass)
+
+
+ !Do not write topography to text output file. Keep it on the binary one
+ !********************************
+
+ !do ix=0,numxgrid-1
+ ! write(unitheader,*) (oroout(ix,jy),jy=0,numygrid-1)
+ !end do
+
+ close(unitheader)
+ close(unitheader_txt)
+
+ return
+
+
+998 write(*,*) ' #### FLEXPART MODEL ERROR! THE FILE #### '
+ write(*,*) ' #### '//path(2)(1:length(2))//'header_txt'//' #### '
+ write(*,*) ' #### CANNOT BE OPENED. IF A FILE WITH THIS #### '
+ write(*,*) ' #### NAME ALREADY EXISTS, DELETE IT AND START #### '
+ write(*,*) ' #### THE PROGRAM AGAIN. #### '
+ stop
+end subroutine writeheader_txt
+
+end module txt_output_mod
diff --git a/src/unc_mod.f90 b/src/unc_mod.f90
index d773636e..312117c9 100644
--- a/src/unc_mod.f90
+++ b/src/unc_mod.f90
@@ -9,30 +9,91 @@
module unc_mod
- use par_mod, only:dep_prec
+ use par_mod, only:dp,dep_prec,nclassunc
implicit none
- real,allocatable, dimension (:,:,:,:,:,:,:) :: gridunc
+ real(dep_prec),allocatable, dimension (:,:,:,:,:,:,:) :: gridunc
#ifdef USE_MPIINPLACE
#else
! If MPI_IN_PLACE option is not used in mpi_mod.f90::mpif_tm_reduce_grid(),
! then an aux array is needed for parallel grid reduction
- real,allocatable, dimension (:,:,:,:,:,:,:) :: gridunc0
- real,allocatable, dimension (:,:,:,:,:,:,:) :: griduncn0
+ real(dep_prec),allocatable, dimension (:,:,:,:,:,:,:) :: gridunc0
+ real(dep_prec),allocatable, dimension (:,:,:,:,:,:,:) :: griduncn0
#endif
- real,allocatable, dimension (:,:,:,:,:,:,:) :: griduncn
+ real(dep_prec),allocatable, dimension (:,:,:,:,:,:,:) :: griduncn
real(dep_prec),allocatable, dimension (:,:,:,:,:,:) :: drygridunc
real(dep_prec),allocatable, dimension (:,:,:,:,:,:) :: drygriduncn
real(dep_prec),allocatable, dimension (:,:,:,:,:,:) :: wetgridunc
real(dep_prec),allocatable, dimension (:,:,:,:,:,:) :: wetgriduncn
-
+#ifdef _OPENMP
+ real(dep_prec),allocatable, dimension (:,:,:,:,:,:,:,:) :: gridunc_omp
+ real(dep_prec),allocatable, dimension (:,:,:,:,:,:,:,:) :: griduncn_omp
+ real(dep_prec),allocatable, dimension (:,:,:,:,:,:,:) :: drygridunc_omp
+ real(dep_prec),allocatable, dimension (:,:,:,:,:,:,:) :: drygriduncn_omp
+ real(dep_prec),allocatable, dimension (:,:,:,:,:,:,:) :: wetgridunc_omp
+ real(dep_prec),allocatable, dimension (:,:,:,:,:,:,:) :: wetgriduncn_omp
+#endif
! For sum of individual contributions, used for the MPI version
real(dep_prec),allocatable, dimension (:,:,:,:,:,:) :: drygridunc0
real(dep_prec),allocatable, dimension (:,:,:,:,:,:) :: drygriduncn0
real(dep_prec),allocatable, dimension (:,:,:,:,:,:) :: wetgridunc0
real(dep_prec),allocatable, dimension (:,:,:,:,:,:) :: wetgriduncn0
- real,allocatable, dimension (:,:,:,:,:) :: init_cond
+contains
+
+subroutine radioactive_decay()
+ ! Accumulated deposited mass radioactively decays
+ use com_mod
+
+ implicit none
+
+ integer :: &
+ j,i, & ! loop variable over grid
+ ks, & ! loop variable species
+ kp, & ! loop variable for maxpointspec_act
+ l, & ! loop variable over nclassunc
+ nage, & ! loop variable over age classes
+ n ! loop variable over particles
+
+!$OMP PARALLEL PRIVATE(ks,kp,nage,l,j,i)
+!$OMP DO COLLAPSE(2)
+ do ks=1,nspec
+ do kp=1,maxpointspec_act
+ if (decay(ks).gt.0.) then
+ do nage=1,nageclass
+ do l=1,nclassunc
+ ! Mother output grid
+ do j=0,numygrid-1
+ do i=0,numxgrid-1
+ wetgridunc(i,j,ks,kp,l,nage)= &
+ wetgridunc(i,j,ks,kp,l,nage)* &
+ exp(-1.*outstep*decay(ks))
+ drygridunc(i,j,ks,kp,l,nage)= &
+ drygridunc(i,j,ks,kp,l,nage)* &
+ exp(-1.*outstep*decay(ks))
+ end do
+ end do
+ ! Nested output grid
+ if (nested_output.eq.1) then
+ do j=0,numygridn-1
+ do i=0,numxgridn-1
+ wetgriduncn(i,j,ks,kp,l,nage)= &
+ wetgriduncn(i,j,ks,kp,l,nage)* &
+ exp(-1.*outstep*decay(ks))
+ drygriduncn(i,j,ks,kp,l,nage)= &
+ drygriduncn(i,j,ks,kp,l,nage)* &
+ exp(-1.*outstep*decay(ks))
+ end do
+ end do
+ endif
+ end do
+ end do
+ endif
+ end do
+ end do
+!$OMP END DO
+!$OMP END PARALLEL
+end subroutine radioactive_decay
end module unc_mod
diff --git a/src/verttransform_mod.f90 b/src/verttransform_mod.f90
new file mode 100644
index 00000000..f33a7f50
--- /dev/null
+++ b/src/verttransform_mod.f90
@@ -0,0 +1,1968 @@
+! SPDX-FileCopyrightText: FLEXPART 1998-2019, see flexpart_license.txt
+! SPDX-License-Identifier: GPL-3.0-or-later
+
+ !*****************************************************************************
+ ! *
+ ! This module contains all subroutines computing the vertical coordinate *
+ ! transformation of the meteorological input data (L. Bakels 2021) *
+ ! *
+ !*****************************************************************************
+
+module verttransform_mod
+ use par_mod
+ use com_mod
+ use qvsat_mod
+ use cmapf_mod, only: cc2gll
+ use windfields_mod
+
+ implicit none
+
+contains
+
+subroutine verttransform_ecmwf(n,uuh,vvh,wwh,pvh)
+ ! i i i i i
+ !*****************************************************************************
+ ! *
+ ! This subroutine transforms temperature, dew point temperature and *
+ ! wind components from eta to meter coordinates. *
+ ! The vertical wind component is transformed from Pa/s to m/s using *
+ ! the conversion factor pinmconv. *
+ ! In addition, this routine calculates vertical density gradients *
+ ! needed for the parameterization of the turbulent velocities. *
+ ! *
+ ! Author: A. Stohl, G. Wotawa *
+ ! *
+ ! 12 August 1996 *
+ ! Update: 16 January 1998 *
+ ! *
+ ! Major update: 17 February 1999 *
+ ! by G. Wotawa *
+ ! *
+ ! - Vertical levels for u, v and w are put together *
+ ! - Slope correction for vertical velocity: Modification of calculation *
+ ! procedure *
+ ! *
+ !*****************************************************************************
+ ! Changes, Bernd C. Krueger, Feb. 2001:
+ ! Variables tth and qvh (on eta coordinates) from common block
+ !
+ ! Sabine Eckhardt, March 2007
+ ! added the variable cloud for use with scavenging - descr. in com_mod
+ !
+ ! Unified ECMWF and GFS builds
+ ! Marian Harustak, 12.5.2017
+ ! - Renamed from verttransform to verttransform_ecmwf
+ !
+ ! Date: 2017-05-30 modification of a bug in ew. Don Morton (CTBTO project) *
+ ! *
+ ! Lucie Bakels, 2022 *
+ ! - Separated the code into subroutines *
+ ! - In case of wind_coord_type='ETA': keep ECMWF vertical winds in eta *
+ ! coordinates *
+ ! - OpenMP parallelisation *
+ !*****************************************************************************
+ ! *
+ ! Variables: *
+ ! nx,ny,nz field dimensions in x,y and z direction *
+ ! clouds(0:nxmax,0:nymax,0:nzmax,numwfmem) cloud field for wet deposition *
+ ! uu(0:nxmax,0:nymax,nzmax,numwfmem) wind components in x-direction [m/s]*
+ ! vv(0:nxmax,0:nymax,nzmax,numwfmem) wind components in y-direction [m/s]*
+ ! ww(0:nxmax,0:nymax,nzmax,numwfmem) wind components in z-direction *
+ ! [deltaeta/s] *
+ ! tt(0:nxmax,0:nymax,nzmax,numwfmem) temperature [K] *
+ ! pv(0:nxmax,0:nymax,nzmax,numwfmem) potential voriticity (pvu) *
+ ! ps(0:nxmax,0:nymax,numwfmem) surface pressure [Pa] *
+ ! *
+ !*****************************************************************************
+
+ implicit none
+
+ integer, intent(in) :: n
+ real,intent(in),dimension(0:nxmax-1,0:nymax-1,nuvzmax) :: uuh,vvh,pvh
+ real,intent(in),dimension(0:nxmax-1,0:nymax-1,nwzmax) :: wwh
+
+ real,dimension(0:nxmax-1,0:nymax-1,nuvzmax) :: rhoh
+ real,dimension(0:nxmax-1,0:nymax-1,nzmax) :: pinmconv
+ ! RLT added pressure
+ real,dimension(0:nxmax-1,0:nymax-1,nuvzmax) :: prsh
+
+ logical :: init = .true.
+
+ !*************************************************************************
+ ! If verttransform is called the first time, initialize heights of the *
+ ! z levels in meter. The heights are the heights of model levels, where *
+ ! u,v,T and qv are given, and of the interfaces, where w is given. So, *
+ ! the vertical resolution in the z system is doubled. As reference point,*
+ ! the lower left corner of the grid is used. *
+ ! Unlike in the eta system, no difference between heights for u,v and *
+ ! heights for w exists. *
+ !*************************************************************************
+
+
+ !eso measure CPU time
+ ! call mpif_mtime('verttransform',0)
+
+ if (init) then
+
+ ! Search for a point with high surface pressure (i.e. not above significant topography)
+ ! Then, use this point to construct a reference z profile, to be used at all times
+ !*****************************************************************************
+ call initialise_verttransform(n)
+
+ ! Do not repeat initialization of the Cartesian z grid
+ !*****************************************************
+
+ init=.false.
+ endif
+
+
+ ! Compute heights of eta levels and their respective pressure and density fields
+ !*******************************************************************************
+ call verttransform_ecmwf_heights(nxmax-1,nymax-1,tt2(:,:,1,n),td2(:,:,1,n), &
+ ps(:,:,1,n),qvh(:,:,:,n),tth(:,:,:,n),prsh,rhoh,pinmconv, &
+ etauvheight(:,:,:,n),etawheight(:,:,:,n))
+
+ ! Transform the wind fields to the internal coordinate system and save the native ETA
+ ! fields when case wind_coord_type==ETA
+ !*************************************************************
+ call verttransform_ecmwf_transform_windfields(n,uuh,vvh,wwh,pvh,rhoh,prsh,pinmconv)
+
+ ! If north or south pole is in the domain, calculate wind velocities in polar
+ ! stereographic coordinates
+ !*******************************************************************
+ call verttransform_ecmwf_stereographic(n)
+
+ ! Create cloud fields
+ !*********************
+ call verttransform_ecmwf_clouds(n,readclouds,sumclouds,nxmin1,nymin1,clouds(:,:,:,n), &
+ cloudsh(:,:,n),clw(:,:,:,n),ctwc(:,:,n),clwc(:,:,:,n),ciwc(:,:,:,n),lsprec(:,:,1,n), &
+ convprec(:,:,1,n),rho(:,:,:,n),tt(:,:,:,n),qv(:,:,:,n),etauvheight(:,:,:,n))
+end subroutine verttransform_ecmwf
+
+subroutine verttransform_nests(n,uuhn,vvhn,wwhn,pvhn)
+ ! i i i i i
+ !*****************************************************************************
+ ! *
+ ! This subroutine transforms temperature, dew point temperature and *
+ ! wind components from eta to meter coordinates. *
+ ! The vertical wind component is transformed from Pa/s to m/s using *
+ ! the conversion factor pinmconv. *
+ ! In addition, this routine calculates vertical density gradients *
+ ! needed for the parameterization of the turbulent velocities. *
+ ! It is similar to verttransform, but makes the transformations for *
+ ! the nested grids. *
+ ! *
+ ! Author: A. Stohl, G. Wotawa *
+ ! *
+ ! 12 August 1996 *
+ ! Update: 16 January 1998 *
+ ! *
+ ! Major update: 17 February 1999 *
+ ! by G. Wotawa *
+ ! *
+ ! - Vertical levels for u, v and w are put together *
+ ! - Slope correction for vertical velocity: Modification of calculation *
+ ! procedure *
+ ! *
+ !*****************************************************************************
+ ! Changes, Bernd C. Krueger, Feb. 2001: (marked "C-cv")
+ ! Variables tthn and qvhn (on eta coordinates) from common block
+ !*****************************************************************************
+ ! Sabine Eckhardt, March 2007
+ ! add the variable cloud for use with scavenging - descr. in com_mod
+ !*****************************************************************************
+ ! ESO, 2016
+ ! -note that divide-by-zero occurs when nxmaxn,nymaxn etc. are larger than
+ ! the actual field dimensions
+ !*****************************************************************************
+ ! Date: 2017-05-30 modification of a bug in ew. Don Morton (CTBTO project) *
+ !*****************************************************************************
+ ! *
+ ! Variables: *
+ ! nxn,nyn,nuvz,nwz field dimensions in x,y and z direction *
+ ! uun wind components in x-direction [m/s] *
+ ! vvn wind components in y-direction [m/s] *
+ ! wwn wind components in z-direction [deltaeta/s]*
+ ! ttn temperature [K] *
+ ! pvn potential vorticity (pvu) *
+ ! psn surface pressure [Pa] *
+ ! *
+ !*****************************************************************************
+
+ implicit none
+
+ real,intent(in),dimension(0:nxmaxn-1,0:nymaxn-1,nuvzmax,maxnests) :: uuhn,vvhn,pvhn
+ real,intent(in),dimension(0:nxmaxn-1,0:nymaxn-1,nwzmax,maxnests) :: wwhn
+
+ real,dimension(0:nxmaxn-1,0:nymaxn-1,nuvzmax) :: rhohn,uvzlev,wzlev,prshn
+ real,dimension(0:nxmaxn-1,0:nymaxn-1,nzmax) :: pinmconv
+
+ integer,dimension(0:nxmaxn-1,0:nymaxn-1) :: rain_cloud_above, idx
+
+ integer :: ix,jy,kz,iz,n,l,kmin,kl,klp,ix1,jy1,ixp,jyp,kz_inv
+ integer :: nxm1, nym1
+
+ ! real,parameter :: precmin = 0.002 ! minimum prec in mm/h for cloud diagnostics
+
+ ! Loop over all nests
+ !********************
+
+ do l=1,numbnests
+ nxm1=nxn(l)-1
+ nym1=nyn(l)-1
+ call verttransform_ecmwf_heights(nxm1,nym1, &
+ tt2n(0:nxm1,0:nym1,1,n,l),td2n(0:nxm1,0:nym1,1,n,l),psn(0:nxm1,0:nym1,1,n,l), &
+ qvhn(0:nxm1,0:nym1,:,n,l),tthn(0:nxm1,0:nym1,:,n,l),prshn(0:nxm1,0:nym1,:), &
+ rhohn(0:nxm1,0:nym1,:),pinmconv(0:nxm1,0:nym1,:), &
+ etauvheightn(0:nxm1,0:nym1,:,n,l),etawheightn(0:nxm1,0:nym1,:,n,l))
+
+ call verttransform_ecmwf_nests_transform_windfields(l,n,uuhn,vvhn,wwhn,pvhn, &
+ rhohn,prshn,pinmconv)
+
+ ! Create cloud fields
+ !*********************
+
+ call verttransform_ecmwf_clouds(n,readclouds_nest(l),sumclouds_nest(l),nxm1,nym1, &
+ cloudsn(0:nxm1,0:nym1,:,n,l),cloudshn(0:nxm1,0:nym1,n,l),clwn(0:nxm1,0:nym1,:,n,l), &
+ ctwcn(0:nxm1,0:nym1,n,l),clwcn(0:nxm1,0:nym1,:,n,l),ciwcn(0:nxm1,0:nym1,:,n,l), &
+ lsprecn(0:nxm1,0:nym1,1,n,l),convprecn(0:nxm1,0:nym1,1,n,l),rhon(0:nxm1,0:nym1,:,n,l), &
+ ttn(0:nxm1,0:nym1,:,n,l),qvn(0:nxm1,0:nym1,:,n,l),etauvheightn(0:nxm1,0:nym1,:,n,l))
+
+ end do ! end loop over nests
+end subroutine verttransform_nests
+
+subroutine initialise_verttransform(n)
+ implicit none
+
+ integer, intent(in) :: n
+ real :: tvold,pold,pint,tv
+ integer :: ix,jy,kz,ixm,jym
+ real,parameter :: const=r_air/ga
+
+ if ((ipin.eq.1).or.(ipin.eq.4)) then
+ call read_heightlevels(height,nmixz)
+ return
+ endif
+
+ loop1: do jy=0,nymin1
+ do ix=0,nxmin1
+ if (ps(ix,jy,1,n).gt.100000.) then
+ ixm=ix
+ jym=jy
+ exit loop1
+ endif
+ end do
+ end do loop1
+
+ tvold=tt2(ixm,jym,1,n)*(1.+0.378*ew(td2(ixm,jym,1,n),ps(ixm,jym,1,n))/ &
+ ps(ixm,jym,1,n))
+ pold=ps(ixm,jym,1,n)
+ height(1)=0.
+
+ do kz=2,nuvz
+ pint=akz(kz)+bkz(kz)*ps(ixm,jym,1,n)
+ tv=tth(ixm,jym,kz,n)*(1.+0.608*qvh(ixm,jym,kz,n))
+
+ if (abs(tv-tvold).gt.0.2) then
+ height(kz)= height(kz-1)+const*log(pold/pint)* &
+ (tv-tvold)/log(tv/tvold)
+ else
+ height(kz)=height(kz-1)+const*log(pold/pint)*tv
+ endif
+
+ tvold=tv
+ pold=pint
+ end do
+
+ ! Determine highest levels that can be within PBL
+ !************************************************
+
+ do kz=1,nz
+ if (height(kz).gt.hmixmax) then
+ nmixz=kz
+ exit
+ endif
+ end do
+
+ if (loutrestart.ne.-1) then
+ call output_heightlevels(height,nmixz)
+ endif
+end subroutine initialise_verttransform
+
+subroutine output_heightlevels(height_tmp,nmixz_tmp)
+ implicit none
+
+ real,intent(in) :: height_tmp(nzmax)
+ integer,intent(in) :: nmixz_tmp
+ integer :: kz
+ character(len=256) :: heightlevels_filename
+
+ heightlevels_filename = path(2)(1:length(2))//'heightlevels.bin'
+
+ write(*,*) 'Writing Initialised heightlevels to file:', trim(heightlevels_filename)
+
+ open(unitheightlevels,file=trim(heightlevels_filename),form='unformatted')
+
+ write(unitheightlevels) nmixz_tmp
+
+ do kz=1,nz
+ write(unitheightlevels) height_tmp(kz)
+ end do
+ close(unitheightlevels)
+end subroutine output_heightlevels
+
+subroutine read_heightlevels(height_tmp,nmixz_tmp)
+ implicit none
+
+ real,intent(out) :: height_tmp(nzmax)
+ integer,intent(out) :: nmixz_tmp
+ integer :: kz,ios
+ character(len=256) :: heightlevels_filename
+
+ heightlevels_filename = path(2)(1:length(2))//'heightlevels.bin'
+
+ write(*,*) 'Reading heightlevels from file:', trim(heightlevels_filename)
+
+ open(unitheightlevels,file=trim(heightlevels_filename),form='unformatted',err=9988)
+
+ read(unitheightlevels,iostat=ios) nmixz_tmp
+
+ do kz=1,nz
+ read(unitheightlevels) height_tmp(kz)
+ end do
+ close(unitheightlevels)
+
+ return
+
+9988 write(*,*) ' #### FLEXPART MODEL ERROR! THE FILE #### '
+ write(*,*) ' #### '//path(2)(1:length(2))//'heightlevels.bin'//' #### '
+ write(*,*) ' #### CANNOT BE OPENED. IF A FILE WITH THIS #### '
+ write(*,*) ' #### NAME DOES NOT EXISTS, REMOVE call read_heightlevels #### '
+ write(*,*) ' #### FROM VERTTRANSFORM_MOD. #### '
+end subroutine read_heightlevels
+
+subroutine verttransform_ecmwf_transform_windfields(n,uuh,vvh,wwh,pvh,rhoh,prsh,pinmconv)
+ implicit none
+
+ integer,intent(in) :: n
+ real,intent(in),dimension(0:nxmax-1,0:nymax-1,nuvzmax) :: uuh,vvh,pvh
+ real,intent(in),dimension(0:nxmax-1,0:nymax-1,nwzmax) :: wwh
+ real,intent(in),dimension(0:nxmax-1,0:nymax-1,nuvzmax) :: rhoh
+ real,intent(in),dimension(0:nxmax-1,0:nymax-1,nzmax) :: pinmconv
+ ! RLT added pressure
+ real,intent(in),dimension(0:nxmax-1,0:nymax-1,nuvzmax) :: prsh
+
+ !real,dimension(0:nxmax-1,0:nymax-1) :: dpdeta
+
+ real,dimension(0:nymax-1) :: cosf
+
+ integer,dimension(0:nxmax-1,0:nymax-1) :: idx
+
+ integer :: ix,jy,kz,iz,kmin,ixp,jyp,ix1,jy1
+ real :: dz1,dz2,dz,dpdeta
+ real :: xlon,ylat,xlonr,dzdx,dzdy
+ real :: dzdx1,dzdx2,dzdy1,dzdy2
+
+ ! Levels, where u,v,t and q are given
+ !************************************
+!$OMP PARALLEL PRIVATE(jy,ix,kz,dz1,dz2,dz,ix1,jy1,ixp,jyp,dzdx1,dzdx2,dzdx,dzdy1,dzdy2,dzdy, &
+!$OMP dpdeta)
+
+!$OMP DO
+ do jy=0,nymin1
+ do ix=0,nxmin1
+
+ uu(ix,jy,1,n)=uuh(ix,jy,1)
+ uu(ix,jy,nz,n)=uuh(ix,jy,nuvz)
+ vv(ix,jy,1,n)=vvh(ix,jy,1)
+ vv(ix,jy,nz,n)=vvh(ix,jy,nuvz)
+ tt(ix,jy,1,n)=tth(ix,jy,1,n)
+ tt(ix,jy,nz,n)=tth(ix,jy,nuvz,n)
+ pv(ix,jy,1,n)=pvh(ix,jy,1)
+ pv(ix,jy,nz,n)=pvh(ix,jy,nuvz)
+ if (wind_coord_type.ne.'ETA') then
+ qv(ix,jy,1,n)=qvh(ix,jy,1,n)
+ qv(ix,jy,nz,n)=qvh(ix,jy,nuvz,n)
+ !hg adding the cloud water
+ if (readclouds) then
+ clwc(ix,jy,1,n)=clwch(ix,jy,1,n)
+ clwc(ix,jy,nz,n)=clwch(ix,jy,nuvz,n)
+ if (.not.sumclouds) then
+ ciwc(ix,jy,1,n)=ciwch(ix,jy,1,n)
+ ciwc(ix,jy,nz,n)=ciwch(ix,jy,nuvz,n)
+ endif
+ end if
+ !hg
+ endif
+ rho(ix,jy,1,n)=rhoh(ix,jy,1)
+ rho(ix,jy,nz,n)=rhoh(ix,jy,nuvz)
+ ! RLT add pressure
+ prs(ix,jy,1,n)=prsh(ix,jy,1)
+ prs(ix,jy,nz,n)=prsh(ix,jy,nuvz)
+ ! RLT
+
+ idx(ix,jy)=2
+ end do
+ end do
+!$OMP END DO
+
+ do iz=2,nz-1
+!$OMP DO SCHEDULE(dynamic)
+ do jy=0,nymin1
+ do ix=0,nxmin1
+ if(height(iz).gt.etauvheight(ix,jy,nuvz,n)) then
+ uu(ix,jy,iz,n)=uu(ix,jy,nz,n)
+ vv(ix,jy,iz,n)=vv(ix,jy,nz,n)
+ tt(ix,jy,iz,n)=tt(ix,jy,nz,n)
+ pv(ix,jy,iz,n)=pv(ix,jy,nz,n)
+ if (wind_coord_type.ne.'ETA') then
+ qv(ix,jy,iz,n)=qv(ix,jy,nz,n)
+ !hg adding the cloud water
+ if (readclouds) then
+ clwc(ix,jy,iz,n)=clwc(ix,jy,nz,n)
+ if (.not.sumclouds) ciwc(ix,jy,iz,n)=ciwc(ix,jy,nz,n)
+ end if
+ endif
+ rho(ix,jy,iz,n)=rho(ix,jy,nz,n)
+ prs(ix,jy,iz,n)=prs(ix,jy,nz,n) ! RLT
+ else
+ innuvz: do kz=idx(ix,jy),nuvz
+ if (idx(ix,jy) .le. kz .and. (height(iz).gt.etauvheight(ix,jy,kz-1,n)).and. &
+ (height(iz).le.etauvheight(ix,jy,kz,n))) then
+ idx(ix,jy)=kz
+ exit innuvz
+ endif
+ enddo innuvz
+ endif
+
+ if(height(iz).le.etauvheight(ix,jy,nuvz,n)) then
+ kz=idx(ix,jy)
+ dz1=height(iz)-etauvheight(ix,jy,kz-1,n)
+ dz2=etauvheight(ix,jy,kz,n)-height(iz)
+ dz=dz1+dz2
+ uu(ix,jy,iz,n)=(uuh(ix,jy,kz-1)*dz2+uuh(ix,jy,kz)*dz1)/dz
+ vv(ix,jy,iz,n)=(vvh(ix,jy,kz-1)*dz2+vvh(ix,jy,kz)*dz1)/dz
+ tt(ix,jy,iz,n)=(tth(ix,jy,kz-1,n)*dz2 &
+ +tth(ix,jy,kz,n)*dz1)/dz
+ pv(ix,jy,iz,n)=(pvh(ix,jy,kz-1)*dz2+pvh(ix,jy,kz)*dz1)/dz
+ if (wind_coord_type.ne.'ETA') then
+ qv(ix,jy,iz,n)=(qvh(ix,jy,kz-1,n)*dz2+qvh(ix,jy,kz,n)*dz1)/dz
+ !hg adding the cloud water
+ if (readclouds) then
+ clwc(ix,jy,iz,n)=(clwch(ix,jy,kz-1,n)*dz2+clwch(ix,jy,kz,n)*dz1)/dz
+ if (.not.sumclouds) &
+ &ciwc(ix,jy,iz,n)=(ciwch(ix,jy,kz-1,n)*dz2+ciwch(ix,jy,kz,n)*dz1)/dz
+ end if
+ !hg
+ endif
+ rho(ix,jy,iz,n)=(rhoh(ix,jy,kz-1)*dz2+rhoh(ix,jy,kz)*dz1)/dz
+ ! RLT add pressure
+ prs(ix,jy,iz,n)=(prsh(ix,jy,kz-1)*dz2+prsh(ix,jy,kz)*dz1)/dz
+ endif
+ enddo
+ enddo
+!$OMP END DO
+!$OMP BARRIER
+ enddo
+ ! Levels, where w is given
+ !*************************
+
+!$OMP DO
+ do jy=0,nymin1
+ do ix=0,nxmin1
+ idx(ix,jy)=2
+ ww(ix,jy,1,n)=wwh(ix,jy,1)*pinmconv(ix,jy,1)
+ ww(ix,jy,nz,n)=wwh(ix,jy,nwz)*pinmconv(ix,jy,nz)
+ end do
+ end do
+!$OMP END DO
+
+ do iz=2,nz-1
+!$OMP DO SCHEDULE(dynamic)
+ do jy=0,nymin1
+ do ix=0,nxmin1
+
+ inn: do kz=idx(ix,jy),nwz
+ if(idx(ix,jy) .le. kz .and. height(iz).gt.etawheight(ix,jy,kz-1,n).and. &
+ height(iz).le.etawheight(ix,jy,kz,n)) then
+ idx(ix,jy)=kz
+ exit inn
+ endif
+ enddo inn
+
+ kz=idx(ix,jy)
+ dz1=height(iz)-etawheight(ix,jy,kz-1,n)
+ dz2=etawheight(ix,jy,kz,n)-height(iz)
+ dz=dz1+dz2
+ ww(ix,jy,iz,n)=(wwh(ix,jy,kz-1)*pinmconv(ix,jy,kz-1)*dz2 &
+ +wwh(ix,jy,kz)*pinmconv(ix,jy,kz)*dz1)/dz
+ ! Compute density gradients at intermediate levels
+ !*************************************************
+ drhodz(ix,jy,iz,n)=(rho(ix,jy,iz+1,n)-rho(ix,jy,iz-1,n))/ &
+ (height(iz+1)-height(iz-1))
+ end do
+ end do
+!$OMP END DO
+!$OMP BARRIER
+ end do
+
+!$OMP DO
+ do jy=0,nymin1
+ do ix=0,nxmin1
+ drhodz(ix,jy,nz,n)=drhodz(ix,jy,nz-1,n)
+ drhodz(ix,jy,1,n)=(rho(ix,jy,2,n)-rho(ix,jy,1,n))/(height(2)-height(1))
+ end do
+ end do
+!$OMP END DO NOWAIT
+
+ !****************************************************************
+ ! Compute slope of eta levels in windward direction and resulting
+ ! vertical wind correction
+ !****************************************************************
+
+!$OMP DO
+ do jy=1,ny-2
+ cosf(jy)=1./cos((real(jy)*dy+ylat0)*pi180)
+ do ix=1,nx-2
+ idx(ix,jy)=2
+ end do
+ end do
+!$OMP END DO
+
+ do iz=2,nz-1
+!$OMP DO SCHEDULE(dynamic)
+ do jy=1,ny-2
+ do ix=1,nx-2
+ ! For gridpoint (ix,jy) and height (iz), this loop finds the first eta levels that is
+ ! encompassing the height(iz) level and saves it in idx(ix,jy)
+ inneta: do kz=idx(ix,jy),nz
+ if (idx(ix,jy) .le. kz .and. (height(iz).gt.etauvheight(ix,jy,kz-1,n)).and. &
+ (height(iz).le.etauvheight(ix,jy,kz,n))) then
+ idx(ix,jy)=kz
+ exit inneta
+ endif
+ enddo inneta
+
+ kz=idx(ix,jy)
+ dz1=height(iz)-etauvheight(ix,jy,kz-1,n)
+ dz2=etauvheight(ix,jy,kz,n)-height(iz)
+ dz=dz1+dz2
+ ix1=ix-1
+ jy1=jy-1
+ ixp=ix+1
+ jyp=jy+1
+
+ dzdx1=(etauvheight(ixp,jy,kz-1,n)-etauvheight(ix1,jy,kz-1,n))/2.
+ dzdx2=(etauvheight(ixp,jy,kz,n)-etauvheight(ix1,jy,kz,n))/2.
+ dzdx=(dzdx1*dz2+dzdx2*dz1)/dz
+
+ dzdy1=(etauvheight(ix,jyp,kz-1,n)-etauvheight(ix,jy1,kz-1,n))/2.
+ dzdy2=(etauvheight(ix,jyp,kz,n)-etauvheight(ix,jy1,kz,n))/2.
+ dzdy=(dzdy1*dz2+dzdy2*dz1)/dz
+
+ ww(ix,jy,iz,n)=ww(ix,jy,iz,n)+(dzdx*uu(ix,jy,iz,n)*dxconst*cosf(jy)+dzdy*vv(ix,jy,iz,n)*dyconst)
+ end do
+ end do
+!$OMP END DO
+!$OMP BARRIER
+ end do
+
+ ! Keep original fields if wind_coord_type==ETA
+ if (wind_coord_type.eq.'ETA') then
+!$OMP DO
+
+ do kz=1,nz
+ do jy=0,nymin1
+ do ix=0,nxmin1
+ uueta(ix,jy,kz,n) = uuh(ix,jy,kz)
+ vveta(ix,jy,kz,n) = vvh(ix,jy,kz)
+ tteta(ix,jy,kz,n) = tth(ix,jy,kz,n)
+ qv(ix,jy,kz,n) = qvh(ix,jy,kz,n)
+ pveta(ix,jy,kz,n) = pvh(ix,jy,kz)
+ rhoeta(ix,jy,kz,n) = rhoh(ix,jy,kz)
+ prseta(ix,jy,kz,n) = prsh(ix,jy,kz)
+ ! tvirtual(ix,jy,kz,n)=tteta(ix,jy,kz,n)* & ! eq A11 from Mid-latitude atmospheric dynamics by Jonathan E. Martin
+ ! ((qv(ix,jy,kz,n)+0.622)/(0.622*qv(ix,jy,kz,n)+0.622))
+ if ((kz.gt.1).and.(kz.lt.nz)) drhodzeta(ix,jy,kz,n)= &
+ (rhoh(ix,jy,kz+1)-rhoh(ix,jy,kz-1))/ &
+ (height(kz+1)-height(kz-1)) ! Note that this is still in SI units and not in eta
+ if (readclouds) then
+ clwc(ix,jy,kz,n)=clwch(ix,jy,kz,n)
+ if (.not. sumclouds) ciwc(ix,jy,kz,n)=ciwch(ix,jy,kz,n)
+ endif
+ end do
+ end do
+ end do
+!$OMP END DO NOWAIT
+
+!$OMP DO
+ do jy=0,nymin1
+ do ix=0,nxmin1
+ drhodzeta(ix,jy,1,n)=(rhoh(ix,jy,2)-rhoh(ix,jy,1))/(height(2)-height(1))
+ drhodzeta(ix,jy,nz,n)=drhodzeta(ix,jy,nz-1,n)
+ ! tvirtual(ix,jy,1,n)=tt2(ix,jy,1,n)* &
+ ! (1.+0.378*ew(td2(ix,jy,1,n),ps(ix,jy,1,n))/ps(ix,jy,1,n))
+ ! Convert w from Pa/s to eta/s, following FLEXTRA
+ !************************************************
+ do kz=1,nuvz-1
+ if (kz.eq.1) then
+ dpdeta=(akm(kz+1)-akm(kz)+(bkm(kz+1)-bkm(kz))*ps(ix,jy,1,n))/ &
+ (wheight(kz+1)-wheight(kz))
+ else if (kz.eq.nuvz-1) then
+ dpdeta=(akm(kz)-akm(kz-1)+(bkm(kz)-bkm(kz-1))*ps(ix,jy,1,n))/ &
+ (wheight(kz)-wheight(kz-1))
+ else
+ dpdeta=(akm(kz+1)-akm(kz-1)+(bkm(kz+1)-bkm(kz-1))*ps(ix,jy,1,n))/ &
+ (wheight(kz+1)-wheight(kz-1))
+ endif
+ wweta(ix,jy,kz,n)=wwh(ix,jy,kz)/dpdeta
+ end do
+ wweta(ix,jy,nuvz,n)=wweta(ix,jy,nuvz-1,n) !What is the appropriate value for the top level???
+ end do
+ end do
+!$OMP END DO
+ endif
+!$OMP END PARALLEL
+
+end subroutine verttransform_ecmwf_transform_windfields
+
+subroutine verttransform_ecmwf_stereographic(n)
+ implicit none
+
+ integer, intent(in) :: n
+
+ integer :: ix,jy,iz
+ real :: xlon,ylat,xlonr
+ real :: uuaux,vvaux,uupolaux,vvpolaux,ddpol,ffpol,wdummy
+
+ if (nglobal) then
+ do iz=1,nz
+ do jy=int(switchnorthg)-2,nymin1
+ ylat=ylat0+real(jy)*dy
+ do ix=0,nxmin1
+ xlon=xlon0+real(ix)*dx
+ call cc2gll(northpolemap,ylat,xlon,uu(ix,jy,iz,n), &
+ vv(ix,jy,iz,n),uupol(ix,jy,iz,n), &
+ vvpol(ix,jy,iz,n))
+ if (wind_coord_type.eq.'ETA') then
+ call cc2gll(northpolemap,ylat,xlon,uueta(ix,jy,iz,n), &
+ vveta(ix,jy,iz,n),uupoleta(ix,jy,iz,n), &
+ vvpoleta(ix,jy,iz,n))
+ endif
+ end do
+ end do
+ end do
+
+
+ do iz=1,nz
+
+ ! CALCULATE FFPOL, DDPOL FOR CENTRAL GRID POINT
+ !
+ ! AMSnauffer Nov 18 2004 Added check for case vv=0
+ !
+ xlon=xlon0+real(nx/2-1)*dx
+ xlonr=xlon*pi/180.
+ ffpol=sqrt(uu(nx/2-1,nymin1,iz,n)**2+ &
+ vv(nx/2-1,nymin1,iz,n)**2)
+ if (vv(nx/2-1,nymin1,iz,n).lt.0.) then
+ ddpol=atan(uu(nx/2-1,nymin1,iz,n)/ &
+ vv(nx/2-1,nymin1,iz,n))-xlonr
+ else if (vv(nx/2-1,nymin1,iz,n).gt.0.) then
+ ddpol=pi+atan(uu(nx/2-1,nymin1,iz,n)/ &
+ vv(nx/2-1,nymin1,iz,n))-xlonr
+ else
+ ddpol=pi/2-xlonr
+ endif
+ if(ddpol.lt.0.) ddpol=2.0*pi+ddpol
+ if(ddpol.gt.2.0*pi) ddpol=ddpol-2.0*pi
+
+ ! CALCULATE U,V FOR 180 DEG, TRANSFORM TO POLAR STEREOGRAPHIC GRID
+ xlon=180.0
+ xlonr=xlon*pi/180.
+ ylat=90.0
+ uuaux=-ffpol*sin(xlonr+ddpol)
+ vvaux=-ffpol*cos(xlonr+ddpol)
+ call cc2gll(northpolemap,ylat,xlon,uuaux,vvaux,uupolaux, &
+ vvpolaux)
+
+ jy=nymin1
+ do ix=0,nxmin1
+ uupol(ix,jy,iz,n)=uupolaux
+ vvpol(ix,jy,iz,n)=vvpolaux
+ end do
+ end do
+
+ if (wind_coord_type.eq.'ETA') then
+ do iz=1,nz
+
+ xlon=xlon0+real(nx/2-1)*dx
+ xlonr=xlon*pi/180.
+ ffpol=sqrt(uueta(nx/2-1,nymin1,iz,n)**2+ &
+ vveta(nx/2-1,nymin1,iz,n)**2)
+ if (vveta(nx/2-1,nymin1,iz,n).lt.0.) then
+ ddpol=atan(uueta(nx/2-1,nymin1,iz,n)/ &
+ vveta(nx/2-1,nymin1,iz,n))-xlonr
+ else if (vveta(nx/2-1,nymin1,iz,n).gt.0.) then
+ ddpol=pi+atan(uueta(nx/2-1,nymin1,iz,n)/ &
+ vveta(nx/2-1,nymin1,iz,n))-xlonr
+ else
+ ddpol=pi/2-xlonr
+ endif
+ if(ddpol.lt.0.) ddpol=2.0*pi+ddpol
+ if(ddpol.gt.2.0*pi) ddpol=ddpol-2.0*pi
+
+ ! CALCULATE U,V FOR 180 DEG, TRANSFORM TO POLAR STEREOGRAPHIC GRID
+ xlon=180.0
+ xlonr=xlon*pi/180.
+ ylat=90.0
+ uuaux=-ffpol*sin(xlonr+ddpol)
+ vvaux=-ffpol*cos(xlonr+ddpol)
+ call cc2gll(northpolemap,ylat,xlon,uuaux,vvaux,uupolaux, &
+ vvpolaux)
+
+ jy=nymin1
+ do ix=0,nxmin1
+ uupoleta(ix,jy,iz,n)=uupolaux
+ vvpoleta(ix,jy,iz,n)=vvpolaux
+ end do
+ end do
+ endif
+
+
+ ! Fix: Set W at pole to the zonally averaged W of the next equator-
+ ! ward parallel of latitude
+
+ do iz=1,nz
+ wdummy=0.
+ jy=ny-2
+ do ix=0,nxmin1
+ wdummy=wdummy+ww(ix,jy,iz,n)
+ end do
+ wdummy=wdummy/real(nx)
+ jy=nymin1
+ do ix=0,nxmin1
+ ww(ix,jy,iz,n)=wdummy
+ end do
+ end do
+
+ if (wind_coord_type.eq.'ETA') then
+ do iz=1,nz
+ wdummy=0.
+ jy=ny-2
+ do ix=0,nxmin1
+ wdummy=wdummy+wweta(ix,jy,iz,n)
+ end do
+ wdummy=wdummy/real(nx)
+ jy=nymin1
+ do ix=0,nxmin1
+ wweta(ix,jy,iz,n)=wdummy
+ end do
+ end do
+ endif
+
+ endif
+
+
+ ! If south pole is in the domain, calculate wind velocities in polar
+ ! stereographic coordinates
+ !*******************************************************************
+
+ if (sglobal) then
+ do iz=1,nz
+ do jy=0,int(switchsouthg)+3
+ ylat=ylat0+real(jy)*dy
+ do ix=0,nxmin1
+ xlon=xlon0+real(ix)*dx
+ call cc2gll(southpolemap,ylat,xlon,uu(ix,jy,iz,n), &
+ vv(ix,jy,iz,n),uupol(ix,jy,iz,n), &
+ vvpol(ix,jy,iz,n))
+ if (wind_coord_type.eq.'ETA') then
+ call cc2gll(southpolemap,ylat,xlon,uueta(ix,jy,iz,n), &
+ vveta(ix,jy,iz,n),uupoleta(ix,jy,iz,n), &
+ vvpoleta(ix,jy,iz,n))
+ endif
+ end do
+ end do
+ end do
+
+ do iz=1,nz
+
+ ! CALCULATE FFPOL, DDPOL FOR CENTRAL GRID POINT
+ !
+ ! AMSnauffer Nov 18 2004 Added check for case vv=0
+ !
+ xlon=xlon0+real(nx/2-1)*dx
+ xlonr=xlon*pi/180.
+ ffpol=sqrt(uu(nx/2-1,0,iz,n)**2+ &
+ vv(nx/2-1,0,iz,n)**2)
+ if (vv(nx/2-1,0,iz,n).lt.0.) then
+ ddpol=atan(uu(nx/2-1,0,iz,n)/ &
+ vv(nx/2-1,0,iz,n))+xlonr
+ else if (vv(nx/2-1,0,iz,n).gt.0.) then
+ ddpol=pi+atan(uu(nx/2-1,0,iz,n)/ &
+ vv(nx/2-1,0,iz,n))+xlonr
+ else
+ ddpol=pi/2-xlonr
+ endif
+ if(ddpol.lt.0.) ddpol=2.0*pi+ddpol
+ if(ddpol.gt.2.0*pi) ddpol=ddpol-2.0*pi
+
+ ! CALCULATE U,V FOR 180 DEG, TRANSFORM TO POLAR STEREOGRAPHIC GRID
+ xlon=180.0
+ xlonr=xlon*pi/180.
+ ylat=-90.0
+ uuaux=+ffpol*sin(xlonr-ddpol)
+ vvaux=-ffpol*cos(xlonr-ddpol)
+ call cc2gll(northpolemap,ylat,xlon,uuaux,vvaux,uupolaux, &
+ vvpolaux)
+
+ jy=0
+ do ix=0,nxmin1
+ uupol(ix,jy,iz,n)=uupolaux
+ vvpol(ix,jy,iz,n)=vvpolaux
+ end do
+ end do
+
+ if (wind_coord_type.eq.'ETA') then
+ do iz=1,nz
+ ! CALCULATE FFPOL, DDPOL FOR CENTRAL GRID POINT
+ !
+ ! AMSnauffer Nov 18 2004 Added check for case vv=0
+ !
+ xlon=xlon0+real(nx/2-1)*dx
+ xlonr=xlon*pi/180.
+ ffpol=sqrt(uueta(nx/2-1,0,iz,n)**2+ &
+ vveta(nx/2-1,0,iz,n)**2)
+ if (vveta(nx/2-1,0,iz,n).lt.0.) then
+ ddpol=atan(uueta(nx/2-1,0,iz,n)/ &
+ vveta(nx/2-1,0,iz,n))+xlonr
+ else if (vveta(nx/2-1,0,iz,n).gt.0.) then
+ ddpol=pi+atan(uueta(nx/2-1,0,iz,n)/ &
+ vveta(nx/2-1,0,iz,n))+xlonr
+ else
+ ddpol=pi/2-xlonr
+ endif
+ if(ddpol.lt.0.) ddpol=2.0*pi+ddpol
+ if(ddpol.gt.2.0*pi) ddpol=ddpol-2.0*pi
+
+ ! CALCULATE U,V FOR 180 DEG, TRANSFORM TO POLAR STEREOGRAPHIC GRID
+ xlon=180.0
+ xlonr=xlon*pi/180.
+ ylat=-90.0
+ uuaux=+ffpol*sin(xlonr-ddpol)
+ vvaux=-ffpol*cos(xlonr-ddpol)
+ call cc2gll(northpolemap,ylat,xlon,uuaux,vvaux,uupolaux, &
+ vvpolaux)
+
+ jy=0
+ do ix=0,nxmin1
+ uupoleta(ix,jy,iz,n)=uupolaux
+ vvpoleta(ix,jy,iz,n)=vvpolaux
+ end do
+ end do
+ endif
+
+ ! Fix: Set W at pole to the zonally averaged W of the next equator-
+ ! ward parallel of latitude
+
+ do iz=1,nz
+ wdummy=0.
+ jy=1
+ do ix=0,nxmin1
+ wdummy=wdummy+ww(ix,jy,iz,n)
+ end do
+ wdummy=wdummy/real(nx)
+ jy=0
+ do ix=0,nxmin1
+ ww(ix,jy,iz,n)=wdummy
+ end do
+ end do
+
+ if (wind_coord_type.eq.'ETA') then
+ do iz=1,nz
+ wdummy=0.
+ jy=1
+ do ix=0,nxmin1
+ wdummy=wdummy+wweta(ix,jy,iz,n)
+ end do
+ wdummy=wdummy/real(nx)
+ jy=0
+ do ix=0,nxmin1
+ wweta(ix,jy,iz,n)=wdummy
+ end do
+ end do
+ endif
+ endif
+end subroutine verttransform_ecmwf_stereographic
+
+subroutine verttransform_ecmwf_clouds(n,lreadclouds,lsumclouds,nxlim,nylim,clouds_tmp,cloudsh_tmp,&
+ clw_tmp,ctwc_tmp,clwc_tmp,ciwc_tmp,lsprec_tmp,convprec_tmp,rho_tmp,tt_tmp,qv_tmp,uvzlev)
+ implicit none
+
+ logical,intent(in) :: lreadclouds,lsumclouds
+ integer, intent(in) :: nxlim,nylim
+ integer, intent(in) :: n
+ integer(kind=1),intent(inout) :: clouds_tmp(0:nxlim,0:nylim,nzmax)
+ integer,intent(inout) :: cloudsh_tmp(0:nxlim,0:nylim)
+ real,intent(inout) :: clw_tmp(0:nxlim,0:nylim,nzmax)
+ real,intent(inout) :: ctwc_tmp(0:nxlim,0:nylim)
+ real,intent(inout) :: clwc_tmp(0:nxlim,0:nylim,nzmax)
+ real,intent(in) :: ciwc_tmp(0:nxlim,0:nylim,nzmax)
+ real,intent(in) :: lsprec_tmp(0:nxlim,0:nylim),convprec_tmp(0:nxlim,0:nylim)
+ real,intent(in),dimension(0:nxlim,0:nylim,nzmax) :: rho_tmp,tt_tmp,qv_tmp
+ real,intent(out),dimension(0:nxlim,0:nylim,nzmax) :: uvzlev
+
+ integer,dimension(0:nxmax-1,0:nymax-1) :: rain_cloud_above
+
+ integer :: ix,jy,kz,kz_inv
+ real :: pressure,rh,lsp,convp,cloudh_min,prec
+
+ !***********************************************************************************
+ if (lreadclouds) then !HG METHOD
+ ! The method is loops all grids vertically and constructs the 3D matrix for clouds
+ ! Cloud top and cloud bottom gid cells are assigned as well as the total column
+ ! cloud water. For precipitating grids, the type and whether it is in or below
+ ! cloud scavenging are assigned with numbers 2-5 (following the old metod).
+ ! Distinction is done for lsp and convp though they are treated the same in regards
+ ! to scavenging. Also clouds that are not precipitating are defined which may be
+ ! to include future cloud processing by non-precipitating-clouds.
+ !***********************************************************************************
+ !write(*,*) 'Global ECMWF fields: using cloud water'
+ clw_tmp(0:nxlim,0:nylim,:)=0.0
+ ! icloud_stats(:,:,:,n)=0.0
+ ctwc_tmp(:,:)=0.0
+ clouds_tmp(0:nxlim,0:nylim,:)=0
+ ! If water/ice are read separately into clwc and ciwc, store sum in clwc
+ if (.not.lsumclouds) then
+ clwc_tmp(0:nxlim,0:nylim,:) = clwc_tmp(0:nxlim,0:nylim,:) + ciwc_tmp(:,:,:)
+ end if
+ do jy=0,nylim
+ do ix=0,nxlim
+ lsp=lsprec_tmp(ix,jy)
+ convp=convprec_tmp(ix,jy)
+ prec=lsp+convp
+ ! tot_cloud_h=0
+ ! Find clouds in the vertical
+ do kz=1, nz-1 !go from top to bottom
+ if (clwc_tmp(ix,jy,kz).gt.0) then
+ ! assuming rho is in kg/m3 and hz in m gives: kg/kg * kg/m3 *m3/kg /m = m2/m3
+ if (wind_coord_type.eq.'ETA') then
+ clw_tmp(ix,jy,kz)=(clwc_tmp(ix,jy,kz)*rho_tmp(ix,jy,kz))* &
+ (uvzlev(ix,jy,kz+1)-uvzlev(ix,jy,kz))
+ cloudh_min=min(uvzlev(ix,jy,kz+1),uvzlev(ix,jy,kz))
+ else
+ clw_tmp(ix,jy,kz)=(clwc_tmp(ix,jy,kz)*rho_tmp(ix,jy,kz))*(height(kz+1)-height(kz))
+ ! icloud_stats(ix,jy,3,n)= min(height(kz+1),height(kz)) ! Cloud BOT height stats [m]
+ cloudh_min=min(height(kz+1),height(kz))
+ endif
+ ! tot_cloud_h=tot_cloud_h+(height(kz+1)-height(kz))
+
+ ! icloud_stats(ix,jy,4,n)= icloud_stats(ix,jy,4,n)+clw(ix,jy,kz,n) ! Column cloud water [m3/m3]
+ ctwc_tmp(ix,jy) = ctwc_tmp(ix,jy)+clw_tmp(ix,jy,kz)
+
+ endif
+ end do
+
+ ! If Precipitation. Define removal type in the vertical
+ if ((lsp.gt.0.01).or.(convp.gt.0.01)) then ! cloud and precipitation
+
+ do kz=nz,2,-1 !go Bottom up!
+ if (clw_tmp(ix,jy,kz).gt. 0) then ! is in cloud
+ if (wind_coord_type.eq.'ETA') then
+ cloudsh_tmp(ix,jy)=cloudsh_tmp(ix,jy)+uvzlev(ix,jy,kz)-uvzlev(ix,jy,kz-1)
+ else
+ cloudsh_tmp(ix,jy)=cloudsh_tmp(ix,jy)+height(kz)-height(kz-1)
+ endif
+ clouds_tmp(ix,jy,kz)=1 ! is a cloud
+ if (lsp.ge.convp) then
+ clouds_tmp(ix,jy,kz)=3 ! lsp in-cloud
+ else
+ clouds_tmp(ix,jy,kz)=2 ! convp in-cloud
+ endif ! convective or large scale
+ elseif((clw_tmp(ix,jy,kz).le.0) .and. (cloudh_min.ge.height(kz))) then ! is below cloud
+ if (lsp.ge.convp) then
+ clouds_tmp(ix,jy,kz)=5 ! lsp dominated washout
+ else
+ clouds_tmp(ix,jy,kz)=4 ! convp dominated washout
+ endif ! convective or large scale
+ endif
+
+ if (height(kz).ge. 19000) then ! set a max height for removal
+ clouds_tmp(ix,jy,kz)=0
+ endif !clw>0
+ end do !nz
+ endif ! precipitation
+ end do
+ end do
+
+ ! eso: copy the relevant data to clw4 to reduce amount of communicated data for MPI
+ ! ctwc(:,:,n) = icloud_stats(:,:,4,n)
+
+ !**************************************************************************
+ else ! use old definitions
+ !**************************************************************************
+ ! create a cloud and rainout/washout field, clouds occur where rh>80%
+ ! total cloudheight is stored at level 0
+ !write(*,*) 'Global fields: using cloud water from Parameterization'
+ do jy=0,nylim
+ do ix=0,nxlim
+ ! OLD METHOD
+ rain_cloud_above(ix,jy)=0
+ lsp=lsprec_tmp(ix,jy)
+ convp=convprec_tmp(ix,jy)
+ cloudsh_tmp(ix,jy)=0
+ do kz_inv=1,nz-1
+ kz=nz-kz_inv+1
+ pressure=rho_tmp(ix,jy,kz)*r_air*tt_tmp(ix,jy,kz)
+ rh=qv_tmp(ix,jy,kz)/f_qvsat(pressure,tt_tmp(ix,jy,kz))
+ clouds_tmp(ix,jy,kz)=0
+ if (rh.gt.0.8) then ! in cloud
+ if ((lsp.gt.0.01).or.(convp.gt.0.01)) then ! cloud and precipitation
+ rain_cloud_above(ix,jy)=1
+ if (wind_coord_type.eq.'ETA') then
+ cloudsh_tmp(ix,jy)=cloudsh_tmp(ix,jy)+ &
+ uvzlev(ix,jy,kz)-uvzlev(ix,jy,kz-1)
+ else
+ cloudsh_tmp(ix,jy)=cloudsh_tmp(ix,jy)+ &
+ height(kz)-height(kz-1)
+ endif
+ if (lsp.ge.convp) then
+ clouds_tmp(ix,jy,kz)=3 ! lsp dominated rainout
+ else
+ clouds_tmp(ix,jy,kz)=2 ! convp dominated rainout
+ endif
+ else ! no precipitation
+ clouds_tmp(ix,jy,kz)=1 ! cloud
+ endif
+ else ! no cloud
+ if (rain_cloud_above(ix,jy).eq.1) then ! scavenging
+ if (lsp.ge.convp) then
+ clouds_tmp(ix,jy,kz)=5 ! lsp dominated washout
+ else
+ clouds_tmp(ix,jy,kz)=4 ! convp dominated washout
+ endif
+ endif
+ endif
+ end do
+ !END OLD METHOD
+ end do
+ end do
+ endif !readclouds
+end subroutine verttransform_ecmwf_clouds
+
+subroutine verttransform_gfs(n,uuh,vvh,wwh,pvh)
+ ! i i i i i
+ !*****************************************************************************
+ ! *
+ ! This subroutine transforms temperature, dew point temperature and *
+ ! wind components from eta to meter coordinates. *
+ ! The vertical wind component is transformed from Pa/s to m/s using *
+ ! the conversion factor pinmconv. *
+ ! In addition, this routine calculates vertical density gradients *
+ ! needed for the parameterization of the turbulent velocities. *
+ ! *
+ ! Author: A. Stohl, G. Wotawa *
+ ! *
+ ! 12 August 1996 *
+ ! Update: 16 January 1998 *
+ ! *
+ ! Major update: 17 February 1999 *
+ ! by G. Wotawa *
+ ! CHANGE 17/11/2005 Caroline Forster, NCEP GFS version *
+ ! *
+ ! - Vertical levels for u, v and w are put together *
+ ! - Slope correction for vertical velocity: Modification of calculation *
+ ! procedure *
+ ! *
+ !*****************************************************************************
+ ! Changes, Bernd C. Krueger, Feb. 2001:
+ ! Variables tth and qvh (on eta coordinates) from common block
+ !
+ ! Unified ECMWF and GFS builds
+ ! Marian Harustak, 12.5.2017
+ ! - Renamed routine from verttransform to verttransform_gfs
+ !
+ !*****************************************************************************
+ ! *
+ ! Variables: *
+ ! nx,ny,nz field dimensions in x,y and z direction *
+ ! uu(0:nxmax,0:nymax,nzmax,2) wind components in x-direction [m/s] *
+ ! vv(0:nxmax,0:nymax,nzmax,2) wind components in y-direction [m/s] *
+ ! ww(0:nxmax,0:nymax,nzmax,2) wind components in z-direction [deltaeta/s]*
+ ! tt(0:nxmax,0:nymax,nzmax,2) temperature [K] *
+ ! pv(0:nxmax,0:nymax,nzmax,2) potential voriticity (pvu) *
+ ! ps(0:nxmax,0:nymax,2) surface pressure [Pa] *
+ ! clouds(0:nxmax,0:nymax,0:nzmax,2) cloud field for wet deposition *
+ ! *
+ !*****************************************************************************
+
+ !use cmapf_mod
+
+ implicit none
+
+ integer :: ix,jy,kz,iz,n,kmin,kl,klp,ix1,jy1,ixp,jyp,ixm,jym
+ integer :: rain_cloud_above,kz_inv
+ real :: pressure
+ real :: rh,lsp,cloudh_min,convp,prec
+ real :: rhoh(nuvzmax),pinmconv(nzmax)
+ real :: pint,tv,tvold,pold,dz1,dz2,dz,ui,vi
+ real :: xlon,ylat,xlonr,dzdx,dzdy
+ real :: dzdx1,dzdx2,dzdy1,dzdy2,cosf
+ real :: uuaux,vvaux,uupolaux,vvpolaux,ddpol,ffpol,wdummy
+ real :: uuh(0:nxmax-1,0:nymax-1,nuvzmax)
+ real :: vvh(0:nxmax-1,0:nymax-1,nuvzmax)
+ real :: pvh(0:nxmax-1,0:nymax-1,nuvzmax)
+ real :: wwh(0:nxmax-1,0:nymax-1,nwzmax)
+ real :: wzlev(nwzmax),uvwzlev(0:nxmax-1,0:nymax-1,nzmax)
+ real,parameter :: const=r_air/ga
+
+ ! NCEP version
+ integer :: llev, i
+
+ logical :: init = .true.
+
+
+ !*************************************************************************
+ ! If verttransform is called the first time, initialize heights of the *
+ ! z levels in meter. The heights are the heights of model levels, where *
+ ! u,v,T and qv are given. *
+ !*************************************************************************
+
+ if (init) then
+
+ ! Search for a point with high surface pressure (i.e. not above significant topography)
+ ! Then, use this point to construct a reference z profile, to be used at all times
+ !*****************************************************************************
+ call initialise_verttransform(n)
+
+ ! Do not repeat initialization of the Cartesian z grid
+ !*****************************************************
+
+ init=.false.
+
+ endif
+
+
+ ! Loop over the whole grid
+ !*************************
+
+ do jy=0,nymin1
+ do ix=0,nxmin1
+
+ ! NCEP version: find first level above ground
+ llev = 0
+ do i=1,nuvz
+ if (ps(ix,jy,1,n).lt.akz(i)) llev=i
+ end do
+ llev = llev+1
+ if (llev.gt.nuvz-2) llev = nuvz-2
+ ! if (llev.eq.nuvz-2) write(*,*) 'verttransform
+ ! +WARNING: LLEV eq NUZV-2'
+ ! NCEP version
+
+
+ ! compute height of pressure levels above ground
+ !***********************************************
+
+ tvold=tth(ix,jy,llev,n)*(1.+0.608*qvh(ix,jy,llev,n))
+ pold=akz(llev)
+ wzlev(llev)=0.
+ uvwzlev(ix,jy,llev)=0.
+ rhoh(llev)=pold/(r_air*tvold)
+
+ do kz=llev+1,nuvz
+ pint=akz(kz)+bkz(kz)*ps(ix,jy,1,n)
+ tv=tth(ix,jy,kz,n)*(1.+0.608*qvh(ix,jy,kz,n))
+ rhoh(kz)=pint/(r_air*tv)
+
+ if (abs(tv-tvold).gt.0.2) then
+ uvwzlev(ix,jy,kz)=uvwzlev(ix,jy,kz-1)+const*log(pold/pint)* &
+ (tv-tvold)/log(tv/tvold)
+ else
+ uvwzlev(ix,jy,kz)=uvwzlev(ix,jy,kz-1)+const*log(pold/pint)*tv
+ endif
+ wzlev(kz)=uvwzlev(ix,jy,kz)
+
+ tvold=tv
+ pold=pint
+ end do
+
+ ! pinmconv=(h2-h1)/(p2-p1)
+
+ pinmconv(llev)=(uvwzlev(ix,jy,llev+1)-uvwzlev(ix,jy,llev))/ &
+ ((aknew(llev+1)+bknew(llev+1)*ps(ix,jy,1,n))- &
+ (aknew(llev)+bknew(llev)*ps(ix,jy,1,n)))
+ do kz=llev+1,nz-1
+ pinmconv(kz)=(uvwzlev(ix,jy,kz+1)-uvwzlev(ix,jy,kz-1))/ &
+ ((aknew(kz+1)+bknew(kz+1)*ps(ix,jy,1,n))- &
+ (aknew(kz-1)+bknew(kz-1)*ps(ix,jy,1,n)))
+ end do
+ pinmconv(nz)=(uvwzlev(ix,jy,nz)-uvwzlev(ix,jy,nz-1))/ &
+ ((aknew(nz)+bknew(nz)*ps(ix,jy,1,n))- &
+ (aknew(nz-1)+bknew(nz-1)*ps(ix,jy,1,n)))
+
+
+ ! Levels, where u,v,t and q are given
+ !************************************
+
+ uu(ix,jy,1,n)=uuh(ix,jy,llev)
+ vv(ix,jy,1,n)=vvh(ix,jy,llev)
+ tt(ix,jy,1,n)=tth(ix,jy,llev,n)
+ qv(ix,jy,1,n)=qvh(ix,jy,llev,n)
+ ! IP & SEC, 201812 add clouds
+ if (readclouds) then
+ clwc(ix,jy,1,n)=clwch(ix,jy,llev,n)
+ endif
+ pv(ix,jy,1,n)=pvh(ix,jy,llev)
+ rho(ix,jy,1,n)=rhoh(llev)
+ pplev(ix,jy,1,n)=akz(llev)
+ uu(ix,jy,nz,n)=uuh(ix,jy,nuvz)
+ vv(ix,jy,nz,n)=vvh(ix,jy,nuvz)
+ tt(ix,jy,nz,n)=tth(ix,jy,nuvz,n)
+ qv(ix,jy,nz,n)=qvh(ix,jy,nuvz,n)
+ ! IP & SEC, 201812 add clouds
+ if (readclouds) then
+ clwc(ix,jy,nz,n)=clwch(ix,jy,nuvz,n)
+ endif
+ pv(ix,jy,nz,n)=pvh(ix,jy,nuvz)
+ rho(ix,jy,nz,n)=rhoh(nuvz)
+ pplev(ix,jy,nz,n)=akz(nuvz)
+ kmin=llev+1
+ do iz=2,nz-1
+ do kz=kmin,nuvz
+ if(height(iz).gt.uvwzlev(ix,jy,nuvz)) then
+ uu(ix,jy,iz,n)=uu(ix,jy,nz,n)
+ vv(ix,jy,iz,n)=vv(ix,jy,nz,n)
+ tt(ix,jy,iz,n)=tt(ix,jy,nz,n)
+ qv(ix,jy,iz,n)=qv(ix,jy,nz,n)
+ ! IP & SEC, 201812 add clouds
+ if (readclouds) then
+ clwc(ix,jy,iz,n)=clwc(ix,jy,nz,n)
+ endif
+ pv(ix,jy,iz,n)=pv(ix,jy,nz,n)
+ rho(ix,jy,iz,n)=rho(ix,jy,nz,n)
+ pplev(ix,jy,iz,n)=pplev(ix,jy,nz,n)
+ exit
+ endif
+ if ((height(iz).gt.uvwzlev(ix,jy,kz-1)).and. &
+ (height(iz).le.uvwzlev(ix,jy,kz))) then
+ dz1=height(iz)-uvwzlev(ix,jy,kz-1)
+ dz2=uvwzlev(ix,jy,kz)-height(iz)
+ dz=dz1+dz2
+ uu(ix,jy,iz,n)=(uuh(ix,jy,kz-1)*dz2+uuh(ix,jy,kz)*dz1)/dz
+ vv(ix,jy,iz,n)=(vvh(ix,jy,kz-1)*dz2+vvh(ix,jy,kz)*dz1)/dz
+ tt(ix,jy,iz,n)=(tth(ix,jy,kz-1,n)*dz2 &
+ +tth(ix,jy,kz,n)*dz1)/dz
+ qv(ix,jy,iz,n)=(qvh(ix,jy,kz-1,n)*dz2 &
+ +qvh(ix,jy,kz,n)*dz1)/dz
+ ! IP & SEC, 201812 add clouds
+ if (readclouds) then
+ clwc(ix,jy,iz,n)=(clwch(ix,jy,kz-1,n)*dz2 &
+ +clwch(ix,jy,kz,n)*dz1)/dz
+ endif
+ pv(ix,jy,iz,n)=(pvh(ix,jy,kz-1)*dz2+pvh(ix,jy,kz)*dz1)/dz
+ rho(ix,jy,iz,n)=(rhoh(kz-1)*dz2+rhoh(kz)*dz1)/dz
+ pplev(ix,jy,iz,n)=(akz(kz-1)*dz2+akz(kz)*dz1)/dz
+ endif
+ end do
+ end do
+
+
+ ! Levels, where w is given
+ !*************************
+
+ ww(ix,jy,1,n)=wwh(ix,jy,llev)*pinmconv(llev)
+ ww(ix,jy,nz,n)=wwh(ix,jy,nwz)*pinmconv(nz)
+ kmin=llev+1
+ do iz=2,nz
+ do kz=kmin,nwz
+ if ((height(iz).gt.wzlev(kz-1)).and. &
+ (height(iz).le.wzlev(kz))) then
+ dz1=height(iz)-wzlev(kz-1)
+ dz2=wzlev(kz)-height(iz)
+ dz=dz1+dz2
+ ww(ix,jy,iz,n)=(wwh(ix,jy,kz-1)*pinmconv(kz-1)*dz2 &
+ +wwh(ix,jy,kz)*pinmconv(kz)*dz1)/dz
+ endif
+ end do
+ end do
+
+
+ ! Compute density gradients at intermediate levels
+ !*************************************************
+
+ drhodz(ix,jy,1,n)=(rho(ix,jy,2,n)-rho(ix,jy,1,n))/ &
+ (height(2)-height(1))
+ do kz=2,nz-1
+ drhodz(ix,jy,kz,n)=(rho(ix,jy,kz+1,n)-rho(ix,jy,kz-1,n))/ &
+ (height(kz+1)-height(kz-1))
+ end do
+ drhodz(ix,jy,nz,n)=drhodz(ix,jy,nz-1,n)
+
+ end do
+ end do
+
+
+ !****************************************************************
+ ! Compute slope of eta levels in windward direction and resulting
+ ! vertical wind correction
+ !****************************************************************
+
+ do jy=1,ny-2
+ cosf=cos((real(jy)*dy+ylat0)*pi180)
+ do ix=1,nx-2
+
+ ! NCEP version: find first level above ground
+ llev = 0
+ do i=1,nuvz
+ if (ps(ix,jy,1,n).lt.akz(i)) llev=i
+ end do
+ llev = llev+1
+ if (llev.gt.nuvz-2) llev = nuvz-2
+ ! if (llev.eq.nuvz-2) write(*,*) 'verttransform
+ ! +WARNING: LLEV eq NUZV-2'
+ ! NCEP version
+
+ kmin=llev+1
+ do iz=2,nz-1
+
+ ui=uu(ix,jy,iz,n)*dxconst/cosf
+ vi=vv(ix,jy,iz,n)*dyconst
+
+ do kz=kmin,nz
+ if ((height(iz).gt.uvwzlev(ix,jy,kz-1)).and. &
+ (height(iz).le.uvwzlev(ix,jy,kz))) then
+ dz1=height(iz)-uvwzlev(ix,jy,kz-1)
+ dz2=uvwzlev(ix,jy,kz)-height(iz)
+ dz=dz1+dz2
+ kl=kz-1
+ klp=kz
+ exit
+ endif
+ end do
+
+ ix1=ix-1
+ jy1=jy-1
+ ixp=ix+1
+ jyp=jy+1
+
+ dzdx1=(uvwzlev(ixp,jy,kl)-uvwzlev(ix1,jy,kl))/2.
+ dzdx2=(uvwzlev(ixp,jy,klp)-uvwzlev(ix1,jy,klp))/2.
+ dzdx=(dzdx1*dz2+dzdx2*dz1)/dz
+
+ dzdy1=(uvwzlev(ix,jyp,kl)-uvwzlev(ix,jy1,kl))/2.
+ dzdy2=(uvwzlev(ix,jyp,klp)-uvwzlev(ix,jy1,klp))/2.
+ dzdy=(dzdy1*dz2+dzdy2*dz1)/dz
+
+ ww(ix,jy,iz,n)=ww(ix,jy,iz,n)+(dzdx*ui+dzdy*vi)
+
+ end do
+
+ end do
+ end do
+
+
+ ! If north pole is in the domain, calculate wind velocities in polar
+ ! stereographic coordinates
+ !*******************************************************************
+
+ if (nglobal) then
+ do jy=int(switchnorthg)-2,nymin1
+ ylat=ylat0+real(jy)*dy
+ do ix=0,nxmin1
+ xlon=xlon0+real(ix)*dx
+ do iz=1,nz
+ call cc2gll(northpolemap,ylat,xlon,uu(ix,jy,iz,n), &
+ vv(ix,jy,iz,n),uupol(ix,jy,iz,n), &
+ vvpol(ix,jy,iz,n))
+ end do
+ end do
+ end do
+
+
+ do iz=1,nz
+
+ ! CALCULATE FFPOL, DDPOL FOR CENTRAL GRID POINT
+ xlon=xlon0+real(nx/2-1)*dx
+ xlonr=xlon*pi/180.
+ ffpol=sqrt(uu(nx/2-1,nymin1,iz,n)**2+vv(nx/2-1,nymin1,iz,n)**2)
+ if (vv(nx/2-1,nymin1,iz,n).lt.0.) then
+ ddpol=atan(uu(nx/2-1,nymin1,iz,n)/vv(nx/2-1,nymin1,iz,n))-xlonr
+ elseif (vv(nx/2-1,nymin1,iz,n).gt.0.) then
+ ddpol=pi+atan(uu(nx/2-1,nymin1,iz,n)/ &
+ vv(nx/2-1,nymin1,iz,n))-xlonr
+ else
+ ddpol=pi/2-xlonr
+ endif
+ if(ddpol.lt.0.) ddpol=2.0*pi+ddpol
+ if(ddpol.gt.2.0*pi) ddpol=ddpol-2.0*pi
+
+ ! CALCULATE U,V FOR 180 DEG, TRANSFORM TO POLAR STEREOGRAPHIC GRID
+ xlon=180.0
+ xlonr=xlon*pi/180.
+ ylat=90.0
+ uuaux=-ffpol*sin(xlonr+ddpol)
+ vvaux=-ffpol*cos(xlonr+ddpol)
+ call cc2gll(northpolemap,ylat,xlon,uuaux,vvaux,uupolaux,vvpolaux)
+ jy=nymin1
+ do ix=0,nxmin1
+ uupol(ix,jy,iz,n)=uupolaux
+ vvpol(ix,jy,iz,n)=vvpolaux
+ end do
+ end do
+
+
+ ! Fix: Set W at pole to the zonally averaged W of the next equator-
+ ! ward parallel of latitude
+
+ do iz=1,nz
+ wdummy=0.
+ jy=ny-2
+ do ix=0,nxmin1
+ wdummy=wdummy+ww(ix,jy,iz,n)
+ end do
+ wdummy=wdummy/real(nx)
+ jy=nymin1
+ do ix=0,nxmin1
+ ww(ix,jy,iz,n)=wdummy
+ end do
+ end do
+
+ endif
+
+
+ ! If south pole is in the domain, calculate wind velocities in polar
+ ! stereographic coordinates
+ !*******************************************************************
+
+ if (sglobal) then
+ do jy=0,int(switchsouthg)+3
+ ylat=ylat0+real(jy)*dy
+ do ix=0,nxmin1
+ xlon=xlon0+real(ix)*dx
+ do iz=1,nz
+ call cc2gll(southpolemap,ylat,xlon,uu(ix,jy,iz,n), &
+ vv(ix,jy,iz,n),uupol(ix,jy,iz,n),vvpol(ix,jy,iz,n))
+ end do
+ end do
+ end do
+
+ do iz=1,nz
+
+ ! CALCULATE FFPOL, DDPOL FOR CENTRAL GRID POINT
+ xlon=xlon0+real(nx/2-1)*dx
+ xlonr=xlon*pi/180.
+ ffpol=sqrt(uu(nx/2-1,0,iz,n)**2+vv(nx/2-1,0,iz,n)**2)
+ if(vv(nx/2-1,0,iz,n).lt.0.) then
+ ddpol=atan(uu(nx/2-1,0,iz,n)/vv(nx/2-1,0,iz,n))+xlonr
+ elseif (vv(nx/2-1,0,iz,n).gt.0.) then
+ ddpol=pi+atan(uu(nx/2-1,0,iz,n)/vv(nx/2-1,0,iz,n))-xlonr
+ else
+ ddpol=pi/2-xlonr
+ endif
+ if(ddpol.lt.0.) ddpol=2.0*pi+ddpol
+ if(ddpol.gt.2.0*pi) ddpol=ddpol-2.0*pi
+
+ ! CALCULATE U,V FOR 180 DEG, TRANSFORM TO POLAR STEREOGRAPHIC GRID
+ xlon=180.0
+ xlonr=xlon*pi/180.
+ ylat=-90.0
+ uuaux=+ffpol*sin(xlonr-ddpol)
+ vvaux=-ffpol*cos(xlonr-ddpol)
+ call cc2gll(northpolemap,ylat,xlon,uuaux,vvaux,uupolaux,vvpolaux)
+
+ jy=0
+ do ix=0,nxmin1
+ uupol(ix,jy,iz,n)=uupolaux
+ vvpol(ix,jy,iz,n)=vvpolaux
+ end do
+ end do
+
+
+ ! Fix: Set W at pole to the zonally averaged W of the next equator-
+ ! ward parallel of latitude
+
+ do iz=1,nz
+ wdummy=0.
+ jy=1
+ do ix=0,nxmin1
+ wdummy=wdummy+ww(ix,jy,iz,n)
+ end do
+ wdummy=wdummy/real(nx)
+ jy=0
+ do ix=0,nxmin1
+ ww(ix,jy,iz,n)=wdummy
+ end do
+ end do
+ endif
+
+
+
+ !***********************************************************************************
+ ! IP & SEC, 201812 GFS clouds read
+ if (readclouds) then
+ ! The method is loops all grids vertically and constructs the 3D matrix for clouds
+ ! Cloud top and cloud bottom gid cells are assigned as well as the total column
+ ! cloud water. For precipitating grids, the type and whether it is in or below
+ ! cloud scavenging are assigned with numbers 2-5 (following the old metod).
+ ! Distinction is done for lsp and convp though they are treated the same in regards
+ ! to scavenging. Also clouds that are not precipitating are defined which may be
+ ! to include future cloud processing by non-precipitating-clouds.
+ !***********************************************************************************
+ write(*,*) 'Global NCEP fields: using cloud water'
+ clw(:,:,:,n)=0.0
+ ctwc(:,:,n)=0.0
+ clouds(:,:,:,n)=0
+ ! If water/ice are read separately into clwc and ciwc, store sum in clwc
+ do jy=0,nymin1
+ do ix=0,nxmin1
+ lsp=lsprec(ix,jy,1,n)
+ convp=convprec(ix,jy,1,n)
+ prec=lsp+convp
+ ! Find clouds in the vertical
+ do kz=1, nz-1 !go from top to bottom
+ if (clwc(ix,jy,kz,n).gt.0) then
+ ! assuming rho is in kg/m3 and hz in m gives: kg/kg * kg/m3 *m3/kg /m = m2/m3
+ clw(ix,jy,kz,n)=(clwc(ix,jy,kz,n)*rho(ix,jy,kz,n))*(height(kz+1)-height(kz))
+ ctwc(ix,jy,n) = ctwc(ix,jy,n)+clw(ix,jy,kz,n)
+ cloudh_min=min(height(kz+1),height(kz))
+ endif
+ end do
+
+ ! If Precipitation. Define removal type in the vertical
+ if ((lsp.gt.0.01).or.(convp.gt.0.01)) then ! cloud and precipitation
+
+ do kz=nz,2,-1 !go Bottom up!
+ if (clw(ix,jy,kz,n).gt. 0) then ! is in cloud
+ cloudsh(ix,jy,n)=cloudsh(ix,jy,n)+height(kz)-height(kz-1)
+ clouds(ix,jy,kz,n)=1 ! is a cloud
+ if (lsp.ge.convp) then
+ clouds(ix,jy,kz,n)=3 ! lsp in-cloud
+ else
+ clouds(ix,jy,kz,n)=2 ! convp in-cloud
+ endif ! convective or large scale
+ elseif((clw(ix,jy,kz,n).le.0) .and. (cloudh_min.ge.height(kz))) then ! is below cloud
+ if (lsp.ge.convp) then
+ clouds(ix,jy,kz,n)=5 ! lsp dominated washout
+ else
+ clouds(ix,jy,kz,n)=4 ! convp dominated washout
+ endif ! convective or large scale
+ endif
+
+ if (height(kz).ge. 19000) then ! set a max height for removal
+ clouds(ix,jy,kz,n)=0
+ endif !clw>0
+ end do !nz
+ endif ! precipitation
+ end do
+ end do
+ else
+ write(*,*) 'Global NCEP fields: using cloud water from Parameterization'
+ ! write (*,*) 'initializing clouds, n:',n,nymin1,nxmin1,nz
+ ! create a cloud and rainout/washout field, clouds occur where rh>80%
+ ! total cloudheight is stored at level 0
+ do jy=0,nymin1
+ do ix=0,nxmin1
+ rain_cloud_above=0
+ lsp=lsprec(ix,jy,1,n)
+ convp=convprec(ix,jy,1,n)
+ cloudsh(ix,jy,n)=0
+ do kz_inv=1,nz-1
+ kz=nz-kz_inv+1
+ pressure=rho(ix,jy,kz,n)*r_air*tt(ix,jy,kz,n)
+ rh=qv(ix,jy,kz,n)/f_qvsat(pressure,tt(ix,jy,kz,n))
+ clouds(ix,jy,kz,n)=0
+ if (rh.gt.0.8) then ! in cloud
+ if ((lsp.gt.0.01).or.(convp.gt.0.01)) then ! cloud and precipitation
+ rain_cloud_above=1
+ cloudsh(ix,jy,n)=cloudsh(ix,jy,n)+height(kz)-height(kz-1)
+ if (lsp.ge.convp) then
+ clouds(ix,jy,kz,n)=3 ! lsp dominated rainout
+ else
+ clouds(ix,jy,kz,n)=2 ! convp dominated rainout
+ endif
+ else ! no precipitation
+ clouds(ix,jy,kz,n)=1 ! cloud
+ endif
+ else ! no cloud
+ if (rain_cloud_above.eq.1) then ! scavenging
+ if (lsp.ge.convp) then
+ clouds(ix,jy,kz,n)=5 ! lsp dominated washout
+ else
+ clouds(ix,jy,kz,n)=4 ! convp dominated washout
+ endif
+ endif
+ endif
+ end do
+ end do
+ end do
+ endif ! IP & SEC 201812, GFS clouds read
+end subroutine verttransform_gfs
+
+subroutine verttransform_ecmwf_heights(nxlim,nylim, &
+ tt2_tmp,td2_tmp,ps_tmp,qvh_tmp,tth_tmp,prsh_tmp, &
+ rhoh_tmp,pinmconv,uvzlev,wzlev)
+
+ implicit none
+
+ integer, intent(in) :: nxlim,nylim
+ real,intent(in),dimension(0:nxlim,0:nylim) :: tt2_tmp,td2_tmp,ps_tmp
+ real,intent(in),dimension(0:nxlim,0:nylim,nuvzmax) :: qvh_tmp,tth_tmp
+ real,intent(out),dimension(0:nxlim,0:nylim,nuvzmax) :: rhoh_tmp,prsh_tmp
+ real,intent(out),dimension(0:nxlim,0:nylim,nzmax) :: pinmconv
+ real,intent(out),dimension(0:nxlim,0:nylim,nuvzmax) :: uvzlev,wzlev
+ real,dimension(0:nxlim,0:nylim) :: tvold,pold,pint,tv
+ real,parameter :: const=r_air/ga
+ integer :: ix,jy,kz
+ integer :: nxm1,nym1
+
+ ! Loop over the whole grid
+ !*************************
+
+ do jy=0,nylim
+ do ix=0,nxlim
+ tvold(ix,jy)=tt2_tmp(ix,jy)*(1.+0.378*ew(td2_tmp(ix,jy),ps_tmp(ix,jy))/ &
+ ps_tmp(ix,jy))
+ end do
+ end do
+
+ pold(:,:)=ps_tmp(:,:)
+ uvzlev(:,:,1)=0.
+ wzlev(:,:,1)=0.
+ rhoh_tmp(:,:,1)=pold(:,:)/(r_air*tvold(:,:))
+ prsh_tmp(:,:,1)=ps_tmp(:,:)
+
+ ! Compute heights of eta levels
+ !******************************
+
+ do kz=2,nuvz
+ pint(:,:)=akz(kz)+bkz(kz)*ps_tmp(:,:)
+ prsh_tmp(:,:,kz)=pint(:,:)
+ tv(:,:)=tth_tmp(:,:,kz)*(1.+0.608*qvh_tmp(:,:,kz))
+ rhoh_tmp(:,:,kz)=pint(:,:)/(r_air*tv(:,:))
+
+ where (abs(tv(:,:)-tvold(:,:)).gt.0.2)
+ uvzlev(:,:,kz)=uvzlev(:,:,kz-1)+const*&
+ &log(pold(:,:)/pint(:,:))* &
+ (tv(:,:)-tvold(:,:))/&
+ &log(tv(:,:)/tvold(:,:))
+ elsewhere
+ uvzlev(:,:,kz)=uvzlev(:,:,kz-1)+const*&
+ &log(pold(:,:)/pint(:,:))*tv(:,:)
+ endwhere
+
+ tvold(:,:)=tv(:,:)
+ pold(:,:)=pint(:,:)
+
+ end do
+
+ do kz=2,nwz-1
+ wzlev(:,:,kz)=(uvzlev(:,:,kz+1)+uvzlev(:,:,kz))/2.
+ end do
+ wzlev(:,:,nwz)=wzlev(:,:,nwz-1)+ &
+ uvzlev(:,:,nuvz)-uvzlev(:,:,nuvz-1)
+
+
+ pinmconv(:,:,1)=(uvzlev(:,:,2))/ &
+ ((aknew(2)+bknew(2)*ps_tmp(:,:))- &
+ (aknew(1)+bknew(1)*ps_tmp(:,:)))
+ do kz=2,nz-1
+ pinmconv(:,:,kz)=(uvzlev(:,:,kz+1)-uvzlev(:,:,kz-1))/ &
+ ((aknew(kz+1)+bknew(kz+1)*ps_tmp(:,:))- &
+ (aknew(kz-1)+bknew(kz-1)*ps_tmp(:,:)))
+ end do
+ pinmconv(:,:,nz)=(uvzlev(:,:,nz)-uvzlev(:,:,nz-1))/ &
+ ((aknew(nz)+bknew(nz)*ps_tmp(:,:))- &
+ (aknew(nz-1)+bknew(nz-1)*ps_tmp(:,:)))
+end subroutine verttransform_ecmwf_heights
+
+subroutine verttransform_ecmwf_nests_transform_windfields(l,n, &
+ uuhn,vvhn,wwhn,pvhn,rhohn,prshn,pinmconv)
+
+ implicit none
+
+ integer,intent(in) :: l,n
+ real,intent(in),dimension(0:nxmaxn-1,0:nymaxn-1,nuvzmax,maxnests) :: uuhn,vvhn,pvhn
+ real,intent(in),dimension(0:nxmaxn-1,0:nymaxn-1,nwzmax,maxnests) :: wwhn
+ real,intent(in),dimension(0:nxmaxn-1,0:nymaxn-1,nuvzmax) :: rhohn
+ real,intent(in),dimension(0:nxmaxn-1,0:nymaxn-1,nuvzmax) :: prshn
+ real,intent(in),dimension(0:nxmaxn-1,0:nymaxn-1,nzmax) :: pinmconv
+ real,dimension(0:nymaxn-1) :: cosf
+
+ integer,dimension(0:nxmaxn-1,0:nymaxn-1) :: rain_cloud_above, idx
+
+ integer :: ix,jy,kz,iz,kmin,kl,klp,ix1,jy1,ixp,jyp,kz_inv
+ real :: pressure,rh,lsp,convp,cloudh_min,prec
+
+ real :: dz1,dz2,dz,dpdeta
+ real :: dzdx,dzdy
+ real :: dzdx1,dzdx2,dzdy1,dzdy2
+ real :: tot_cloud_h
+ integer :: nxm1, nym1
+
+ nxm1=nxn(l)-1
+ nym1=nyn(l)-1
+
+ ! Levels, where u,v,t and q are given
+ !************************************
+!$OMP PARALLEL PRIVATE(jy,ix,kz,dz1,dz2,dz,ix1,jy1,ixp,jyp,dzdx1,dzdx2,dzdx,dzdy1,dzdy2,dzdy, &
+!$OMP dpdeta)
+
+!$OMP DO
+ do jy=0,nym1
+ do ix=0,nxm1
+ uun(ix,jy,1,n,l)=uuhn(ix,jy,1,l)
+ vvn(ix,jy,1,n,l)=vvhn(ix,jy,1,l)
+ ttn(ix,jy,1,n,l)=tthn(ix,jy,1,n,l)
+ if (wind_coord_type.ne.'ETA') then
+ qvn(ix,jy,1,n,l)=qvhn(ix,jy,1,n,l)
+ endif
+ if (readclouds_nest(l)) then
+ clwcn(ix,jy,1,n,l)=clwchn(ix,jy,1,n,l)
+ if (.not.sumclouds_nest(l)) ciwcn(ix,jy,1,n,l)=ciwchn(ix,jy,1,n,l)
+ end if
+ pvn(ix,jy,1,n,l)=pvhn(ix,jy,1,l)
+ rhon(ix,jy,1,n,l)=rhohn(ix,jy,1)
+ prsn(ix,jy,1,n,l)=prshn(ix,jy,1)
+
+ uun(ix,jy,nz,n,l)=uuhn(ix,jy,nuvz,l)
+ vvn(ix,jy,nz,n,l)=vvhn(ix,jy,nuvz,l)
+ ttn(ix,jy,nz,n,l)=tthn(ix,jy,nuvz,n,l)
+ if (wind_coord_type.ne.'ETA') then
+ qvn(ix,jy,nz,n,l)=qvhn(ix,jy,nuvz,n,l)
+ if (readclouds_nest(l)) then
+ clwcn(ix,jy,nz,n,l)=clwchn(ix,jy,nuvz,n,l)
+ if (.not.sumclouds_nest(l)) ciwcn(ix,jy,nz,n,l)=ciwchn(ix,jy,nuvz,n,l)
+ endif
+ endif
+ pvn(ix,jy,nz,n,l)=pvhn(ix,jy,nuvz,l)
+ rhon(ix,jy,nz,n,l)=rhohn(ix,jy,nuvz)
+ prsn(ix,jy,nz,n,l)=prshn(ix,jy,nuvz)
+
+ idx(ix,jy)=2
+ end do
+ end do
+!$OMP END DO
+
+ do iz=2,nz-1
+!$OMP DO SCHEDULE(dynamic)
+ do jy=0,nym1
+ do ix=0,nxm1
+ if(height(iz).gt.etauvheightn(ix,jy,nuvz,n,l)) then
+ uun(ix,jy,iz,n,l)=uun(ix,jy,nz,n,l)
+ vvn(ix,jy,iz,n,l)=vvn(ix,jy,nz,n,l)
+ ttn(ix,jy,iz,n,l)=ttn(ix,jy,nz,n,l)
+ pvn(ix,jy,iz,n,l)=pvn(ix,jy,nz,n,l)
+ if (wind_coord_type.ne.'ETA') then
+ qvn(ix,jy,iz,n,l)=qvn(ix,jy,nz,n,l)
+ !hg adding the cloud water
+ if (readclouds_nest(l)) then
+ clwcn(ix,jy,iz,n,l)=clwcn(ix,jy,nz,n,l)
+ if (.not.sumclouds_nest(l)) ciwcn(ix,jy,iz,n,l)=ciwcn(ix,jy,nz,n,l)
+ endif
+ endif
+ rhon(ix,jy,iz,n,l)=rhon(ix,jy,nz,n,l)
+ prsn(ix,jy,iz,n,l)=prsn(ix,jy,nz,n,l)
+ else
+ innuvz: do kz=idx(ix,jy),nuvz
+ if (idx(ix,jy) .le. kz .and. (height(iz).gt.etauvheightn(ix,jy,kz-1,n,l)).and. &
+ (height(iz).le.etauvheightn(ix,jy,kz,n,l))) then
+ idx(ix,jy)=kz
+ exit innuvz
+ endif
+ enddo innuvz
+ endif
+
+ if(height(iz).le.etauvheightn(ix,jy,nuvz,n,l)) then
+ kz=idx(ix,jy)
+ dz1=height(iz)-etauvheightn(ix,jy,kz-1,n,l)
+ dz2=etauvheightn(ix,jy,kz,n,l)-height(iz)
+ dz=dz1+dz2
+ uun(ix,jy,iz,n,l)=(uuhn(ix,jy,kz-1,l)*dz2+uuhn(ix,jy,kz,l)*dz1)/dz
+ vvn(ix,jy,iz,n,l)=(vvhn(ix,jy,kz-1,l)*dz2+vvhn(ix,jy,kz,l)*dz1)/dz
+ ttn(ix,jy,iz,n,l)=(tthn(ix,jy,kz-1,n,l)*dz2 &
+ +tthn(ix,jy,kz,n,l)*dz1)/dz
+ pvn(ix,jy,iz,n,l)=(pvhn(ix,jy,kz-1,l)*dz2+pvhn(ix,jy,kz,l)*dz1)/dz
+ if (wind_coord_type.ne.'ETA') then
+ qvn(ix,jy,iz,n,l)=(qvhn(ix,jy,kz-1,n,l)*dz2 &
+ +qvhn(ix,jy,kz,n,l)*dz1)/dz
+ !hg adding the cloud water
+ if (readclouds_nest(l)) then
+ clwcn(ix,jy,iz,n,l)=(clwchn(ix,jy,kz-1,n,l)*dz2+clwchn(ix,jy,kz,n,l)*dz1)/dz
+ if (.not.sumclouds_nest(l)) &
+ &ciwcn(ix,jy,iz,n,l)=(ciwchn(ix,jy,kz-1,n,l)*dz2+ciwchn(ix,jy,kz,n,l)*dz1)/dz
+ end if
+ endif
+ rhon(ix,jy,iz,n,l)=(rhohn(ix,jy,kz-1)*dz2+rhohn(ix,jy,kz)*dz1)/dz
+ prsn(ix,jy,iz,n,l)=(prshn(ix,jy,kz-1)*dz2+prshn(ix,jy,kz)*dz1)/dz
+ endif
+ enddo
+ enddo
+!$OMP END DO
+!$OMP BARRIER
+ enddo
+
+ ! Levels, where w is given
+ !*************************
+
+!$OMP DO
+ do jy=0,nym1
+ do ix=0,nxm1
+ idx(ix,jy)=2
+ wwn(ix,jy,1,n,l)=wwhn(ix,jy,1,l)*pinmconv(ix,jy,1)
+ wwn(ix,jy,nz,n,l)=wwhn(ix,jy,nwz,l)*pinmconv(ix,jy,nz)
+ end do
+ end do
+!$OMP END DO
+
+ do iz=2,nz-1
+!$OMP DO SCHEDULE(dynamic)
+ do jy=0,nym1
+ do ix=0,nxm1
+
+ inn: do kz=idx(ix,jy),nwz
+ if(idx(ix,jy) .le. kz .and. height(iz).gt.etawheightn(ix,jy,kz-1,n,l).and. &
+ height(iz).le.etawheightn(ix,jy,kz,n,l)) then
+ idx(ix,jy)=kz
+ exit inn
+ endif
+ enddo inn
+
+ kz=idx(ix,jy)
+ dz1=height(iz)-etawheightn(ix,jy,kz-1,n,l)
+ dz2=etawheightn(ix,jy,kz,n,l)-height(iz)
+ dz=dz1+dz2
+ wwn(ix,jy,iz,n,l)=(wwhn(ix,jy,kz-1,l)*pinmconv(ix,jy,kz-1)*dz2 &
+ +wwhn(ix,jy,kz,l)*pinmconv(ix,jy,kz)*dz1)/dz
+ drhodzn(ix,jy,iz,n,l)=(rhon(ix,jy,iz+1,n,l)-rhon(ix,jy,iz-1,n,l))/ &
+ (height(iz+1)-height(iz-1))
+ enddo
+ enddo
+!$OMP END DO
+!$OMP BARRIER
+ end do
+
+ ! Compute density gradients at intermediate levels
+ !*************************************************
+!$OMP DO
+ do jy=0,nym1
+ do ix=0,nxm1
+ drhodzn(ix,jy,nz,n,l)=drhodzn(ix,jy,nz-1,n,l)
+ drhodzn(ix,jy,1,n,l)=(rhon(ix,jy,2,n,l)-rhon(ix,jy,1,n,l))/ &
+ (height(2)-height(1))
+ end do
+ end do
+!$OMP END DO NOWAIT
+
+ !****************************************************************
+ ! Compute slope of eta levels in windward direction and resulting
+ ! vertical wind correction
+ !****************************************************************
+
+!$OMP DO
+ do jy=1,nyn(l)-2
+ cosf(jy)=1./cos((real(jy)*dyn(l)+ylat0n(l))*pi180)
+ do ix=1,nxn(l)-2
+ idx(ix,jy)=2
+ end do
+ end do
+!$OMP END DO
+
+ do iz=2,nz-1
+!$OMP DO SCHEDULE(dynamic)
+ do jy=1,nyn(l)-2
+ do ix=1,nxn(l)-2
+
+ inneta: do kz=idx(ix,jy),nz
+ if (idx(ix,jy) .le. kz .and. (height(iz).gt.etauvheightn(ix,jy,kz-1,n,l)).and. &
+ (height(iz).le.etauvheightn(ix,jy,kz,n,l))) then
+ idx(ix,jy)=kz
+ exit inneta
+ endif
+ enddo inneta
+
+ kz=idx(ix,jy)
+ dz1=height(iz)-etauvheightn(ix,jy,kz-1,n,l)
+ dz2=etauvheightn(ix,jy,kz,n,l)-height(iz)
+ dz=dz1+dz2
+ ix1=ix-1
+ jy1=jy-1
+ ixp=ix+1
+ jyp=jy+1
+
+ dzdx1=(etauvheightn(ixp,jy,kz-1,n,l)-etauvheightn(ix1,jy,kz-1,n,l))/2.
+ dzdx2=(etauvheightn(ixp,jy,kz,n,l)-etauvheightn(ix1,jy,kz,n,l))/2.
+ dzdx=(dzdx1*dz2+dzdx2*dz1)/dz
+
+ dzdy1=(etauvheightn(ix,jyp,kz-1,n,l)-etauvheightn(ix,jy1,kz-1,n,l))/2.
+ dzdy2=(etauvheightn(ix,jyp,kz,n,l)-etauvheightn(ix,jy1,kz,n,l))/2.
+ dzdy=(dzdy1*dz2+dzdy2*dz1)/dz
+
+ wwn(ix,jy,iz,n,l)=wwn(ix,jy,iz,n,l)+(dzdx*uun(ix,jy,iz,n,l)*dxconst*xresoln(l)*cosf(jy)+ &
+ dzdy*vvn(ix,jy,iz,n,l)*dyconst*yresoln(l))
+
+ end do
+ end do
+!$OMP END DO
+!$OMP BARRIER
+ end do
+
+ ! Keep original fields if wind_coord_type==ETA
+ if (wind_coord_type.eq.'ETA') then
+!$OMP DO
+
+ do kz=1,nz
+ do jy=0,nym1
+ do ix=0,nxm1
+ uuetan(ix,jy,kz,n,l) = uuhn(ix,jy,kz,l)
+ vvetan(ix,jy,kz,n,l) = vvhn(ix,jy,kz,l)
+ ttetan(ix,jy,kz,n,l) = tthn(ix,jy,kz,n,l)
+ qvn(ix,jy,kz,n,l) = qvhn(ix,jy,kz,n,l)
+ pvetan(ix,jy,kz,n,l) = pvhn(ix,jy,kz,l)
+ rhoetan(ix,jy,kz,n,l) = rhohn(ix,jy,kz)
+ prsetan(ix,jy,kz,n,l) = prshn(ix,jy,kz)
+ ! tvirtualn(ix,jy,kz,n,l)=ttetan(ix,jy,kz,n,l)* & ! eq A11 from Mid-latitude atmospheric dynamics by Jonathan E. Martin
+ ! ((qvn(ix,jy,kz,n,l)+0.622)/(0.622*qvn(ix,jy,kz,n,l)+0.622))
+ if ((kz.gt.1).and.(kz.lt.nz)) drhodzetan(ix,jy,kz,n,l)= &
+ (rhohn(ix,jy,kz+1)-rhohn(ix,jy,kz-1))/(height(kz+1)-height(kz-1))
+ if (readclouds) then
+ clwcn(ix,jy,kz,n,l)=clwchn(ix,jy,kz,n,l)
+ if (.not.sumclouds_nest(l)) ciwcn(ix,jy,kz,n,l)=ciwchn(ix,jy,kz,n,l)
+ endif
+ end do
+ end do
+ end do
+!$OMP END DO NOWAIT
+
+!$OMP DO
+ do jy=0,nym1
+ do ix=0,nxm1
+ drhodzetan(ix,jy,1,n,l)=(rhoetan(ix,jy,2,n,l)-rhoetan(ix,jy,1,n,l))/ &
+ (height(2)-height(1))
+ drhodzetan(ix,jy,nz,n,l)=drhodzetan(ix,jy,nz-1,n,l)
+ ! tvirtualn(ix,jy,1,n,l)=tt2n(ix,jy,1,n,l)* &
+ ! (1.+0.378*ew(td2n(ix,jy,1,n,l),psn(ix,jy,1,n,l))/ps(ix,jy,1,n,l))
+ ! Convert w from Pa/s to eta/s, following FLEXTRA
+ !************************************************
+ do kz=1,nuvz-1
+ if (kz.eq.1) then
+ dpdeta=(akm(kz+1)-akm(kz)+(bkm(kz+1)-bkm(kz))*ps(ix,jy,1,n))/ &
+ (wheight(kz+1)-wheight(kz))
+ else if (kz.eq.nuvz-1) then
+ dpdeta=(akm(kz)-akm(kz-1)+(bkm(kz)-bkm(kz-1))*ps(ix,jy,1,n))/ &
+ (wheight(kz)-wheight(kz-1))
+ else
+ dpdeta=(akm(kz+1)-akm(kz-1)+(bkm(kz+1)-bkm(kz-1))*ps(ix,jy,1,n))/ &
+ (wheight(kz+1)-wheight(kz-1))
+ endif
+ wwetan(ix,jy,kz,n,l)=wwhn(ix,jy,kz,l)/dpdeta
+ end do
+ wwetan(ix,jy,nuvz,n,l)=wwetan(ix,jy,nuvz-1,n,l)
+ end do
+ end do
+!$OMP END DO
+ endif
+!$OMP END PARALLEL
+end subroutine verttransform_ecmwf_nests_transform_windfields
+
+end module verttransform_mod
\ No newline at end of file
diff --git a/src/wetdepo_mod.f90 b/src/wetdepo_mod.f90
new file mode 100644
index 00000000..0d3a56ca
--- /dev/null
+++ b/src/wetdepo_mod.f90
@@ -0,0 +1,838 @@
+ !*****************************************************************************
+ ! *
+ ! L. Bakels 2021: This module contains dry deposition related subroutines *
+ ! *
+ !*****************************************************************************
+
+module wetdepo_mod
+ use point_mod
+ use par_mod
+ use com_mod
+ use particle_mod
+
+ implicit none
+
+contains
+
+subroutine wetdepo(itime,ltsample,loutnext)
+ ! i i i
+ !*****************************************************************************
+ ! *
+ ! Calculation of wet deposition using the concept of scavenging coefficients.*
+ ! For lack of detailed information, washout and rainout are jointly treated. *
+ ! It is assumed that precipitation does not occur uniformly within the whole *
+ ! grid cell, but that only a fraction of the grid cell experiences rainfall. *
+ ! This fraction is parameterized from total cloud cover and rates of large *
+ ! scale and convective precipitation. *
+ ! *
+ ! Author: A. Stohl *
+ ! *
+ ! 1 December 1996 *
+ ! *
+ ! Correction by Petra Seibert, Sept 2002: *
+ ! use centred precipitation data for integration *
+ ! Code may not be correct for decay of deposition! *
+ ! *
+ ! 2021 Andreas Plach: - moved backward wet depo. calc. here from timemanager *
+ ! - bugfix in-cloud scavenging *
+ !*****************************************************************************
+ ! *
+ ! Variables: *
+ ! ix,jy indices of output grid cell for each particle *
+ ! itime [s] actual simulation time [s] *
+ ! jpart particle index *
+ ! ldeltat [s] interval since radioactive decay was computed *
+ ! loutnext [s] time for which gridded deposition is next output *
+ ! loutstep [s] interval at which gridded deposition is output *
+ ! ltsample [s] interval over which mass is deposited *
+ ! wetdeposit mass that is wet deposited *
+ ! wetgrid accumulated deposited mass on output grid *
+ ! wetscav scavenging coefficient *
+ ! *
+ ! Constants: *
+ ! *
+ !*****************************************************************************
+#ifdef _OPENMP
+ use omp_lib
+#endif
+ use unc_mod
+
+ implicit none
+
+ integer :: jpart,itime,ltsample,loutnext,ldeltat
+ integer :: itage,nage,inage,ithread,thread
+ integer :: ks, kp
+ integer(selected_int_kind(16)), dimension(nspec) :: blc_count, inc_count
+ real :: grfraction(3),wetscav
+ real :: wetdeposit(maxspec),restmass
+ real,parameter :: smallnum = tiny(0.0) ! smallest number that can be handled
+
+ ! Compute interval since radioactive decay of deposited mass was computed
+ !************************************************************************
+
+ if (itime.le.loutnext) then
+ ldeltat=itime-(loutnext-loutstep)
+ else ! first half of next interval
+ ldeltat=itime-loutnext
+ endif
+
+ ! Loop over all particles
+ !************************
+ blc_count(:)=0
+ inc_count(:)=0
+
+#ifdef _OPENMP
+ call omp_set_num_threads(numthreads_grid)
+#endif
+!$OMP PARALLEL PRIVATE(jpart,itage,nage,inage,ks,kp,thread,wetscav,wetdeposit, &
+!$OMP restmass, grfraction) REDUCTION(+:blc_count,inc_count)
+
+#if (defined _OPENMP)
+ thread = OMP_GET_THREAD_NUM() ! Starts with 0
+#else
+ thread = 0
+#endif
+
+!$OMP DO
+ do jpart=1,numpart
+
+ ! Check if memory has been deallocated
+ if (.not. is_particle_allocated(jpart)) cycle
+
+ ! Check if particle is still allive
+ if (.not. part(jpart)%alive) cycle
+
+ ! Determine age class of the particle - nage is used for the kernel
+ !******************************************************************
+ itage=abs(itime-part(jpart)%tstart)
+ nage=1
+ do inage=1,nageclass
+ nage=inage
+ if (itage.lt.lage(nage)) exit
+ end do
+
+ do ks=1,nspec ! loop over species
+
+ if (WETDEPSPEC(ks).eqv..false.) cycle
+
+ !**************************************************
+ ! CALCULATE DEPOSITION
+ !**************************************************
+
+ call get_wetscav(itime,ltsample,loutnext,jpart,ks,grfraction,inc_count,blc_count,wetscav) ! OMP carefully check
+
+ if (WETBKDEP) then
+ if ((xscav_frac1(jpart,ks).lt.-0.1)) then ! particle marked as starting particle
+ if (wetscav.gt.0.) then
+ xscav_frac1(jpart,ks)=wetscav*(zpoint2(part(jpart)%npoint)-&
+ zpoint1(part(jpart)%npoint))*grfraction(1)
+ else
+ part(jpart)%mass(ks)=0.
+ xscav_frac1(jpart,ks)=0.
+ endif
+ endif
+ endif
+
+ if (wetscav.gt.0.) then
+ wetdeposit(ks)=part(jpart)%mass(ks)* &
+ (1.-exp(-wetscav*abs(ltsample)))*grfraction(1) ! wet deposition
+ else ! if no scavenging
+ wetdeposit(ks)=0.
+ endif
+ part(jpart)%wetdepo(ks)=part(jpart)%wetdepo(ks)+wetdeposit(ks)
+ restmass = part(jpart)%mass(ks)-wetdeposit(ks)
+ if (ioutputforeachrelease.eq.1) then
+ kp=part(jpart)%npoint
+ else
+ kp=1
+ endif
+ if (restmass .gt. smallnum) then
+ part(jpart)%mass(ks)=restmass
+ ! depostatistic
+ ! wetdepo_sum(ks,kp)=wetdepo_sum(ks,kp)+wetdeposit(ks)
+ ! depostatistic
+ else
+ part(jpart)%mass(ks)=0.
+ endif
+ ! Correct deposited mass to the last time step when radioactive decay of
+ ! gridded deposited mass was calculated
+ if (decay(ks).gt.0.) then
+ wetdeposit(ks)=wetdeposit(ks)*exp(abs(ldeltat)*decay(ks))
+ endif
+
+ ! endif ! no deposition
+ end do ! loop over species
+
+ ! Sabine Eckhardt, June 2008 create deposition runs only for forward runs
+ ! Add the wet deposition to accumulated amount on output grid and nested output grid
+ !*****************************************************************************
+
+ if ((ldirect.eq.1).and.(iout.ne.0)) then !OMP reduction necessary for wetgridunc
+ call wetdepokernel(part(jpart)%nclass,wetdeposit,real(part(jpart)%xlon), &
+ real(part(jpart)%ylat),nage,kp,thread+1)
+ if (nested_output.eq.1) call wetdepokernel_nest(part(jpart)%nclass, &
+ wetdeposit,real(part(jpart)%xlon),real(part(jpart)%ylat),nage,kp,thread+1)
+ endif
+
+ end do ! all particles
+
+!$OMP END DO
+!$OMP END PARALLEL
+
+#ifdef _OPENMP
+ call omp_set_num_threads(numthreads)
+#endif
+
+#ifdef _OPENMP
+ if ((ldirect.eq.1).and.(iout.ne.0)) then
+ do ithread=1,numthreads_grid
+ wetgridunc(:,:,:,:,:,:)=wetgridunc(:,:,:,:,:,:)+gridunc_omp(:,:,1,:,:,:,:,ithread)
+ gridunc_omp(:,:,1,:,:,:,:,ithread)=0.
+ end do
+ if (nested_output.eq.1) then
+ do ithread=1,numthreads_grid
+ wetgriduncn(:,:,:,:,:,:)=wetgriduncn(:,:,:,:,:,:)+griduncn_omp(:,:,1,:,:,:,:,ithread)
+ griduncn_omp(:,:,1,:,:,:,:,ithread)=0.
+ end do
+ endif
+ endif
+#endif
+ !write(*,*) 'WETGRIDUNC:',sum(wetgridunc),wetgridunc(20,270,1,1,1,1),wetgridunc(19,269,1,1,1,1)
+ ! count the total number of below-cloud and in-cloud occurences:
+ tot_blc_count(1:nspec)=tot_blc_count(1:nspec)+blc_count(1:nspec)
+ tot_inc_count(1:nspec)=tot_inc_count(1:nspec)+inc_count(1:nspec)
+end subroutine wetdepo
+
+subroutine get_wetscav(itime,ltsample,loutnext,jpart,ks,grfraction,inc_count,blc_count,wetscav)
+ ! i i i i i o o o o
+ !*****************************************************************************
+ ! *
+ ! Calculation of wet deposition using the concept of scavenging coefficients.*
+ ! For lack of detailed information, washout and rainout are jointly treated. *
+ ! It is assumed that precipitation does not occur uniformly within the whole *
+ ! grid cell, but that only a fraction of the grid cell experiences rainfall. *
+ ! This fraction is parameterized from total cloud cover and rates of large *
+ ! scale and convective precipitation. *
+ ! *
+ ! Author: A. Stohl *
+ ! *
+ ! 1 December 1996 *
+ ! *
+ ! Correction by Petra Seibert, Sept 2002: *
+ ! use centred precipitation data for integration *
+ ! Code may not be correct for decay of deposition! *
+ ! *
+ !*****************************************************************************
+ ! *
+ ! Variables: *
+ ! cc [0-1] total cloud cover *
+ ! convp [mm/h] convective precipitation rate *
+ ! grfraction [0-1] fraction of grid, for which precipitation occurs *
+ ! ix,jy indices of output grid cell for each particle *
+ ! itime [s] actual simulation time [s] *
+ ! jpart particle index *
+ ! lfr, cfr area fraction covered by precipitation for large scale *
+ ! and convective precipitation (dependent on prec. rate) *
+ ! loutnext [s] time for which gridded deposition is next output *
+ ! loutstep [s] interval at which gridded deposition is output *
+ ! lsp [mm/h] large scale precipitation rate *
+ ! ltsample [s] interval over which mass is deposited *
+ ! prec [mm/h] precipitation rate in subgrid, where precipitation occurs*
+ ! wetgrid accumulated deposited mass on output grid *
+ ! wetscav scavenging coefficient *
+ ! *
+ ! Constants: *
+ ! *
+ !*****************************************************************************
+
+ use interpol_mod
+ use windfields_mod
+ use coordinates_ecmwf_mod
+
+ implicit none
+
+ integer :: jpart,itime,ltsample,loutnext,i,j
+ integer :: hz,il,interp_time, n
+ integer(kind=1) :: clouds_v
+ integer :: ks, kp
+ integer(selected_int_kind(16)), dimension(nspec) :: blc_count, inc_count
+
+ ! integer :: n1,n2, icbot,ictop, indcloud !TEST
+ real :: S_i, act_temp, cl, cle ! in cloud scavenging
+ real :: clouds_h ! cloud height for the specific grid point
+ real :: lsp,convp,cc,grfraction(3),prec(3),wetscav,totprec
+ real :: restmass
+ real,parameter :: smallnum = tiny(0.0) ! smallest number that can be handled
+ !save lfr,cfr
+ real :: xts,yts
+
+ real, parameter :: lfr(5) = (/ 0.5,0.65,0.8,0.9,0.95/)
+ real, parameter :: cfr(5) = (/ 0.4,0.55,0.7,0.8,0.9 /)
+
+ !ZHG aerosol below-cloud scavenging removal polynomial constants for rain and snow
+ real, parameter :: bclr(6) = (/274.35758, 332839.59273, 226656.57259, 58005.91340, 6588.38582, 0.244984/) !rain (Laakso et al 2003)
+ real, parameter :: bcls(6) = (/22.7, 0.0, 0.0, 1321.0, 381.0, 0.0/) !now (Kyro et al 2009)
+ real :: frac_act, liq_frac, ice_frac, dquer_m
+
+ real :: Si_dummy, wetscav_dummy
+ logical :: readclouds_this_nest
+
+
+ wetscav=0.
+
+ ! Interpolate large scale precipitation, convective precipitation and
+ ! total cloud cover
+ ! Note that interpolated time refers to itime-0.5*ltsample [PS]
+ !********************************************************************
+ interp_time=nint(itime-0.5*ltsample)
+
+ n=memind(2)
+ if (abs(memtime(1)-interp_time).lt.abs(memtime(2)-interp_time)) &
+ n=memind(1)
+
+ xts=real(part(jpart)%xlon)
+ yts=real(part(jpart)%ylat)
+
+ ! Determine which nesting level to be used
+ !*****************************************
+ call find_ngrid(xts,yts)
+
+ ! If point at border of grid -> small displacement into grid
+ !***********************************************************
+ if (ngrid.le.0) then
+ if (xts.ge.real(nx-1)) xts=real(nx-1)-0.00001
+ if (yts.ge.real(ny-1)) yts=real(ny-1)-0.00001
+ else
+ if (xts.ge.real(nx-1)) xts=real(nx-1)-0.00001
+ if (yts.ge.real(ny-1)) yts=real(ny-1)-0.00001
+ endif
+
+ call determine_grid_coordinates(xts,yts)
+ call find_grid_distances(xts,yts)
+
+ if (ngrid.le.0) then
+ ! No temporal interpolation to stay consistent with clouds
+ call horizontal_interpolation(lsprec,lsp,1,n,1) ! large scale total precipitation
+ call horizontal_interpolation(convprec,convp,1,n,1) ! convective precipitation
+ call horizontal_interpolation(tcc,cc,1,n,1) ! total cloud cover
+ else
+ call horizontal_interpolation_nests(lsprecn,lsp,1,n,1) ! large scale total precipitation
+ call horizontal_interpolation_nests(convprecn,convp,1,n,1) ! convective precipitation
+ call horizontal_interpolation_nests(tccn,cc,1,n,1) ! total cloud cover
+ endif
+
+ ! If total precipitation is less than 0.01 mm/h - no scavenging occurs
+ if ((lsp.lt.0.01).and.(convp.lt.0.01)) return
+
+ if (wind_coord_type.eq.'ETA') then
+ call find_z_level_eta_uv(real(part(jpart)%zeta))
+ hz=induv
+ else
+ call find_z_level_meters(real(part(jpart)%z))
+ hz=indz
+ endif
+
+ if (ngrid.le.0) then
+ clouds_v=clouds(ix,jy,hz,n)
+ clouds_h=cloudsh(ix,jy,n)
+ else
+ clouds_v=cloudsn(ix,jy,hz,n,ngrid)
+ clouds_h=cloudshn(ix,jy,n,ngrid)
+ endif
+
+ ! if there is no precipitation or the particle is above the clouds no
+ ! scavenging is done
+
+ if (clouds_v.le.1) return
+
+ ! 1) Parameterization of the the area fraction of the grid cell where the
+ ! precipitation occurs: the absolute limit is the total cloud cover, but
+ ! for low precipitation rates, an even smaller fraction of the grid cell
+ ! is used. Large scale precipitation occurs over larger areas than
+ ! convective precipitation.
+ !**************************************************************************
+
+ if (lsp.gt.20.) then
+ i=5
+ else if (lsp.gt.8.) then
+ i=4
+ else if (lsp.gt.3.) then
+ i=3
+ else if (lsp.gt.1.) then
+ i=2
+ else
+ i=1
+ endif
+
+ if (convp.gt.20.) then
+ j=5
+ else if (convp.gt.8.) then
+ j=4
+ else if (convp.gt.3.) then
+ j=3
+ else if (convp.gt.1.) then
+ j=2
+ else
+ j=1
+ endif
+
+
+ !ZHG oct 2014 : Calculated for 1) both 2) lsp 3) convp - 2 and 3 not used removed by SE
+ ! Tentatively differentiate the grfraction for lsp and convp for treating differently the two forms
+ ! for now they are treated the same
+ grfraction(1)=max(0.05,cc*(lsp*lfr(i)+convp*cfr(j))/(lsp+convp))
+
+ ! 2) Computation of precipitation rate in sub-grid cell
+ !******************************************************
+ prec(1)=(lsp+convp)/grfraction(1)
+
+ ! 3) Computation of scavenging coefficients for all species
+ ! Computation of wet deposition
+ !**********************************************************
+
+ if (ngrid.gt.0) then
+ if (wind_coord_type.eq.'ETA') then
+ act_temp=ttetan(ix,jy,hz,n,ngrid)
+ else
+ act_temp=ttn(ix,jy,hz,n,ngrid)
+ endif
+ else
+ if (wind_coord_type.eq.'ETA') then
+ act_temp=tteta(ix,jy,hz,n)
+ else
+ act_temp=tt(ix,jy,hz,n)
+ endif
+ endif
+
+ !***********************
+ ! BELOW CLOUD SCAVENGING
+ !***********************
+ if (clouds_v.ge.4) then !below cloud
+
+ ! For gas: if positive below-cloud parameters (A or B), and dquer<=0
+ !******************************************************************
+ if ((dquer(ks).le.0.).and.(weta_gas(ks).gt.0..or.wetb_gas(ks).gt.0.)) then
+ blc_count(ks)=blc_count(ks)+1
+ wetscav=weta_gas(ks)*prec(1)**wetb_gas(ks)
+
+ ! For aerosols: if positive below-cloud parameters (Crain/Csnow or B), and dquer>0
+ !*********************************************************************************
+ else if ((dquer(ks).gt.0.).and.(crain_aero(ks).gt.0..or.csnow_aero(ks).gt.0.)) then
+ blc_count(ks)=blc_count(ks)+1
+
+ !NIK 17.02.2015
+ ! For the calculation here particle size needs to be in meter and not um as dquer is
+ ! changed in readreleases
+ ! For particles larger than 10 um use the largest size defined in the parameterizations (10um)
+ dquer_m=min(10.,dquer(ks))/1000000. !conversion from um to m
+
+ ! Rain:
+ if (act_temp .ge. 273. .and. crain_aero(ks).gt.0.) then
+
+ ! ZHG 2014 : Particle RAIN scavenging coefficient based on Laakso et al 2003,
+ ! the below-cloud scavenging (rain efficienty) parameter Crain (=crain_aero) from SPECIES file
+ wetscav=crain_aero(ks)*10**(bclr(1)+(bclr(2)*(log10(dquer_m))**(-4))+ &
+ & (bclr(3)*(log10(dquer_m))**(-3))+ (bclr(4)*(log10(dquer_m))**(-2))+&
+ &(bclr(5)*(log10(dquer_m))**(-1))+bclr(6)* (prec(1))**(0.5))
+
+ ! Snow:
+ elseif (act_temp .lt. 273. .and. csnow_aero(ks).gt.0.) then
+ ! ZHG 2014 : Particle SNOW scavenging coefficient based on Kyro et al 2009,
+ ! the below-cloud scavenging (Snow efficiency) parameter Csnow (=csnow_aero) from SPECIES file
+ wetscav=csnow_aero(ks)*10**(bcls(1)+(bcls(2)*(log10(dquer_m))**(-4))+&
+ &(bcls(3)*(log10(dquer_m))**(-3))+ (bcls(4)*(log10(dquer_m))**(-2))+&
+ &(bcls(5)*(log10(dquer_m))**(-1))+ bcls(6)* (prec(1))**(0.5))
+
+ endif
+
+ endif ! gas or particle
+ ! endif ! positive below-cloud scavenging parameters given in Species file
+ endif !end BELOW
+
+ !********************
+ ! IN CLOUD SCAVENGING
+ !********************
+ if (clouds_v.lt.4) then ! In-cloud
+ ! NIK 13 may 2015: only do incloud if positive in-cloud scavenging parameters are
+ ! given in species file, or if gas and positive Henry's constant
+ if ((ccn_aero(ks).gt.0. .or. in_aero(ks).gt.0.).or.(henry(ks).gt.0.and.dquer(ks).le.0)) then
+ inc_count(ks)=inc_count(ks)+1
+ ! if negative coefficients (turned off) set to zero for use in equation
+ if (ccn_aero(ks).lt.0.) ccn_aero(ks)=0.
+ if (in_aero(ks).lt.0.) in_aero(ks)=0.
+
+ !ZHG 2015 Cloud liquid & ice water (CLWC+CIWC) from ECMWF
+ ! nested fields
+ if (ngrid.gt.0.and.readclouds_this_nest) then
+ cl=ctwcn(ix,jy,n,ngrid)*(grfraction(1)/cc)
+ else if (ngrid.eq.0.and.readclouds) then
+ ! cl=ctwc(ix,jy,n)*(grfraction(1)/cc)
+ ! A.Plach 2021 cl should not become too small
+ cl=max(1E6*2E-7*prec(1)**0.36, ctwc(ix,jy,n)*(grfraction(1)/cc))
+ else !parameterize cloudwater m2/m3
+ !ZHG updated parameterization of cloud water to better reproduce the values coming from ECMWF
+ ! sec test
+ ! cl=1E6*1E-7*prec(1)**0.3 !Sec GFS new
+ cl=1E6*2E-7*prec(1)**0.36 !Sec ECMWF new, is also suitable for GFS
+ ! cl=2E-7*prec(1)**0.36 !Andreas
+ ! cl=1.6E-6*prec(1)**0.36 !Henrik
+ endif
+
+ !ZHG: Calculate the partition between liquid and water phase water.
+ if (act_temp .le. 253.) then
+ liq_frac=0
+ ice_frac=1
+ else if (act_temp .ge. 273.) then
+ liq_frac=1
+ ice_frac=0
+ else
+ ! sec bugfix after FLEXPART paper review, liq_frac was 1-liq_frac
+ ! IP bugfix v10.4, calculate ice_frac and liq_frac
+ ice_frac= ((act_temp-273.)/(273.-253.))**2.
+ !liq_frac = 1-ice_frac !((act_temp-253.)/(273.-253.))**2.
+ liq_frac=max(0.,1.-ice_frac)
+ end if
+ ! ZHG: Calculate the aerosol partition based on cloud phase and Ai and Bi
+ ! frac_act = liq_frac*ccn_aero(ks) +(1-liq_frac)*in_aero(ks)
+ ! IP, use ice_frac and liq_frac
+ frac_act = liq_frac*ccn_aero(ks) + ice_frac*in_aero(ks)
+
+ !ZHG Use the activated fraction and the liqid water to calculate the washout
+
+ ! AEROSOL
+ !********
+ if (dquer(ks).gt.0.) then
+ S_i= frac_act/cl
+ ! GAS
+ !****
+ else
+ cle=(1-cl)/(henry(ks)*(r_air/3500.)*act_temp)+cl
+ S_i=1/cle
+ endif ! gas or particle
+
+ ! scavenging coefficient based on Hertel et al 1995 - using the S_i for either gas or aerosol
+ !SEC wetscav fix, the cloud height is no longer needed, it gives wrong results
+ wetscav=incloud_ratio*S_i*(prec(1)/3.6E6)
+ endif ! positive in-cloud scavenging parameters given in Species file
+ endif !incloud
+end subroutine get_wetscav
+
+subroutine wetdepokernel(nunc,deposit,x,y,nage,kp,thread)
+ ! i i i i i
+ !*****************************************************************************
+ ! *
+ ! Attribution of the deposition from an individual particle to the *
+ ! deposition fields using a uniform kernel with bandwidths dxout and dyout.*
+ ! *
+ ! Author: A. Stohl *
+ ! *
+ ! 26 December 1996 *
+ ! *
+ !*****************************************************************************
+ ! *
+ ! Variables: *
+ ! *
+ ! nunc uncertainty class of the respective particle *
+ ! nage age class of the respective particle *
+ ! deposit amount (kg) to be deposited *
+ ! *
+ !*****************************************************************************
+ ! Changes:
+ ! eso 10/2016: Added option to disregard kernel
+ !
+ !*****************************************************************************
+
+ use unc_mod
+
+ implicit none
+
+ integer,intent(in) :: thread
+ real :: x,y,deposit(maxspec),ddx,ddy,xl,yl,wx,wy,w
+ integer :: ix,jy,ixp,jyp,nunc,nage,ks,kp
+
+ xl=(x*dx+xoutshift)/dxout
+ yl=(y*dy+youtshift)/dyout
+ ix=int(xl)
+ jy=int(yl)
+ ddx=xl-real(ix) ! distance to left cell border
+ ddy=yl-real(jy) ! distance to lower cell border
+
+ if (ddx.gt.0.5) then
+ ixp=ix+1
+ wx=1.5-ddx
+ else
+ ixp=ix-1
+ wx=0.5+ddx
+ endif
+
+ if (ddy.gt.0.5) then
+ jyp=jy+1
+ wy=1.5-ddy
+ else
+ jyp=jy-1
+ wy=0.5+ddy
+ endif
+
+ ! If no kernel is used, direct attribution to grid cell
+ !******************************************************
+
+ if (.not.lusekerneloutput) then
+ do ks=1,nspec
+ if ((ix.ge.0).and.(jy.ge.0).and.(ix.le.numxgrid-1).and. &
+ (jy.le.numygrid-1)) then
+#ifdef _OPENMP
+ gridunc_omp(ix,jy,1,ks,kp,nunc,nage,thread)= &
+ gridunc_omp(ix,jy,1,ks,kp,nunc,nage,thread)+deposit(ks)
+#else
+ wetgridunc(ix,jy,ks,kp,nunc,nage)= &
+ wetgridunc(ix,jy,ks,kp,nunc,nage)+deposit(ks)
+#endif
+ end if
+ end do
+ else ! use kernel
+
+ ! Determine mass fractions for four grid points
+ !**********************************************
+
+ do ks=1,nspec
+
+ if ((ix.ge.0).and.(jy.ge.0).and.(ix.le.numxgrid-1).and. &
+ (jy.le.numygrid-1)) then
+ w=wx*wy
+#ifdef _OPENMP
+ gridunc_omp(ix,jy,1,ks,kp,nunc,nage,thread)= &
+ gridunc_omp(ix,jy,1,ks,kp,nunc,nage,thread)+deposit(ks)*w
+#else
+ wetgridunc(ix,jy,ks,kp,nunc,nage)= &
+ wetgridunc(ix,jy,ks,kp,nunc,nage)+deposit(ks)*w
+#endif
+ endif
+
+ if ((ixp.ge.0).and.(jyp.ge.0).and.(ixp.le.numxgrid-1).and. &
+ (jyp.le.numygrid-1)) then
+ w=(1.-wx)*(1.-wy)
+#ifdef _OPENMP
+ gridunc_omp(ixp,jyp,1,ks,kp,nunc,nage,thread)= &
+ gridunc_omp(ixp,jyp,1,ks,kp,nunc,nage,thread)+deposit(ks)*w
+#else
+ wetgridunc(ixp,jyp,ks,kp,nunc,nage)= &
+ wetgridunc(ixp,jyp,ks,kp,nunc,nage)+deposit(ks)*w
+#endif
+ endif
+
+ if ((ixp.ge.0).and.(jy.ge.0).and.(ixp.le.numxgrid-1).and. &
+ (jy.le.numygrid-1)) then
+ w=(1.-wx)*wy
+#ifdef _OPENMP
+ gridunc_omp(ixp,jy,1,ks,kp,nunc,nage,thread)= &
+ gridunc_omp(ixp,jy,1,ks,kp,nunc,nage,thread)+deposit(ks)*w
+#else
+ wetgridunc(ixp,jy,ks,kp,nunc,nage)= &
+ wetgridunc(ixp,jy,ks,kp,nunc,nage)+deposit(ks)*w
+#endif
+ endif
+
+ if ((ix.ge.0).and.(jyp.ge.0).and.(ix.le.numxgrid-1).and. &
+ (jyp.le.numygrid-1)) then
+ w=wx*(1.-wy)
+#ifdef _OPENMP
+ gridunc_omp(ix,jyp,1,ks,kp,nunc,nage,thread)= &
+ gridunc_omp(ix,jyp,1,ks,kp,nunc,nage,thread)+deposit(ks)*w
+#else
+ wetgridunc(ix,jyp,ks,kp,nunc,nage)= &
+ wetgridunc(ix,jyp,ks,kp,nunc,nage)+deposit(ks)*w
+#endif
+ endif
+
+ end do
+ end if
+end subroutine wetdepokernel
+
+subroutine wetdepokernel_nest(nunc,deposit,x,y,nage,kp,thread)
+ ! i i i i i i
+ !*****************************************************************************
+ ! *
+ ! Attribution of the deposition from an individual particle to the *
+ ! nested deposition fields using a uniform kernel with bandwidths *
+ ! dxoutn and dyoutn. *
+ ! *
+ ! Author: A. Stohl *
+ ! *
+ ! 26 December 1996 *
+ ! *
+ ! 2 September 2004: Adaptation from wetdepokernel. *
+ ! *
+ ! *
+ !*****************************************************************************
+ ! *
+ ! Variables: *
+ ! *
+ ! nunc uncertainty class of the respective particle *
+ ! nage age class of the respective particle *
+ ! deposit amount (kg) to be deposited *
+ ! *
+ !*****************************************************************************
+
+ use unc_mod
+
+ implicit none
+
+ integer,intent(in) :: thread
+ real :: x,y,deposit(maxspec),ddx,ddy,xl,yl,wx,wy,w
+ integer :: ix,jy,ixp,jyp,ks,kp,nunc,nage
+
+ xl=(x*dx+xoutshiftn)/dxoutn
+ yl=(y*dy+youtshiftn)/dyoutn
+
+ ! old:
+ ! ix=int(xl)
+ ! jy=int(yl)
+
+ ! ESO: for xl,yl in range <-.5,-1> we get ix,jy=0 and thus negative
+ ! wx,wy as the int function rounds upwards for negative numbers.
+ ! Either use the floor function, or (perhaps more correctly?) use "(xl.gt.-0.5)"
+ ! in place of "(ix.ge.0)" and similar for the upper boundary.
+
+ ! new:
+ ix=floor(xl)
+ jy=floor(yl)
+
+ ddx=xl-real(ix) ! distance to left cell border
+ ddy=yl-real(jy) ! distance to lower cell border
+
+
+ if (ddx.gt.0.5) then
+ ixp=ix+1
+ wx=1.5-ddx
+ else
+ ixp=ix-1
+ wx=0.5+ddx
+ endif
+
+ if (ddy.gt.0.5) then
+ jyp=jy+1
+ wy=1.5-ddy
+ else
+ jyp=jy-1
+ wy=0.5+ddy
+ endif
+
+ ! Determine mass fractions for four grid points
+ !**********************************************
+
+ do ks=1,nspec
+ if ((ix.ge.0).and.(jy.ge.0).and.(ix.le.numxgridn-1).and. &
+ (jy.le.numygridn-1)) then
+ w=wx*wy
+#ifdef _OPENMP
+ griduncn_omp(ix,jy,1,ks,kp,nunc,nage,thread)= &
+ griduncn_omp(ix,jy,1,ks,kp,nunc,nage,thread)+deposit(ks)*w
+#else
+ wetgriduncn(ix,jy,ks,kp,nunc,nage)= &
+ wetgriduncn(ix,jy,ks,kp,nunc,nage)+deposit(ks)*w
+#endif
+ endif
+
+ if ((ixp.ge.0).and.(jyp.ge.0).and.(ixp.le.numxgridn-1).and. &
+ (jyp.le.numygridn-1)) then
+ w=(1.-wx)*(1.-wy)
+#ifdef _OPENMP
+ griduncn_omp(ixp,jyp,1,ks,kp,nunc,nage,thread)= &
+ griduncn_omp(ixp,jyp,1,ks,kp,nunc,nage,thread)+deposit(ks)*w
+#else
+ wetgriduncn(ixp,jyp,ks,kp,nunc,nage)= &
+ wetgriduncn(ixp,jyp,ks,kp,nunc,nage)+deposit(ks)*w
+#endif
+ endif
+
+ if ((ixp.ge.0).and.(jy.ge.0).and.(ixp.le.numxgridn-1).and. &
+ (jy.le.numygridn-1)) then
+ w=(1.-wx)*wy
+#ifdef _OPENMP
+ griduncn_omp(ixp,jy,1,ks,kp,nunc,nage,thread)= &
+ griduncn_omp(ixp,jy,1,ks,kp,nunc,nage,thread)+deposit(ks)*w
+#else
+ wetgriduncn(ixp,jy,ks,kp,nunc,nage)= &
+ wetgriduncn(ixp,jy,ks,kp,nunc,nage)+deposit(ks)*w
+#endif
+ endif
+
+ if ((ix.ge.0).and.(jyp.ge.0).and.(ix.le.numxgridn-1).and. &
+ (jyp.le.numygridn-1)) then
+ w=wx*(1.-wy)
+#ifdef _OPENMP
+ griduncn_omp(ix,jyp,1,ks,kp,nunc,nage,thread)= &
+ griduncn_omp(ix,jyp,1,ks,kp,nunc,nage,thread)+deposit(ks)*w
+#else
+ wetgriduncn(ix,jyp,ks,kp,nunc,nage)= &
+ wetgriduncn(ix,jyp,ks,kp,nunc,nage)+deposit(ks)*w
+#endif
+ endif
+
+ end do
+end subroutine wetdepokernel_nest
+
+subroutine writeprecip(itime,imem)
+
+ !*****************************************************************************
+ ! *
+ ! This routine produces a file containing total precipitation for each *
+ ! releases point. *
+ ! *
+ ! Author: S. Eckhardt *
+ ! 7 Mai 2017 *
+ !*****************************************************************************
+
+ use point_mod
+ use par_mod
+ use com_mod
+ use date_mod
+ use windfields_mod
+
+ implicit none
+
+ integer :: jjjjmmdd,ihmmss,itime,i
+ real(kind=dp) :: jul
+ character :: adate*8,atime*6
+
+ integer :: ix,jy,imem
+ real :: xp1,yp1
+
+
+ if (itime.eq.0) then
+ open(unitprecip,file=path(2)(1:length(2))//'wetscav_precip.txt', &
+ form='formatted',err=998)
+ else
+ open(unitprecip,file=path(2)(1:length(2))//'wetscav_precip.txt', &
+ ACCESS='APPEND',form='formatted',err=998)
+ endif
+
+ jul=bdate+real(itime,kind=dp)/86400._dp
+ call caldate(jul,jjjjmmdd,ihmmss)
+ write(adate,'(i8.8)') jjjjmmdd
+ write(atime,'(i6.6)') ihmmss
+
+ do i=1,numpoint
+ xp1=xpoint1(i)*dx+xlon0 !lat, long (real) coord
+ yp1=ypoint1(i)*dy+ylat0 !lat, long (real) coord
+ ix=int((xpoint1(i)+xpoint2(i))/2.)
+ jy=int((ypoint1(i)+ypoint2(i))/2.)
+ write(unitprecip,*) jjjjmmdd, ihmmss, &
+ xp1,yp1,lsprec(ix,jy,1,imem),convprec(ix,jy,1,imem) !time is the same as in the ECMWF windfield
+! units mm/h, valid for the time given in the windfield
+ end do
+
+ close(unitprecip)
+
+ return
+
+
+998 write(*,*) ' #### FLEXPART MODEL ERROR! THE FILE #### '
+ write(*,*) ' #### '//path(2)(1:length(2))//'header_txt'//' #### '
+ write(*,*) ' #### CANNOT BE OPENED. IF A FILE WITH THIS #### '
+ write(*,*) ' #### NAME ALREADY EXISTS, DELETE IT AND START #### '
+ write(*,*) ' #### THE PROGRAM AGAIN. #### '
+ stop
+end subroutine writeprecip
+
+end module wetdepo_mod
diff --git a/src/windfields_mod.f90 b/src/windfields_mod.f90
new file mode 100644
index 00000000..fce83819
--- /dev/null
+++ b/src/windfields_mod.f90
@@ -0,0 +1,4007 @@
+! SPDX-FileCopyrightText: FLEXPART 1998-2019, see flexpart_license.txt
+! SPDX-License-Identifier: GPL-3.0-or-later
+
+ !*****************************************************************************
+ ! *
+ ! This module stores all meteorological input data and contains routines *
+ ! reading and allocating this data *
+ ! *
+ ! L. Bakels 2021 *
+ ! *
+ !*****************************************************************************
+
+module windfields_mod
+ use par_mod
+ use com_mod
+ use point_mod
+ use pbl_profile_mod
+
+ implicit none
+
+ !******************************************************************************
+ ! Variables associated with the ECMWF meteorological input data ("wind fields")
+ !******************************************************************************
+
+ integer :: &
+ numbwf, & ! actual number of wind fields
+ wftime(maxwf) ! times relative to beginning time of wind fields [s]
+
+ character(len=255) :: &
+ wfname(maxwf), & ! file names of wind fields
+ wfspec(maxwf) ! specifications of wind field file, e.g. if on hard
+
+ ! Nested equivalents
+ !*******************
+ character(len=255),allocatable,dimension(:,:) :: &
+ wfnamen ! nested wind field names
+ character(len=18),allocatable,dimension(:,:) :: &
+ wfspecn ! specifications of wind field file, e.g. if on hard
+ ! disc or on tape
+
+ !Windfield parameters
+ !********************
+ !integer :: nxmax,nymax,nuvzmax,nwzmax,nzmax !Size of windfield
+
+ ! Fixed fields, unchangeable with time
+ !*************************************
+ real, allocatable,dimension(:,:) :: &
+ oro, & ! orography of the ECMWF model
+ excessoro, & ! excess orography mother domain
+ lsm ! land sea mask of the ECMWF model
+
+ ! Nested fields, unchangeable with time
+ !**************************************
+ real, allocatable,dimension(:,:,:) :: &
+ oron, & ! orography of the ECMWF model
+ excessoron, & ! excess orography mother domain
+ lsmn ! land sea mask of the ECMWF model
+
+ ! 3d fields necessary for eta coordinates option
+ !************************************************
+ real, allocatable,dimension(:,:,:,:) :: &
+ uueta,vveta, & ! wind components on half model levels in x and y direction [m/s]
+ wweta, & ! wind component on model levels in z direction [eta/s]
+ uupoleta,vvpoleta, & ! wind components on half model levels in polar stereographic projection [m/s]
+ tteta, & ! temperature data on half model levels [K]
+ pveta, & ! potential vorticity on half model levels
+ rhoeta, & ! air density on half model levels [kg/m3]
+ prseta, & ! air pressure on half model levels
+ drhodzeta, & ! vertical air density gradient on half model levels [kg/m2]
+ !tvirtual, & ! Virtual temperature on half model levels
+ etauvheight,etawheight ! Saved half model and model heights for ETA coordinate system [m]
+
+ ! 3d fields
+ !**********
+ real, allocatable,dimension(:,:,:,:) :: &
+ uu,vv,ww, & ! wind components in x,y and z direction [m/s]
+ uupol,vvpol, & ! wind components in polar stereographic projection [m/s]
+ tt,tth, & ! temperature data on internal and half model levels [K]
+ qv,qvh, & ! specific humidity data on internal and half model levels
+ pv, & ! potential vorticity
+ rho, & ! air density [kg/m3]
+ drhodz, & ! vertical air density gradient [kg/m2]
+ pplev, & ! Pressure on half model levels
+ prs, & ! air pressure RLT
+ rho_dry ! dry air density RLT Only printed out in binary mode???
+
+ ! Cloud properties
+ ! clouds: no cloud, no precipitation 0
+ ! cloud, no precipitation 1
+ ! rainout conv/lsp dominated 2/3
+ ! washout conv/lsp dominated 4/5
+ ! PS 2013
+ !*****************************************
+ real, allocatable,dimension(:,:,:,:) :: &
+ clwc, & ! liquid [kg/kg] ZHG
+ ciwc, & ! ice [kg/kg] ZHG
+ clw, & ! combined [m3/m3] ZHG
+ clwch, & ! original eta level liquid [kg/kg] ZHG
+ ciwch ! original eta level ice [kg/kg] ZHG
+ real, allocatable,dimension(:,:,:) :: &
+ ctwc ! ESO: =icloud_stats(:,:,4,:) total cloud water content
+ integer(kind=1),allocatable,dimension(:,:,:,:) :: &
+ clouds ! scavenging NIK, PS
+ integer,allocatable,dimension(:,:,:) :: &
+ cloudsh ! scavenging NIK, PS
+
+ ! 3d nested fields
+ !*****************
+ real,allocatable,dimension(:,:,:,:,:) :: &
+ uun, vvn, wwn, & ! wind components in x,y and z direction [m/s]
+ ttn, tthn, & ! temperature data on internal and half model levels [K]
+ qvn, qvhn, & ! specific humidity data on internal and half model levels
+ pvn, & ! potential vorticity
+ rhon, & ! air density [kg/m3]
+ prsn, & ! air pressure RLT
+ drhodzn ! vertical air density gradient [kg/m2]
+
+ ! ETA equivalents
+ real,allocatable,dimension(:,:,:,:,:) :: &
+ uuetan,vvetan, & ! wind components on half model levels in x and y direction [m/s]
+ wwetan, & ! wind component on model levels in z direction [eta/s]
+ ttetan, & ! temperature data on half model levels [K]
+ pvetan, & ! potential vorticity on half model levels
+ rhoetan, & ! air density on half model levels [kg/m3]
+ prsetan, & ! air pressure on half model levels
+ drhodzetan, & ! vertical air density gradient on half model levels [kg/m2]
+ !tvirtualn, & ! Virtual temperature on half model levels
+ etauvheightn,etawheightn ! Saved half model and model heights for ETA coordinate system [m]
+
+
+ ! Nested cloud properties
+ real,allocatable,dimension(:,:,:,:,:) :: &
+ clwcn, & ! liquid [kg/kg] ZHG
+ ciwcn, & ! ice [kg/kg] ZHG
+ clwn, & ! combined [m3/m3] ZHG
+ clwchn, & ! original eta level liquid [kg/kg] ZHG
+ ciwchn ! original eta level ice [kg/kg] ZHG
+ real,allocatable,dimension(:,:,:,:) :: &
+ ctwcn ! ESO: =icloud_stats(:,:,4,:) total cloud water content
+ integer(kind=1),allocatable,dimension(:,:,:,:,:) :: &
+ cloudsn ! scavenging NIK, PS
+ integer,allocatable,dimension(:,:,:,:) :: &
+ cloudshn ! scavenging NIK, PS
+
+ ! 2d fields
+ !**********
+ real, allocatable,dimension(:,:,:,:) :: &
+ ps, & ! surface pressure
+ sd, & ! snow depth
+ msl, & ! mean sea level pressure
+ tcc, & ! total cloud cover
+ u10, & ! 10 meter u
+ v10, & ! 10 meter v
+ tt2, & ! 2 meter temperature
+ td2, & ! 2 meter dew point
+ lsprec, & ! large scale total precipitation [mm/h]
+ convprec, & ! convective precipitation [mm/h]
+ sshf, & ! surface sensible heat flux
+ ssr, & ! surface solar radiation
+ surfstr, & ! surface stress
+ ustar, & ! friction velocity [m/s]
+ wstar, & ! convective velocity scale [m/s]
+ hmix, & ! mixing height [m]
+ tropopause, & ! altitude of thermal tropopause [m]
+ oli ! inverse Obukhov length (1/L) [m]
+
+ ! 2d nested fields
+ !*******************
+ real, allocatable,dimension(:,:,:,:,:) :: &
+ psn, & ! surface pressure
+ sdn, & ! snow depth
+ msln, & ! mean sea level pressure
+ tccn, & ! total cloud cover
+ u10n, & ! 10 meter u
+ v10n, & ! 10 meter v
+ tt2n, & ! 2 meter temperature
+ td2n, & ! 2 meter dew point
+ lsprecn, & ! large scale total precipitation [mm/h]
+ convprecn, & ! convective precipitation [mm/h]
+ sshfn, & ! surface sensible heat flux
+ ssrn, & ! surface solar radiation
+ surfstrn, & ! surface stress
+ ustarn, & ! friction velocity [m/s]
+ wstarn, & ! convective velocity scale [m/s]
+ hmixn, & ! mixing height [m]
+ tropopausen, & ! altitude of thermal tropopause [m]
+ olin, & ! inverse Obukhov length (1/L) [m]
+ vdepn !
+
+ integer :: metdata_format ! storing the input data type (ECMWF/NCEP)
+
+ !****************************************************************************
+ ! Variables defining actual size and geographical location of the wind fields
+ !****************************************************************************
+
+ integer :: &
+ nx,ny,nz, & ! actual dimensions of wind fields in x,y and z direction, respectively
+ nxmin1, & ! nx-1
+ nymin1, & ! ny-1
+ nxfield, & ! same as nx for limited area fields, but for global fields nx=nxfield+1
+ nuvz,nwz, & ! vertical dimension of original ECMWF data (u,v components/ w components(staggered grid))
+ nmixz, & ! number of levels up to maximum PBL height (3500 m)
+ nlev_ec ! number of levels ECMWF model
+ real :: &
+ dxconst, & ! auxiliary variables for utransform
+ dyconst ! auxiliary variables for vtransform
+ ! integer :: nconvlevmax !maximum number of levels for convection
+ ! integer :: na ! parameter used in Emanuel's convect subroutine
+
+ !*************************************************
+ ! Variables used for vertical model discretization
+ !*************************************************
+ real,allocatable,dimension(:) :: &
+ height, & ! heights of all levels [m]
+ wheight, & ! model level heights [m]
+ uvheight, & ! half-model level heights [m]
+ akm,bkm, & ! coefficients which regulate vertical discretization of ecmwf model levels
+ akz,bkz, & ! model discretization coefficients at the centre of the layers
+ aknew,bknew ! model discretization coefficients at the interpolated levels
+
+ !*********************************************************************
+ ! Variables characterizing size and location of the nested wind fields
+ !*********************************************************************
+
+ integer,allocatable,dimension(:) :: &
+ nxn,nyn ! actual dimensions of nested wind fields in x and y direction
+ real,allocatable,dimension(:) :: &
+ dxn,dyn, & ! grid distances in x,y direction for the nested grids
+ xlon0n, & ! geographical longitude of lower left grid point of nested wind fields
+ ylat0n ! geographical latitude of lower left grid point of nested wind fields
+
+ !*************************************************
+ ! Certain auxiliary variables needed for the nests
+ !*************************************************
+
+ real,allocatable,dimension(:) :: &
+ xresoln,yresoln, & ! Factors by which the resolutions in the nests
+ ! are enhanced compared to mother grid
+ xln,yln,xrn,yrn ! Corner points of nested grids in grid coordinates of mother grid
+
+contains
+
+subroutine detectformat
+
+ !*****************************************************************************
+ ! *
+ ! This routine reads the 1st file with windfields to determine *
+ ! the format. *
+ ! *
+ ! Authors: M. Harustak *
+ ! *
+ ! 6 May 2015 *
+ ! *
+ ! Unified ECMWF and GFS builds *
+ ! Marian Harustak, 12.5.2017 *
+ ! - Added routine to FP10 Flexpart distribution *
+ !*****************************************************************************
+ ! *
+ ! Variables: *
+ ! fname file name of file to check *
+ ! *
+ !*****************************************************************************
+
+ use par_mod
+ use com_mod
+ use class_gribfile
+
+
+ implicit none
+
+ character(len=255) :: filename
+ character(len=255) :: wfname1(maxwf)
+
+ ! If no file is available
+ if ( maxwf.le.0 ) then
+ print*,'No wind file available'
+ metdata_format = GRIBFILE_CENTRE_UNKNOWN
+ return
+ endif
+
+ ! construct filename
+ filename = path(3)(1:length(3)) // trim(wfname(1))
+
+ ! get format
+ metdata_format = gribfile_centre(TRIM(filename))
+end subroutine detectformat
+
+subroutine gridcheck_ecmwf
+
+ !**********************************************************************
+ ! *
+ ! FLEXPART MODEL SUBROUTINE GRIDCHECK *
+ ! *
+ !**********************************************************************
+ ! *
+ ! AUTHOR: G. WOTAWA *
+ ! DATE: 1997-08-06 *
+ ! LAST UPDATE: 1997-10-10 *
+ ! *
+ ! Update: 1999-02-08, global fields allowed, A. Stohl*
+ ! CHANGE: 11/01/2008, Harald Sodemann, GRIB1/2 input with *
+ ! ECMWF grib_api *
+ ! CHANGE: 03/12/2008, Harald Sodemann, update to f90 with *
+ ! ECMWF grib_api *
+ ! *
+ ! Unified ECMWF and GFS builds *
+ ! Marian Harustak, 12.5.2017 *
+ ! - Renamed from gridcheck to gridcheck_ecmwf *
+ ! *
+ !**********************************************************************
+ ! *
+ ! DESCRIPTION: *
+ ! *
+ ! THIS SUBROUTINE DETERMINES THE GRID SPECIFICATIONS (LOWER LEFT *
+ ! LONGITUDE, LOWER LEFT LATITUDE, NUMBER OF GRID POINTS, GRID DIST- *
+ ! ANCE AND VERTICAL DISCRETIZATION OF THE ECMWF MODEL) FROM THE *
+ ! GRIB HEADER OF THE FIRST INPUT FILE. THE CONSISTANCY (NO CHANGES *
+ ! WITHIN ONE FLEXPART RUN) IS CHECKED IN THE ROUTINE "READWIND" AT *
+ ! ANY CALL. *
+ ! *
+ ! XLON0 geographical longitude of lower left gridpoint *
+ ! YLAT0 geographical latitude of lower left gridpoint *
+ ! NX number of grid points x-direction *
+ ! NY number of grid points y-direction *
+ ! DX grid distance x-direction *
+ ! DY grid distance y-direction *
+ ! NUVZ number of grid points for horizontal wind *
+ ! components in z direction *
+ ! NWZ number of grid points for vertical wind *
+ ! component in z direction *
+ ! sizesouth, sizenorth give the map scale (i.e. number of virtual grid*
+ ! points of the polar stereographic grid): *
+ ! used to check the CFL criterion *
+ ! UVHEIGHT(1)- heights of gridpoints where u and v are *
+ ! UVHEIGHT(NUVZ) given *
+ ! WHEIGHT(1)- heights of gridpoints where w is given *
+ ! WHEIGHT(NWZ) *
+ ! *
+ !**********************************************************************
+
+ use grib_api
+ use cmapf_mod, only: stlmbr,stcm2p
+
+ implicit none
+
+ !HSO parameters for grib_api
+ integer :: ifile
+ integer :: iret
+ integer :: igrib
+ integer :: gotGrid
+ real(kind=4) :: xaux1,xaux2,yaux1,yaux2
+ real(kind=8) :: xaux1in,xaux2in,yaux1in,yaux2in
+ integer :: gribVer,parCat,parNum,typSurf,valSurf,discipl,parId
+ !HSO end
+ integer :: ix,jy,i,ifn,ifield,j,k,iumax,iwmax,numskip
+ real :: sizesouth,sizenorth,xauxa,conversion_factor
+
+ ! VARIABLES AND ARRAYS NEEDED FOR GRIB DECODING
+
+ ! dimension of isec2 at least (22+n), where n is the number of parallels or
+ ! meridians in a quasi-regular (reduced) Gaussian or lat/long grid
+
+ ! dimension of zsec2 at least (10+nn), where nn is the number of vertical
+ ! coordinate parameters
+
+ integer :: isec1(56),isec2(22+nxmax+nymax)
+ real(kind=4) :: zsec2(60+2*nuvzmax),zsec4(jpunp)
+ character(len=1) :: opt
+
+ !HSO grib api error messages
+ character(len=24) :: gribErrorMsg = 'Error reading grib file'
+ character(len=20) :: gribFunction = 'gridcheck'
+
+
+ iumax=0
+ iwmax=0
+
+ if(ideltas.gt.0) then
+ ifn=1
+ else
+ ifn=numbwf
+ endif
+ !
+ ! OPENING OF DATA FILE (GRIB CODE)
+ !
+5 call grib_open_file(ifile,path(3)(1:length(3)) &
+ //trim(wfname(ifn)),'r',iret)
+ if (iret.ne.GRIB_SUCCESS) then
+ goto 999 ! ERROR DETECTED
+ endif
+ !turn on support for multi fields messages
+ !call grib_multi_support_on
+
+ gotGrid=0
+ ifield=0
+ do while(.true.)
+ ifield=ifield+1
+ !
+ ! GET NEXT FIELDS
+ !
+ call grib_new_from_file(ifile,igrib,iret)
+ if (iret.eq.GRIB_END_OF_FILE ) then
+ exit ! EOF DETECTED
+ elseif (iret.ne.GRIB_SUCCESS) then
+ goto 999 ! ERROR DETECTED
+ endif
+
+ !first see if we read GRIB1 or GRIB2
+ call grib_get_int(igrib,'editionNumber',gribVer,iret)
+ call grib_check(iret,gribFunction,gribErrorMsg)
+
+ if (gribVer.eq.1) then ! GRIB Edition 1
+
+ !print*,'GRiB Edition 1'
+ !read the grib2 identifiers
+ call grib_get_int(igrib,'indicatorOfParameter',isec1(6),iret)
+ call grib_check(iret,gribFunction,gribErrorMsg)
+ call grib_get_int(igrib,'level',isec1(8),iret)
+ call grib_check(iret,gribFunction,gribErrorMsg)
+
+ !change code for etadot to code for omega
+ if (isec1(6).eq.77) then
+ isec1(6)=135
+ endif
+
+ !print*,isec1(6),isec1(8)
+
+ else
+
+ !print*,'GRiB Edition 2'
+ !read the grib2 identifiers
+ call grib_get_int(igrib,'discipline',discipl,iret)
+ call grib_check(iret,gribFunction,gribErrorMsg)
+ call grib_get_int(igrib,'parameterCategory',parCat,iret)
+ call grib_check(iret,gribFunction,gribErrorMsg)
+ call grib_get_int(igrib,'parameterNumber',parNum,iret)
+ call grib_check(iret,gribFunction,gribErrorMsg)
+ call grib_get_int(igrib,'typeOfFirstFixedSurface',typSurf,iret)
+ call grib_check(iret,gribFunction,gribErrorMsg)
+ call grib_get_int(igrib,'level',valSurf,iret)
+ call grib_check(iret,gribFunction,gribErrorMsg)
+ call grib_get_int(igrib,'paramId',parId,iret)
+ call grib_check(iret,gribFunction,gribErrorMsg)
+
+ !print*,discipl,parCat,parNum,typSurf,valSurf
+
+ !convert to grib1 identifiers
+ isec1(6)=-1
+ isec1(7)=-1
+ isec1(8)=-1
+ isec1(8)=valSurf ! level
+ if ((parCat.eq.0).and.(parNum.eq.0).and.(typSurf.eq.105)) then ! T
+ isec1(6)=130 ! indicatorOfParameter
+ elseif ((parCat.eq.2).and.(parNum.eq.2).and.(typSurf.eq.105)) then ! U
+ isec1(6)=131 ! indicatorOfParameter
+ elseif ((parCat.eq.2).and.(parNum.eq.3).and.(typSurf.eq.105)) then ! V
+ isec1(6)=132 ! indicatorOfParameter
+ elseif ((parCat.eq.1).and.(parNum.eq.0).and.(typSurf.eq.105)) then ! Q
+ isec1(6)=133 ! indicatorOfParameter
+ !ZHG FOR CLOUDS FROM GRIB
+ elseif ((parCat.eq.1).and.(parNum.eq.83).and.(typSurf.eq.105)) then ! clwc
+ isec1(6)=246 ! indicatorOfParameter
+ elseif ((parCat.eq.1).and.(parNum.eq.84).and.(typSurf.eq.105)) then ! ciwc
+ isec1(6)=247 ! indicatorOfParameter
+ !ZHG end
+ ! ESO qc(=clwc+ciwc)
+ elseif ((parCat.eq.201).and.(parNum.eq.31).and.(typSurf.eq.105)) then ! qc
+ isec1(6)=201031 ! indicatorOfParameter
+ elseif ((parCat.eq.3).and.(parNum.eq.0).and.(typSurf.eq.1)) then !SP
+ isec1(6)=134 ! indicatorOfParameter
+ elseif ((parCat.eq.2).and.(parNum.eq.32)) then ! W, actually eta dot
+ isec1(6)=135 ! indicatorOfParameter
+ elseif ((parCat.eq.128).and.(parNum.eq.77)) then ! W, actually eta dot
+ isec1(6)=135 ! indicatorOfParameter
+ elseif ((parCat.eq.3).and.(parNum.eq.0).and.(typSurf.eq.101)) then !SLP
+ isec1(6)=151 ! indicatorOfParameter
+ elseif ((parCat.eq.2).and.(parNum.eq.2).and.(typSurf.eq.103)) then ! 10U
+ isec1(6)=165 ! indicatorOfParameter
+ elseif ((parCat.eq.2).and.(parNum.eq.3).and.(typSurf.eq.103)) then ! 10V
+ isec1(6)=166 ! indicatorOfParameter
+ elseif ((parCat.eq.0).and.(parNum.eq.0).and.(typSurf.eq.103)) then ! 2T
+ isec1(6)=167 ! indicatorOfParameter
+ elseif ((parCat.eq.0).and.(parNum.eq.6).and.(typSurf.eq.103)) then ! 2D
+ isec1(6)=168 ! indicatorOfParameter
+ elseif ((parCat.eq.1).and.(parNum.eq.11).and.(typSurf.eq.1)) then ! SD
+ isec1(6)=141 ! indicatorOfParameter
+ elseif ((parCat.eq.6).and.(parNum.eq.1) .or. parId .eq. 164) then ! CC
+ isec1(6)=164 ! indicatorOfParameter
+ elseif ((parCat.eq.1).and.(parNum.eq.9) .or. parId .eq. 142) then ! LSP
+ isec1(6)=142 ! indicatorOfParameter
+ elseif ((parCat.eq.1).and.(parNum.eq.10)) then ! CP
+ isec1(6)=143 ! indicatorOfParameter
+ elseif ((parCat.eq.0).and.(parNum.eq.11).and.(typSurf.eq.1)) then ! SHF
+ isec1(6)=146 ! indicatorOfParameter
+ elseif ((parCat.eq.4).and.(parNum.eq.9).and.(typSurf.eq.1)) then ! SR
+ isec1(6)=176 ! indicatorOfParameter
+ elseif ((parCat.eq.2).and.(parNum.eq.17) .or. parId .eq. 180) then ! EWSS
+ isec1(6)=180 ! indicatorOfParameter
+ elseif ((parCat.eq.2).and.(parNum.eq.18) .or. parId .eq. 181) then ! NSSS
+ isec1(6)=181 ! indicatorOfParameter
+ elseif ((parCat.eq.3).and.(parNum.eq.4)) then ! ORO
+ isec1(6)=129 ! indicatorOfParameter
+ elseif ((parCat.eq.3).and.(parNum.eq.7) .or. parId .eq. 160) then ! SDO
+ isec1(6)=160 ! indicatorOfParameter
+ elseif ((discipl.eq.2).and.(parCat.eq.0).and.(parNum.eq.0).and. &
+ (typSurf.eq.1)) then ! LSM
+ isec1(6)=172 ! indicatorOfParameter
+ else
+ print*,'***ERROR: undefined GRiB2 message found!',discipl, &
+ parCat,parNum,typSurf
+ endif
+ if(parId .ne. isec1(6) .and. parId .ne. 77) then
+ write(*,*) 'parId',parId, 'isec1(6)',isec1(6)
+ ! stop
+ endif
+
+ endif
+
+ call grib_get_int(igrib,'numberOfPointsAlongAParallel', &
+ isec2(2),iret)
+ ! ! nx=isec2(2)
+ ! ! WRITE(*,*) nx,nxmax
+ ! if (isec2(2).gt.nxmax) then
+ ! WRITE(*,*) 'FLEXPART error: Too many grid points in x direction.'
+ ! WRITE(*,*) 'Reduce resolution of wind fields.'
+ ! WRITE(*,*) 'Or change parameter settings in file ecmwf_mod.'
+ ! WRITE(*,*) isec2(2),nxmax
+ ! ! STOP
+ ! endif
+
+ !get the size and data of the values array
+ if (isec1(6).ne.-1) then
+ call grib_get_real4_array(igrib,'values',zsec4,iret)
+ call grib_check(iret,gribFunction,gribErrorMsg)
+ endif
+
+ if (ifield.eq.1) then
+
+ !HSO get the required fields from section 2 in a gribex compatible manner
+ call grib_get_int(igrib,'numberOfPointsAlongAParallel', &
+ isec2(2),iret)
+ call grib_check(iret,gribFunction,gribErrorMsg)
+ call grib_get_int(igrib,'numberOfPointsAlongAMeridian', &
+ isec2(3),iret)
+ call grib_check(iret,gribFunction,gribErrorMsg)
+ call grib_get_real8(igrib,'longitudeOfFirstGridPointInDegrees', &
+ xaux1in,iret)
+ call grib_check(iret,gribFunction,gribErrorMsg)
+ call grib_get_int(igrib,'numberOfVerticalCoordinateValues', &
+ isec2(12),iret)
+ call grib_check(iret,gribFunction,gribErrorMsg)
+
+ nxfield=isec2(2)
+ ny=isec2(3)
+ nlev_ec=isec2(12)/2-1
+
+ ! get the size and data of the vertical coordinate array
+ call grib_get_real4_array(igrib,'pv',zsec2,iret)
+ call grib_check(iret,gribFunction,gribErrorMsg)
+ endif
+
+ !HSO get the second part of the grid dimensions only from GRiB1 messages
+ if (isec1(6) .eq. 167 .and. (gotGrid.eq.0)) then
+ call grib_get_real8(igrib,'longitudeOfLastGridPointInDegrees', &
+ xaux2in,iret)
+ call grib_check(iret,gribFunction,gribErrorMsg)
+ call grib_get_real8(igrib,'latitudeOfLastGridPointInDegrees', &
+ yaux1in,iret)
+ call grib_check(iret,gribFunction,gribErrorMsg)
+ call grib_get_real8(igrib,'latitudeOfFirstGridPointInDegrees', &
+ yaux2in,iret)
+ call grib_check(iret,gribFunction,gribErrorMsg)
+ xaux1=xaux1in
+ xaux2=xaux2in
+ yaux1=yaux1in
+ yaux2=yaux2in
+ if (xaux1.gt.180.) xaux1=xaux1-360.0
+ if (xaux2.gt.180.) xaux2=xaux2-360.0
+ if (xaux1.lt.-180.) xaux1=xaux1+360.0
+ if (xaux2.lt.-180.) xaux2=xaux2+360.0
+ if (xaux2.lt.xaux1) xaux2=xaux2+360.0
+ xlon0=xaux1
+ ylat0=yaux1
+ dx=(xaux2-xaux1)/real(nxfield-1)
+ dy=(yaux2-yaux1)/real(ny-1)
+ dxconst=180./(dx*r_earth*pi)
+ dyconst=180./(dy*r_earth*pi)
+ gotGrid=1
+ ! Check whether fields are global
+ ! If they contain the poles, specify polar stereographic map
+ ! projections using the stlmbr- and stcm2p-calls
+ !***********************************************************
+
+ xauxa=abs(xaux2+dx-360.-xaux1)
+ if (xauxa.lt.0.001) then
+ nx=nxfield+1 ! field is cyclic
+ xglobal=.true.
+ if (abs(nxshift).ge.nx) &
+ stop 'nxshift in file par_mod is too large'
+ xlon0=xlon0+real(nxshift)*dx
+ else
+ nx=nxfield
+ xglobal=.false.
+ if (nxshift.ne.0) &
+ stop 'nxshift (par_mod) must be zero for non-global domain'
+ endif
+ nxmin1=nx-1
+ nymin1=ny-1
+ if (xlon0.gt.180.) xlon0=xlon0-360.
+ xauxa=abs(yaux1+90.)
+ if (xglobal.and.xauxa.lt.0.001) then
+ sglobal=.true. ! field contains south pole
+ ! Enhance the map scale by factor 3 (*2=6) compared to north-south
+ ! map scale
+ sizesouth=6.*(switchsouth+90.)/dy
+ call stlmbr(southpolemap,-90.,0.)
+ call stcm2p(southpolemap,0.,0.,switchsouth,0.,sizesouth, &
+ sizesouth,switchsouth,180.)
+ switchsouthg=(switchsouth-ylat0)/dy
+ else
+ sglobal=.false.
+ switchsouthg=999999.
+ endif
+ xauxa=abs(yaux2-90.)
+ if (xglobal.and.xauxa.lt.0.001) then
+ nglobal=.true. ! field contains north pole
+ ! Enhance the map scale by factor 3 (*2=6) compared to north-south
+ ! map scale
+ sizenorth=6.*(90.-switchnorth)/dy
+ call stlmbr(northpolemap,90.,0.)
+ call stcm2p(northpolemap,0.,0.,switchnorth,0.,sizenorth, &
+ sizenorth,switchnorth,180.)
+ switchnorthg=(switchnorth-ylat0)/dy
+ else
+ nglobal=.false.
+ switchnorthg=999999.
+ endif
+ if (nxshift.lt.0) &
+ stop 'nxshift (par_mod) must not be negative'
+ if (nxshift.ge.nxfield) stop 'nxshift (par_mod) too large'
+ endif ! gotGrid
+
+ if (nx.gt.nxmax) then
+ write(*,*) 'FLEXPART error: Too many grid points in x direction.'
+ write(*,*) 'Reduce resolution of wind fields.'
+ write(*,*) 'Or change parameter settings in file par_mod.'
+ write(*,*) nx,nxmax
+ stop
+ endif
+
+ if (ny.gt.nymax) then
+ write(*,*) 'FLEXPART error: Too many grid points in y direction.'
+ write(*,*) 'Reduce resolution of wind fields.'
+ write(*,*) 'Or change parameter settings in file par_mod.'
+ write(*,*) ny,nymax
+ stop
+ endif
+
+ k=isec1(8)
+ if(isec1(6).eq.131) iumax=max(iumax,nlev_ec-k+1)
+ if(isec1(6).eq.135) iwmax=max(iwmax,nlev_ec-k+1)
+
+ if (isec1(6) .eq. 167) then
+ ! ! Assing grid values and allocate memory to read windfields
+ ! nxmax=nxfield
+ ! if (xglobal) then
+ ! nxmax=nxfield+1
+ ! endif
+ ! nymax=ny
+ ! nwzmax=iwmax+1
+ ! nuvzmax=iumax+1
+ ! nzmax=nuvzmax
+ ! nconvlevmax=iumax
+ ! na=nuvzmax
+ ! ! Temporary nxmax and nymax
+ call fixedfields_allocate
+ endif
+
+ if(isec1(6).eq.129) then
+ do jy=0,ny-1
+ do ix=0,nxfield-1
+ oro(ix,jy)=zsec4(nxfield*(ny-jy-1)+ix+1)/ga
+ end do
+ end do
+ endif
+ if(isec1(6).eq.172) then
+ do jy=0,ny-1
+ do ix=0,nxfield-1
+ lsm(ix,jy)=zsec4(nxfield*(ny-jy-1)+ix+1)
+ end do
+ end do
+ endif
+ if(isec1(6).eq.160) then
+ do jy=0,ny-1
+ do ix=0,nxfield-1
+ excessoro(ix,jy)=zsec4(nxfield*(ny-jy-1)+ix+1)
+ end do
+ end do
+ endif
+
+ call grib_release(igrib)
+ end do !! READ NEXT LEVEL OR PARAMETER
+ !
+ ! CLOSING OF INPUT DATA FILE
+ !
+ call grib_close_file(ifile)
+
+ ! call windfields_allocate
+
+ !error message if no fields found with correct first longitude in it
+ if (gotGrid.eq.0) then
+ print*,'***ERROR: input file needs to contain GRiB1 formatted'// &
+ 'messages'
+ stop
+ endif
+
+ nuvz=iumax
+ nwz =iwmax
+ if(nuvz.eq.nlev_ec) nwz=nlev_ec+1
+
+ ! if (nuvz+1.gt.nuvzmax) then
+ ! write(*,*) 'FLEXPART error: Too many u,v grid points in z '// &
+ ! 'direction.'
+ ! write(*,*) 'Reduce resolution of wind fields.'
+ ! write(*,*) 'Or change parameter settings in file par_mod.'
+ ! write(*,*) nuvz+1,nuvzmax
+ ! stop
+ ! endif
+
+ ! if (nwz.gt.nwzmax) then
+ ! write(*,*) 'FLEXPART error: Too many w grid points in z '// &
+ ! 'direction.'
+ ! write(*,*) 'Reduce resolution of wind fields.'
+ ! write(*,*) 'Or change parameter settings in file par_mod.'
+ ! write(*,*) nwz,nwzmax
+ ! stop
+ ! endif
+
+ ! If desired, shift all grids by nxshift grid cells
+ !**************************************************
+
+ if (xglobal) then
+ call shift_field_0(oro,nxfield,ny)
+ call shift_field_0(lsm,nxfield,ny)
+ call shift_field_0(excessoro,nxfield,ny)
+ endif
+
+ ! Output of grid info
+ !********************
+
+ if (lroot) then
+ write(*,'(a,2i7)') ' Vertical levels in ECMWF data: ', &
+ nuvz+1,nwz
+ write(*,*)
+ write(*,'(a)') ' Mother domain:'
+ write(*,'(a,f10.5,a,f10.5,a,f10.5)') ' Longitude range: ', &
+ xlon0,' to ',xlon0+(nx-1)*dx,' Grid distance: ',dx
+ write(*,'(a,f10.5,a,f10.5,a,f10.5)') ' Latitude range : ', &
+ ylat0,' to ',ylat0+(ny-1)*dy,' Grid distance: ',dy
+ write(*,*)
+ end if
+
+ ! CALCULATE VERTICAL DISCRETIZATION OF ECMWF MODEL
+ ! PARAMETER akm,bkm DESCRIBE THE HYBRID "ETA" COORDINATE SYSTEM
+
+ numskip=nlev_ec-nuvz ! number of ecmwf model layers not used
+ ! by trajectory model
+ !do 8940 i=1,244
+ ! write (*,*) 'zsec2:',i,ifield,zsec2(i),numskip
+ !940 continue
+ ! stop
+ ! SEC SEC SEC
+ ! for unknown reason zsec 1 to 10 is filled in this version
+ ! compared to the old one
+ ! SEC SEC SE
+ do i=1,nwz
+ j=numskip+i
+ k=nlev_ec+1+numskip+i
+ akm(nwz-i+1)=zsec2(j)
+ ! write (*,*) 'ifield:',ifield,k,j,zsec2(10+j)
+ bkm(nwz-i+1)=zsec2(k)
+ wheight(nwz-i+1)=akm(nwz-i+1)/101325.+bkm(nwz-i+1) ! From FLEXTRA
+ end do
+
+ !
+ ! CALCULATION OF AKZ, BKZ
+ ! AKZ,BKZ: model discretization parameters at the center of each model
+ ! layer
+ !
+ ! Assign the 10 m winds to an artificial model level with akz=0 and bkz=1.0,
+ ! i.e. ground level
+ !*****************************************************************************
+
+ akz(1)=0.
+ bkz(1)=1.0
+ uvheight(1)=1.
+ do i=1,nuvz
+ uvheight(i+1)=0.5*(wheight(i+1)+wheight(i)) ! From FLEXTRA
+ akz(i+1)=0.5*(akm(i+1)+akm(i))
+ bkz(i+1)=0.5*(bkm(i+1)+bkm(i))
+ end do
+ ! exuvheight=wheight
+ nuvz=nuvz+1
+
+ ! NOTE: In FLEXPART versions up to 4.0, the number of model levels was doubled
+ ! upon the transformation to z levels. In order to save computer memory, this is
+ ! not done anymore in the standard version. However, this option can still be
+ ! switched on by replacing the following lines with those below, that are
+ ! currently commented out. For this, similar changes are necessary in
+ ! verttransform.f and verttranform_nests.f
+ !*****************************************************************************
+
+ nz=nuvz
+ if (nz.gt.nzmax) stop 'nzmax too small'
+ do i=1,nuvz
+ aknew(i)=akz(i)
+ bknew(i)=bkz(i)
+ end do
+
+ ! Switch on following lines to use doubled vertical resolution
+ !*************************************************************
+ !nz=nuvz+nwz-1
+ !if (nz.gt.nzmax) stop 'nzmax too small'
+ !do 100 i=1,nwz
+ ! aknew(2*(i-1)+1)=akm(i)
+ !00 bknew(2*(i-1)+1)=bkm(i)
+ !do 110 i=2,nuvz
+ ! aknew(2*(i-1))=akz(i)
+ !10 bknew(2*(i-1))=bkz(i)
+ ! End doubled vertical resolution
+ return
+
+999 write(*,*)
+ write(*,*) ' ###########################################'// &
+ '###### '
+ write(*,*) ' TRAJECTORY MODEL SUBROUTINE GRIDCHECK:'
+ write(*,*) ' CAN NOT OPEN INPUT DATA FILE '//wfname(ifn)
+ write(*,*) ' ###########################################'// &
+ '###### '
+ write(*,*)
+ write(*,'(a)') '!!! PLEASE INSERT A NEW CD-ROM AND !!!'
+ write(*,'(a)') '!!! PRESS ANY KEY TO CONTINUE... !!!'
+ write(*,'(a)') '!!! ...OR TERMINATE FLEXPART PRESSING!!!'
+ write(*,'(a)') '!!! THE "X" KEY... !!!'
+ write(*,*)
+ read(*,'(a)') opt
+ if(opt.eq.'X') then
+ stop
+ else
+ goto 5
+ endif
+end subroutine gridcheck_ecmwf
+
+subroutine gridcheck_gfs
+
+ !**********************************************************************
+ ! *
+ ! FLEXPART MODEL SUBROUTINE GRIDCHECK *
+ ! *
+ !**********************************************************************
+ ! *
+ ! AUTHOR: G. WOTAWA *
+ ! DATE: 1997-08-06 *
+ ! LAST UPDATE: 1997-10-10 *
+ ! *
+ ! Update: 1999-02-08, global fields allowed, A. Stohl*
+ ! CHANGE: 17/11/2005, Caroline Forster, GFS data *
+ ! CHANGE: 11/01/2008, Harald Sodemann, GRIB1/2 input with *
+ ! ECMWF grib_api *
+ ! CHANGE: 03/12/2008, Harald Sodemann, update to f90 with *
+ ! ECMWF grib_api *
+ ! *
+ ! Unified ECMWF and GFS builds *
+ ! Marian Harustak, 12.5.2017 *
+ ! - Renamed routine from gridcheck to gridcheck_gfs *
+ ! *
+ !**********************************************************************
+ ! *
+ ! DESCRIPTION: *
+ ! *
+ ! THIS SUBROUTINE DETERMINES THE GRID SPECIFICATIONS (LOWER LEFT *
+ ! LONGITUDE, LOWER LEFT LATITUDE, NUMBER OF GRID POINTS, GRID DIST- *
+ ! ANCE AND VERTICAL DISCRETIZATION OF THE ECMWF MODEL) FROM THE *
+ ! GRIB HEADER OF THE FIRST INPUT FILE. THE CONSISTANCY (NO CHANGES *
+ ! WITHIN ONE FLEXPART RUN) IS CHECKED IN THE ROUTINE "READWIND" AT *
+ ! ANY CALL. *
+ ! *
+ ! XLON0 geographical longitude of lower left gridpoint *
+ ! YLAT0 geographical latitude of lower left gridpoint *
+ ! NX number of grid points x-direction *
+ ! NY number of grid points y-direction *
+ ! DX grid distance x-direction *
+ ! DY grid distance y-direction *
+ ! NUVZ number of grid points for horizontal wind *
+ ! components in z direction *
+ ! NWZ number of grid points for vertical wind *
+ ! component in z direction *
+ ! sizesouth, sizenorth give the map scale (i.e. number of virtual grid*
+ ! points of the polar stereographic grid): *
+ ! used to check the CFL criterion *
+ ! UVHEIGHT(1)- heights of gridpoints where u and v are *
+ ! UVHEIGHT(NUVZ) given *
+ ! WHEIGHT(1)- heights of gridpoints where w is given *
+ ! WHEIGHT(NWZ) *
+ ! *
+ !**********************************************************************
+
+ use grib_api
+ use cmapf_mod, only: stlmbr,stcm2p
+
+ implicit none
+
+ !HSO parameters for grib_api
+ integer :: ifile
+ integer :: iret
+ integer :: igrib
+ real(kind=4) :: xaux1,xaux2,yaux1,yaux2
+ real(kind=8) :: xaux1in,xaux2in,yaux1in,yaux2in
+ integer :: gribVer,parCat,parNum,typSurf,valSurf,discipl
+ !HSO end
+ integer :: ix,jy,i,ifn,ifield,j,k,iumax,iwmax,numskip
+ real :: sizesouth,sizenorth,xauxa,pint
+ real :: akm_usort(nwzmax)
+ real,parameter :: eps=0.0001
+
+ ! NCEP GFS
+ real :: pres(nwzmax), help
+
+ integer :: i179,i180,i181
+
+ ! VARIABLES AND ARRAYS NEEDED FOR GRIB DECODING
+
+ integer :: isec1(8),isec2(3)
+ real(kind=4) :: zsec4(jpunp)
+ character(len=1) :: opt
+
+ !HSO grib api error messages
+ character(len=24) :: gribErrorMsg = 'Error reading grib file'
+ character(len=20) :: gribFunction = 'gridcheckwind_gfs'
+ !
+ if (numbnests.ge.1) then
+ write(*,*) ' ###########################################'
+ write(*,*) ' FLEXPART ERROR SUBROUTINE GRIDCHECK:'
+ write(*,*) ' NO NESTED WINDFIELDAS ALLOWED FOR GFS! '
+ write(*,*) ' ###########################################'
+ stop
+ endif
+
+ iumax=0
+ iwmax=0
+
+ if(ideltas.gt.0) then
+ ifn=1
+ else
+ ifn=numbwf
+ endif
+ !
+ ! OPENING OF DATA FILE (GRIB CODE)
+ !
+5 call grib_open_file(ifile,path(3)(1:length(3)) &
+ //trim(wfname(ifn)),'r',iret)
+ if (iret.ne.GRIB_SUCCESS) then
+ goto 999 ! ERROR DETECTED
+ endif
+ !turn on support for multi fields messages
+ call grib_multi_support_on
+
+ ifield=0
+ do
+ ifield=ifield+1
+ !
+ ! GET NEXT FIELDS
+ !
+ call grib_new_from_file(ifile,igrib,iret)
+ if (iret.eq.GRIB_END_OF_FILE ) then
+ exit ! EOF DETECTED
+ elseif (iret.ne.GRIB_SUCCESS) then
+ goto 999 ! ERROR DETECTED
+ endif
+
+ !first see if we read GRIB1 or GRIB2
+ call grib_get_int(igrib,'editionNumber',gribVer,iret)
+ call grib_check(iret,gribFunction,gribErrorMsg)
+
+ if (gribVer.eq.1) then ! GRIB Edition 1
+
+ !read the grib1 identifiers
+ call grib_get_int(igrib,'indicatorOfParameter',isec1(6),iret)
+ call grib_check(iret,gribFunction,gribErrorMsg)
+ call grib_get_int(igrib,'indicatorOfTypeOfLevel',isec1(7),iret)
+ call grib_check(iret,gribFunction,gribErrorMsg)
+ call grib_get_int(igrib,'level',isec1(8),iret)
+ call grib_check(iret,gribFunction,gribErrorMsg)
+
+ !get the size and data of the values array
+ call grib_get_real4_array(igrib,'values',zsec4,iret)
+ call grib_check(iret,gribFunction,gribErrorMsg)
+
+ else ! GRIB Edition 2
+
+ !read the grib2 identifiers
+ call grib_get_int(igrib,'discipline',discipl,iret)
+ call grib_check(iret,gribFunction,gribErrorMsg)
+ call grib_get_int(igrib,'parameterCategory',parCat,iret)
+ call grib_check(iret,gribFunction,gribErrorMsg)
+ call grib_get_int(igrib,'parameterNumber',parNum,iret)
+ call grib_check(iret,gribFunction,gribErrorMsg)
+ call grib_get_int(igrib,'typeOfFirstFixedSurface',typSurf,iret)
+ call grib_check(iret,gribFunction,gribErrorMsg)
+ call grib_get_int(igrib,'scaledValueOfFirstFixedSurface', &
+ valSurf,iret)
+ call grib_check(iret,gribFunction,gribErrorMsg)
+
+ !convert to grib1 identifiers
+ isec1(6)=-1
+ isec1(7)=-1
+ isec1(8)=-1
+ if ((parCat.eq.2).and.(parNum.eq.2).and.(typSurf.eq.100)) then ! U
+ isec1(6)=33 ! indicatorOfParameter
+ isec1(7)=100 ! indicatorOfTypeOfLevel
+ isec1(8)=valSurf/100 ! level, convert to hPa
+ elseif ((parCat.eq.3).and.(parNum.eq.5).and.(typSurf.eq.1)) then ! TOPO
+ isec1(6)=7 ! indicatorOfParameter
+ isec1(7)=1 ! indicatorOfTypeOfLevel
+ isec1(8)=0
+ elseif ((parCat.eq.0).and.(parNum.eq.0).and.(typSurf.eq.1) &
+ .and.(discipl.eq.2)) then ! LSM
+ isec1(6)=81 ! indicatorOfParameter
+ isec1(7)=1 ! indicatorOfTypeOfLevel
+ isec1(8)=0
+ endif
+
+ if (isec1(6).ne.-1) then
+ ! get the size and data of the values array
+ call grib_get_real4_array(igrib,'values',zsec4,iret)
+ call grib_check(iret,gribFunction,gribErrorMsg)
+ endif
+
+ endif ! gribVer
+
+ if(ifield.eq.1) then
+
+ !get the required fields from section 2
+ !store compatible to gribex input
+ call grib_get_int(igrib,'numberOfPointsAlongAParallel', &
+ isec2(2),iret)
+ call grib_check(iret,gribFunction,gribErrorMsg)
+ call grib_get_int(igrib,'numberOfPointsAlongAMeridian', &
+ isec2(3),iret)
+ call grib_check(iret,gribFunction,gribErrorMsg)
+ call grib_get_real8(igrib,'longitudeOfFirstGridPointInDegrees', &
+ xaux1in,iret)
+ call grib_check(iret,gribFunction,gribErrorMsg)
+ call grib_get_real8(igrib,'longitudeOfLastGridPointInDegrees', &
+ xaux2in,iret)
+ call grib_check(iret,gribFunction,gribErrorMsg)
+ call grib_get_real8(igrib,'latitudeOfLastGridPointInDegrees', &
+ yaux1in,iret)
+ call grib_check(iret,gribFunction,gribErrorMsg)
+ call grib_get_real8(igrib,'latitudeOfFirstGridPointInDegrees', &
+ yaux2in,iret)
+ call grib_check(iret,gribFunction,gribErrorMsg)
+
+ ! Fix for flexpart.eu ticket #48
+ if (xaux2in.lt.0) xaux2in = 359.0
+
+ xaux1=xaux1in
+ xaux2=xaux2in
+ yaux1=yaux1in
+ yaux2=yaux2in
+
+ nxfield=isec2(2)
+ ny=isec2(3)
+ if((abs(xaux1).lt.eps).and.(xaux2.ge.359)) then ! NCEP DATA FROM 0 TO
+ xaux1=-179.0 ! 359 DEG EAST ->
+ xaux2=-179.0+360.-360./real(nxfield) ! TRANSFORMED TO -179
+ endif ! TO 180 DEG EAST
+ if (xaux1.gt.180) xaux1=xaux1-360.0
+ if (xaux2.gt.180) xaux2=xaux2-360.0
+ if (xaux1.lt.-180) xaux1=xaux1+360.0
+ if (xaux2.lt.-180) xaux2=xaux2+360.0
+ if (xaux2.lt.xaux1) xaux2=xaux2+360.
+ xlon0=xaux1
+ ylat0=yaux1
+ dx=(xaux2-xaux1)/real(nxfield-1)
+ dy=(yaux2-yaux1)/real(ny-1)
+ dxconst=180./(dx*r_earth*pi)
+ dyconst=180./(dy*r_earth*pi)
+ !HSO end edits
+
+
+ ! Check whether fields are global
+ ! If they contain the poles, specify polar stereographic map
+ ! projections using the stlmbr- and stcm2p-calls
+ !***********************************************************
+
+ xauxa=abs(xaux2+dx-360.-xaux1)
+ if (xauxa.lt.0.001) then
+ nx=nxfield+1 ! field is cyclic
+ xglobal=.true.
+ if (abs(nxshift).ge.nx) &
+ stop 'nxshift in file par_mod is too large'
+ xlon0=xlon0+real(nxshift)*dx
+ else
+ nx=nxfield
+ xglobal=.false.
+ if (nxshift.ne.0) &
+ stop 'nxshift (par_mod) must be zero for non-global domain'
+ endif
+ nxmin1=nx-1
+ nymin1=ny-1
+ if (xlon0.gt.180.) xlon0=xlon0-360.
+ xauxa=abs(yaux1+90.)
+ if (xglobal.and.xauxa.lt.0.001) then
+ sglobal=.true. ! field contains south pole
+ ! Enhance the map scale by factor 3 (*2=6) compared to north-south
+ ! map scale
+ sizesouth=6.*(switchsouth+90.)/dy
+ call stlmbr(southpolemap,-90.,0.)
+ call stcm2p(southpolemap,0.,0.,switchsouth,0.,sizesouth, &
+ sizesouth,switchsouth,180.)
+ switchsouthg=(switchsouth-ylat0)/dy
+ else
+ sglobal=.false.
+ switchsouthg=999999.
+ endif
+ xauxa=abs(yaux2-90.)
+ if (xglobal.and.xauxa.lt.0.001) then
+ nglobal=.true. ! field contains north pole
+ ! Enhance the map scale by factor 3 (*2=6) compared to north-south
+ ! map scale
+ sizenorth=6.*(90.-switchnorth)/dy
+ call stlmbr(northpolemap,90.,0.)
+ call stcm2p(northpolemap,0.,0.,switchnorth,0.,sizenorth, &
+ sizenorth,switchnorth,180.)
+ switchnorthg=(switchnorth-ylat0)/dy
+ else
+ nglobal=.false.
+ switchnorthg=999999.
+ endif
+ endif ! ifield.eq.1
+
+ if (nxshift.lt.0) stop 'nxshift (par_mod) must not be negative'
+ if (nxshift.ge.nxfield) stop 'nxshift (par_mod) too large'
+
+ ! NCEP ISOBARIC LEVELS
+ !*********************
+
+ if((isec1(6).eq.33).and.(isec1(7).eq.100)) then ! check for U wind
+ iumax=iumax+1
+ pres(iumax)=real(isec1(8))*100.0
+ endif
+
+
+ i179=nint(179./dx)
+ if (dx.lt.0.7) then
+ i180=nint(180./dx)+1 ! 0.5 deg data
+ else
+ i180=nint(179./dx)+1 ! 1 deg data
+ endif
+ i181=i180+1
+
+
+ ! NCEP TERRAIN
+ !*************
+
+ if((isec1(6).eq.007).and.(isec1(7).eq.001)) then
+ ! IP 8/5/23 allocate fields missing for GFS reading
+ call fixedfields_allocate
+ ! IP 8/5/23
+ do jy=0,ny-1
+ do ix=0,nxfield-1
+ help=zsec4(nxfield*(ny-jy-1)+ix+1)
+ if(ix.le.i180) then
+ oro(i179+ix,jy)=help
+ excessoro(i179+ix,jy)=0.0 ! ISOBARIC SURFACES: SUBGRID TERRAIN DISREGARDED
+ else
+ oro(ix-i181,jy)=help
+ excessoro(ix-i181,jy)=0.0 ! ISOBARIC SURFACES: SUBGRID TERRAIN DISREGARDED
+ endif
+ end do
+ end do
+ endif
+
+ ! NCEP LAND SEA MASK
+ !*******************
+
+ if((isec1(6).eq.081).and.(isec1(7).eq.001)) then
+ do jy=0,ny-1
+ do ix=0,nxfield-1
+ help=zsec4(nxfield*(ny-jy-1)+ix+1)
+ if(ix.le.i180) then
+ lsm(i179+ix,jy)=help
+ else
+ lsm(ix-i181,jy)=help
+ endif
+ end do
+ end do
+ endif
+
+ call grib_release(igrib)
+
+ end do !! READ NEXT LEVEL OR PARAMETER
+ !
+ ! CLOSING OF INPUT DATA FILE
+ !
+
+ ! HSO
+ call grib_close_file(ifile)
+ ! HSO end edits
+
+ nuvz=iumax
+ nwz =iumax
+ nlev_ec=iumax
+
+ ! ! Assing grid values and allocate memory to read windfields
+ ! nxmax=nx
+ ! nymax=ny
+ ! nwzmax=nwz
+ ! nuvzmax=nuvz
+ ! nzmax=nuvz
+ ! ! nconvlevmax=nuvzmax-1
+ ! ! na=nconvlevmax+1
+
+ ! call windfields_allocate
+
+ if (nx.gt.nxmax) then
+ write(*,*) 'FLEXPART error: Too many grid points in x direction.'
+ write(*,*) 'Reduce resolution of wind fields.'
+ write(*,*) 'Or change parameter settings in file par_mod.'
+ write(*,*) nx,nxmax
+ stop
+ endif
+
+ if (ny.gt.nymax) then
+ write(*,*) 'FLEXPART error: Too many grid points in y direction.'
+ write(*,*) 'Reduce resolution of wind fields.'
+ write(*,*) 'Or change parameter settings in file par_mod.'
+ write(*,*) ny,nymax
+ stop
+ endif
+
+ if (nuvz.gt.nuvzmax) then
+ write(*,*) 'FLEXPART error: Too many u,v grid points in z '// &
+ 'direction.'
+ write(*,*) 'Reduce resolution of wind fields.'
+ write(*,*) 'Or change parameter settings in file par_mod.'
+ write(*,*) nuvz,nuvzmax
+ stop
+ endif
+
+ if (nwz.gt.nwzmax) then
+ write(*,*) 'FLEXPART error: Too many w grid points in z '// &
+ 'direction.'
+ write(*,*) 'Reduce resolution of wind fields.'
+ write(*,*) 'Or change parameter settings in file par_mod.'
+ write(*,*) nwz,nwzmax
+ stop
+ endif
+
+ ! If desired, shift all grids by nxshift grid cells
+ !**************************************************
+
+ if (xglobal) then
+ call shift_field_0(oro,nxfield,ny)
+ call shift_field_0(lsm,nxfield,ny)
+ call shift_field_0(excessoro,nxfield,ny)
+ endif
+
+ ! Output of grid info
+ !********************
+
+ if (lroot) then
+ write(*,*)
+ write(*,*)
+ write(*,'(a,2i7)') 'Vertical levels in NCEP data: ', &
+ nuvz,nwz
+ write(*,*)
+ write(*,'(a)') 'Mother domain:'
+ write(*,'(a,f10.2,a1,f10.2,a,f10.2)') ' Longitude range: ', &
+ xlon0,' to ',xlon0+(nx-1)*dx,' Grid distance: ',dx
+ write(*,'(a,f10.2,a1,f10.2,a,f10.2)') ' Latitude range : ', &
+ ylat0,' to ',ylat0+(ny-1)*dy,' Grid distance: ',dy
+ write(*,*)
+ end if
+
+ ! CALCULATE VERTICAL DISCRETIZATION OF ECMWF MODEL
+ ! PARAMETER akm,bkm DESCRIBE THE HYBRID "ETA" COORDINATE SYSTEM
+
+ numskip=nlev_ec-nuvz ! number of ecmwf model layers not used
+ ! by trajectory model
+ do i=1,nwz
+ j=numskip+i
+ k=nlev_ec+1+numskip+i
+ akm_usort(nwz-i+1)=pres(nwz-i+1)
+ bkm(nwz-i+1)=0.0
+ end do
+
+ !******************************
+ ! change Sabine Eckhardt: akm should always be in descending order ... readwind adapted!
+ !******************************
+ do i=1,nwz
+ if (akm_usort(1).gt.akm_usort(2)) then
+ akm(i)=akm_usort(i)
+ else
+ akm(i)=akm_usort(nwz-i+1)
+ endif
+ end do
+
+ !
+ ! CALCULATION OF AKZ, BKZ
+ ! AKZ,BKZ: model discretization parameters at the center of each model
+ ! layer
+ !
+ ! Assign the 10 m winds to an artificial model level with akz=0 and bkz=1.0,
+ ! i.e. ground level
+ !*****************************************************************************
+
+ do i=1,nuvz
+ akz(i)=akm(i)
+ bkz(i)=bkm(i)
+ end do
+
+ ! NOTE: In FLEXPART versions up to 4.0, the number of model levels was doubled
+ ! upon the transformation to z levels. In order to save computer memory, this is
+ ! not done anymore in the standard version. However, this option can still be
+ ! switched on by replacing the following lines with those below, that are
+ ! currently commented out. For this, similar changes are necessary in
+ ! verttransform.f and verttranform_nests.f
+ !*****************************************************************************
+
+ nz=nuvz
+ if (nz.gt.nzmax) stop 'nzmax too small'
+ do i=1,nuvz
+ aknew(i)=akz(i)
+ bknew(i)=bkz(i)
+ end do
+
+ ! Switch on following lines to use doubled vertical resolution
+ !*************************************************************
+ !nz=nuvz+nwz-1
+ !if (nz.gt.nzmax) stop 'nzmax too small'
+ !do 100 i=1,nwz
+ ! aknew(2*(i-1)+1)=akm(i)
+ !00 bknew(2*(i-1)+1)=bkm(i)
+ !do 110 i=2,nuvz
+ ! aknew(2*(i-1))=akz(i)
+ !10 bknew(2*(i-1))=bkz(i)
+ ! End doubled vertical resolution
+ return
+
+999 write(*,*)
+ write(*,*) ' ###########################################'// &
+ '###### '
+ write(*,*) ' TRAJECTORY MODEL SUBROUTINE GRIDCHECK:'
+ write(*,*) ' CAN NOT OPEN INPUT DATA FILE '//wfname(ifn)
+ write(*,*) ' ###########################################'// &
+ '###### '
+ write(*,*)
+ write(*,'(a)') '!!! PLEASE INSERT A NEW CD-ROM AND !!!'
+ write(*,'(a)') '!!! PRESS ANY KEY TO CONTINUE... !!!'
+ write(*,'(a)') '!!! ...OR TERMINATE FLEXPART PRESSING!!!'
+ write(*,'(a)') '!!! THE "X" KEY... !!!'
+ write(*,*)
+ read(*,'(a)') opt
+ if(opt.eq.'X') then
+ stop
+ else
+ goto 5
+ endif
+
+end subroutine gridcheck_gfs
+
+subroutine gridcheck_nests
+
+ !*****************************************************************************
+ ! *
+ ! This routine checks the grid specification for the nested model *
+ ! domains. It is similar to subroutine gridcheck, which checks the *
+ ! mother domain. *
+ ! *
+ ! Authors: A. Stohl, G. Wotawa *
+ ! *
+ ! 8 February 1999 *
+ ! *
+ !*****************************************************************************
+ ! CHANGE: 11/01/2008, Harald Sodemann, GRIB1/2 input with ECMWF grib_api *
+ ! CHANGE: 03/12/2008, Harald Sodemann, change to f90 grib_api *
+ !*****************************************************************************
+
+ use grib_api
+
+ implicit none
+
+ !HSO parameters for grib_api
+ integer :: ifile
+ integer :: iret
+ integer :: igrib
+ integer :: gribVer,parCat,parNum,typSurf,valSurf,discipl
+ integer :: parID !added by mc for making it consistent with new gridcheck.f90
+ integer :: gotGrib
+ !HSO end
+ integer :: i,j,k,l,ifn,ifield,iumax,iwmax,numskip,nlev_ecn
+ integer :: nuvzn,nwzn
+ real :: akmn(nwzmax),bkmn(nwzmax),akzn(nuvzmax),bkzn(nuvzmax)
+ real(kind=4) :: xaux1,xaux2,yaux1,yaux2
+ real(kind=8) :: xaux1in,xaux2in,yaux1in,yaux2in
+ real :: conversion_factor !added by mc to make it consistent with new gridchek.f90
+
+ ! VARIABLES AND ARRAYS NEEDED FOR GRIB DECODING
+
+ ! dimension of isec2 at least (22+n), where n is the number of parallels or
+ ! meridians in a quasi-regular (reduced) Gaussian or lat/long grid
+
+ ! dimension of zsec2 at least (10+nn), where nn is the number of vertical
+ ! coordinate parameters
+
+ integer :: isec1(56),isec2(22+nxmaxn+nymaxn)
+ real(kind=4) :: zsec2(60+2*nuvzmax),zsec4(jpunp)
+
+ !HSO grib api error messages
+ character(len=24) :: gribErrorMsg = 'Error reading grib file'
+ character(len=20) :: gribFunction = 'gridcheck_nests'
+
+ xresoln(0)=1. ! resolution enhancement for mother grid
+ yresoln(0)=1. ! resolution enhancement for mother grid
+
+ ! Loop about all nesting levels
+ !******************************
+
+ do l=1,numbnests
+
+ iumax=0
+ iwmax=0
+
+ if(ideltas.gt.0) then
+ ifn=1
+ else
+ ifn=numbwf
+ endif
+ !
+ ! OPENING OF DATA FILE (GRIB CODE)
+ !
+ ifile=0
+ igrib=0
+ iret=0
+
+5 call grib_open_file(ifile,path(numpath+2*(l-1)+1) &
+ (1:length(numpath+2*(l-1)+1))//trim(wfnamen(l,ifn)),'r',iret)
+ if (iret.ne.GRIB_SUCCESS) then
+ goto 999 ! ERROR DETECTED
+ endif
+ !turn on support for multi fields messages
+ !call grib_multi_support_on
+
+ gotGrib=0
+ ifield=0
+ do
+ ifield=ifield+1
+
+ !
+ ! GET NEXT FIELDS
+ !
+ call grib_new_from_file(ifile,igrib,iret)
+ if (iret.eq.GRIB_END_OF_FILE) then
+ exit ! EOF DETECTED
+ elseif (iret.ne.GRIB_SUCCESS) then
+ goto 999 ! ERROR DETECTED
+ endif
+
+ !first see if we read GRIB1 or GRIB2
+ call grib_get_int(igrib,'editionNumber',gribVer,iret)
+ call grib_check(iret,gribFunction,gribErrorMsg)
+
+ if (gribVer.eq.1) then ! GRIB Edition 1
+
+ !print*,'GRiB Edition 1'
+ !read the grib2 identifiers
+ call grib_get_int(igrib,'indicatorOfParameter',isec1(6),iret)
+ call grib_check(iret,gribFunction,gribErrorMsg)
+ call grib_get_int(igrib,'level',isec1(8),iret)
+ call grib_check(iret,gribFunction,gribErrorMsg)
+
+ !change code for etadot to code for omega
+ if (isec1(6).eq.77) then
+ isec1(6)=135
+ endif
+
+ !print*,isec1(6),isec1(8)
+
+ else
+
+ !print*,'GRiB Edition 2'
+ !read the grib2 identifiers
+ call grib_get_int(igrib,'discipline',discipl,iret)
+ call grib_check(iret,gribFunction,gribErrorMsg)
+ call grib_get_int(igrib,'parameterCategory',parCat,iret)
+ call grib_check(iret,gribFunction,gribErrorMsg)
+ call grib_get_int(igrib,'parameterNumber',parNum,iret)
+ call grib_check(iret,gribFunction,gribErrorMsg)
+ call grib_get_int(igrib,'typeOfFirstFixedSurface',typSurf,iret)
+ call grib_check(iret,gribFunction,gribErrorMsg)
+ call grib_get_int(igrib,'level',valSurf,iret)
+ call grib_check(iret,gribFunction,gribErrorMsg)
+ call grib_get_int(igrib,'paramId',parId,iret) !added by mc to make it consisitent with new grid_check.f90
+ call grib_check(iret,gribFunction,gribErrorMsg) !added by mc to make it consisitent with new grid_check.f90
+
+ !print*,discipl,parCat,parNum,typSurf,valSurf
+
+ !convert to grib1 identifiers
+ isec1(6)=-1
+ isec1(7)=-1
+ isec1(8)=-1
+ isec1(8)=valSurf ! level
+ if ((parCat.eq.0).and.(parNum.eq.0).and.(typSurf.eq.105)) then ! T
+ isec1(6)=130 ! indicatorOfParameter
+ elseif ((parCat.eq.2).and.(parNum.eq.2).and.(typSurf.eq.105)) then ! U
+ isec1(6)=131 ! indicatorOfParameter
+ elseif ((parCat.eq.2).and.(parNum.eq.3).and.(typSurf.eq.105)) then ! V
+ isec1(6)=132 ! indicatorOfParameter
+ elseif ((parCat.eq.1).and.(parNum.eq.0).and.(typSurf.eq.105)) then ! Q
+ isec1(6)=133 ! indicatorOfParameter
+ elseif ((parCat.eq.1).and.(parNum.eq.83).and.(typSurf.eq.105)) then ! clwc
+ isec1(6)=246 ! indicatorOfParameter
+ elseif ((parCat.eq.1).and.(parNum.eq.84).and.(typSurf.eq.105)) then ! ciwc
+ isec1(6)=247 ! indicatorOfParameter
+ !ZHG end
+ ! ESO qc(=clwc+ciwc)
+ elseif ((parCat.eq.201).and.(parNum.eq.31).and.(typSurf.eq.105)) then ! qc
+ isec1(6)=201031 ! indicatorOfParameter
+ elseif ((parCat.eq.3).and.(parNum.eq.0).and.(typSurf.eq.1)) then !SP
+ isec1(6)=134 ! indicatorOfParameter
+ elseif ((parCat.eq.2).and.(parNum.eq.32)) then ! W, actually eta dot
+ isec1(6)=135 ! indicatorOfParameter
+ elseif ((parCat.eq.128).and.(parNum.eq.77)) then ! W, actually eta dot !added bymc to make it consistent with new gridcheck.f90
+ isec1(6)=135 ! indicatorOfParameter !
+ elseif ((parCat.eq.3).and.(parNum.eq.0).and.(typSurf.eq.101)) then !SLP
+ isec1(6)=151 ! indicatorOfParameter
+ elseif ((parCat.eq.2).and.(parNum.eq.2).and.(typSurf.eq.103)) then ! 10U
+ isec1(6)=165 ! indicatorOfParameter
+ elseif ((parCat.eq.2).and.(parNum.eq.3).and.(typSurf.eq.103)) then ! 10V
+ isec1(6)=166 ! indicatorOfParameter
+ elseif ((parCat.eq.0).and.(parNum.eq.0).and.(typSurf.eq.103)) then ! 2T
+ isec1(6)=167 ! indicatorOfParameter
+ elseif ((parCat.eq.0).and.(parNum.eq.6).and.(typSurf.eq.103)) then ! 2D
+ isec1(6)=168 ! indicatorOfParameter
+ elseif ((parCat.eq.1).and.(parNum.eq.11).and.(typSurf.eq.1)) then ! SD
+ isec1(6)=141 ! indicatorOfParameter
+ elseif ((parCat.eq.6).and.(parNum.eq.1) .or. parId .eq. 164) then ! CC !added by mc to make it consistent with new gridchek.f90
+ isec1(6)=164 ! indicatorOfParameter
+ elseif ((parCat.eq.1).and.(parNum.eq.9) .or. parId .eq. 142) then ! LSP !added by mc to make it consistent with new gridchek.f90
+ isec1(6)=142 ! indicatorOfParameter
+ elseif ((parCat.eq.1).and.(parNum.eq.10)) then ! CP
+ isec1(6)=143 ! indicatorOfParameter
+ elseif ((parCat.eq.0).and.(parNum.eq.11).and.(typSurf.eq.1)) then ! SHF
+ isec1(6)=146 ! indicatorOfParameter
+ elseif ((parCat.eq.4).and.(parNum.eq.9).and.(typSurf.eq.1)) then ! SR
+ isec1(6)=176 ! indicatorOfParameter
+ elseif ((parCat.eq.2).and.(parNum.eq.17) .or. parId .eq. 180) then ! EWSS !added by mc to make it consistent with new gridchek.f90
+ isec1(6)=180 ! indicatorOfParameter
+ elseif ((parCat.eq.2).and.(parNum.eq.18) .or. parId .eq. 181) then ! NSSS !added by mc to make it consistent with new gridchek.f90
+ isec1(6)=181 ! indicatorOfParameter
+ elseif ((parCat.eq.3).and.(parNum.eq.4)) then ! ORO
+ isec1(6)=129 ! indicatorOfParameter
+ elseif ((parCat.eq.3).and.(parNum.eq.7) .or. parId .eq. 160) then ! SDO !added by mc to make it consistent with new gridchek.f90
+ isec1(6)=160 ! indicatorOfParameter
+ elseif ((discipl.eq.2).and.(parCat.eq.0).and.(parNum.eq.0).and. &
+ (typSurf.eq.1)) then ! LSM
+ isec1(6)=172 ! indicatorOfParameter
+ else
+ print*,'***ERROR: undefined GRiB2 message found!',discipl, &
+ parCat,parNum,typSurf
+ endif
+ if(parId .ne. isec1(6) .and. parId .ne. 77) then !added by mc to make it consistent with new gridchek.f90
+ write(*,*) 'parId',parId, 'isec1(6)',isec1(6)
+ ! stop
+ endif
+
+ endif
+
+ !get the size and data of the values array
+ if (isec1(6).ne.-1) then
+ call grib_get_real4_array(igrib,'values',zsec4,iret)
+ call grib_check(iret,gribFunction,gribErrorMsg)
+ endif
+
+ !HSO get the required fields from section 2 in a gribex compatible manner
+ if (ifield.eq.1) then
+ call grib_get_int(igrib,'numberOfPointsAlongAParallel', &
+ isec2(2),iret)
+ call grib_check(iret,gribFunction,gribErrorMsg)
+ call grib_get_int(igrib,'numberOfPointsAlongAMeridian', &
+ isec2(3),iret)
+ call grib_check(iret,gribFunction,gribErrorMsg)
+ call grib_get_int(igrib,'numberOfVerticalCoordinateValues', &
+ isec2(12),iret)
+ call grib_check(iret,gribFunction,gribErrorMsg)
+ !HSO get the size and data of the vertical coordinate array
+ call grib_get_real4_array(igrib,'pv',zsec2,iret)
+ call grib_check(iret,gribFunction,gribErrorMsg)
+
+ nxn(l)=isec2(2)
+ nyn(l)=isec2(3)
+ nlev_ecn=isec2(12)/2-1
+ endif ! ifield
+
+ if (nxn(l).gt.nxmaxn) then
+ write(*,*) 'FLEXPART error: Too many grid points in x direction.'
+ write(*,*) 'Reduce resolution of wind fields (file GRIDSPEC)'
+ write(*,*) 'for nesting level ',l
+ write(*,*) 'Or change parameter settings in file par_mod.'
+ write(*,*) nxn(l),nxmaxn
+ stop
+ endif
+
+ if (nyn(l).gt.nymaxn) then
+ write(*,*) 'FLEXPART error: Too many grid points in y direction.'
+ write(*,*) 'Reduce resolution of wind fields (file GRIDSPEC)'
+ write(*,*) 'for nesting level ',l
+ write(*,*) 'Or change parameter settings in file par_mod.'
+ write(*,*) nyn(l),nymaxn
+ stop
+ endif
+
+ !HSO get the second part of the grid dimensions only from GRiB1 messages
+ if (isec1(6) .eq. 167 .and. (gotGrib.eq.0)) then !added by mc to make it consistent with new gridchek.f90 note that gotGrid must be changed in gotGrib!!
+ call grib_get_real8(igrib,'longitudeOfFirstGridPointInDegrees', & !comment by mc: note that this was in the (if (ifield.eq.1) ..end above in gridchek.f90 see line 257
+ xaux1in,iret)
+ call grib_check(iret,gribFunction,gribErrorMsg)
+ call grib_get_real8(igrib,'longitudeOfLastGridPointInDegrees', &
+ xaux2in,iret)
+ call grib_check(iret,gribFunction,gribErrorMsg)
+ call grib_get_real8(igrib,'latitudeOfLastGridPointInDegrees', &
+ yaux1in,iret)
+ call grib_check(iret,gribFunction,gribErrorMsg)
+ call grib_get_real8(igrib,'latitudeOfFirstGridPointInDegrees', &
+ yaux2in,iret)
+ call grib_check(iret,gribFunction,gribErrorMsg)
+ xaux1=xaux1in
+ xaux2=xaux2in
+ yaux1=yaux1in
+ yaux2=yaux2in
+ if(xaux1.gt.180.) xaux1=xaux1-360.0
+ if(xaux2.gt.180.) xaux2=xaux2-360.0
+ if(xaux1.lt.-180.) xaux1=xaux1+360.0
+ if(xaux2.lt.-180.) xaux2=xaux2+360.0
+ if (xaux2.lt.xaux1) xaux2=xaux2+360.0
+ xlon0n(l)=xaux1
+ ylat0n(l)=yaux1
+ dxn(l)=(xaux2-xaux1)/real(nxn(l)-1)
+ dyn(l)=(yaux2-yaux1)/real(nyn(l)-1)
+ gotGrib=1 !commetn by mc note tahthere gotGRIB is used instead of gotGrid!!!
+ endif ! ifield.eq.1
+
+ k=isec1(8)
+ if(isec1(6).eq.131) iumax=max(iumax,nlev_ec-k+1)
+ if(isec1(6).eq.135) iwmax=max(iwmax,nlev_ec-k+1)
+
+ if(isec1(6).eq.129) then
+ do j=0,nyn(l)-1
+ do i=0,nxn(l)-1
+ oron(i,j,l)=zsec4(nxn(l)*(nyn(l)-j-1)+i+1)/ga
+ end do
+ end do
+ endif
+ if(isec1(6).eq.172) then
+ do j=0,nyn(l)-1
+ do i=0,nxn(l)-1
+ lsmn(i,j,l)=zsec4(nxn(l)*(nyn(l)-j-1)+i+1)/ga
+ end do
+ end do
+ endif
+ if(isec1(6).eq.160) then
+ do j=0,nyn(l)-1
+ do i=0,nxn(l)-1
+ excessoron(i,j,l)=zsec4(nxn(l)*(nyn(l)-j-1)+i+1)/ga
+ end do
+ end do
+ endif
+
+ call grib_release(igrib)
+ end do !! READ NEXT LEVEL OR PARAMETER
+ !
+ ! CLOSING OF INPUT DATA FILE
+ !
+
+ call grib_close_file(ifile)
+
+ !error message if no fields found with correct first longitude in it
+ if (gotGrib.eq.0) then
+ print*,'***ERROR: input file needs to contain GRiB1 formatted'// &
+ 'messages'
+ stop
+ endif
+
+ nuvzn=iumax
+ nwzn=iwmax
+ if(nuvzn.eq.nlev_ec) nwzn=nlev_ecn+1
+
+ if ((nuvzn.gt.nuvzmax).or.(nwzn.gt.nwzmax)) then
+ write(*,*) 'FLEXPART error: Nested wind fields have too many'// &
+ 'vertical levels.'
+ write(*,*) 'Problem was encountered for nesting level ',l
+ stop
+ endif
+
+
+ ! Output of grid info
+ !********************
+
+ write(*,'(a,i2,a)') ' Nested domain ',l,':'
+ write(*,'(a,f10.5,a,f10.5,a,f10.5)') ' Longitude range: ', &
+ xlon0n(l),' to ',xlon0n(l)+(nxn(l)-1)*dxn(l), &
+ ' Grid distance: ',dxn(l)
+ write(*,'(a,f10.5,a,f10.5,a,f10.5)') ' Latitude range : ', &
+ ylat0n(l),' to ',ylat0n(l)+(nyn(l)-1)*dyn(l), &
+ ' Grid distance: ',dyn(l)
+ write(*,*)
+
+ ! Determine, how much the resolutions in the nests are enhanced as
+ ! compared to the mother grid
+ !*****************************************************************
+
+ xresoln(l)=dx/dxn(l)
+ yresoln(l)=dy/dyn(l)
+
+ ! Determine the mother grid coordinates of the corner points of the
+ ! nested grids
+ ! Convert first to geographical coordinates, then to grid coordinates
+ !********************************************************************
+
+ xaux1=xlon0n(l)
+ xaux2=xlon0n(l)+real(nxn(l)-1)*dxn(l)
+ yaux1=ylat0n(l)
+ yaux2=ylat0n(l)+real(nyn(l)-1)*dyn(l)
+
+ xln(l)=(xaux1-xlon0)/dx
+ xrn(l)=(xaux2-xlon0)/dx
+ yln(l)=(yaux1-ylat0)/dy
+ yrn(l)=(yaux2-ylat0)/dy
+
+
+ if ((xln(l).lt.0.).or.(yln(l).lt.0.).or. &
+ (xrn(l).gt.real(nxmin1)).or.(yrn(l).gt.real(nymin1))) then
+ write(*,*) 'Nested domain does not fit into mother domain'
+ write(*,*) 'For global mother domain fields, you can shift'
+ write(*,*) 'shift the mother domain into x-direction'
+ write(*,*) 'by setting nxshift (file par_mod) to a'
+ write(*,*) 'positive value. Execution is terminated.'
+ stop
+ endif
+
+
+ ! CALCULATE VERTICAL DISCRETIZATION OF ECMWF MODEL
+ ! PARAMETER akm,bkm DESCRIBE THE HYBRID "ETA" COORDINATE SYSTEM
+
+ numskip=nlev_ecn-nuvzn ! number of ecmwf model layers not used by FLEXPART
+ do i=1,nwzn
+ j=numskip+i
+ k=nlev_ecn+1+numskip+i
+ akmn(nwzn-i+1)=zsec2(j)
+ bkmn(nwzn-i+1)=zsec2(k)
+ end do
+
+ !
+ ! CALCULATION OF AKZ, BKZ
+ ! AKZ,BKZ: model discretization parameters at the center of each model
+ ! layer
+ !
+ ! Assign the 10 m winds to an artificial model level with akz=0 and bkz=1.0,
+ ! i.e. ground level
+ !*****************************************************************************
+
+ akzn(1)=0.
+ bkzn(1)=1.0
+ do i=1,nuvzn
+ akzn(i+1)=0.5*(akmn(i+1)+akmn(i))
+ bkzn(i+1)=0.5*(bkmn(i+1)+bkmn(i))
+ end do
+ nuvzn=nuvzn+1
+
+ ! Check, whether the heights of the model levels of the nested
+ ! wind fields are consistent with those of the mother domain.
+ ! If not, terminate model run.
+ !*************************************************************
+
+ do i=1,nuvz
+ if ((akzn(i).ne.akz(i)).or.(bkzn(i).ne.bkz(i))) then
+ write(*,*) 'FLEXPART error: The wind fields of nesting level',l
+ write(*,*) 'are not consistent with the mother domain:'
+ write(*,*) 'Differences in vertical levels detected.'
+ stop
+ endif
+ end do
+
+ do i=1,nwz
+ if ((akmn(i).ne.akm(i)).or.(bkmn(i).ne.bkm(i))) then
+ write(*,*) 'FLEXPART error: The wind fields of nesting level',l
+ write(*,*) 'are not consistent with the mother domain:'
+ write(*,*) 'Differences in vertical levels detected.'
+ stop
+ endif
+ end do
+
+ end do
+
+ return
+
+999 write(*,*)
+ write(*,*) ' ###########################################'// &
+ '###### '
+ write(*,*) ' FLEXPART SUBROUTINE GRIDCHECK:'
+ write(*,*) ' CAN NOT OPEN INPUT DATA FILE '//wfnamen(l,ifn)
+ write(*,*) ' FOR NESTING LEVEL ',k
+ write(*,*) ' ###########################################'// &
+ '###### '
+ stop
+
+end subroutine gridcheck_nests
+
+subroutine readwind_ecmwf(indj,n,uuh,vvh,wwh)
+
+ !**********************************************************************
+ ! *
+ ! TRAJECTORY MODEL SUBROUTINE READWIND *
+ ! *
+ !**********************************************************************
+ ! *
+ ! AUTHOR: G. WOTAWA *
+ ! DATE: 1997-08-05 *
+ ! LAST UPDATE: 2000-10-17, Andreas Stohl *
+ ! CHANGE: 11/01/2008, Harald Sodemann, GRIB1/2 input with *
+ ! ECMWF grib_api *
+ ! CHANGE: 03/12/2008, Harald Sodemann, update to f90 with *
+ ! ECMWF grib_api *
+ ! *
+ !**********************************************************************
+ ! Changes, Bernd C. Krueger, Feb. 2001:
+ ! Variables tth and qvh (on eta coordinates) in common block
+ !
+ ! Unified ECMWF and GFS builds
+ ! Marian Harustak, 12.5.2017
+ ! - Renamed from readwind to readwind_ecmwf
+ !
+ ! L. Bakels, 2021: OpenMP parallelisation (following CTM version)
+ !**********************************************************************
+ ! *
+ ! DESCRIPTION: *
+ ! *
+ ! READING OF ECMWF METEOROLOGICAL FIELDS FROM INPUT DATA FILES. THE *
+ ! INPUT DATA FILES ARE EXPECTED TO BE AVAILABLE IN GRIB CODE *
+ ! *
+ ! INPUT: *
+ ! indj indicates number of the wind field to be read in *
+ ! n temporal index for meteorological fields (1 to 3)*
+ ! *
+ ! IMPORTANT VARIABLES FROM COMMON BLOCK: *
+ ! *
+ ! wfname File name of data to be read in *
+ ! nx,ny,nuvz,nwz expected field dimensions *
+ ! nlev_ec number of vertical levels ecmwf model *
+ ! uu,vv,ww wind fields *
+ ! tt,qv temperature and specific humidity *
+ ! ps surface pressure *
+ ! *
+ !**********************************************************************
+
+ use grib_api
+
+ implicit none
+
+ ! include 'grib_api.h'
+
+ !HSO parameters for grib_api
+ integer :: ifile
+ integer :: iret
+ integer, dimension(:), allocatable :: igrib
+ integer :: nfield, ii, arsize
+ integer :: gribVer,parCat,parNum,typSurf,valSurf,discipl,parId
+ integer :: gotGrid
+ ! HSO end
+
+ real(kind=4) :: uuh(0:nxmax-1,0:nymax-1,nuvzmax)
+ real(kind=4) :: vvh(0:nxmax-1,0:nymax-1,nuvzmax)
+ real(kind=4) :: wwh(0:nxmax-1,0:nymax-1,nwzmax)
+ integer :: indj,i,j,k,n,levdiff2,iumax,iwmax!,ifield
+ integer :: kz
+
+ ! VARIABLES AND ARRAYS NEEDED FOR GRIB DECODING
+
+ ! dimension of isec2 at least (22+n), where n is the number of parallels or
+ ! meridians in a quasi-regular (reduced) Gaussian or lat/long grid
+
+ ! dimension of zsec2 at least (10+nn), where nn is the number of vertical
+ ! coordinate parameters
+
+ integer :: isec1(56),isec2(22+nxmax+nymax)
+ real(kind=4), allocatable, dimension(:) :: zsec4
+ ! real(kind=4) :: zsec4(jpunp)
+ real(kind=4) :: xaux,yaux,xaux0,yaux0
+ real(kind=8) :: xauxin,yauxin
+ real,parameter :: eps=1.e-4
+ real(kind=4) :: nsss(0:nxmax-1,0:nymax-1),ewss(0:nxmax-1,0:nymax-1)
+ real :: plev1,pmean,tv,fu,hlev1,ff10m,fflev1,conversion_factor
+ integer :: stat
+
+ logical :: hflswitch,strswitch!,readcloud
+
+ !HSO grib api error messages
+ character(len=24) :: gribErrorMsg = 'Error reading grib file'
+ character(len=20) :: gribFunction = 'readwind'
+
+ hflswitch=.false.
+ strswitch=.false.
+ !ZHG test the grib fields that have lcwc without using them
+ ! readcloud=.false.
+
+ levdiff2=nlev_ec-nwz+1
+ iumax=0
+ iwmax=0
+
+ !
+ ! OPENING OF DATA FILE (GRIB CODE)
+ !
+ call grib_open_file(ifile,path(3)(1:length(3)) &
+ //trim(wfname(indj)),'r',iret)
+ if (iret.ne.GRIB_SUCCESS) then
+ goto 888 ! ERROR DETECTED
+ endif
+
+ call grib_count_in_file(ifile,nfield)
+
+ ! allocate memory for grib handles
+ allocate(igrib(nfield), stat=stat)
+ if (stat.ne.0) stop "Could not allocate igrib"
+ ! initialise
+ igrib(:) = -1
+
+ do ii = 1,nfield
+ call grib_new_from_file(ifile, igrib(ii), iret)
+ end do
+
+ call grib_close_file(ifile)
+
+ !turn on support for multi fields messages */
+ !call grib_multi_support_on
+
+ gotGrid=0
+
+!$OMP PARALLEL DEFAULT(none) &
+!$OMP SHARED (nfield, igrib, gribFunction, nxfield, ny, nlev_ec, dx, xlon0, ylat0, &
+!$OMP n, tth, uuh, vvh, iumax, qvh, ps, wwh, iwmax, sd, msl, tcc, u10, v10, tt2, &
+!$OMP td2, lsprec, convprec, sshf, hflswitch, ssr, ewss, nsss, strswitch, oro, &
+!$OMP excessoro, lsm, nymin1,ciwch,clwch,readclouds,sumclouds, nxshift) &
+!$OMP PRIVATE(ii, gribVer, iret, isec1, discipl, parCat, parNum, parId,typSurf, valSurf, &
+!$OMP zsec4, isec2, gribErrorMsg, xauxin, yauxin, xaux, yaux, xaux0, &
+!$OMP yaux0, k, arsize, stat, conversion_factor) &
+!$OMP REDUCTION(+:gotGrid)
+ !
+ ! GET NEXT FIELDS
+ !
+ ! allocate memory for reading from grib
+ allocate(zsec4(nxfield*ny), stat=stat)
+ if (stat.ne.0) stop "Could not allocate zsec4"
+
+!$OMP DO SCHEDULE(static)
+
+ fieldloop : do ii=1,nfield
+
+ !first see if we read GRIB1 or GRIB2
+ call grib_get_int(igrib(ii),'editionNumber',gribVer,iret)
+ call grib_check(iret,gribFunction,gribErrorMsg)
+
+ if (gribVer.eq.1) then ! GRIB Edition 1
+
+ !print*,'GRiB Edition 1'
+ !read the grib2 identifiers
+ call grib_get_int(igrib(ii),'indicatorOfParameter',isec1(6),iret)
+ call grib_check(iret,gribFunction,gribErrorMsg)
+ call grib_get_int(igrib(ii),'level',isec1(8),iret)
+ call grib_check(iret,gribFunction,gribErrorMsg)
+
+ !change code for etadot to code for omega
+ if (isec1(6).eq.77) then
+ isec1(6)=135
+ endif
+
+ conversion_factor=1.
+
+ else
+
+ !print*,'GRiB Edition 2'
+ !read the grib2 identifiers
+ call grib_get_int(igrib(ii),'discipline',discipl,iret)
+ call grib_check(iret,gribFunction,gribErrorMsg)
+ call grib_get_int(igrib(ii),'parameterCategory',parCat,iret)
+ call grib_check(iret,gribFunction,gribErrorMsg)
+ call grib_get_int(igrib(ii),'parameterNumber',parNum,iret)
+ call grib_check(iret,gribFunction,gribErrorMsg)
+ call grib_get_int(igrib(ii),'typeOfFirstFixedSurface',typSurf,iret)
+ call grib_check(iret,gribFunction,gribErrorMsg)
+ call grib_get_int(igrib(ii),'level',valSurf,iret)
+ call grib_check(iret,gribFunction,gribErrorMsg)
+ call grib_get_int(igrib(ii),'paramId',parId,iret)
+ call grib_check(iret,gribFunction,gribErrorMsg)
+
+ !print*,discipl,parCat,parNum,typSurf,valSurf
+
+ !convert to grib1 identifiers
+ isec1(6)=-1
+ isec1(7)=-1
+ isec1(8)=-1
+ isec1(8)=valSurf ! level
+ conversion_factor=1.
+ if ((parCat.eq.0).and.(parNum.eq.0).and.(typSurf.eq.105)) then ! T
+ isec1(6)=130 ! indicatorOfParameter
+ elseif ((parCat.eq.2).and.(parNum.eq.2).and.(typSurf.eq.105)) then ! U
+ isec1(6)=131 ! indicatorOfParameter
+ elseif ((parCat.eq.2).and.(parNum.eq.3).and.(typSurf.eq.105)) then ! V
+ isec1(6)=132 ! indicatorOfParameter
+ elseif ((parCat.eq.1).and.(parNum.eq.0).and.(typSurf.eq.105)) then ! Q
+ isec1(6)=133 ! indicatorOfParameter
+ ! ESO Cloud water is in a) fields CLWC and CIWC, *or* b) field QC
+ elseif ((parCat.eq.1).and.(parNum.eq.83).and.(typSurf.eq.105)) then ! clwc
+ isec1(6)=246 ! indicatorOfParameter
+ elseif ((parCat.eq.1).and.(parNum.eq.84).and.(typSurf.eq.105)) then ! ciwc
+ isec1(6)=247 ! indicatorOfParameter
+ ! ESO qc(=clwc+ciwc):
+ elseif ((parCat.eq.201).and.(parNum.eq.31).and.(typSurf.eq.105)) then ! qc
+ isec1(6)=201031 ! indicatorOfParameter
+ elseif ((parCat.eq.3).and.(parNum.eq.0).and.(typSurf.eq.1)) then !SP
+ isec1(6)=134 ! indicatorOfParameter
+ elseif ((parCat.eq.2).and.(parNum.eq.32)) then ! W, actually eta dot
+ isec1(6)=135 ! indicatorOfParameter
+ elseif ((parCat.eq.128).and.(parNum.eq.77)) then ! W, actually eta dot
+ isec1(6)=135 ! indicatorOfParameter
+ elseif ((parCat.eq.3).and.(parNum.eq.0).and.(typSurf.eq.101)) then !SLP
+ isec1(6)=151 ! indicatorOfParameter
+ elseif ((parCat.eq.2).and.(parNum.eq.2).and.(typSurf.eq.103)) then ! 10U
+ isec1(6)=165 ! indicatorOfParameter
+ elseif ((parCat.eq.2).and.(parNum.eq.3).and.(typSurf.eq.103)) then ! 10V
+ isec1(6)=166 ! indicatorOfParameter
+ elseif ((parCat.eq.0).and.(parNum.eq.0).and.(typSurf.eq.103)) then ! 2T
+ isec1(6)=167 ! indicatorOfParameter
+ elseif ((parCat.eq.0).and.(parNum.eq.6).and.(typSurf.eq.103)) then ! 2D
+ isec1(6)=168 ! indicatorOfParameter
+ elseif ((parCat.eq.1).and.(parNum.eq.11).and.(typSurf.eq.1)) then ! SD
+ isec1(6)=141 ! indicatorOfParameter
+ conversion_factor=1000.
+ elseif ((parCat.eq.6).and.(parNum.eq.1) .or. parId .eq. 164) then ! CC
+ isec1(6)=164 ! indicatorOfParameter
+ elseif ((parCat.eq.1).and.(parNum.eq.9) .or. parId .eq. 142) then ! LSP
+ isec1(6)=142 ! indicatorOfParameter
+ elseif ((parCat.eq.1).and.(parNum.eq.10)) then ! CP
+ isec1(6)=143 ! indicatorOfParameter
+ conversion_factor=1000.
+ elseif ((parCat.eq.0).and.(parNum.eq.11).and.(typSurf.eq.1)) then ! SHF
+ isec1(6)=146 ! indicatorOfParameter
+ elseif ((parCat.eq.4).and.(parNum.eq.9).and.(typSurf.eq.1)) then ! SR
+ isec1(6)=176 ! indicatorOfParameter
+ ! elseif ((parCat.eq.2).and.(parNum.eq.17) .or. parId .eq. 180) then ! EWSS --wrong
+ elseif ((parCat.eq.2).and.(parNum.eq.38) .or. parId .eq. 180) then ! EWSS --correct
+ isec1(6)=180 ! indicatorOfParameter
+ ! elseif ((parCat.eq.2).and.(parNum.eq.18) .or. parId .eq. 181) then ! NSSS --wrong
+ elseif ((parCat.eq.2).and.(parNum.eq.37) .or. parId .eq. 181) then ! NSSS --correct
+ isec1(6)=181 ! indicatorOfParameter
+ elseif ((parCat.eq.3).and.(parNum.eq.4)) then ! ORO
+ isec1(6)=129 ! indicatorOfParameter
+ elseif ((parCat.eq.3).and.(parNum.eq.7) .or. parId .eq. 160) then ! SDO
+ isec1(6)=160 ! indicatorOfParameter
+ elseif ((discipl.eq.2).and.(parCat.eq.0).and.(parNum.eq.0).and. &
+ (typSurf.eq.1)) then ! LSM
+ isec1(6)=172 ! indicatorOfParameter
+ elseif (parNum.eq.152) then
+ isec1(6)=152 ! avoid warning for lnsp
+ else
+ print*,'***WARNING: undefined GRiB2 message found!',discipl, &
+ parCat,parNum,typSurf
+ endif
+ if(parId .ne. isec1(6) .and. parId .ne. 77) then
+ write(*,*) 'parId',parId, 'isec1(6)',isec1(6)
+ ! stop
+ endif
+
+ endif
+
+ !HSO get the size and data of the values array
+ if (isec1(6).ne.-1) then
+ call grib_get_real4_array(igrib(ii),'values',zsec4,iret)
+ call grib_check(iret,gribFunction,gribErrorMsg)
+ endif
+
+ !HSO get the required fields from section 2 in a gribex compatible manner
+ if (ii.eq.1) then
+ call grib_get_int(igrib(ii),'numberOfPointsAlongAParallel',isec2(2),iret)
+ call grib_check(iret,gribFunction,gribErrorMsg)
+ call grib_get_int(igrib(ii),'numberOfPointsAlongAMeridian',isec2(3),iret)
+ call grib_check(iret,gribFunction,gribErrorMsg)
+ call grib_get_int(igrib(ii),'numberOfVerticalCoordinateValues',isec2(12))
+ call grib_check(iret,gribFunction,gribErrorMsg)
+ ! CHECK GRID SPECIFICATIONS
+ if(isec2(2).ne.nxfield) stop 'READWIND: NX NOT CONSISTENT'
+ if(isec2(3).ne.ny) stop 'READWIND: NY NOT CONSISTENT'
+ if(isec2(12)/2-1.ne.nlev_ec) &
+ stop 'READWIND: VERTICAL DISCRETIZATION NOT CONSISTENT'
+ endif ! ifield
+
+!$OMP CRITICAL
+ !HSO get the second part of the grid dimensions only from GRiB1 messages
+ if (isec1(6) .eq. 167 .and. (gotGrid.eq.0)) then
+ call grib_get_real8(igrib(ii),'longitudeOfFirstGridPointInDegrees', &
+ xauxin,iret)
+ call grib_check(iret,gribFunction,gribErrorMsg)
+ call grib_get_real8(igrib(ii),'latitudeOfLastGridPointInDegrees', &
+ yauxin,iret)
+ call grib_check(iret,gribFunction,gribErrorMsg)
+ if (xauxin.gt.180.) xauxin=xauxin-360.0
+ if (xauxin.lt.-180.) xauxin=xauxin+360.0
+
+ xaux=xauxin+real(nxshift)*dx
+ yaux=yauxin
+ if (xaux.gt.180.) xaux=xaux-360.0
+ if(abs(xaux-xlon0).gt.eps) &
+ stop 'READWIND: LOWER LEFT LONGITUDE NOT CONSISTENT'
+ if(abs(yaux-ylat0).gt.eps) &
+ stop 'READWIND: LOWER LEFT LATITUDE NOT CONSISTENT'
+ gotGrid=1
+ endif ! gotGrid
+!$OMP END CRITICAL
+
+ k=isec1(8)
+ select case(isec1(6))
+ !! TEMPERATURE
+ case(130)
+ do j=0,nymin1
+ do i=0,nxfield-1
+ tth(i,j,nlev_ec-k+2,n) = zsec4(nxfield*(ny-j-1)+i+1)
+ end do
+ end do
+ !! U VELOCITY
+ case(131)
+ do j=0,nymin1
+ do i=0,nxfield-1
+ uuh(i,j,nlev_ec-k+2) = zsec4(nxfield*(ny-j-1)+i+1)
+ end do
+ end do
+!$OMP CRITICAL
+ iumax=max(iumax,nlev_ec-k+1)
+!$OMP END CRITICAL
+ !! V VELOCITY
+ case(132)
+ do j=0,nymin1
+ do i=0,nxfield-1
+ vvh(i,j,nlev_ec-k+2) = zsec4(nxfield*(ny-j-1)+i+1)
+ end do
+ end do
+ !! SPEC. HUMIDITY
+ case(133)
+ do j=0,nymin1
+ do i=0,nxfield-1
+ qvh(i,j,nlev_ec-k+2,n) = zsec4(nxfield*(ny-j-1)+i+1)
+ if (qvh(i,j,nlev_ec-k+2,n) .lt. 0.) &
+ qvh(i,j,nlev_ec-k+2,n) = 0.
+ ! this is necessary because the gridded data may contain
+ ! spurious negative values
+ end do
+ end do
+ !! SURF. PRESS.
+ case(134)
+ do j=0,nymin1
+ do i=0,nxfield-1
+ ps(i,j,1,n) = zsec4(nxfield*(ny-j-1)+i+1)
+ end do
+ end do
+ !! W VELOCITY
+ case(135)
+ do j=0,nymin1
+ do i=0,nxfield-1
+ wwh(i,j,nlev_ec-k+1) = zsec4(nxfield*(ny-j-1)+i+1)
+ end do
+ end do
+!$OMP CRITICAL
+ iwmax=max(iwmax,nlev_ec-k+1)
+!$OMP END CRITICAL
+ !! SNOW DEPTH
+ case(141)
+ do j=0,nymin1
+ do i=0,nxfield-1
+ sd(i,j,1,n)= zsec4(nxfield*(ny-j-1)+i+1)/conversion_factor
+ end do
+ end do
+ !! SEA LEVEL PRESS.
+ case(151)
+ do j=0,nymin1
+ do i=0,nxfield-1
+ msl(i,j,1,n) = zsec4(nxfield*(ny-j-1)+i+1)
+ end do
+ end do
+ !! CLOUD COVER
+ case(164)
+ do j=0,nymin1
+ do i=0,nxfield-1
+ tcc(i,j,1,n) = zsec4(nxfield*(ny-j-1)+i+1)
+ end do
+ end do
+ !! 10 M U VELOCITY
+ case(165)
+ do j=0,nymin1
+ do i=0,nxfield-1
+ u10(i,j,1,n)= zsec4(nxfield*(ny-j-1)+i+1)
+ end do
+ end do
+ !! 10 M V VELOCITY
+ case(166)
+ do j=0,nymin1
+ do i=0,nxfield-1
+ v10(i,j,1,n) = zsec4(nxfield*(ny-j-1)+i+1)
+ end do
+ end do
+ !! 2 M TEMPERATURE
+ case(167)
+ do j=0,nymin1
+ do i=0,nxfield-1
+ tt2(i,j,1,n) = zsec4(nxfield*(ny-j-1)+i+1)
+ end do
+ end do
+ !! 2 M DEW POINT
+ case(168)
+ do j=0,nymin1
+ do i=0,nxfield-1
+ td2(i,j,1,n) = zsec4(nxfield*(ny-j-1)+i+1)
+ end do
+ end do
+ !! LARGE SCALE PREC.
+ case(142)
+ do j=0,nymin1
+ do i=0,nxfield-1
+ lsprec(i,j,1,n)=zsec4(nxfield*(ny-j-1)+i+1)
+ if (lsprec(i,j,1,n).lt.0.) lsprec(i,j,1,n)=0.
+ end do
+ end do
+ !! CONVECTIVE PREC.
+ case(143)
+ do j=0,nymin1
+ do i=0,nxfield-1
+ convprec(i,j,1,n)=zsec4(nxfield*(ny-j-1)+i+1)/conversion_factor
+ if (convprec(i,j,1,n).lt.0.) convprec(i,j,1,n)=0.
+ end do
+ end do
+ !! SENS. HEAT FLUX
+ case(146)
+ do j=0,nymin1
+ do i=0,nxfield-1
+ sshf(i,j,1,n) = zsec4(nxfield*(ny-j-1)+i+1)
+!$OMP CRITICAL
+ if(zsec4(nxfield*(ny-j-1)+i+1).ne.0.) &
+ hflswitch=.true. ! Heat flux available
+!$OMP END CRITICAL
+ end do
+ end do
+ !! SOLAR RADIATION
+ case(176)
+ do j=0,nymin1
+ do i=0,nxfield-1
+ ssr(i,j,1,n)=zsec4(nxfield*(ny-j-1)+i+1)
+ if (ssr(i,j,1,n).lt.0.) ssr(i,j,1,n)=0.
+ end do
+ end do
+ !! EW SURFACE STRESS
+ case(180)
+ do j=0,nymin1
+ do i=0,nxfield-1
+ ewss(i,j) = zsec4(nxfield*(ny-j-1)+i+1)
+!$OMP CRITICAL
+ if (zsec4(nxfield*(ny-j-1)+i+1).ne.0.) strswitch=.true. ! stress available
+!$OMP END CRITICAL
+ end do
+ end do
+ !! NS SURFACE STRESS
+ case(181)
+ do j=0,nymin1
+ do i=0,nxfield-1
+ nsss(i,j) = zsec4(nxfield*(ny-j-1)+i+1)
+!$OMP CRITICAL
+ if (zsec4(nxfield*(ny-j-1)+i+1).ne.0.) strswitch=.true. ! stress available
+!$OMP END CRITICAL
+ end do
+ end do
+ !! ECMWF OROGRAPHY
+ case(129)
+ do j=0,nymin1
+ do i=0,nxfield-1
+ oro(i,j) = zsec4(nxfield*(ny-j-1)+i+1)/ga
+ end do
+ end do
+ !! STANDARD DEVIATION OF OROGRAPHY
+ case(160)
+ do j=0,nymin1
+ do i=0,nxfield-1
+ excessoro(i,j) = zsec4(nxfield*(ny-j-1)+i+1)
+ end do
+ end do
+ !! ECMWF LAND SEA MASK
+ case(172)
+ do j=0,nymin1
+ do i=0,nxfield-1
+ lsm(i,j) = zsec4(nxfield*(ny-j-1)+i+1)
+ end do
+ end do
+ !! CLWC Cloud liquid water content [kg/kg]
+ case(246)
+ do j=0,nymin1
+ do i=0,nxfield-1
+ clwch(i,j,nlev_ec-k+2,n)=zsec4(nxfield*(ny-j-1)+i+1)
+ end do
+ end do
+!$OMP CRITICAL
+ readclouds=.true.
+ sumclouds=.false.
+!$OMP END CRITICAL
+ !! CIWC Cloud ice water content
+ case(247)
+ do j=0,nymin1
+ do i=0,nxfield-1
+ ciwch(i,j,nlev_ec-k+2,n)=zsec4(nxfield*(ny-j-1)+i+1)
+ end do
+ end do
+ !ZHG end
+ !ESO read qc (=clwc+ciwc)
+ !! QC Cloud liquid water content [kg/kg]
+ case(201031)
+ do j=0,nymin1
+ do i=0,nxfield-1
+ clwch(i,j,nlev_ec-k+2,n)=zsec4(nxfield*(ny-j-1)+i+1)
+ end do
+ end do
+!$OMP CRITICAL
+ readclouds=.true.
+ sumclouds=.false.
+!$OMP END CRITICAL
+
+ end select
+
+ call grib_release(igrib(ii))
+
+ end do fieldloop
+!$OMP END DO
+ deallocate(zsec4)
+!$OMP END PARALLEL
+
+ deallocate(igrib)
+ !
+ ! CLOSING OF INPUT DATA FILE
+ !
+
+ ! 50 call grib_close_file(ifile)
+
+ !error message if no fields found with correct first longitude in it
+ if (gotGrid.eq.0) then
+ print*,'***ERROR: input file needs to contain GRiB1 formatted'// &
+ 'messages'
+ stop
+ endif
+
+ if(levdiff2.eq.0) then
+ iwmax=nlev_ec+1
+ do i=0,nxmin1
+ do j=0,nymin1
+ wwh(i,j,nlev_ec+1)=0.
+ end do
+ end do
+ endif
+
+ ! For global fields, assign the leftmost data column also to the rightmost
+ ! data column; if required, shift whole grid by nxshift grid points
+ !*************************************************************************
+
+ if (xglobal) then
+ call shift_field_0(ewss,nxfield,ny)
+ call shift_field_0(nsss,nxfield,ny)
+ call shift_field_0(oro,nxfield,ny)
+ call shift_field_0(excessoro,nxfield,ny)
+ call shift_field_0(lsm,nxfield,ny)
+ call shift_field(ps,nxfield,ny,1,1,2,n)
+ call shift_field(sd,nxfield,ny,1,1,2,n)
+ call shift_field(msl,nxfield,ny,1,1,2,n)
+ call shift_field(tcc,nxfield,ny,1,1,2,n)
+ call shift_field(u10,nxfield,ny,1,1,2,n)
+ call shift_field(v10,nxfield,ny,1,1,2,n)
+ call shift_field(tt2,nxfield,ny,1,1,2,n)
+ call shift_field(td2,nxfield,ny,1,1,2,n)
+ call shift_field(lsprec,nxfield,ny,1,1,2,n)
+ call shift_field(convprec,nxfield,ny,1,1,2,n)
+ call shift_field(sshf,nxfield,ny,1,1,2,n)
+ call shift_field(ssr,nxfield,ny,1,1,2,n)
+ call shift_field(tth,nxfield,ny,nuvzmax,nuvz,2,n)
+ call shift_field(qvh,nxfield,ny,nuvzmax,nuvz,2,n)
+ call shift_field(uuh,nxfield,ny,nuvzmax,nuvz,1,1)
+ call shift_field(vvh,nxfield,ny,nuvzmax,nuvz,1,1)
+ call shift_field(wwh,nxfield,ny,nwzmax,nwz,1,1)
+ !ZHG
+ call shift_field(clwch,nxfield,ny,nuvzmax,nuvz,2,n)
+ if (.not.sumclouds) call shift_field(ciwch,nxfield,ny,nuvzmax,nuvz,2,n)
+ !ZHG end
+
+ endif
+
+ do i=0,nxmin1
+ do j=0,nymin1
+ if ((ewss(i,j).eq.0.).and.(nsss(i,j).eq.0.)) then
+ if ((i.ne.0).and.(j.ne.0).and.(i.ne.nxmin1).and.(j.ne.nymin1)) then
+ ewss(i,j)=(ewss(i-1,j-1)+ewss(i+1,j+1)+ewss(i+1,j)+ewss(i-1,j)+ &
+ ewss(i,j+1)+ewss(i,j-1)+ewss(i-1,j+1)+ewss(i+1,j-1))/8.
+ nsss(i,j)=(nsss(i-1,j-1)+nsss(i+1,j+1)+nsss(i+1,j)+nsss(i-1,j)+ &
+ nsss(i,j+1)+nsss(i,j-1)+nsss(i-1,j+1)+nsss(i+1,j-1))/8.
+ else if ((i.eq.0).and.(j.eq.0)) then
+ ewss(i,j)=(ewss(i+1,j+1)+ewss(i+1,j)+ewss(i,j+1))/3.
+ nsss(i,j)=(nsss(i+1,j+1)+nsss(i+1,j)+nsss(i,j+1))/3.
+ else if ((i.eq.nxmin1).and.(j.eq.nymin1)) then
+ ewss(i,j)=(ewss(i-1,j-1)+ewss(i-1,j)+ewss(i,j-1))/3.
+ nsss(i,j)=(nsss(i-1,j-1)+nsss(i-1,j)+nsss(i,j-1))/3.
+ else if ((i.eq.0).and.(j.eq.nymin1)) then
+ ewss(i,j)=(ewss(i+1,j-1)+ewss(i+1,j)+ewss(i,j-1))/3.
+ nsss(i,j)=(nsss(i+1,j-1)+nsss(i+1,j)+nsss(i,j-1))/3.
+ else if ((i.eq.nxmin1).and.(j.eq.0)) then
+ ewss(i,j)=(ewss(i-1,j+1)+ewss(i-1,j)+ewss(i,j+1))/3.
+ nsss(i,j)=(nsss(i-1,j+1)+nsss(i-1,j)+nsss(i,j+1))/3.
+ else if (i.eq.0) then
+ ewss(i,j)=(ewss(i+1,j+1)+ewss(i+1,j)+ewss(i,j+1)+ewss(i,j-1)+ewss(i+1,j-1))/5.
+ nsss(i,j)=(nsss(i+1,j+1)+nsss(i+1,j)+nsss(i,j+1)+nsss(i,j-1)+nsss(i+1,j-1))/5.
+ else if (i.eq.nxmin1) then
+ ewss(i,j)=(ewss(i-1,j+1)+ewss(i-1,j)+ewss(i,j+1)+ewss(i,j-1)+ewss(i-1,j-1))/5.
+ nsss(i,j)=(nsss(i-1,j+1)+nsss(i-1,j)+nsss(i,j+1)+nsss(i,j-1)+nsss(i-1,j-1))/5.
+ else if (j.eq.0) then
+ ewss(i,j)=(ewss(i+1,j+1)+ewss(i+1,j)+ewss(i-1,j)+ewss(i,j+1)+ewss(i-1,j+1))/5.
+ nsss(i,j)=(nsss(i+1,j+1)+nsss(i+1,j)+nsss(i-1,j)+nsss(i,j+1)+nsss(i-1,j+1))/5.
+ else if (j.eq.nymin1) then
+ ewss(i,j)=(ewss(i+1,j-1)+ewss(i+1,j)+ewss(i-1,j)+ewss(i,j-1)+ewss(i-1,j-1))/5.
+ nsss(i,j)=(nsss(i+1,j-1)+nsss(i+1,j)+nsss(i-1,j)+nsss(i,j-1)+nsss(i-1,j-1))/5.
+ endif
+ endif
+ surfstr(i,j,1,n)=sqrt(ewss(i,j)**2+nsss(i,j)**2)
+ end do
+ end do
+
+ if ((.not.hflswitch).or.(.not.strswitch)) then
+ write(*,*) 'WARNING: No flux data contained in GRIB file ', &
+ wfname(indj)
+
+ ! CALCULATE USTAR AND SSHF USING THE PROFILE METHOD
+ ! As ECMWF has increased the model resolution, such that now the first model
+ ! level is at about 10 m (where 10-m wind is given), use the 2nd ECMWF level
+ ! (3rd model level in FLEXPART) for the profile method
+ !***************************************************************************
+
+ do i=0,nxmin1
+ do j=0,nymin1
+ plev1=akz(3)+bkz(3)*ps(i,j,1,n)
+ pmean=0.5*(ps(i,j,1,n)+plev1)
+ tv=tth(i,j,3,n)*(1.+0.61*qvh(i,j,3,n))
+ fu=-r_air*tv/ga/pmean
+ hlev1=fu*(plev1-ps(i,j,1,n)) ! HEIGTH OF FIRST MODEL LAYER
+ ff10m= sqrt(u10(i,j,1,n)**2+v10(i,j,1,n)**2)
+ fflev1=sqrt(uuh(i,j,3)**2+vvh(i,j,3)**2)
+ call pbl_profile(ps(i,j,1,n),td2(i,j,1,n),hlev1, &
+ tt2(i,j,1,n),tth(i,j,3,n),ff10m,fflev1, &
+ surfstr(i,j,1,n),sshf(i,j,1,n))
+ if(sshf(i,j,1,n).gt.200.) sshf(i,j,1,n)=200.
+ if(sshf(i,j,1,n).lt.-400.) sshf(i,j,1,n)=-400.
+ end do
+ end do
+ endif
+
+
+ ! Assign 10 m wind to model level at eta=1.0 to have one additional model
+ ! level at the ground
+ ! Specific humidity is taken the same as at one level above
+ ! Temperature is taken as 2 m temperature
+ !**************************************************************************
+
+ do i=0,nxmin1
+ do j=0,nymin1
+ uuh(i,j,1)=u10(i,j,1,n)
+ vvh(i,j,1)=v10(i,j,1,n)
+ qvh(i,j,1,n)=qvh(i,j,2,n)
+ tth(i,j,1,n)=tt2(i,j,1,n)
+ end do
+ end do
+
+ if(iumax.ne.nuvz-1) stop 'READWIND: NUVZ NOT CONSISTENT'
+ if(iwmax.ne.nwz) stop 'READWIND: NWZ NOT CONSISTENT'
+
+ return
+
+888 write(*,*) ' #### FLEXPART MODEL ERROR! WINDFIELD #### '
+ write(*,*) ' #### ',wfname(indj),' #### '
+ write(*,*) ' #### IS NOT GRIB FORMAT !!! #### '
+ stop 'Execution terminated'
+
+end subroutine readwind_ecmwf
+
+subroutine readwind_gfs(indj,n,uuh,vvh,wwh)
+
+ !***********************************************************************
+ !* *
+ !* TRAJECTORY MODEL SUBROUTINE READWIND *
+ !* *
+ !***********************************************************************
+ !* *
+ !* AUTHOR: G. WOTAWA *
+ !* DATE: 1997-08-05 *
+ !* LAST UPDATE: 2000-10-17, Andreas Stohl *
+ !* CHANGE: 01/02/2001, Bernd C. Krueger, Variables tth and *
+ !* qvh (on eta coordinates) in common block *
+ !* CHANGE: 16/11/2005, Caroline Forster, GFS data *
+ !* CHANGE: 11/01/2008, Harald Sodemann, Input of GRIB1/2 *
+ !* data with the ECMWF grib_api library *
+ !* CHANGE: 03/12/2008, Harald Sodemann, update to f90 with *
+ !* ECMWF grib_api *
+ ! *
+ ! Unified ECMWF and GFS builds *
+ ! Marian Harustak, 12.5.2017 *
+ ! - Renamed routine from readwind to readwind_gfs *
+ !* *
+ !***********************************************************************
+ !* *
+ !* DESCRIPTION: *
+ !* *
+ !* READING OF ECMWF METEOROLOGICAL FIELDS FROM INPUT DATA FILES. THE *
+ !* INPUT DATA FILES ARE EXPECTED TO BE AVAILABLE IN GRIB CODE *
+ !* *
+ !* INPUT: *
+ !* indj indicates number of the wind field to be read in *
+ !* n temporal index for meteorological fields (1 to 3)*
+ !* *
+ !* IMPORTANT VARIABLES FROM COMMON BLOCK: *
+ !* *
+ !* wfname File name of data to be read in *
+ !* nx,ny,nuvz,nwz expected field dimensions *
+ !* nlev_ec number of vertical levels ecmwf model *
+ !* uu,vv,ww wind fields *
+ !* tt,qv temperature and specific humidity *
+ !* ps surface pressure *
+ !* *
+ !***********************************************************************
+
+ use grib_api
+ use qvsat_mod
+
+ implicit none
+
+ !HSO new parameters for grib_api
+ integer :: ifile
+ integer :: iret
+ integer :: igrib
+ integer :: gribVer,parCat,parNum,typSurf,valSurf,discipl
+ !HSO end edits
+ real :: uuh(0:nxmax-1,0:nymax-1,nuvzmax)
+ real :: vvh(0:nxmax-1,0:nymax-1,nuvzmax)
+ real :: wwh(0:nxmax-1,0:nymax-1,nwzmax)
+ integer :: ii,indj,i,j,k,n,levdiff2,ifield,iumax,iwmax
+
+ ! NCEP
+ integer :: numpt,numpu,numpv,numpw,numprh,numpclwch
+ real :: help, temp
+ real :: elev
+ real :: ulev1(0:nxmax-1,0:nymax-1),vlev1(0:nxmax-1,0:nymax-1)
+ real :: tlev1(0:nxmax-1,0:nymax-1)
+ real :: qvh2(0:nxmax-1,0:nymax-1)
+
+ integer :: i179,i180,i181
+
+ ! VARIABLES AND ARRAYS NEEDED FOR GRIB DECODING
+ !HSO kept isec1, isec2 and zsec4 for consistency with gribex GRIB input
+
+ integer :: isec1(8),isec2(3)
+ real(kind=4) :: zsec4(jpunp)
+ real(kind=4) :: xaux,yaux,xaux0,yaux0
+ real(kind=8) :: xauxin,yauxin
+ real,parameter :: eps=1.e-4
+ real(kind=4) :: ewss(0:nxmax-1,0:nymax-1),nsss(0:nxmax-1,0:nymax-1)
+ real :: plev1,hlev1,ff10m,fflev1
+
+ logical :: hflswitch,strswitch
+
+ !HSO for grib api error messages
+ character(len=24) :: gribErrorMsg = 'Error reading grib file'
+ character(len=20) :: gribFunction = 'readwind_gfs'
+ character(len=20) :: shortname
+
+
+ hflswitch=.false.
+ strswitch=.false.
+ levdiff2=nlev_ec-nwz+1
+ iumax=0
+ iwmax=0
+
+
+ ! OPENING OF DATA FILE (GRIB CODE)
+
+ !HSO
+ call grib_open_file(ifile,path(3)(1:length(3)) &
+ //trim(wfname(indj)),'r',iret)
+ if (iret.ne.GRIB_SUCCESS) then
+ goto 888 ! ERROR DETECTED
+ endif
+ !turn on support for multi fields messages
+ call grib_multi_support_on
+
+ numpt=0
+ numpu=0
+ numpv=0
+ numpw=0
+ numprh=0
+ numpclwch=0
+ ifield=0
+ do
+ ifield=ifield+1
+ !
+ ! GET NEXT FIELDS
+ !
+ call grib_new_from_file(ifile,igrib,iret)
+ if (iret.eq.GRIB_END_OF_FILE) then
+ exit ! EOF DETECTED
+ elseif (iret.ne.GRIB_SUCCESS) then
+ goto 888 ! ERROR DETECTED
+ endif
+
+ !first see if we read GRIB1 or GRIB2
+ call grib_get_int(igrib,'editionNumber',gribVer,iret)
+ ! call grib_check(iret,gribFunction,gribErrorMsg)
+
+ if (gribVer.eq.1) then ! GRIB Edition 1
+
+ !read the grib1 identifiers
+ call grib_get_int(igrib,'indicatorOfParameter',isec1(6),iret)
+ ! call grib_check(iret,gribFunction,gribErrorMsg)
+ call grib_get_int(igrib,'indicatorOfTypeOfLevel',isec1(7),iret)
+ ! call grib_check(iret,gribFunction,gribErrorMsg)
+ call grib_get_int(igrib,'level',isec1(8),iret)
+ ! call grib_check(iret,gribFunction,gribErrorMsg)
+
+ else ! GRIB Edition 2
+
+ !read the grib2 identifiers
+ call grib_get_string(igrib,'shortName',shortname,iret)
+
+ call grib_get_int(igrib,'discipline',discipl,iret)
+ ! call grib_check(iret,gribFunction,gribErrorMsg)
+ call grib_get_int(igrib,'parameterCategory',parCat,iret)
+ ! call grib_check(iret,gribFunction,gribErrorMsg)
+ call grib_get_int(igrib,'parameterNumber',parNum,iret)
+ ! call grib_check(iret,gribFunction,gribErrorMsg)
+ call grib_get_int(igrib,'typeOfFirstFixedSurface',typSurf,iret)
+ ! call grib_check(iret,gribFunction,gribErrorMsg)
+ call grib_get_int(igrib,'scaledValueOfFirstFixedSurface', &
+ valSurf,iret)
+ ! call grib_check(iret,gribFunction,gribErrorMsg)
+
+ ! write(*,*) 'Field: ',ifield,parCat,parNum,typSurf,shortname
+ !convert to grib1 identifiers
+ isec1(6)=-1
+ isec1(7)=-1
+ isec1(8)=-1
+ if ((parCat.eq.0).and.(parNum.eq.0).and.(typSurf.eq.100)) then ! T
+ isec1(6)=11 ! indicatorOfParameter
+ isec1(7)=100 ! indicatorOfTypeOfLevel
+ isec1(8)=valSurf/100 ! level, convert to hPa
+ elseif ((parCat.eq.2).and.(parNum.eq.2).and.(typSurf.eq.100)) then ! U
+ isec1(6)=33 ! indicatorOfParameter
+ isec1(7)=100 ! indicatorOfTypeOfLevel
+ isec1(8)=valSurf/100 ! level, convert to hPa
+ elseif ((parCat.eq.2).and.(parNum.eq.3).and.(typSurf.eq.100)) then ! V
+ isec1(6)=34 ! indicatorOfParameter
+ isec1(7)=100 ! indicatorOfTypeOfLevel
+ isec1(8)=valSurf/100 ! level, convert to hPa
+ elseif ((parCat.eq.2).and.(parNum.eq.8).and.(typSurf.eq.100)) then ! W
+ isec1(6)=39 ! indicatorOfParameter
+ isec1(7)=100 ! indicatorOfTypeOfLevel
+ isec1(8)=valSurf/100 ! level, convert to hPa
+ elseif ((parCat.eq.1).and.(parNum.eq.1).and.(typSurf.eq.100)) then ! RH
+ isec1(6)=52 ! indicatorOfParameter
+ isec1(7)=100 ! indicatorOfTypeOfLevel
+ isec1(8)=valSurf/100 ! level, convert to hPa
+ elseif ((parCat.eq.1).and.(parNum.eq.1).and.(typSurf.eq.103)) then ! RH2
+ isec1(6)=52 ! indicatorOfParameter
+ isec1(7)=105 ! indicatorOfTypeOfLevel
+ isec1(8)=2
+ elseif ((parCat.eq.0).and.(parNum.eq.0).and.(typSurf.eq.103)) then ! T2
+ isec1(6)=11 ! indicatorOfParameter
+ isec1(7)=105 ! indicatorOfTypeOfLevel
+ isec1(8)=2
+ elseif ((parCat.eq.2).and.(parNum.eq.2).and.(typSurf.eq.103)) then ! U10
+ isec1(6)=33 ! indicatorOfParameter
+ isec1(7)=105 ! indicatorOfTypeOfLevel
+ isec1(8)=10
+ elseif ((parCat.eq.2).and.(parNum.eq.3).and.(typSurf.eq.103)) then ! V10
+ isec1(6)=34 ! indicatorOfParameter
+ isec1(7)=105 ! indicatorOfTypeOfLevel
+ isec1(8)=10
+ elseif ((parCat.eq.1).and.(parNum.eq.22).and.(typSurf.eq.100)) then ! CLWMR Cloud Mixing Ratio [kg/kg]:
+ isec1(6)=153 ! indicatorOfParameter
+ isec1(7)=100 ! indicatorOfTypeOfLevel
+ isec1(8)=valSurf/100 ! level, convert to hPa
+ elseif ((parCat.eq.3).and.(parNum.eq.1).and.(typSurf.eq.101)) then ! SLP
+ isec1(6)=2 ! indicatorOfParameter
+ isec1(7)=102 ! indicatorOfTypeOfLevel
+ isec1(8)=0
+ elseif ((parCat.eq.3).and.(parNum.eq.0).and.(typSurf.eq.1)) then ! SP
+ isec1(6)=1 ! indicatorOfParameter
+ isec1(7)=1 ! indicatorOfTypeOfLevel
+ isec1(8)=0
+ elseif ((parCat.eq.1).and.(parNum.eq.13).and.(typSurf.eq.1)) then ! SNOW
+ isec1(6)=66 ! indicatorOfParameter
+ isec1(7)=1 ! indicatorOfTypeOfLevel
+ isec1(8)=0
+ elseif ((parCat.eq.0).and.(parNum.eq.0).and.(typSurf.eq.104)) then ! T sigma 0
+ isec1(6)=11 ! indicatorOfParameter
+ isec1(7)=107 ! indicatorOfTypeOfLevel
+ isec1(8)=0.995 ! lowest sigma level
+ elseif ((parCat.eq.2).and.(parNum.eq.2).and.(typSurf.eq.104)) then ! U sigma 0
+ isec1(6)=33 ! indicatorOfParameter
+ isec1(7)=107 ! indicatorOfTypeOfLevel
+ isec1(8)=0.995 ! lowest sigma level
+ elseif ((parCat.eq.2).and.(parNum.eq.3).and.(typSurf.eq.104)) then ! V sigma 0
+ isec1(6)=34 ! indicatorOfParameter
+ isec1(7)=107 ! indicatorOfTypeOfLevel
+ isec1(8)=0.995 ! lowest sigma level
+ elseif ((parCat.eq.3).and.(parNum.eq.5).and.(typSurf.eq.1)) then ! TOPO
+ isec1(6)=7 ! indicatorOfParameter
+ isec1(7)=1 ! indicatorOfTypeOfLevel
+ isec1(8)=0
+ elseif ((parCat.eq.0).and.(parNum.eq.0).and.(typSurf.eq.1) &
+ .and.(discipl.eq.2)) then ! LSM
+ isec1(6)=81 ! indicatorOfParameter
+ isec1(7)=1 ! indicatorOfTypeOfLevel
+ isec1(8)=0
+ elseif ((parCat.eq.3).and.(parNum.eq.196).and.(typSurf.eq.1)) then ! BLH
+ isec1(6)=221 ! indicatorOfParameter
+ isec1(7)=1 ! indicatorOfTypeOfLevel
+ isec1(8)=0
+ elseif ((parCat.eq.1).and.(parNum.eq.7).and.(typSurf.eq.1)) then ! LSP/TP
+ isec1(6)=62 ! indicatorOfParameter
+ isec1(7)=1 ! indicatorOfTypeOfLevel
+ isec1(8)=0
+ elseif ((parCat.eq.1).and.(parNum.eq.196).and.(typSurf.eq.1)) then ! CP
+ isec1(6)=63 ! indicatorOfParameter
+ isec1(7)=1 ! indicatorOfTypeOfLevel
+ isec1(8)=0
+ endif
+
+ endif ! gribVer
+
+ if (isec1(6).ne.-1) then
+ ! get the size and data of the values array
+ call grib_get_real4_array(igrib,'values',zsec4,iret)
+ ! call grib_check(iret,gribFunction,gribErrorMsg)
+ endif
+
+ if(ifield.eq.1) then
+
+ !get the required fields from section 2
+ !store compatible to gribex input
+ call grib_get_int(igrib,'numberOfPointsAlongAParallel', &
+ isec2(2),iret)
+ ! call grib_check(iret,gribFunction,gribErrorMsg)
+ call grib_get_int(igrib,'numberOfPointsAlongAMeridian', &
+ isec2(3),iret)
+ ! call grib_check(iret,gribFunction,gribErrorMsg)
+ call grib_get_real8(igrib,'longitudeOfFirstGridPointInDegrees', &
+ xauxin,iret)
+ ! call grib_check(iret,gribFunction,gribErrorMsg)
+ call grib_get_real8(igrib,'latitudeOfLastGridPointInDegrees', &
+ yauxin,iret)
+ ! call grib_check(iret,gribFunction,gribErrorMsg)
+ xaux=xauxin+real(nxshift)*dx
+ yaux=yauxin
+
+ ! CHECK GRID SPECIFICATIONS
+
+ if(isec2(2).ne.nxfield) stop 'READWIND: NX NOT CONSISTENT'
+ if(isec2(3).ne.ny) stop 'READWIND: NY NOT CONSISTENT'
+ if(xaux.eq.0.) xaux=-179.0 ! NCEP DATA
+ xaux0=xlon0
+ yaux0=ylat0
+ if(xaux.lt.0.) xaux=xaux+360.
+ if(yaux.lt.0.) yaux=yaux+360.
+ if(xaux0.lt.0.) xaux0=xaux0+360.
+ if(yaux0.lt.0.) yaux0=yaux0+360.
+ if(abs(xaux-xaux0).gt.eps) &
+ stop 'READWIND: LOWER LEFT LONGITUDE NOT CONSISTENT'
+ if(abs(yaux-yaux0).gt.eps) &
+ stop 'READWIND: LOWER LEFT LATITUDE NOT CONSISTENT'
+ endif
+ !HSO end of edits
+
+ i179=nint(179./dx)
+ if (dx.lt.0.7) then
+ i180=nint(180./dx)+1 ! 0.5 deg data
+ else
+ i180=nint(179./dx)+1 ! 1 deg data
+ endif
+ i181=i180+1
+
+ if (isec1(6).ne.-1) then
+
+ do j=0,nymin1
+ do i=0,nxfield-1
+ if((isec1(6).eq.011).and.(isec1(7).eq.100)) then
+ ! TEMPERATURE
+ if((i.eq.0).and.(j.eq.0)) then
+ do ii=1,nuvz
+ if ((isec1(8)*100.0).eq.akz(ii)) numpt=ii
+ end do
+ endif
+ help=zsec4(nxfield*(ny-j-1)+i+1)
+ if(i.le.i180) then
+ tth(i179+i,j,numpt,n)=help
+ else
+ tth(i-i181,j,numpt,n)=help
+ endif
+ endif
+ if((isec1(6).eq.033).and.(isec1(7).eq.100)) then
+ ! U VELOCITY
+ if((i.eq.0).and.(j.eq.0)) then
+ do ii=1,nuvz
+ if ((isec1(8)*100.0).eq.akz(ii)) numpu=ii
+ end do
+ endif
+ help=zsec4(nxfield*(ny-j-1)+i+1)
+ if(i.le.i180) then
+ uuh(i179+i,j,numpu)=help
+ else
+ uuh(i-i181,j,numpu)=help
+ endif
+ endif
+ if((isec1(6).eq.034).and.(isec1(7).eq.100)) then
+ ! V VELOCITY
+ if((i.eq.0).and.(j.eq.0)) then
+ do ii=1,nuvz
+ if ((isec1(8)*100.0).eq.akz(ii)) numpv=ii
+ end do
+ endif
+ help=zsec4(nxfield*(ny-j-1)+i+1)
+ if(i.le.i180) then
+ vvh(i179+i,j,numpv)=help
+ else
+ vvh(i-i181,j,numpv)=help
+ endif
+ endif
+ if((isec1(6).eq.052).and.(isec1(7).eq.100)) then
+ ! RELATIVE HUMIDITY -> CONVERT TO SPECIFIC HUMIDITY LATER
+ if((i.eq.0).and.(j.eq.0)) then
+ do ii=1,nuvz
+ if ((isec1(8)*100.0).eq.akz(ii)) numprh=ii
+ end do
+ endif
+ help=zsec4(nxfield*(ny-j-1)+i+1)
+ if(i.le.i180) then
+ qvh(i179+i,j,numprh,n)=help
+ else
+ qvh(i-i181,j,numprh,n)=help
+ endif
+ endif
+ if((isec1(6).eq.001).and.(isec1(7).eq.001)) then
+ ! SURFACE PRESSURE
+ help=zsec4(nxfield*(ny-j-1)+i+1)
+ if(i.le.i180) then
+ ps(i179+i,j,1,n)=help
+ else
+ ps(i-i181,j,1,n)=help
+ endif
+ endif
+ if((isec1(6).eq.039).and.(isec1(7).eq.100)) then
+ ! W VELOCITY
+ if((i.eq.0).and.(j.eq.0)) then
+ do ii=1,nuvz
+ if ((isec1(8)*100.0).eq.akz(ii)) numpw=ii
+ end do
+ endif
+ help=zsec4(nxfield*(ny-j-1)+i+1)
+ if(i.le.i180) then
+ wwh(i179+i,j,numpw)=help
+ else
+ wwh(i-i181,j,numpw)=help
+ endif
+ endif
+ if((isec1(6).eq.066).and.(isec1(7).eq.001)) then
+ ! SNOW DEPTH
+ help=zsec4(nxfield*(ny-j-1)+i+1)
+ if(i.le.i180) then
+ sd(i179+i,j,1,n)=help
+ else
+ sd(i-i181,j,1,n)=help
+ endif
+ endif
+ if((isec1(6).eq.002).and.(isec1(7).eq.102)) then
+ ! MEAN SEA LEVEL PRESSURE
+ help=zsec4(nxfield*(ny-j-1)+i+1)
+ if(i.le.i180) then
+ msl(i179+i,j,1,n)=help
+ else
+ msl(i-i181,j,1,n)=help
+ endif
+ endif
+ if((isec1(6).eq.071).and.(isec1(7).eq.244)) then
+ ! TOTAL CLOUD COVER
+ help=zsec4(nxfield*(ny-j-1)+i+1)
+ if(i.le.i180) then
+ tcc(i179+i,j,1,n)=help
+ else
+ tcc(i-i181,j,1,n)=help
+ endif
+ endif
+ if((isec1(6).eq.033).and.(isec1(7).eq.105).and. &
+ (isec1(8).eq.10)) then
+ ! 10 M U VELOCITY
+ help=zsec4(nxfield*(ny-j-1)+i+1)
+ if(i.le.i180) then
+ u10(i179+i,j,1,n)=help
+ else
+ u10(i-i181,j,1,n)=help
+ endif
+ endif
+ if((isec1(6).eq.034).and.(isec1(7).eq.105).and. &
+ (isec1(8).eq.10)) then
+ ! 10 M V VELOCITY
+ help=zsec4(nxfield*(ny-j-1)+i+1)
+ if(i.le.i180) then
+ v10(i179+i,j,1,n)=help
+ else
+ v10(i-i181,j,1,n)=help
+ endif
+ endif
+ if((isec1(6).eq.011).and.(isec1(7).eq.105).and. &
+ (isec1(8).eq.02)) then
+ ! 2 M TEMPERATURE
+ help=zsec4(nxfield*(ny-j-1)+i+1)
+ if(i.le.i180) then
+ tt2(i179+i,j,1,n)=help
+ else
+ tt2(i-i181,j,1,n)=help
+ endif
+ endif
+ if((isec1(6).eq.017).and.(isec1(7).eq.105).and. &
+ (isec1(8).eq.02)) then
+ ! 2 M DEW POINT TEMPERATURE
+ help=zsec4(nxfield*(ny-j-1)+i+1)
+ if(i.le.i180) then
+ td2(i179+i,j,1,n)=help
+ else
+ td2(i-i181,j,1,n)=help
+ endif
+ endif
+ if((isec1(6).eq.062).and.(isec1(7).eq.001)) then
+ ! LARGE SCALE PREC.
+ help=zsec4(nxfield*(ny-j-1)+i+1)
+ if(i.le.i180) then
+ lsprec(i179+i,j,1,n)=help
+ else
+ lsprec(i-i181,j,1,n)=help
+ endif
+ endif
+ if((isec1(6).eq.063).and.(isec1(7).eq.001)) then
+ ! CONVECTIVE PREC.
+ help=zsec4(nxfield*(ny-j-1)+i+1)
+ if(i.le.i180) then
+ convprec(i179+i,j,1,n)=help
+ else
+ convprec(i-i181,j,1,n)=help
+ endif
+ endif
+ if((isec1(6).eq.007).and.(isec1(7).eq.001)) then
+ ! TOPOGRAPHY
+ help=zsec4(nxfield*(ny-j-1)+i+1)
+ if(i.le.i180) then
+ oro(i179+i,j)=help
+ excessoro(i179+i,j)=0.0 ! ISOBARIC SURFACES: SUBGRID TERRAIN DISREGARDED
+ else
+ oro(i-i181,j)=help
+ excessoro(i-i181,j)=0.0 ! ISOBARIC SURFACES: SUBGRID TERRAIN DISREGARDED
+ endif
+ endif
+ if((isec1(6).eq.081).and.(isec1(7).eq.001)) then
+ ! LAND SEA MASK
+ help=zsec4(nxfield*(ny-j-1)+i+1)
+ if(i.le.i180) then
+ lsm(i179+i,j)=help
+ else
+ lsm(i-i181,j)=help
+ endif
+ endif
+ if((isec1(6).eq.221).and.(isec1(7).eq.001)) then
+ ! MIXING HEIGHT
+ help=zsec4(nxfield*(ny-j-1)+i+1)
+ if(i.le.i180) then
+ hmix(i179+i,j,1,n)=help
+ else
+ hmix(i-i181,j,1,n)=help
+ endif
+ endif
+ if((isec1(6).eq.052).and.(isec1(7).eq.105).and. &
+ (isec1(8).eq.02)) then
+ ! 2 M RELATIVE HUMIDITY
+ help=zsec4(nxfield*(ny-j-1)+i+1)
+ if(i.le.i180) then
+ qvh2(i179+i,j)=help
+ else
+ qvh2(i-i181,j)=help
+ endif
+ endif
+ if((isec1(6).eq.011).and.(isec1(7).eq.107)) then
+ ! TEMPERATURE LOWEST SIGMA LEVEL
+ help=zsec4(nxfield*(ny-j-1)+i+1)
+ if(i.le.i180) then
+ tlev1(i179+i,j)=help
+ else
+ tlev1(i-i181,j)=help
+ endif
+ endif
+ if((isec1(6).eq.033).and.(isec1(7).eq.107)) then
+ ! U VELOCITY LOWEST SIGMA LEVEL
+ help=zsec4(nxfield*(ny-j-1)+i+1)
+ if(i.le.i180) then
+ ulev1(i179+i,j)=help
+ else
+ ulev1(i-i181,j)=help
+ endif
+ endif
+ if((isec1(6).eq.034).and.(isec1(7).eq.107)) then
+ ! V VELOCITY LOWEST SIGMA LEVEL
+ help=zsec4(nxfield*(ny-j-1)+i+1)
+ if(i.le.i180) then
+ vlev1(i179+i,j)=help
+ else
+ vlev1(i-i181,j)=help
+ endif
+ endif
+ ! SEC & IP 12/2018 read GFS clouds
+ if((isec1(6).eq.153).and.(isec1(7).eq.100)) then !! CLWCR Cloud liquid water content [kg/kg]
+ if((i.eq.0).and.(j.eq.0)) then
+ do ii=1,nuvz
+ if ((isec1(8)*100.0).eq.akz(ii)) numpclwch=ii
+ end do
+ endif
+ help=zsec4(nxfield*(ny-j-1)+i+1)
+ if(i.le.i180) then
+ clwch(i179+i,j,numpclwch,n)=help
+ else
+ clwch(i-i181,j,numpclwch,n)=help
+ endif
+ readclouds=.true.
+ sumclouds=.true.
+ ! readclouds=.false.
+ ! sumclouds=.false.
+ endif
+
+
+ end do
+ end do
+
+ endif
+
+ if((isec1(6).eq.33).and.(isec1(7).eq.100)) then
+ ! NCEP ISOBARIC LEVELS
+ iumax=iumax+1
+ endif
+
+ call grib_release(igrib)
+ end do !! READ NEXT LEVEL OR PARAMETER
+ !
+ ! CLOSING OF INPUT DATA FILE
+ !
+
+ !HSO close grib file
+ call grib_close_file(ifile)
+
+ ! SENS. HEAT FLUX
+ sshf(:,:,1,n)=0.0 ! not available from gfs.tccz.pgrbfxx files
+ hflswitch=.false. ! Heat flux not available
+ ! SOLAR RADIATIVE FLUXES
+ ssr(:,:,1,n)=0.0 ! not available from gfs.tccz.pgrbfxx files
+ ! EW SURFACE STRESS
+ ewss=0.0 ! not available from gfs.tccz.pgrbfxx files
+ ! NS SURFACE STRESS
+ nsss=0.0 ! not available from gfs.tccz.pgrbfxx files
+ strswitch=.false. ! stress not available
+
+ ! CONVERT TP TO LSP (GRIB2 only)
+ if (gribVer.eq.2) then
+ do j=0,nymin1
+ do i=0,nxfield-1
+ if(i.le.i180) then
+ if (convprec(i179+i,j,1,n).lt.lsprec(i179+i,j,1,n)) then ! neg precip would occur
+ lsprec(i179+i,j,1,n)= &
+ lsprec(i179+i,j,1,n)-convprec(i179+i,j,1,n)
+ else
+ lsprec(i179+i,j,1,n)=0
+ endif
+ else
+ if (convprec(i-i181,j,1,n).lt.lsprec(i-i181,j,1,n)) then
+ lsprec(i-i181,j,1,n)= &
+ lsprec(i-i181,j,1,n)-convprec(i-i181,j,1,n)
+ else
+ lsprec(i-i181,j,1,n)=0
+ endif
+ endif
+ enddo
+ enddo
+ endif
+ !HSO end edits
+
+
+ ! TRANSFORM RH TO SPECIFIC HUMIDITY
+
+ do j=0,ny-1
+ do i=0,nxfield-1
+ do k=1,nuvz
+ help=qvh(i,j,k,n)
+ temp=tth(i,j,k,n)
+ plev1=akm(k)+bkm(k)*ps(i,j,1,n)
+ elev=ew(temp,plev1)*help/100.0
+ qvh(i,j,k,n)=xmwml*(elev/(plev1-((1.0-xmwml)*elev)))
+ end do
+ end do
+ end do
+
+ ! CALCULATE 2 M DEW POINT FROM 2 M RELATIVE HUMIDITY
+ ! USING BOLTON'S (1980) FORMULA
+ ! BECAUSE td2 IS NOT AVAILABLE FROM NCEP GFS DATA
+
+ do j=0,ny-1
+ do i=0,nxfield-1
+ help=qvh2(i,j)
+ temp=tt2(i,j,1,n)
+ plev1=akm(k)+bkm(k)*ps(i,j,1,n)
+ elev=ew(temp,plev1)/100.*help/100. !vapour pressure in hPa
+ td2(i,j,1,n)=243.5/(17.67/log(elev/6.112)-1)+273.
+ if (help.le.0.) td2(i,j,1,n)=tt2(i,j,1,n)
+ end do
+ end do
+
+ if(levdiff2.eq.0) then
+ iwmax=nlev_ec+1
+ do i=0,nxmin1
+ do j=0,nymin1
+ wwh(i,j,nlev_ec+1)=0.
+ end do
+ end do
+ endif
+
+
+ ! For global fields, assign the leftmost data column also to the rightmost
+ ! data column; if required, shift whole grid by nxshift grid points
+ !*************************************************************************
+
+ if (xglobal) then
+ call shift_field_0(ewss,nxfield,ny)
+ call shift_field_0(nsss,nxfield,ny)
+ call shift_field_0(oro,nxfield,ny)
+ call shift_field_0(excessoro,nxfield,ny)
+ call shift_field_0(lsm,nxfield,ny)
+ call shift_field_0(ulev1,nxfield,ny)
+ call shift_field_0(vlev1,nxfield,ny)
+ call shift_field_0(tlev1,nxfield,ny)
+ call shift_field_0(qvh2,nxfield,ny)
+ call shift_field(ps,nxfield,ny,1,1,2,n)
+ call shift_field(sd,nxfield,ny,1,1,2,n)
+ call shift_field(msl,nxfield,ny,1,1,2,n)
+ call shift_field(tcc,nxfield,ny,1,1,2,n)
+ call shift_field(u10,nxfield,ny,1,1,2,n)
+ call shift_field(v10,nxfield,ny,1,1,2,n)
+ call shift_field(tt2,nxfield,ny,1,1,2,n)
+ call shift_field(td2,nxfield,ny,1,1,2,n)
+ call shift_field(lsprec,nxfield,ny,1,1,2,n)
+ call shift_field(convprec,nxfield,ny,1,1,2,n)
+ call shift_field(sshf,nxfield,ny,1,1,2,n)
+ call shift_field(ssr,nxfield,ny,1,1,2,n)
+ call shift_field(hmix,nxfield,ny,1,1,2,n)
+ call shift_field(tth,nxfield,ny,nuvzmax,nuvz,2,n)
+ call shift_field(qvh,nxfield,ny,nuvzmax,nuvz,2,n)
+ call shift_field(uuh,nxfield,ny,nuvzmax,nuvz,1,1)
+ call shift_field(vvh,nxfield,ny,nuvzmax,nuvz,1,1)
+ call shift_field(wwh,nxfield,ny,nwzmax,nwz,1,1)
+ ! IP & SEC adding GFS Clouds 20181205
+ call shift_field(clwch,nxfield,ny,nuvzmax,nuvz,2,n)
+ endif
+
+ do i=0,nxmin1
+ do j=0,nymin1
+ ! Convert precip. from mm/s -> mm/hour
+ convprec(i,j,1,n)=convprec(i,j,1,n)*3600.
+ lsprec(i,j,1,n)=lsprec(i,j,1,n)*3600.
+ surfstr(i,j,1,n)=sqrt(ewss(i,j)**2+nsss(i,j)**2)
+ end do
+ end do
+
+ if ((.not.hflswitch).or.(.not.strswitch)) then
+ ! write(*,*) 'WARNING: No flux data contained in GRIB file ',
+ ! + wfname(indj)
+
+ ! CALCULATE USTAR AND SSHF USING THE PROFILE METHOD
+ !***************************************************************************
+
+ do i=0,nxmin1
+ do j=0,nymin1
+ hlev1=30.0 ! HEIGHT OF FIRST MODEL SIGMA LAYER
+ ff10m= sqrt(u10(i,j,1,n)**2+v10(i,j,1,n)**2)
+ fflev1=sqrt(ulev1(i,j)**2+vlev1(i,j)**2)
+ call pbl_profile(ps(i,j,1,n),td2(i,j,1,n),hlev1, &
+ tt2(i,j,1,n),tlev1(i,j),ff10m,fflev1, &
+ surfstr(i,j,1,n),sshf(i,j,1,n))
+ if(sshf(i,j,1,n).gt.200.) sshf(i,j,1,n)=200.
+ if(sshf(i,j,1,n).lt.-400.) sshf(i,j,1,n)=-400.
+ end do
+ end do
+ endif
+
+ if(iumax.ne.nuvz) stop 'READWIND: NUVZ NOT CONSISTENT'
+ if(iumax.ne.nwz) stop 'READWIND: NWZ NOT CONSISTENT'
+
+ return
+888 write(*,*) ' #### FLEXPART MODEL ERROR! WINDFIELD #### '
+ write(*,*) ' #### ',wfname(indj),' #### '
+ write(*,*) ' #### IS NOT GRIB FORMAT !!! #### '
+ stop 'Execution terminated'
+999 write(*,*) ' #### FLEXPART MODEL ERROR! WINDFIELD #### '
+ write(*,*) ' #### ',wfname(indj),' #### '
+ write(*,*) ' #### CANNOT BE OPENED !!! #### '
+ stop 'Execution terminated'
+
+end subroutine readwind_gfs
+
+subroutine readwind_nests(indj,n,uuhn,vvhn,wwhn)
+ ! i i o o o
+ !*****************************************************************************
+ ! *
+ ! This routine reads the wind fields for the nested model domains. *
+ ! It is similar to subroutine readwind, which reads the mother domain. *
+ ! *
+ ! Authors: A. Stohl, G. Wotawa *
+ ! *
+ ! 8 February 1999 *
+ ! *
+ ! Last update: 17 October 2000, A. Stohl *
+ ! *
+ !*****************************************************************************
+ ! Changes, Bernd C. Krueger, Feb. 2001: *
+ ! Variables tthn and qvhn (on eta coordinates) in common block *
+ ! CHANGE: 11/01/2008, Harald Sodemann, GRIB1/2 input with ECMWF grib_api *
+ ! CHANGE: 03/12/2008, Harald Sodemann, update to f90 with ECMWF grib_api *
+ !*****************************************************************************
+
+ use grib_api
+
+ implicit none
+
+ !HSO parameters for grib_api
+ integer :: ifile
+ integer :: iret
+ integer :: igrib
+ integer :: gribVer,parCat,parNum,typSurf,valSurf,discipl
+ integer :: parId !!added by mc for making it consistent with new readwind.f90
+ integer :: gotGrid
+ !HSO end
+
+ real :: uuhn(0:nxmaxn-1,0:nymaxn-1,nuvzmax,maxnests)
+ real :: vvhn(0:nxmaxn-1,0:nymaxn-1,nuvzmax,maxnests)
+ real :: wwhn(0:nxmaxn-1,0:nymaxn-1,nwzmax,maxnests)
+ integer :: indj,i,j,k,n,levdiff2,ifield,iumax,iwmax,l
+
+ ! VARIABLES AND ARRAYS NEEDED FOR GRIB DECODING
+
+ ! dimension of isec2 at least (22+n), where n is the number of parallels or
+ ! meridians in a quasi-regular (reduced) Gaussian or lat/long grid
+
+ ! dimension of zsec2 at least (10+nn), where nn is the number of vertical
+ ! coordinate parameters
+
+ integer :: isec1(56),isec2(22+nxmaxn+nymaxn)
+ real(kind=4) :: zsec4(jpunp)
+ real(kind=4) :: xaux,yaux
+ real(kind=8) :: xauxin,yauxin
+ real,parameter :: eps=1.e-4
+ real :: ewss(0:nxmaxn-1,0:nymaxn-1),nsss(0:nxmaxn-1,0:nymaxn-1)
+ real :: plev1,pmean,tv,fu,hlev1,ff10m,fflev1
+ real :: conversion_factor !added by mc to make it consistent with new gridchek.f90
+
+ logical :: hflswitch,strswitch
+
+ !HSO grib api error messages
+ character(len=24) :: gribErrorMsg = 'Error reading grib file'
+ character(len=20) :: gribFunction = 'readwind_nests'
+
+ do l=1,numbnests
+ hflswitch=.false.
+ strswitch=.false.
+ levdiff2=nlev_ec-nwz+1
+ iumax=0
+ iwmax=0
+
+ ifile=0
+ igrib=0
+ iret=0
+
+ !
+ ! OPENING OF DATA FILE (GRIB CODE)
+ !
+
+5 call grib_open_file(ifile,path(numpath+2*(l-1)+1) &
+ (1:length(numpath+2*(l-1)+1))//trim(wfnamen(l,indj)),'r')
+ if (iret.ne.GRIB_SUCCESS) then
+ goto 888 ! ERROR DETECTED
+ endif
+ !turn on support for multi fields messages */
+ !call grib_multi_support_on
+
+ gotGrid=0
+ ifield=0
+ do
+ ifield=ifield+1
+ !
+ ! GET NEXT FIELDS
+ !
+ call grib_new_from_file(ifile,igrib,iret)
+ if (iret.eq.GRIB_END_OF_FILE) then
+ exit ! EOF DETECTED
+ elseif (iret.ne.GRIB_SUCCESS) then
+ goto 888 ! ERROR DETECTED
+ endif
+
+ !first see if we read GRIB1 or GRIB2
+ call grib_get_int(igrib,'editionNumber',gribVer,iret)
+ call grib_check(iret,gribFunction,gribErrorMsg)
+
+ if (gribVer.eq.1) then ! GRIB Edition 1
+
+ !print*,'GRiB Edition 1'
+ !read the grib2 identifiers
+ call grib_get_int(igrib,'indicatorOfParameter',isec1(6),iret)
+ call grib_check(iret,gribFunction,gribErrorMsg)
+ call grib_get_int(igrib,'level',isec1(8),iret)
+ call grib_check(iret,gribFunction,gribErrorMsg)
+
+ !change code for etadot to code for omega
+ if (isec1(6).eq.77) then
+ isec1(6)=135
+ endif
+
+ conversion_factor=1.
+
+
+ else
+
+ !print*,'GRiB Edition 2'
+ !read the grib2 identifiers
+ call grib_get_int(igrib,'discipline',discipl,iret)
+ call grib_check(iret,gribFunction,gribErrorMsg)
+ call grib_get_int(igrib,'parameterCategory',parCat,iret)
+ call grib_check(iret,gribFunction,gribErrorMsg)
+ call grib_get_int(igrib,'parameterNumber',parNum,iret)
+ call grib_check(iret,gribFunction,gribErrorMsg)
+ call grib_get_int(igrib,'typeOfFirstFixedSurface',typSurf,iret)
+ call grib_check(iret,gribFunction,gribErrorMsg)
+ call grib_get_int(igrib,'level',valSurf,iret)
+ call grib_check(iret,gribFunction,gribErrorMsg)
+ call grib_get_int(igrib,'paramId',parId,iret) !added by mc to make it consisitent with new readwind.f90
+ call grib_check(iret,gribFunction,gribErrorMsg) !added by mc to make it consisitent with new readwind.f90
+
+ !print*,discipl,parCat,parNum,typSurf,valSurf
+
+ !convert to grib1 identifiers
+ isec1(6)=-1
+ isec1(7)=-1
+ isec1(8)=-1
+ isec1(8)=valSurf ! level
+ conversion_factor=1.
+ if ((parCat.eq.0).and.(parNum.eq.0).and.(typSurf.eq.105)) then ! T
+ isec1(6)=130 ! indicatorOfParameter
+ elseif ((parCat.eq.2).and.(parNum.eq.2).and.(typSurf.eq.105)) then ! U
+ isec1(6)=131 ! indicatorOfParameter
+ elseif ((parCat.eq.2).and.(parNum.eq.3).and.(typSurf.eq.105)) then ! V
+ isec1(6)=132 ! indicatorOfParameter
+ elseif ((parCat.eq.1).and.(parNum.eq.0).and.(typSurf.eq.105)) then ! Q
+ isec1(6)=133 ! indicatorOfParameter
+ ! ESO Cloud water is in a) fields CLWC and CIWC, *or* b) field QC
+ elseif ((parCat.eq.1).and.(parNum.eq.83).and.(typSurf.eq.105)) then ! clwc
+ isec1(6)=246 ! indicatorOfParameter
+ elseif ((parCat.eq.1).and.(parNum.eq.84).and.(typSurf.eq.105)) then ! ciwc
+ isec1(6)=247 ! indicatorOfParameter
+ ! ESO qc(=clwc+ciwc):
+ elseif ((parCat.eq.201).and.(parNum.eq.31).and.(typSurf.eq.105)) then ! qc
+ isec1(6)=201031 ! indicatorOfParameter
+ elseif ((parCat.eq.3).and.(parNum.eq.0).and.(typSurf.eq.1)) then !SP
+ isec1(6)=134 ! indicatorOfParameter
+ elseif ((parCat.eq.2).and.(parNum.eq.32)) then ! W, actually eta dot !
+ isec1(6)=135 ! indicatorOfParameter
+ elseif ((parCat.eq.128).and.(parNum.eq.77)) then ! W, actually eta dot !added by mc to make it consisitent with new readwind.f90
+ isec1(6)=135 ! indicatorOfParameter !added by mc to make it consisitent with new readwind.f90
+ elseif ((parCat.eq.3).and.(parNum.eq.0).and.(typSurf.eq.101)) then !SLP
+ isec1(6)=151 ! indicatorOfParameter
+ elseif ((parCat.eq.2).and.(parNum.eq.2).and.(typSurf.eq.103)) then ! 10U
+ isec1(6)=165 ! indicatorOfParameter
+ elseif ((parCat.eq.2).and.(parNum.eq.3).and.(typSurf.eq.103)) then ! 10V
+ isec1(6)=166 ! indicatorOfParameter
+ elseif ((parCat.eq.0).and.(parNum.eq.0).and.(typSurf.eq.103)) then ! 2T
+ isec1(6)=167 ! indicatorOfParameter
+ elseif ((parCat.eq.0).and.(parNum.eq.6).and.(typSurf.eq.103)) then ! 2D
+ isec1(6)=168 ! indicatorOfParameter
+ elseif ((parCat.eq.1).and.(parNum.eq.11).and.(typSurf.eq.1)) then ! SD
+ isec1(6)=141 ! indicatorOfParameter
+ conversion_factor=1000. !added by mc to make it consisitent with new readwind.f90
+ elseif ((parCat.eq.6).and.(parNum.eq.1) .or. parId .eq. 164) then ! CC !added by mc to make it consisitent with new readwind.f90
+ isec1(6)=164 ! indicatorOfParameter
+ elseif ((parCat.eq.1).and.(parNum.eq.9) .or. parId .eq. 142) then ! LSP !added by mc to make it consisitent with new readwind.f90
+ isec1(6)=142 ! indicatorOfParameter
+ elseif ((parCat.eq.1).and.(parNum.eq.10)) then ! CP
+ isec1(6)=143 ! indicatorOfParameter
+ conversion_factor=1000. !added by mc to make it consisitent with new readwind.f90
+ elseif ((parCat.eq.0).and.(parNum.eq.11).and.(typSurf.eq.1)) then ! SHF
+ isec1(6)=146 ! indicatorOfParameter
+ elseif ((parCat.eq.4).and.(parNum.eq.9).and.(typSurf.eq.1)) then ! SR
+ isec1(6)=176 ! indicatorOfParameter
+ elseif ((parCat.eq.2).and.(parNum.eq.38) .or. parId .eq. 180) then ! EWSS !added by mc to make it consisitent with new readwind.f90
+ isec1(6)=180 ! indicatorOfParameter
+ elseif ((parCat.eq.2).and.(parNum.eq.37) .or. parId .eq. 181) then ! NSSS !added by mc to make it consisitent with new readwind.f90
+ isec1(6)=181 ! indicatorOfParameter
+ elseif ((parCat.eq.3).and.(parNum.eq.4)) then ! ORO
+ isec1(6)=129 ! indicatorOfParameter
+ elseif ((parCat.eq.3).and.(parNum.eq.7) .or. parId .eq. 160) then ! SDO !added by mc to make it consisitent with new readwind.f90
+ isec1(6)=160 ! indicatorOfParameter
+ elseif ((discipl.eq.2).and.(parCat.eq.0).and.(parNum.eq.0).and. &
+ (typSurf.eq.1)) then ! LSM
+ isec1(6)=172 ! indicatorOfParameter
+ elseif (parNum.eq.152) then
+ isec1(6)=152 ! avoid warning for lnsp
+ else
+ print*,'***WARNING: undefined GRiB2 message found!',discipl, &
+ parCat,parNum,typSurf
+ endif
+ if(parId .ne. isec1(6) .and. parId .ne. 77) then !added by mc to make it consisitent with new readwind.f90
+ write(*,*) 'parId',parId, 'isec1(6)',isec1(6) !
+ ! stop
+ endif
+
+ endif
+
+ !HSO get the size and data of the values array
+ if (isec1(6).ne.-1) then
+ call grib_get_real4_array(igrib,'values',zsec4,iret)
+ call grib_check(iret,gribFunction,gribErrorMsg)
+ endif
+
+ !HSO get the required fields from section 2 in a gribex compatible manner
+ if(ifield.eq.1) then
+ call grib_get_int(igrib,'numberOfPointsAlongAParallel', &
+ isec2(2),iret)
+ call grib_check(iret,gribFunction,gribErrorMsg)
+ call grib_get_int(igrib,'numberOfPointsAlongAMeridian', &
+ isec2(3),iret)
+ call grib_check(iret,gribFunction,gribErrorMsg)
+ call grib_get_int(igrib,'numberOfVerticalCoordinateValues', &
+ isec2(12))
+ call grib_check(iret,gribFunction,gribErrorMsg)
+ ! CHECK GRID SPECIFICATIONS
+ if(isec2(2).ne.nxn(l)) stop &
+ 'READWIND: NX NOT CONSISTENT FOR A NESTING LEVEL'
+ if(isec2(3).ne.nyn(l)) stop &
+ 'READWIND: NY NOT CONSISTENT FOR A NESTING LEVEL'
+ if(isec2(12)/2-1.ne.nlev_ec) stop 'READWIND: VERTICAL DISCRET&
+ &IZATION NOT CONSISTENT FOR A NESTING LEVEL'
+ endif ! ifield
+
+ !HSO get the second part of the grid dimensions only from GRiB1 messages
+ if (isec1(6) .eq. 167 .and. (gotGrid.eq.0)) then ! !added by mc to make it consisitent with new readwind.f90
+ call grib_get_real8(igrib,'longitudeOfFirstGridPointInDegrees', &
+ xauxin,iret)
+ call grib_check(iret,gribFunction,gribErrorMsg)
+ call grib_get_real8(igrib,'latitudeOfLastGridPointInDegrees', &
+ yauxin,iret)
+ call grib_check(iret,gribFunction,gribErrorMsg)
+ if (xauxin.gt.180.) xauxin=xauxin-360.0
+ if (xauxin.lt.-180.) xauxin=xauxin+360.0
+
+ xaux=xauxin
+ yaux=yauxin
+ if (abs(xaux-xlon0n(l)).gt.eps) &
+ stop 'READWIND: LOWER LEFT LONGITUDE NOT CONSISTENT FOR A NESTING LEVEL'
+ if (abs(yaux-ylat0n(l)).gt.eps) &
+ stop 'READWIND: LOWER LEFT LATITUDE NOT CONSISTENT FOR A NESTING LEVEL'
+ gotGrid=1
+ endif
+
+ do j=0,nyn(l)-1
+ do i=0,nxn(l)-1
+ k=isec1(8)
+ if(isec1(6).eq.130) tthn(i,j,nlev_ec-k+2,n,l)= &!! TEMPERATURE
+ zsec4(nxn(l)*(nyn(l)-j-1)+i+1)
+ if(isec1(6).eq.131) uuhn(i,j,nlev_ec-k+2,l)= &!! U VELOCITY
+ zsec4(nxn(l)*(nyn(l)-j-1)+i+1)
+ if(isec1(6).eq.132) vvhn(i,j,nlev_ec-k+2,l)= &!! V VELOCITY
+ zsec4(nxn(l)*(nyn(l)-j-1)+i+1)
+ if(isec1(6).eq.133) then !! SPEC. HUMIDITY
+ qvhn(i,j,nlev_ec-k+2,n,l)=zsec4(nxn(l)*(nyn(l)-j-1)+i+1)
+ if (qvhn(i,j,nlev_ec-k+2,n,l) .lt. 0.) &
+ qvhn(i,j,nlev_ec-k+2,n,l) = 0.
+ ! this is necessary because the gridded data may contain
+ ! spurious negative values
+ endif
+ if(isec1(6).eq.134) psn(i,j,1,n,l)= &!! SURF. PRESS.
+ zsec4(nxn(l)*(nyn(l)-j-1)+i+1)
+ if(isec1(6).eq.135) wwhn(i,j,nlev_ec-k+1,l)= &!! W VELOCITY
+ zsec4(nxn(l)*(nyn(l)-j-1)+i+1)
+ if(isec1(6).eq.141) sdn(i,j,1,n,l)= &!! SNOW DEPTH
+ zsec4(nxn(l)*(nyn(l)-j-1)+i+1)/conversion_factor !added by mc to make it consisitent with new readwind.f90!
+ if(isec1(6).eq.151) msln(i,j,1,n,l)= &!! SEA LEVEL PRESS.
+ zsec4(nxn(l)*(nyn(l)-j-1)+i+1)
+ if(isec1(6).eq.164) tccn(i,j,1,n,l)= &!! CLOUD COVER
+ zsec4(nxn(l)*(nyn(l)-j-1)+i+1)
+ if(isec1(6).eq.165) u10n(i,j,1,n,l)= &!! 10 M U VELOCITY
+ zsec4(nxn(l)*(nyn(l)-j-1)+i+1)
+ if(isec1(6).eq.166) v10n(i,j,1,n,l)= &!! 10 M V VELOCITY
+ zsec4(nxn(l)*(nyn(l)-j-1)+i+1)
+ if(isec1(6).eq.167) tt2n(i,j,1,n,l)= &!! 2 M TEMPERATURE
+ zsec4(nxn(l)*(nyn(l)-j-1)+i+1)
+ if(isec1(6).eq.168) td2n(i,j,1,n,l)= &!! 2 M DEW POINT
+ zsec4(nxn(l)*(nyn(l)-j-1)+i+1)
+ if(isec1(6).eq.142) then !! LARGE SCALE PREC.
+ lsprecn(i,j,1,n,l)=zsec4(nxn(l)*(nyn(l)-j-1)+i+1)
+ if (lsprecn(i,j,1,n,l).lt.0.) lsprecn(i,j,1,n,l)=0.
+ endif
+ if(isec1(6).eq.143) then !! CONVECTIVE PREC.
+ convprecn(i,j,1,n,l)=zsec4(nxn(l)*(nyn(l)-j-1)+i+1)/conversion_factor !added by mc to make it consisitent with new readwind.f90
+ if (convprecn(i,j,1,n,l).lt.0.) convprecn(i,j,1,n,l)=0.
+ endif
+ if(isec1(6).eq.146) sshfn(i,j,1,n,l)= &!! SENS. HEAT FLUX
+ zsec4(nxn(l)*(nyn(l)-j-1)+i+1)
+ if((isec1(6).eq.146).and. &
+ (zsec4(nxn(l)*(nyn(l)-j-1)+i+1).ne.0.)) hflswitch=.true. ! Heat flux available
+ if(isec1(6).eq.176) then !! SOLAR RADIATION
+ ssrn(i,j,1,n,l)=zsec4(nxn(l)*(nyn(l)-j-1)+i+1)
+ if (ssrn(i,j,1,n,l).lt.0.) ssrn(i,j,1,n,l)=0.
+ endif
+ if(isec1(6).eq.180) ewss(i,j)= &!! EW SURFACE STRESS
+ zsec4(nxn(l)*(nyn(l)-j-1)+i+1)
+ if(isec1(6).eq.181) nsss(i,j)= &!! NS SURFACE STRESS
+ zsec4(nxn(l)*(nyn(l)-j-1)+i+1)
+ if(((isec1(6).eq.180).or.(isec1(6).eq.181)).and. &
+ (zsec4(nxn(l)*(nyn(l)-j-1)+i+1).ne.0.)) strswitch=.true. ! stress available
+ if(isec1(6).eq.129) oron(i,j,l)= &!! ECMWF OROGRAPHY
+ zsec4(nxn(l)*(nyn(l)-j-1)+i+1)/ga
+ if(isec1(6).eq.160) excessoron(i,j,l)= &!! STANDARD DEVIATION OF OROGRAPHY
+ zsec4(nxn(l)*(nyn(l)-j-1)+i+1)
+ if(isec1(6).eq.172) lsmn(i,j,l)= &!! ECMWF LAND SEA MASK
+ zsec4(nxn(l)*(nyn(l)-j-1)+i+1)
+ if(isec1(6).eq.131) iumax=max(iumax,nlev_ec-k+1)
+ if(isec1(6).eq.135) iwmax=max(iwmax,nlev_ec-k+1)
+
+ ! ESO TODO:
+ ! -add check for if one of clwc/ciwc missing (error),
+ ! also if all 3 cw fields present, use qc and disregard the others
+ if(isec1(6).eq.246) then !! CLWC Cloud liquid water content [kg/kg]
+ clwchn(i,j,nlev_ec-k+2,n,l)=zsec4(nxn(l)*(nyn(l)-j-1)+i+1)
+ readclouds_nest(l)=.true.
+ sumclouds_nest(l)=.false.
+ endif
+ if(isec1(6).eq.247) then !! CIWC Cloud ice water content
+ ciwchn(i,j,nlev_ec-k+2,n,l)=zsec4(nxn(l)*(nyn(l)-j-1)+i+1)
+ endif
+ !ZHG end
+ !ESO read qc (=clwc+ciwc)
+ if(isec1(6).eq.201031) then !! QC Cloud liquid water content [kg/kg]
+ clwchn(i,j,nlev_ec-k+2,n,l)=zsec4(nxn(l)*(nyn(l)-j-1)+i+1)
+ readclouds_nest(l)=.true.
+ sumclouds_nest(l)=.true.
+ endif
+
+
+ end do
+ end do
+
+ call grib_release(igrib)
+ end do !! READ NEXT LEVEL OR PARAMETER
+ !
+ ! CLOSING OF INPUT DATA FILE
+ !
+ call grib_close_file(ifile)
+
+ !error message if no fields found with correct first longitude in it
+ if (gotGrid.eq.0) then
+ print*,'***ERROR: input file needs to contain GRiB1 formatted'// &
+ 'messages'
+ stop
+ endif
+
+ if(levdiff2.eq.0) then
+ iwmax=nlev_ec+1
+ do i=0,nxn(l)-1
+ do j=0,nyn(l)-1
+ wwhn(i,j,nlev_ec+1,l)=0.
+ end do
+ end do
+ endif
+
+ do i=0,nxn(l)-1
+ do j=0,nyn(l)-1
+ surfstrn(i,j,1,n,l)=sqrt(ewss(i,j)**2+nsss(i,j)**2)
+ end do
+ end do
+
+ if ((.not.hflswitch).or.(.not.strswitch)) then
+ write(*,*) 'WARNING: No flux data contained in GRIB file ', &
+ wfnamen(l,indj)
+
+ ! CALCULATE USTAR AND SSHF USING THE PROFILE METHOD
+ ! As ECMWF has increased the model resolution, such that now the first model
+ ! level is at about 10 m (where 10-m wind is given), use the 2nd ECMWF level
+ ! (3rd model level in FLEXPART) for the profile method
+ !***************************************************************************
+
+ do i=0,nxn(l)-1
+ do j=0,nyn(l)-1
+ plev1=akz(3)+bkz(3)*psn(i,j,1,n,l)
+ pmean=0.5*(psn(i,j,1,n,l)+plev1)
+ tv=tthn(i,j,3,n,l)*(1.+0.61*qvhn(i,j,3,n,l))
+ fu=-r_air*tv/ga/pmean
+ hlev1=fu*(plev1-psn(i,j,1,n,l)) ! HEIGTH OF FIRST MODEL LAYER
+ ff10m= sqrt(u10n(i,j,1,n,l)**2+v10n(i,j,1,n,l)**2)
+ fflev1=sqrt(uuhn(i,j,3,l)**2+vvhn(i,j,3,l)**2)
+ call pbl_profile(psn(i,j,1,n,l),td2n(i,j,1,n,l),hlev1, &
+ tt2n(i,j,1,n,l),tthn(i,j,3,n,l),ff10m,fflev1, &
+ surfstrn(i,j,1,n,l),sshfn(i,j,1,n,l))
+ if(sshfn(i,j,1,n,l).gt.200.) sshfn(i,j,1,n,l)=200.
+ if(sshfn(i,j,1,n,l).lt.-400.) sshfn(i,j,1,n,l)=-400.
+ end do
+ end do
+ endif
+
+
+ ! Assign 10 m wind to model level at eta=1.0 to have one additional model
+ ! level at the ground
+ ! Specific humidity is taken the same as at one level above
+ ! Temperature is taken as 2 m temperature
+ !**************************************************************************
+
+ do i=0,nxn(l)-1
+ do j=0,nyn(l)-1
+ uuhn(i,j,1,l)=u10n(i,j,1,n,l)
+ vvhn(i,j,1,l)=v10n(i,j,1,n,l)
+ qvhn(i,j,1,n,l)=qvhn(i,j,2,n,l)
+ tthn(i,j,1,n,l)=tt2n(i,j,1,n,l)
+ end do
+ end do
+
+ if(iumax.ne.nuvz-1) stop &
+ 'READWIND: NUVZ NOT CONSISTENT FOR A NESTING LEVEL'
+ if(iwmax.ne.nwz) stop &
+ 'READWIND: NWZ NOT CONSISTENT FOR A NESTING LEVEL'
+
+ end do
+
+ return
+888 write(*,*) ' #### FLEXPART MODEL ERROR! WINDFIELD #### '
+ write(*,*) ' #### ',wfnamen(l,indj),' FOR NESTING LEVEL #### '
+ write(*,*) ' #### ',l,' IS NOT GRIB FORMAT !!! #### '
+ stop 'Execution terminated'
+
+
+999 write(*,*) ' #### FLEXPART MODEL ERROR! WINDFIELD #### '
+ write(*,*) ' #### ',wfnamen(l,indj),' #### '
+ write(*,*) ' #### CANNOT BE OPENED FOR NESTING LEVEL ',l,'####'
+
+end subroutine readwind_nests
+
+subroutine shift_field_0(field,nxf,nyf)
+ ! i/o i i
+ !*****************************************************************************
+ ! *
+ ! This subroutine shifts global fields by nxshift grid cells, in order to *
+ ! facilitate all sorts of nested wind fields, or output grids, which, *
+ ! without shifting, would overlap with the domain "boundary". *
+ ! *
+ ! Author: A. Stohl *
+ ! *
+ ! 3 July 2002 *
+ ! *
+ !*****************************************************************************
+ ! *
+ ! Variables: *
+ ! *
+ ! Constants: *
+ ! *
+ !*****************************************************************************
+
+ implicit none
+
+ integer :: nxf,nyf,ix,jy,ixs
+ real :: field(0:nxmax-1,0:nymax-1),xshiftaux(0:nxmax-1)
+
+ ! Loop over y and z
+ !******************
+
+ do jy=0,nyf-1
+
+ ! Shift the data
+ !***************
+
+ if (nxshift.ne.0) then
+ do ix=0,nxf-1
+ if (ix.ge.nxshift) then
+ ixs=ix-nxshift
+ else
+ ixs=nxf-nxshift+ix
+ endif
+ xshiftaux(ixs)=field(ix,jy)
+ end do
+ do ix=0,nxf-1
+ field(ix,jy)=xshiftaux(ix)
+ end do
+ endif
+
+ ! Repeat the westernmost grid cells at the easternmost domain "boundary"
+ !***********************************************************************
+
+ field(nxf,jy)=field(0,jy)
+ end do
+
+ return
+end subroutine shift_field_0
+
+subroutine shift_field(field,nxf,nyf,nzfmax,nzf,nmax,n)
+ ! i/o i i i i i i
+ !*****************************************************************************
+ ! *
+ ! This subroutine shifts global fields by nxshift grid cells, in order to *
+ ! facilitate all sorts of nested wind fields, or output grids, which, *
+ ! without shifting, would overlap with the domain "boundary". *
+ ! *
+ ! Author: A. Stohl *
+ ! *
+ ! 3 July 2002 *
+ ! *
+ !*****************************************************************************
+ ! *
+ ! Variables: *
+ ! *
+ ! Constants: *
+ ! *
+ !*****************************************************************************
+
+ implicit none
+
+ integer :: nxf,nyf,nzf,n,ix,jy,kz,ixs,nzfmax,nmax
+ real :: field(0:nxmax-1,0:nymax-1,nzfmax,nmax),xshiftaux(0:nxmax-1)
+
+ ! Loop over y and z
+ !******************
+
+ do kz=1,nzf
+ do jy=0,nyf-1
+
+ ! Shift the data
+ !***************
+
+ if (nxshift.ne.0) then
+ do ix=0,nxf-1
+ if (ix.ge.nxshift) then
+ ixs=ix-nxshift
+ else
+ ixs=nxf-nxshift+ix
+ endif
+ xshiftaux(ixs)=field(ix,jy,kz,n)
+ end do
+ do ix=0,nxf-1
+ field(ix,jy,kz,n)=xshiftaux(ix)
+ end do
+ endif
+
+ ! Repeat the westernmost grid cells at the easternmost domain "boundary"
+ !***********************************************************************
+
+ field(nxf,jy,kz,n)=field(0,jy,kz,n)
+ end do
+ end do
+end subroutine shift_field
+
+subroutine fixedfields_allocate
+ implicit none
+ allocate(oro(0:nxmax-1,0:nymax-1))
+ allocate(excessoro(0:nxmax-1,0:nymax-1))
+ allocate(lsm(0:nxmax-1,0:nymax-1))
+ allocate(pv(0:nxmax-1,0:nymax-1,nzmax,numwfmem))
+end subroutine fixedfields_allocate
+
+subroutine windfields_allocate
+ implicit none
+
+ ! Eta coordinates
+ !****************
+ allocate(uueta(0:nxmax-1,0:nymax-1,nzmax,numwfmem))
+ allocate(vveta(0:nxmax-1,0:nymax-1,nzmax,numwfmem))
+ allocate(wweta(0:nxmax-1,0:nymax-1,nzmax,numwfmem))
+ allocate(uupoleta(0:nxmax-1,0:nymax-1,nzmax,numwfmem))
+ allocate(vvpoleta(0:nxmax-1,0:nymax-1,nzmax,numwfmem))
+ allocate(tteta(0:nxmax-1,0:nymax-1,nzmax,numwfmem))
+ allocate(pveta(0:nxmax-1,0:nymax-1,nzmax,numwfmem))
+ allocate(prseta(0:nxmax-1,0:nymax-1,nzmax,numwfmem))
+ allocate(rhoeta(0:nxmax-1,0:nymax-1,nzmax,numwfmem))
+ allocate(drhodzeta(0:nxmax-1,0:nymax-1,nzmax,numwfmem))
+ !allocate(tvirtual(0:nxmax-1,0:nymax-1,nzmax,numwfmem))
+ allocate(etauvheight(0:nxmax-1,0:nymax-1,nuvzmax,numwfmem))
+ allocate(etawheight(0:nxmax-1,0:nymax-1,nuvzmax,numwfmem))
+
+ ! Intrinsic coordinates
+ !**********************
+ allocate(uu(0:nxmax-1,0:nymax-1,nzmax,numwfmem))
+ allocate(vv(0:nxmax-1,0:nymax-1,nzmax,numwfmem))
+ allocate(ww(0:nxmax-1,0:nymax-1,nzmax,numwfmem))
+ allocate(uupol(0:nxmax-1,0:nymax-1,nzmax,numwfmem))
+ allocate(vvpol(0:nxmax-1,0:nymax-1,nzmax,numwfmem))
+ allocate(tt(0:nxmax-1,0:nymax-1,nzmax,numwfmem))
+ allocate(tth(0:nxmax-1,0:nymax-1,nuvzmax,numwfmem))
+ allocate(qv(0:nxmax-1,0:nymax-1,nzmax,numwfmem))
+ allocate(qvh(0:nxmax-1,0:nymax-1,nuvzmax,numwfmem))
+ allocate(rho(0:nxmax-1,0:nymax-1,nzmax,numwfmem))
+ allocate(drhodz(0:nxmax-1,0:nymax-1,nzmax,numwfmem))
+ allocate(pplev(0:nxmax-1,0:nymax-1,nuvzmax,numwfmem))
+ allocate(prs(0:nxmax-1,0:nymax-1,nzmax,numwfmem))
+ allocate(rho_dry(0:nxmax-1,0:nymax-1,nzmax,numwfmem))
+
+ ! Cloud data
+ !***********
+ allocate(clwc(0:nxmax-1,0:nymax-1,nzmax,numwfmem))
+ allocate(ciwc(0:nxmax-1,0:nymax-1,nzmax,numwfmem))
+ allocate(clw(0:nxmax-1,0:nymax-1,nzmax,numwfmem))
+ allocate(clwch(0:nxmax-1,0:nymax-1,nuvzmax,numwfmem))
+ allocate(ciwch(0:nxmax-1,0:nymax-1,nuvzmax,numwfmem))
+ clwc=0.0
+ ciwc=0.0
+ clw=0.0
+ clwch=0.0
+ ciwch=0.0
+ allocate(ctwc(0:nxmax-1,0:nymax-1,numwfmem))
+ allocate(cloudsh(0:nxmax-1,0:nymax-1,numwfmem))
+ allocate(clouds(0:nxmax-1,0:nymax-1,nzmax,numwfmem))
+
+ ! 2d fields
+ !**********
+ allocate(ps(0:nxmax-1,0:nymax-1,1,numwfmem))
+ allocate(sd(0:nxmax-1,0:nymax-1,1,numwfmem))
+ allocate(msl(0:nxmax-1,0:nymax-1,1,numwfmem))
+ allocate(tcc(0:nxmax-1,0:nymax-1,1,numwfmem))
+ allocate(u10(0:nxmax-1,0:nymax-1,1,numwfmem))
+ allocate(v10(0:nxmax-1,0:nymax-1,1,numwfmem))
+ allocate(tt2(0:nxmax-1,0:nymax-1,1,numwfmem))
+ allocate(td2(0:nxmax-1,0:nymax-1,1,numwfmem))
+ allocate(lsprec(0:nxmax-1,0:nymax-1,1,numwfmem))
+ allocate(convprec(0:nxmax-1,0:nymax-1,1,numwfmem))
+ allocate(sshf(0:nxmax-1,0:nymax-1,1,numwfmem))
+ allocate(ssr(0:nxmax-1,0:nymax-1,1,numwfmem))
+ allocate(surfstr(0:nxmax-1,0:nymax-1,1,numwfmem))
+ allocate(ustar(0:nxmax-1,0:nymax-1,1,numwfmem))
+ allocate(wstar(0:nxmax-1,0:nymax-1,1,numwfmem))
+ allocate(hmix(0:nxmax-1,0:nymax-1,1,numwfmem))
+ allocate(tropopause(0:nxmax-1,0:nymax-1,1,numwfmem))
+ allocate(oli(0:nxmax-1,0:nymax-1,1,numwfmem))
+
+ ! Vertical descritisation arrays
+ !*******************************
+ allocate(height(nzmax),wheight(nzmax),uvheight(nzmax))
+ allocate(akm(nwzmax),bkm(nwzmax),akz(nuvzmax),bkz(nuvzmax), &
+ aknew(nzmax),bknew(nzmax))
+end subroutine windfields_allocate
+
+subroutine windfields_nest_allocate
+ !*******************************************************************************
+ ! Dynamic allocation of arrays
+ !
+ ! For nested wind fields.
+ !
+ !*******************************************************************************
+ implicit none
+
+ allocate(wfnamen(maxnests,maxwf))
+ allocate(wfspecn(maxnests,maxwf))
+
+ allocate(nxn(maxnests))
+ allocate(nyn(maxnests))
+ allocate(dxn(maxnests))
+ allocate(dyn(maxnests))
+ allocate(xlon0n(maxnests))
+ allocate(ylat0n(maxnests))
+
+ allocate(oron(0:nxmaxn-1,0:nymaxn-1,maxnests))
+ allocate(excessoron(0:nxmaxn-1,0:nymaxn-1,maxnests))
+ allocate(lsmn(0:nxmaxn-1,0:nymaxn-1,maxnests))
+
+ allocate(uun(0:nxmaxn-1,0:nymaxn-1,nzmax,numwfmem,numbnests))
+ allocate(vvn(0:nxmaxn-1,0:nymaxn-1,nzmax,numwfmem,numbnests))
+ allocate(wwn(0:nxmaxn-1,0:nymaxn-1,nzmax,numwfmem,numbnests))
+ allocate(ttn(0:nxmaxn-1,0:nymaxn-1,nzmax,numwfmem,numbnests))
+ allocate(qvn(0:nxmaxn-1,0:nymaxn-1,nzmax,numwfmem,numbnests))
+ allocate(pvn(0:nxmaxn-1,0:nymaxn-1,nzmax,numwfmem,numbnests))
+ allocate(clwcn(0:nxmaxn-1,0:nymaxn-1,nzmax,numwfmem,numbnests))
+ allocate(ciwcn(0:nxmaxn-1,0:nymaxn-1,nzmax,numwfmem,numbnests))
+ allocate(clwn(0:nxmaxn-1,0:nymaxn-1,nzmax,numwfmem,numbnests))
+
+ ! ETA equivalents
+ allocate(uuetan(0:nxmaxn-1,0:nymaxn-1,nzmax,numwfmem,numbnests))
+ allocate(vvetan(0:nxmaxn-1,0:nymaxn-1,nzmax,numwfmem,numbnests))
+ allocate(wwetan(0:nxmaxn-1,0:nymaxn-1,nzmax,numwfmem,numbnests))
+ allocate(ttetan(0:nxmaxn-1,0:nymaxn-1,nzmax,numwfmem,numbnests))
+ allocate(pvetan(0:nxmaxn-1,0:nymaxn-1,nzmax,numwfmem,numbnests))
+ allocate(prsetan(0:nxmaxn-1,0:nymaxn-1,nzmax,numwfmem,numbnests))
+ allocate(rhoetan(0:nxmaxn-1,0:nymaxn-1,nzmax,numwfmem,numbnests))
+ allocate(drhodzetan(0:nxmaxn-1,0:nymaxn-1,nzmax,numwfmem,numbnests))
+ ! allocate(tvirtualn(0:nxmaxn-1,0:nymaxn-1,nzmax,numwfmem,numbnests))
+ allocate(etauvheightn(0:nxmaxn-1,0:nymaxn-1,nuvzmax,numwfmem,numbnests))
+ allocate(etawheightn(0:nxmaxn-1,0:nymaxn-1,nuvzmax,numwfmem,numbnests))
+
+ allocate(cloudsn(0:nxmaxn-1,0:nymaxn-1,nzmax,numwfmem,numbnests))
+ allocate(cloudshn(0:nxmaxn-1,0:nymaxn-1,numwfmem,numbnests))
+ allocate(prsn(0:nxmaxn-1,0:nymaxn-1,nzmax,numwfmem,numbnests))
+ allocate(rhon(0:nxmaxn-1,0:nymaxn-1,nzmax,numwfmem,numbnests))
+ allocate(drhodzn(0:nxmaxn-1,0:nymaxn-1,nzmax,numwfmem,numbnests))
+ allocate(tthn(0:nxmaxn-1,0:nymaxn-1,nuvzmax,numwfmem,numbnests))
+ allocate(qvhn(0:nxmaxn-1,0:nymaxn-1,nuvzmax,numwfmem,numbnests))
+ allocate(clwchn(0:nxmaxn-1,0:nymaxn-1,nuvzmax,numwfmem,numbnests))
+ allocate(ciwchn(0:nxmaxn-1,0:nymaxn-1,nuvzmax,numwfmem,numbnests))
+ allocate(ctwcn(0:nxmaxn-1,0:nymaxn-1,numwfmem,numbnests))
+
+ ! 2d fields
+ !***********
+ allocate(psn(0:nxmaxn-1,0:nymaxn-1,1,numwfmem,maxnests))
+ allocate(sdn(0:nxmaxn-1,0:nymaxn-1,1,numwfmem,maxnests))
+ allocate(msln(0:nxmaxn-1,0:nymaxn-1,1,numwfmem,maxnests))
+ allocate(tccn(0:nxmaxn-1,0:nymaxn-1,1,numwfmem,maxnests))
+ allocate(u10n(0:nxmaxn-1,0:nymaxn-1,1,numwfmem,maxnests))
+ allocate(v10n(0:nxmaxn-1,0:nymaxn-1,1,numwfmem,maxnests))
+ allocate(tt2n(0:nxmaxn-1,0:nymaxn-1,1,numwfmem,maxnests))
+ allocate(td2n(0:nxmaxn-1,0:nymaxn-1,1,numwfmem,maxnests))
+ allocate(lsprecn(0:nxmaxn-1,0:nymaxn-1,1,numwfmem,maxnests))
+ allocate(convprecn(0:nxmaxn-1,0:nymaxn-1,1,numwfmem,maxnests))
+ allocate(sshfn(0:nxmaxn-1,0:nymaxn-1,1,numwfmem,maxnests))
+ allocate(ssrn(0:nxmaxn-1,0:nymaxn-1,1,numwfmem,maxnests))
+ allocate(surfstrn(0:nxmaxn-1,0:nymaxn-1,1,numwfmem,maxnests))
+ allocate(ustarn(0:nxmaxn-1,0:nymaxn-1,1,numwfmem,maxnests))
+ allocate(wstarn(0:nxmaxn-1,0:nymaxn-1,1,numwfmem,maxnests))
+ allocate(hmixn(0:nxmaxn-1,0:nymaxn-1,1,numwfmem,maxnests))
+ allocate(tropopausen(0:nxmaxn-1,0:nymaxn-1,1,numwfmem,maxnests))
+ allocate(olin(0:nxmaxn-1,0:nymaxn-1,1,numwfmem,maxnests))
+ allocate(vdepn(0:nxmaxn-1,0:nymaxn-1,maxspec,numwfmem,maxnests))
+
+ allocate(xresoln(0:maxnests))
+ allocate(yresoln(0:maxnests))
+ allocate(xln(maxnests))
+ allocate(yln(maxnests))
+ allocate(xrn(maxnests))
+ allocate(yrn(maxnests))
+
+ ! Initialise
+ !************
+ clwcn(:,:,:,:,:)=0.
+ ciwcn(:,:,:,:,:)=0.
+ clwchn(:,:,:,:,:)=0.
+ ciwchn(:,:,:,:,:)=0.
+end subroutine windfields_nest_allocate
+
+subroutine windfields_nest_deallocate
+
+ deallocate(wfnamen,wfspecn)
+
+ deallocate(nxn,nyn,dxn,dyn,xlon0n,ylat0n)
+
+ deallocate(oron,excessoron,lsmn)
+
+ deallocate(uun,vvn,wwn,ttn,qvn,pvn,clwcn,ciwcn,clwn,cloudsn, &
+ cloudshn,rhon,prsn,drhodzn,tthn,qvhn,clwchn,ciwchn,ctwcn)
+
+ deallocate(uuetan,vvetan,wwetan,ttetan,pvetan,prsetan,rhoetan, &
+ drhodzetan,etauvheightn,etawheightn)
+
+ deallocate(psn,sdn,msln,tccn,u10n,v10n,tt2n,td2n,lsprecn,convprecn, &
+ sshfn,ssrn,surfstrn,ustarn,wstarn,hmixn,tropopausen,olin,vdepn)
+
+ deallocate(xresoln,yresoln,xln,yln,xrn,yrn)
+end subroutine windfields_nest_deallocate
+
+subroutine windfields_deallocate
+ implicit none
+
+ deallocate(oro,excessoro,lsm)
+
+ deallocate(uueta,vveta,wweta,uupoleta,vvpoleta,tteta,pveta, &
+ prseta,rhoeta,drhodzeta,etauvheight,etawheight)
+
+ deallocate(uu,vv,ww,uupol,vvpol,tt,tth,qv,qvh,pv,rho,drhodz,pplev,prs,rho_dry)
+
+ deallocate(clwc,ciwc,clw,clwch,ciwch,ctwc,cloudsh,clouds)
+
+ deallocate(ps,sd,msl,tcc,u10,v10,tt2,td2,lsprec,convprec,sshf,ssr,surfstr, &
+ ustar,wstar,hmix,tropopause,oli)
+
+ deallocate(height,wheight,uvheight,akm,bkm,akz,bkz,aknew,bknew)
+end subroutine windfields_deallocate
+
+end module windfields_mod
--
GitLab