Changeset 4542 for palm/trunk/SOURCE
- Timestamp:
- May 19, 2020 3:45:12 PM (5 years ago)
- Location:
- palm/trunk/SOURCE
- Files:
-
- 5 edited
Legend:
- Unmodified
- Added
- Removed
-
palm/trunk/SOURCE/bulk_cloud_model_mod.f90
r4535 r4542 1 1 !> @file bulk_cloud_model_mod.f90 2 !------------------------------------------------------------------------------ !2 !--------------------------------------------------------------------------------------------------! 3 3 ! This file is part of the PALM model system. 4 4 ! 5 ! PALM is free software: you can redistribute it and/or modify it under the 6 ! terms of the GNU General Public License as published by the Free Software 7 ! Foundation, either version 3 of the License, or (at your option) any later 8 ! version. 9 ! 10 ! PALM is distributed in the hope that it will be useful, but WITHOUT ANY 11 ! WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR 12 ! A PARTICULAR PURPOSE. See the GNU General Public License for more details. 13 ! 14 ! You should have received a copy of the GNU General Public License along with 15 ! PALM. If not, see <http://www.gnu.org/licenses/>. 5 ! PALM is free software: you can redistribute it and/or modify it under the terms of the GNU General 6 ! Public License as published by the Free Software Foundation, either version 3 of the License, or 7 ! (at your option) any later version. 8 ! 9 ! PALM is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the 10 ! implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General 11 ! Public License for more details. 12 ! 13 ! You should have received a copy of the GNU General Public License along with PALM. If not, see 14 ! <http://www.gnu.org/licenses/>. 16 15 ! 17 16 ! Copyright 1997-2020 Leibniz Universitaet Hannover 18 !------------------------------------------------------------------------------ !17 !--------------------------------------------------------------------------------------------------! 19 18 ! 20 19 ! Current revisions: … … 25 24 ! ----------------- 26 25 ! $Id$ 26 ! file re-formatted to follow the PALM coding standard 27 ! 28 ! 4535 2020-05-15 12:07:23Z raasch 27 29 ! bugfix for restart data format query 28 ! 30 ! 29 31 ! 4533 2020-05-14 14:46:46Z schwenkel 30 32 ! Reformat intrinsic function 31 ! 33 ! 32 34 ! 4532 2020-05-14 13:41:35Z schwenkel 33 35 ! Calculate mean droplet radius assuming gamma distibution for condensation 34 ! 36 ! 35 37 ! 4521 2020-05-06 11:39:49Z schwenkel 36 38 ! Rename variable 37 ! 39 ! 38 40 ! 4517 2020-05-03 14:29:30Z raasch 39 41 ! added restart with MPI-IO for reading local arrays 40 ! 42 ! 41 43 ! 4506 2020-04-21 10:57:45Z schwenkel 42 44 ! Use correct magnus formula for liquid water temperature 43 ! 45 ! 44 46 ! 4502 2020-04-17 16:14:16Z schwenkel 45 47 ! Implementation of ice microphysics 46 ! 48 ! 47 49 ! 4495 2020-04-13 20:11:20Z raasch 48 50 ! restart data handling with MPI-IO added 49 ! 51 ! 50 52 ! 4457 2020-03-11 14:20:43Z raasch 51 53 ! use statement for exchange horiz added 52 ! 54 ! 53 55 ! 4418 2020-02-21 09:41:13Z raasch 54 56 ! bugfix for raindrop number adjustment 55 ! 57 ! 56 58 ! 4370 2020-01-10 14:00:44Z raasch 57 59 ! vector directives added to force vectorization on Intel19 compiler 58 ! 60 ! 59 61 ! 4360 2020-01-07 11:25:50Z suehring 60 62 ! Introduction of wall_flags_total_0, which currently sets bits based on static 61 63 ! topography information used in wall_flags_static_0 62 ! 64 ! 63 65 ! 4329 2019-12-10 15:46:36Z motisi 64 66 ! Renamed wall_flags_0 to wall_flags_static_0 65 ! 67 ! 66 68 ! 4289 2019-11-05 14:33:41Z knoop 67 69 ! Removed parameters precipitation and precipitation_amount_interval from namelist 68 ! 70 ! 69 71 ! 4268 2019-10-17 11:29:38Z schwenkel 70 72 ! Introducing bcm_boundary_conditions 71 ! 73 ! 72 74 ! 4182 2019-08-22 15:20:23Z scharf 73 75 ! Corrected "Former revisions" section 74 ! 76 ! 75 77 ! 4168 2019-08-16 13:50:17Z suehring 76 78 ! Replace function get_topography_top_index by topo_top_ind 77 ! 79 ! 78 80 ! 4110 2019-07-22 17:05:21Z suehring 79 ! Pass integer flag array as well as boundary flags to WS scalar advection 81 ! Pass integer flag array as well as boundary flags to WS scalar advection 80 82 ! routine 81 ! 83 ! 82 84 ! 4109 2019-07-22 17:00:34Z suehring 83 85 ! Added microphyics scheme 'morrision_no_rain' 84 ! 86 ! 85 87 ! 3931 2019-04-24 16:34:28Z schwenkel 86 88 ! Added bcm_exchange_horiz which is called after non_transport_physics 87 ! 89 ! 88 90 ! 3885 2019-04-11 11:29:34Z kanani 89 ! Changes related to global restructuring of location messages and introduction 91 ! Changes related to global restructuring of location messages and introduction 90 92 ! of additional debug messages 91 ! 93 ! 92 94 ! 3874 2019-04-08 16:53:48Z knoop 93 95 ! Implemented non_transport_physics module interfaces 94 ! 96 ! 95 97 ! 3870 2019-04-08 13:44:34Z knoop 96 98 ! Moving prognostic equations of bcm into bulk_cloud_model_mod 97 ! 99 ! 98 100 ! 3869 2019-04-08 11:54:20Z knoop 99 101 ! moving the furniture around ;-) 100 ! 102 ! 101 103 ! 3786 2019-03-06 16:58:03Z raasch 102 104 ! unsed variables removed 103 ! 105 ! 104 106 ! 3767 2019-02-27 08:18:02Z raasch 105 107 ! unused variable for file index removed from rrd-subroutines parameter list 106 ! 108 ! 107 109 ! 3724 2019-02-06 16:28:23Z kanani 108 110 ! Correct double-used log_point_s unit 109 ! 111 ! 110 112 ! 3700 2019-01-26 17:03:42Z knoop 111 113 ! nopointer option removed … … 116 118 ! ------------ 117 119 !> Calculate bulk cloud microphysics. 118 !------------------------------------------------------------------------------ !120 !--------------------------------------------------------------------------------------------------! 119 121 MODULE bulk_cloud_model_mod 120 122 121 123 122 USE advec_s_bc_mod, &124 USE advec_s_bc_mod, & 123 125 ONLY: advec_s_bc 124 126 125 USE advec_s_pw_mod, &127 USE advec_s_pw_mod, & 126 128 ONLY: advec_s_pw 127 129 128 USE advec_s_up_mod, &130 USE advec_s_up_mod, & 129 131 ONLY: advec_s_up 130 132 131 USE advec_ws, &133 USE advec_ws, & 132 134 ONLY: advec_s_ws 133 135 134 USE arrays_3d, &135 ONLY: d dzu, diss, dzu, dzw, hyp, hyrho,&136 nc, nc_1, nc_2, nc_3, nc_p, nr, nr_1, nr_2, nr_3, nr_p,&137 precipitation_amount, prr, pt, d_exner, pt_init, q, ql, ql_1,&138 qc, qc_1, qc_2, qc_3, qc_p, qr, qr_1, qr_2, qr_3, qr_p,&139 exner, zu, tnc_m, tnr_m, tqc_m, tqr_m, tend, rdf_sc, &140 flux_l_qc, flux_l_qr, flux_l_nc, flux_l_nr, &141 flux_ s_qc, flux_s_qr, flux_s_nc, flux_s_nr,&142 diss_l_qc, diss_l_qr, diss_l_nc, diss_l_nr,&143 diss_s_qc, diss_s_qr, diss_s_nc, diss_s_nr,&144 ni, ni_1, ni_2, ni_3, ni_p, tni_m, &145 qi, qi_1, qi_2, qi_3, qi_p, tqi_m,&146 flux_l_qi, flux_l_ni, flux_s_qi, flux_s_ni,&147 diss_l_qi, diss_l_ni, diss_s_qi, diss_s_ni148 149 150 USE averaging, &151 ONLY: nc_av, nr_av, prr_av, qc_av, ql_av, qr_av, ni_av, qi_av152 153 USE basic_constants_and_equations_mod, &154 ONLY: c_p, g, lv_d_cp, lv_d_rd, l_v, magnus, magnus_ice, magnus_tl, &155 molecular_weight_of_solute,&156 molecular_weight_of_water, pi, rho_l, rho_s, r_d, r_v, vanthoff,&157 exner_function, exner_function_invers, ideal_gas_law_rho,&158 ideal_gas_law_rho_pt, barometric_formula, rd_d_rv, l_s,&159 ls_d_cp160 161 USE control_parameters, &162 ONLY: bc_dirichlet_l, &163 bc_dirichlet_n, &164 bc_dirichlet_r, &165 bc_dirichlet_s, &166 bc_radiation_l, &167 bc_radiation_n, &168 bc_radiation_r, &169 bc_radiation_s, &170 debug_output, &171 dt_3d, dt_do2d_xy, intermediate_timestep_count, &172 intermediate_timestep_count_max, large_scale_forcing, &173 l sf_surf, pt_surface, restart_data_format_output, rho_surface,&174 surface_pressure,&175 time_do2d_xy, message_string, initializing_actions,&176 ws_scheme_sca, scalar_advec, timestep_scheme, tsc,&177 loop_optimization, simulated_time178 179 USE cpulog, &136 USE arrays_3d, & 137 ONLY: diss_s_qc, diss_s_qr, diss_s_nc, diss_s_nr, & 138 diss_l_qc, diss_l_qr, diss_l_nc, diss_l_nr, & 139 diss_l_qi, diss_l_ni, diss_s_qi, diss_s_ni, & 140 ddzu, diss, dzu, dzw, hyp, hyrho, & 141 exner, zu, tnc_m, tnr_m, tqc_m, tqr_m, tend, rdf_sc, & 142 flux_l_qc, flux_l_qr, flux_l_nc, flux_l_nr, & 143 flux_l_qi, flux_l_ni, flux_s_qi, flux_s_ni, & 144 flux_s_qc, flux_s_qr, flux_s_nc, flux_s_nr, & 145 nc, nc_1, nc_2, nc_3, nc_p, nr, nr_1, nr_2, nr_3, nr_p, & 146 ni, ni_1, ni_2, ni_3, ni_p, tni_m, & 147 precipitation_amount, prr, pt, d_exner, pt_init, q, ql, ql_1, & 148 qc, qc_1, qc_2, qc_3, qc_p, qr, qr_1, qr_2, qr_3, qr_p, & 149 qi, qi_1, qi_2, qi_3, qi_p, tqi_m 150 151 152 USE averaging, & 153 ONLY: nc_av,ni_av, nr_av, prr_av, qc_av, ql_av, qi_av, qr_av 154 155 USE basic_constants_and_equations_mod, & 156 ONLY: c_p, g, lv_d_cp, lv_d_rd, l_v, magnus, magnus_ice, magnus_tl, & 157 exner_function, exner_function_invers, ideal_gas_law_rho, & 158 ideal_gas_law_rho_pt, barometric_formula, rd_d_rv, l_s, & 159 ls_d_cp, & 160 molecular_weight_of_solute, & 161 molecular_weight_of_water, pi, rho_l, rho_s, r_d, r_v, vanthoff 162 163 USE control_parameters, & 164 ONLY: bc_dirichlet_l, & 165 bc_dirichlet_n, & 166 bc_dirichlet_r, & 167 bc_dirichlet_s, & 168 bc_radiation_l, & 169 bc_radiation_n, & 170 bc_radiation_r, & 171 bc_radiation_s, & 172 debug_output, & 173 dt_3d, dt_do2d_xy, intermediate_timestep_count, & 174 intermediate_timestep_count_max, large_scale_forcing, & 175 loop_optimization, simulated_time, & 176 lsf_surf, pt_surface, restart_data_format_output, rho_surface, & 177 surface_pressure, & 178 time_do2d_xy, message_string, initializing_actions, & 179 ws_scheme_sca, scalar_advec, timestep_scheme, tsc 180 181 USE cpulog, & 180 182 ONLY: cpu_log, log_point, log_point_s 181 183 182 USE diffusion_s_mod, &184 USE diffusion_s_mod, & 183 185 ONLY: diffusion_s 184 186 185 USE grid_variables, &187 USE grid_variables, & 186 188 ONLY: dx, dy 187 189 188 USE indices, &189 ONLY: advc_flags_s, &190 nbgp, nxl, nxlg, nxr, nxrg, nys, nysg, nyn, nyng, nzb, nzt, &191 topo_top_ind, &190 USE indices, & 191 ONLY: advc_flags_s, & 192 nbgp, nxl, nxlg, nxr, nxrg, nys, nysg, nyn, nyng, nzb, nzt, & 193 topo_top_ind, & 192 194 wall_flags_total_0 193 195 194 196 USE kinds 195 197 196 USE pegrid, &198 USE pegrid, & 197 199 ONLY: threads_per_task 198 200 199 USE restart_data_mpi_io_mod, &201 USE restart_data_mpi_io_mod, & 200 202 ONLY: rd_mpi_io_check_array, rrd_mpi_io, wrd_mpi_io 201 203 202 USE statistics, & 203 ONLY: weight_pres, weight_substep, sums_wsncs_ws_l, sums_wsnrs_ws_l, & 204 sums_wsqcs_ws_l, sums_wsqrs_ws_l, & 205 sums_wsqis_ws_l, sums_wsnis_ws_l 206 207 USE surface_mod, & 208 ONLY : bc_h, & 209 surf_bulk_cloud_model, & 210 surf_microphysics_morrison, surf_microphysics_seifert, & 211 surf_microphysics_ice_phase, & 212 surf_def_h, surf_def_v, surf_lsm_h, surf_lsm_v, surf_usm_h, & 204 USE statistics, & 205 ONLY: sums_wsncs_ws_l, sums_wsnis_ws_l, sums_wsnrs_ws_l, sums_wsqcs_ws_l, sums_wsqis_ws_l,& 206 sums_wsqrs_ws_l, weight_pres, weight_substep 207 208 USE surface_mod, & 209 ONLY : bc_h, & 210 surf_bulk_cloud_model, & 211 surf_microphysics_morrison, surf_microphysics_seifert, & 212 surf_microphysics_ice_phase, & 213 surf_def_h, surf_def_v, surf_lsm_h, surf_lsm_v, surf_usm_h, & 213 214 surf_usm_v 214 215 … … 218 219 CHARACTER (LEN=20) :: cloud_scheme = 'saturation_adjust' !< namelist parameter 219 220 220 LOGICAL :: aerosol_nacl =.TRUE. !< nacl aerosol for bulk scheme 221 LOGICAL :: aerosol_c3h4o4 =.FALSE. !< malonic acid aerosol for bulk scheme 222 LOGICAL :: aerosol_nh4no3 =.FALSE. !< malonic acid aerosol for bulk scheme 223 224 LOGICAL :: bulk_cloud_model = .FALSE. !< namelist parameter 225 226 LOGICAL :: cloud_water_sedimentation = .FALSE. !< cloud water sedimentation 227 LOGICAL :: curvature_solution_effects_bulk = .FALSE. !< flag for considering koehler theory 228 LOGICAL :: ice_crystal_sedimentation = .FALSE. !< flag for ice crystal sedimentation 229 LOGICAL :: limiter_sedimentation = .TRUE. !< sedimentation limiter 230 LOGICAL :: collision_turbulence = .FALSE. !< turbulence effects 231 LOGICAL :: ventilation_effect = .TRUE. !< ventilation effect 232 233 LOGICAL :: call_microphysics_at_all_substeps = .FALSE. !< namelist parameter 234 LOGICAL :: microphysics_ice_phase = .FALSE. !< use ice microphysics scheme 235 LOGICAL :: microphysics_sat_adjust = .FALSE. !< use saturation adjust bulk scheme? 236 LOGICAL :: microphysics_kessler = .FALSE. !< use kessler bulk scheme? 237 LOGICAL :: microphysics_morrison = .FALSE. !< use 2-moment Morrison (add. prog. eq. for nc and qc) 238 LOGICAL :: microphysics_seifert = .FALSE. !< use 2-moment Seifert and Beheng scheme 239 LOGICAL :: microphysics_morrison_no_rain = .FALSE. !< use 2-moment Morrison 240 LOGICAL :: precipitation = .FALSE. !< namelist parameter 241 242 REAL(wp) :: precipitation_amount_interval = 9999999.9_wp !< namelist parameter 243 244 REAL(wp) :: a_1 = 8.69E-4_wp !< coef. in turb. parametrization (cm-2 s3) 245 REAL(wp) :: a_2 = -7.38E-5_wp !< coef. in turb. parametrization (cm-2 s3) 246 REAL(wp) :: a_3 = -1.40E-2_wp !< coef. in turb. parametrization 247 REAL(wp) :: a_term = 9.65_wp !< coef. for terminal velocity (m s-1) 248 REAL(wp) :: a_vent = 0.78_wp !< coef. for ventilation effect 249 REAL(wp) :: b_1 = 11.45E-6_wp !< coef. in turb. parametrization (m) 250 REAL(wp) :: b_2 = 9.68E-6_wp !< coef. in turb. parametrization (m) 251 REAL(wp) :: b_3 = 0.62_wp !< coef. in turb. parametrization 252 REAL(wp) :: b_term = 9.8_wp !< coef. for terminal velocity (m s-1) 253 REAL(wp) :: b_vent = 0.308_wp !< coef. for ventilation effect 254 REAL(wp) :: beta_cc = 3.09E-4_wp !< coef. in turb. parametrization (cm-2 s3) 255 REAL(wp) :: c_1 = 4.82E-6_wp !< coef. in turb. parametrization (m) 256 REAL(wp) :: c_2 = 4.8E-6_wp !< coef. in turb. parametrization (m) 257 REAL(wp) :: c_3 = 0.76_wp !< coef. in turb. parametrization 258 REAL(wp) :: c_const = 0.93_wp !< const. in Taylor-microscale Reynolds number 259 REAL(wp) :: c_evap = 0.7_wp !< constant in evaporation 260 REAL(wp) :: c_term = 600.0_wp !< coef. for terminal velocity (m-1) 261 REAL(wp) :: diff_coeff_l = 0.23E-4_wp !< diffusivity of water vapor (m2 s-1) 262 REAL(wp) :: eps_sb = 1.0E-10_wp !< threshold in two-moments scheme 263 REAL(wp) :: eps_mr = 0.0_wp !< threshold for morrison scheme 264 REAL(wp) :: k_cc = 9.44E09_wp !< const. cloud-cloud kernel (m3 kg-2 s-1) 265 REAL(wp) :: k_cr0 = 4.33_wp !< const. cloud-rain kernel (m3 kg-1 s-1) 266 REAL(wp) :: k_rr = 7.12_wp !< const. rain-rain kernel (m3 kg-1 s-1) 267 REAL(wp) :: k_br = 1000.0_wp !< const. in breakup parametrization (m-1) 268 REAL(wp) :: k_st = 1.2E8_wp !< const. in drizzle parametrization (m-1 s-1) 269 REAL(wp) :: kin_vis_air = 1.4086E-5_wp !< kin. viscosity of air (m2 s-1) 270 REAL(wp) :: prec_time_const = 0.001_wp !< coef. in Kessler scheme (s-1) 271 REAL(wp) :: ql_crit = 0.0005_wp !< coef. in Kessler scheme (kg kg-1) 272 REAL(wp) :: schmidt_p_1d3=0.8921121_wp !< Schmidt number**0.33333, 0.71**0.33333 273 REAL(wp) :: sigma_gc = 1.3_wp !< geometric standard deviation cloud droplets 274 REAL(wp) :: thermal_conductivity_l = 2.43E-2_wp !< therm. cond. air (J m-1 s-1 K-1) 275 REAL(wp) :: w_precipitation = 9.65_wp !< maximum terminal velocity (m s-1) 276 REAL(wp) :: x0 = 2.6E-10_wp !< separating drop mass (kg) 277 REAL(wp) :: ximin = 4.42E-14_wp !< minimum mass of ice crystal (kg) (D~10µm) 278 REAL(wp) :: xcmin = 4.18E-15_wp !< minimum cloud drop size (kg) (~ 1µm) 279 REAL(wp) :: xrmin = 2.6E-10_wp !< minimum rain drop size (kg) 280 REAL(wp) :: xrmax = 5.0E-6_wp !< maximum rain drop site (kg) 281 221 LOGICAL :: aerosol_nacl =.TRUE. !< nacl aerosol for bulk scheme 222 LOGICAL :: aerosol_c3h4o4 =.FALSE. !< malonic acid aerosol for bulk scheme 223 LOGICAL :: aerosol_nh4no3 =.FALSE. !< malonic acid aerosol for bulk scheme 224 LOGICAL :: bulk_cloud_model = .FALSE. !< namelist parameter 225 LOGICAL :: call_microphysics_at_all_substeps = .FALSE. !< namelist parameter 226 LOGICAL :: cloud_water_sedimentation = .FALSE. !< cloud water sedimentation 227 LOGICAL :: collision_turbulence = .FALSE. !< turbulence effects 228 LOGICAL :: curvature_solution_effects_bulk = .FALSE. !< flag for considering koehler theory 229 LOGICAL :: ice_crystal_sedimentation = .FALSE. !< flag for ice crystal sedimentation 230 LOGICAL :: limiter_sedimentation = .TRUE. !< sedimentation limiter 231 LOGICAL :: microphysics_ice_phase = .FALSE. !< use ice microphysics scheme 232 LOGICAL :: microphysics_kessler = .FALSE. !< use kessler bulk scheme? 233 LOGICAL :: microphysics_morrison = .FALSE. !< use 2-moment Morrison 234 !< (add. prog. eq. for nc and qc) 235 LOGICAL :: microphysics_morrison_no_rain = .FALSE. !< use 2-moment Morrison 236 LOGICAL :: microphysics_sat_adjust = .FALSE. !< use saturation adjust bulk scheme? 237 LOGICAL :: microphysics_seifert = .FALSE. !< use 2-moment Seifert and Beheng 238 !< scheme 239 LOGICAL :: precipitation = .FALSE. !< namelist parameter 240 LOGICAL :: ventilation_effect = .TRUE. !< ventilation effect 241 242 243 REAL(wp) :: a_1 = 8.69E-4_wp !< coef. in turb. parametrization (cm-2 s3) 244 REAL(wp) :: a_2 = -7.38E-5_wp !< coef. in turb. parametrization (cm-2 s3) 245 REAL(wp) :: a_3 = -1.40E-2_wp !< coef. in turb. parametrization 246 REAL(wp) :: a_term = 9.65_wp !< coef. for terminal velocity (m s-1) 247 REAL(wp) :: a_vent = 0.78_wp !< coef. for ventilation effect 248 REAL(wp) :: b_1 = 11.45E-6_wp !< coef. in turb. parametrization (m) 249 REAL(wp) :: b_2 = 9.68E-6_wp !< coef. in turb. parametrization (m) 250 REAL(wp) :: b_3 = 0.62_wp !< coef. in turb. parametrization 251 REAL(wp) :: b_term = 9.8_wp !< coef. for terminal velocity (m s-1) 252 REAL(wp) :: b_vent = 0.308_wp !< coef. for ventilation effect 253 REAL(wp) :: beta_cc = 3.09E-4_wp !< coef. in turb. parametrization (cm-2 s3) 254 REAL(wp) :: c_1 = 4.82E-6_wp !< coef. in turb. parametrization (m) 255 REAL(wp) :: c_2 = 4.8E-6_wp !< coef. in turb. parametrization (m) 256 REAL(wp) :: c_3 = 0.76_wp !< coef. in turb. parametrization 257 REAL(wp) :: c_const = 0.93_wp !< const. in Taylor-microscale Reynolds number 258 REAL(wp) :: c_evap = 0.7_wp !< constant in evaporation 282 259 REAL(wp) :: c_sedimentation = 2.0_wp !< Courant number of sedimentation process 260 REAL(wp) :: c_term = 600.0_wp !< coef. for terminal velocity (m-1) 261 REAL(wp) :: diff_coeff_l = 0.23E-4_wp !< diffusivity of water vapor (m2 s-1) 283 262 REAL(wp) :: dpirho_l !< 6.0 / ( pi * rho_l ) 284 263 REAL(wp) :: dry_aerosol_radius = 0.05E-6_wp !< dry aerosol radius 285 264 REAL(wp) :: dt_micro !< microphysics time step 265 REAL(wp) :: eps_sb = 1.0E-10_wp !< threshold in two-moments scheme 266 REAL(wp) :: dt_precipitation = 100.0_wp !< timestep precipitation (s) 267 REAL(wp) :: e_s !< saturation water vapor pressure 268 REAL(wp) :: e_si !< saturation water vapor pressure over ice 269 REAL(wp) :: eps_mr = 0.0_wp !< threshold for morrison scheme 286 270 REAL(wp) :: in_init = 1000.0_wp !< initial number of potential ice nucleii 287 REAL(wp) :: sigma_bulk = 2.0_wp !< width of aerosol spectrum 271 REAL(wp) :: k_cc = 9.44E09_wp !< const. cloud-cloud kernel (m3 kg-2 s-1) 272 REAL(wp) :: k_cr0 = 4.33_wp !< const. cloud-rain kernel (m3 kg-1 s-1) 273 REAL(wp) :: k_rr = 7.12_wp !< const. rain-rain kernel (m3 kg-1 s-1) 274 REAL(wp) :: k_br = 1000.0_wp !< const. in breakup parametrization (m-1) 275 REAL(wp) :: k_st = 1.2E8_wp !< const. in drizzle parametrization (m-1 s-1) 276 REAL(wp) :: kin_vis_air = 1.4086E-5_wp !< kin. viscosity of air (m2 s-1) 288 277 REAL(wp) :: na_init = 100.0E6_wp !< Total particle/aerosol concentration (cm-3) 289 278 REAL(wp) :: nc_const = 70.0E6_wp !< cloud droplet concentration 290 REAL(wp) :: dt_precipitation = 100.0_wp !< timestep precipitation (s) 279 REAL(wp) :: pirho_l !< pi * rho_l / 6.0 280 REAL(wp) :: prec_time_const = 0.001_wp !< coef. in Kessler scheme (s-1) 281 REAL(wp) :: precipitation_amount_interval = 9999999.9_wp !< namelist parameter 282 REAL(wp) :: ql_crit = 0.0005_wp !< coef. in Kessler scheme (kg kg-1) 283 REAL(wp) :: q_s !< saturation mixing ratio 284 REAL(wp) :: q_si !< saturation mixing ratio over ice 285 REAL(wp) :: sat !< supersaturation 286 REAL(wp) :: sat_ice !< supersaturation over ice 287 REAL(wp) :: start_ice_microphysics = 0.0_wp !< time from which on ice microhysics are executed 291 288 REAL(wp) :: sed_qc_const !< const. for sedimentation of cloud water 292 REAL(wp) :: pirho_l !< pi * rho_l / 6.0 293 REAL(wp) :: start_ice_microphysics = 0.0_wp !< time from which on ice microhysics are executed 294 295 REAL(wp) :: e_s !< saturation water vapor pressure 296 REAL(wp) :: e_si !< saturation water vapor pressure over ice 297 REAL(wp) :: q_s !< saturation mixing ratio 298 REAL(wp) :: q_si !< saturation mixing ratio over ice 299 REAL(wp) :: sat !< supersaturation 300 REAL(wp) :: sat_ice !< supersaturation over ice 301 REAL(wp) :: t_l !< liquid-(ice) water temperature 289 REAL(wp) :: schmidt_p_1d3=0.8921121_wp !< Schmidt number**0.33333, 0.71**0.33333 290 REAL(wp) :: sigma_bulk = 2.0_wp !< width of aerosol spectrum 291 REAL(wp) :: sigma_gc = 1.3_wp !< geometric standard deviation cloud droplets 292 REAL(wp) :: t_l !< liquid-(ice) water temperature 293 REAL(wp) :: thermal_conductivity_l = 2.43E-2_wp !< therm. cond. air (J m-1 s-1 K-1) 294 REAL(wp) :: w_precipitation = 9.65_wp !< maximum terminal velocity (m s-1) 295 REAL(wp) :: x0 = 2.6E-10_wp !< separating drop mass (kg) 296 REAL(wp) :: ximin = 4.42E-14_wp !< minimum mass of ice crystal (kg) (D~10µm) 297 REAL(wp) :: xcmin = 4.18E-15_wp !< minimum cloud drop size (kg) (~ 1µm) 298 REAL(wp) :: xrmin = 2.6E-10_wp !< minimum rain drop size (kg) 299 REAL(wp) :: xrmax = 5.0E-6_wp !< maximum rain drop site (kg) 300 302 301 303 302 SAVE … … 305 304 PRIVATE 306 305 307 PUBLIC bcm_parin, &308 bcm_check_parameters, &309 bcm_check_data_output, &310 bcm_check_data_output_pr, &311 bcm_init_arrays, &312 bcm_init, &313 bcm_header, &314 bcm_actions, &315 bcm_non_advective_processes, &316 bcm_exchange_horiz, &317 bcm_prognostic_equations, &318 bcm_boundary_conditions, &319 bcm_3d_data_averaging, &320 bcm_data_output_2d, &321 bcm_data_output_3d, &322 bcm_swap_timelevel, &323 bcm_rrd_global, &324 bcm_rrd_local, &325 bcm_wrd_global, &326 bcm_wrd_local, &306 PUBLIC bcm_parin, & 307 bcm_check_parameters, & 308 bcm_check_data_output, & 309 bcm_check_data_output_pr, & 310 bcm_init_arrays, & 311 bcm_init, & 312 bcm_header, & 313 bcm_actions, & 314 bcm_non_advective_processes, & 315 bcm_exchange_horiz, & 316 bcm_prognostic_equations, & 317 bcm_boundary_conditions, & 318 bcm_3d_data_averaging, & 319 bcm_data_output_2d, & 320 bcm_data_output_3d, & 321 bcm_swap_timelevel, & 322 bcm_rrd_global, & 323 bcm_rrd_local, & 324 bcm_wrd_global, & 325 bcm_wrd_local, & 327 326 calc_liquid_water_content 328 327 329 PUBLIC call_microphysics_at_all_substeps,&330 c loud_water_sedimentation,&331 bulk_cloud_model,&332 cloud_scheme, &333 collision_turbulence, &334 dt_precipitation, &335 microphysics_morrison,&336 microphysics_morrison_no_rain,&337 microphysics_ sat_adjust,&338 microphysics_ seifert,&339 microphysics_ ice_phase,&340 na_init,&341 nc_const,&342 precipitation,&343 sigma_gc,&344 start_ice_microphysics,&345 ice_crystal_sedimentation,&346 in_init328 PUBLIC bulk_cloud_model, & 329 call_microphysics_at_all_substeps, & 330 cloud_water_sedimentation, & 331 cloud_scheme, & 332 collision_turbulence, & 333 dt_precipitation, & 334 ice_crystal_sedimentation, & 335 in_init, & 336 microphysics_morrison, & 337 microphysics_morrison_no_rain, & 338 microphysics_sat_adjust, & 339 microphysics_seifert, & 340 microphysics_ice_phase, & 341 na_init, & 342 nc_const, & 343 precipitation, & 344 sigma_gc, & 345 start_ice_microphysics 347 346 348 347 INTERFACE bcm_parin … … 438 437 439 438 440 !------------------------------------------------------------------------------ !439 !--------------------------------------------------------------------------------------------------! 441 440 ! Description: 442 441 ! ------------ 443 442 !> Parin for &bulk_cloud_parameters for the bulk cloud module 444 !------------------------------------------------------------------------------ !443 !--------------------------------------------------------------------------------------------------! 445 444 SUBROUTINE bcm_parin 446 445 … … 448 447 IMPLICIT NONE 449 448 450 CHARACTER (LEN=80) :: line !< dummy string that contains the current line of the parameter file 451 452 NAMELIST /bulk_cloud_parameters/ & 453 aerosol_bulk, & 454 c_sedimentation, & 455 call_microphysics_at_all_substeps, & 456 bulk_cloud_model, & 457 cloud_scheme, & 458 cloud_water_sedimentation, & 459 collision_turbulence, & 460 curvature_solution_effects_bulk, & 461 dry_aerosol_radius, & 462 limiter_sedimentation, & 463 na_init, & 464 nc_const, & 465 sigma_bulk, & 466 ventilation_effect, & 467 ice_crystal_sedimentation, & 468 microphysics_ice_phase, & 469 start_ice_microphysics, & 470 in_init 449 CHARACTER (LEN=80) :: line !< dummy string that contains the current line of the parameter 450 !< file 451 452 NAMELIST /bulk_cloud_parameters/ & 453 aerosol_bulk, & 454 bulk_cloud_model, & 455 c_sedimentation, & 456 call_microphysics_at_all_substeps, & 457 cloud_scheme, & 458 cloud_water_sedimentation, & 459 collision_turbulence, & 460 curvature_solution_effects_bulk, & 461 dry_aerosol_radius, & 462 ice_crystal_sedimentation, & 463 in_init, & 464 limiter_sedimentation, & 465 microphysics_ice_phase, & 466 na_init, & 467 nc_const, & 468 sigma_bulk, & 469 start_ice_microphysics, & 470 ventilation_effect 471 471 472 472 line = ' ' … … 492 492 493 493 494 !------------------------------------------------------------------------------ !494 !--------------------------------------------------------------------------------------------------! 495 495 ! Description: 496 496 ! ------------ 497 497 !> Check parameters routine for bulk cloud module 498 !------------------------------------------------------------------------------ !498 !--------------------------------------------------------------------------------------------------! 499 499 SUBROUTINE bcm_check_parameters 500 500 … … 503 503 ! 504 504 !-- Check cloud scheme 505 !-- This scheme considers only saturation adjustment, 506 !-- i.e. water vapor surplus is converted into liquid 507 !-- water. No other microphysical processes are considered 505 !-- This scheme considers only saturation adjustment, i.e. water vapor surplus is converted into 506 !-- liquid water. No other microphysical processes are considered. 508 507 IF ( cloud_scheme == 'saturation_adjust' ) THEN 509 508 microphysics_sat_adjust = .TRUE. … … 513 512 microphysics_morrison_no_rain = .FALSE. 514 513 ! 515 !-- This scheme includes all process of the seifert 516 !-- beheng scheme (2001,2006). Especially rain processes are 517 !-- considered with prognostic quantities of qr and nr. 518 !-- Cloud droplet concentration is assumed to be constant and 519 !-- qc is diagnostic. 520 !-- Technical remark: The switch 'microphysics_seifert' allocates 521 !-- fields of qr and nr and enables all rain processes. 514 !-- This scheme includes all process of the seifert beheng scheme (2001,2006). Especially rain 515 !-- processes are considered with prognostic quantities of qr and nr. 516 !-- Cloud droplet concentration is assumed to be constant and qc is diagnostic. 517 !-- Technical remark: The switch 'microphysics_seifert' allocates fields of qr and nr and enables 518 !-- all rain processes. 522 519 ELSEIF ( cloud_scheme == 'seifert_beheng' ) THEN 523 520 microphysics_sat_adjust = .FALSE. … … 528 525 microphysics_morrison_no_rain = .FALSE. 529 526 ! 530 !-- The kessler scheme is a simplified scheme without any 531 !-- prognostic quantities for microphyical variables but 532 !-- considering autoconversion. 527 !-- The kessler scheme is a simplified scheme without any prognostic quantities for microphyical 528 !-- variables but considering autoconversion. 533 529 ELSEIF ( cloud_scheme == 'kessler' ) THEN 534 530 microphysics_sat_adjust = .FALSE. … … 539 535 microphysics_morrison_no_rain = .FALSE. 540 536 ! 541 !-- The morrison scheme is an extension of the seifer beheng scheme 542 !-- including also relevant processes for cloud droplet size particles 543 !-- such as activation and an diagnostic mehtod for diffusional growth. 544 !-- I.e. here all processes of Seifert and Beheng as well as of the 545 !-- morrision scheme are used. Therefore, ztis includes prognostic 546 !-- quantities for qc and nc. 547 !-- Technical remark: The switch 'microphysics_morrison' allocates 548 !-- fields of qc and nc and enables diagnostic diffusional growth and 549 !-- activation. 537 !-- The morrison scheme is an extension of the seifer beheng scheme including also relevant 538 !-- processes for cloud droplet size particles such as activation and an diagnostic mehtod for 539 !-- diffusional growth. 540 !-- I.e. here all processes of Seifert and Beheng as well as of the morrision scheme are used. 541 !-- Therefore, ztis includes prognostic quantities for qc and nc. 542 !-- Technical remark: The switch 'microphysics_morrison' allocates fields of qc and nc and 543 !-- enables diagnostic diffusional growth and activation. 550 544 ELSEIF ( cloud_scheme == 'morrison' ) THEN 551 545 microphysics_sat_adjust = .FALSE. … … 554 548 microphysics_morrison = .TRUE. 555 549 precipitation = .TRUE. 556 microphysics_morrison_no_rain = .FALSE. 557 ! 558 !-- The 'morrision_no_rain' scheme includes only processes of morrision scheme 559 !-- without the rain processes of seifert beheng. Therfore, the prog. quantities 560 !-- of qr and nr remain unallocated. This might be appropiate for cloud in which 561 !-- the size distribution is narrow, e.g. fog. 550 microphysics_morrison_no_rain = .FALSE. 551 ! 552 !-- The 'morrision_no_rain' scheme includes only processes of morrision scheme without the rain 553 !-- processes of seifert beheng. Therfore, the prog. quantities of qr and nr remain unallocated. 554 !-- This might be appropiate for cloud in which the size distribution is narrow, e.g. fog. 562 555 ELSEIF ( cloud_scheme == 'morrison_no_rain' ) THEN 563 556 microphysics_sat_adjust = .FALSE. … … 568 561 precipitation = .FALSE. 569 562 ELSE 570 message_string = 'unknown cloud microphysics scheme cloud_scheme ="' // &563 message_string = 'unknown cloud microphysics scheme cloud_scheme ="' // & 571 564 TRIM( cloud_scheme ) // '"' 572 565 CALL message( 'check_parameters', 'PA0357', 1, 2, 0, 6, 0 ) … … 582 575 ELSE 583 576 IF ( precipitation_amount_interval > dt_do2d_xy ) THEN 584 WRITE( message_string, * ) 'precipitation_amount_interval = ', &585 precipitation_amount_interval, ' must not be larger than ',&586 577 WRITE( message_string, * ) 'precipitation_amount_interval = ', & 578 precipitation_amount_interval, ' must not be larger than ', & 579 'dt_do2d_xy = ', dt_do2d_xy 587 580 CALL message( 'check_parameters', 'PA0090', 1, 2, 0, 6, 0 ) 588 581 ENDIF … … 590 583 ENDIF 591 584 592 ! TODO: find better sol lution for circular dependency problem585 ! TODO: find better solution for circular dependency problem 593 586 surf_bulk_cloud_model = bulk_cloud_model 594 587 surf_microphysics_morrison = microphysics_morrison … … 617 610 END SUBROUTINE bcm_check_parameters 618 611 619 !------------------------------------------------------------------------------ !612 !--------------------------------------------------------------------------------------------------! 620 613 ! Description: 621 614 ! ------------ 622 615 !> Check data output for bulk cloud module 623 !------------------------------------------------------------------------------ !616 !--------------------------------------------------------------------------------------------------! 624 617 SUBROUTINE bcm_check_data_output( var, unit ) 625 618 … … 633 626 CASE ( 'nc' ) 634 627 IF ( .NOT. microphysics_morrison ) THEN 635 message_string = 'output of "' // TRIM( var ) // '" ' // & 636 'requires ' // & 628 message_string = 'output of "' // TRIM( var ) // '" ' // 'requires ' // & 637 629 'cloud_scheme = "morrison"' 638 630 CALL message( 'check_parameters', 'PA0359', 1, 2, 0, 6, 0 ) … … 642 634 CASE ( 'ni' ) 643 635 IF ( .NOT. microphysics_ice_phase ) THEN 644 message_string = 'output of "' // TRIM( var ) // '" ' // & 645 'requires ' // & 636 message_string = 'output of "' // TRIM( var ) // '" ' // 'requires ' // & 646 637 'microphysics_ice_phase = ".TRUE."' 647 638 CALL message( 'check_parameters', 'PA0359', 1, 2, 0, 6, 0 ) … … 651 642 CASE ( 'nr' ) 652 643 IF ( .NOT. microphysics_seifert ) THEN 653 message_string = 'output of "' // TRIM( var ) // '" ' // & 654 'requires ' // & 644 message_string = 'output of "' // TRIM( var ) // '" ' // 'requires ' // & 655 645 'cloud_scheme = "seifert_beheng"' 656 646 CALL message( 'check_parameters', 'PA0359', 1, 2, 0, 6, 0 ) … … 660 650 CASE ( 'prr' ) 661 651 IF ( microphysics_sat_adjust ) THEN 662 message_string = 'output of "' // TRIM( var ) // '" ' // & 663 'is not available for ' // & 652 message_string = 'output of "' // TRIM( var ) // '" ' // 'is not available for ' //& 664 653 'cloud_scheme = "saturation_adjust"' 665 654 CALL message( 'check_parameters', 'PA0423', 1, 2, 0, 6, 0 ) … … 672 661 CASE ( 'qi' ) 673 662 IF ( .NOT. microphysics_ice_phase ) THEN 674 message_string = 'output of "' // TRIM( var ) // '" ' // & 675 'requires ' // & 663 message_string = 'output of "' // TRIM( var ) // '" ' // 'requires ' // & 676 664 'microphysics_ice_phase = ".TRUE."' 677 665 CALL message( 'check_parameters', 'PA0359', 1, 2, 0, 6, 0 ) … … 681 669 CASE ( 'qr' ) 682 670 IF ( .NOT. microphysics_seifert ) THEN 683 message_string = 'output of "' // TRIM( var ) // '" ' // & 684 'requires ' // & 671 message_string = 'output of "' // TRIM( var ) // '" ' // 'requires ' // & 685 672 'cloud_scheme = "seifert_beheng"' 686 673 CALL message( 'check_parameters', 'PA0359', 1, 2, 0, 6, 0 ) … … 689 676 690 677 CASE ( 'pra*' ) 691 IF ( .NOT. microphysics_kessler .AND. & 692 .NOT. microphysics_seifert ) THEN 693 message_string = 'output of "' // TRIM( var ) // '" ' // & 694 'requires ' // & 678 IF ( .NOT. microphysics_kessler .AND. .NOT. microphysics_seifert ) THEN 679 message_string = 'output of "' // TRIM( var ) // '" ' // 'requires ' // & 695 680 'cloud_scheme = "kessler" or "seifert_beheng"' 696 681 CALL message( 'check_parameters', 'PA0112', 1, 2, 0, 6, 0 ) 697 682 ENDIF 698 683 ! TODO: find sollution (maybe connected to flow_statistics redesign?) 699 ! 700 ! message_string = 'temporal averaging of precipitation ' //&701 ! 'amount "' // TRIM( var ) // '" is not possible'702 ! 703 ! 684 ! IF ( j == 1 ) THEN 685 ! message_string = 'temporal averaging of precipitation ' // & 686 ! 'amount "' // TRIM( var ) // '" is not possible' 687 ! CALL message( 'check_parameters', 'PA0113', 1, 2, 0, 6, 0 ) 688 ! ENDIF 704 689 unit = 'mm' 705 690 706 691 CASE ( 'prr*' ) 707 IF ( .NOT. microphysics_kessler .AND. & 708 .NOT. microphysics_seifert ) THEN 709 message_string = 'output of "' // TRIM( var ) // '"' // & 710 ' requires' // & 711 ' cloud_scheme = "kessler" or "seifert_beheng"' 692 IF ( .NOT. microphysics_kessler .AND. .NOT. microphysics_seifert ) THEN 693 message_string = 'output of "' // TRIM( var ) // '"' // ' requires' // & 694 ' cloud_scheme = "kessler" or "seifert_beheng"' 712 695 CALL message( 'check_parameters', 'PA0112', 1, 2, 0, 6, 0 ) 713 696 ENDIF … … 723 706 724 707 725 !------------------------------------------------------------------------------ !708 !--------------------------------------------------------------------------------------------------! 726 709 ! Description: 727 710 ! ------------ 728 711 !> Check data output of profiles for bulk cloud module 729 !------------------------------------------------------------------------------ !712 !--------------------------------------------------------------------------------------------------! 730 713 SUBROUTINE bcm_check_data_output_pr( variable, var_count, unit, dopr_unit ) 731 714 732 USE arrays_3d, &715 USE arrays_3d, & 733 716 ONLY: zu 734 717 735 USE control_parameters, &718 USE control_parameters, & 736 719 ONLY: data_output_pr 737 720 738 USE profil_parameter, &721 USE profil_parameter, & 739 722 ONLY: dopr_index 740 723 741 USE statistics, &724 USE statistics, & 742 725 ONLY: hom, statistic_regions 743 726 … … 757 740 CASE ( 'nc' ) 758 741 IF ( .NOT. microphysics_morrison ) THEN 759 message_string = 'data_output_pr = ' // & 760 TRIM( data_output_pr(var_count) ) // & 761 ' is not implemented for' // & 762 ' cloud_scheme /= morrison' 742 message_string = 'data_output_pr = ' // TRIM( data_output_pr(var_count) ) // & 743 ' is not implemented for' // ' cloud_scheme /= morrison' 763 744 CALL message( 'check_parameters', 'PA0358', 1, 2, 0, 6, 0 ) 764 745 ENDIF … … 771 752 CASE ( 'ni' ) 772 753 IF ( .NOT. microphysics_ice_phase ) THEN 773 message_string = 'data_output_pr = ' // & 774 TRIM( data_output_pr(var_count) ) // & 775 ' is not implemented for' // & 776 ' microphysics_ice_phase = ".F."' 754 message_string = 'data_output_pr = ' // TRIM( data_output_pr(var_count) ) // & 755 ' is not implemented for' // ' microphysics_ice_phase = ".F."' 777 756 CALL message( 'check_parameters', 'PA0358', 1, 2, 0, 6, 0 ) 778 757 ENDIF … … 785 764 CASE ( 'nr' ) 786 765 IF ( .NOT. microphysics_seifert ) THEN 787 message_string = 'data_output_pr = ' // & 788 TRIM( data_output_pr(var_count) ) // & 789 ' is not implemented for' // & 790 ' cloud_scheme /= seifert_beheng' 766 message_string = 'data_output_pr = ' // TRIM( data_output_pr(var_count) ) // & 767 ' is not implemented for' // ' cloud_scheme /= seifert_beheng' 791 768 CALL message( 'check_parameters', 'PA0358', 1, 2, 0, 6, 0 ) 792 769 ENDIF … … 799 776 CASE ( 'prr' ) 800 777 IF ( microphysics_sat_adjust ) THEN 801 message_string = 'data_output_pr = ' // & 802 TRIM( data_output_pr(var_count) ) // & 803 ' is not available for' // & 804 ' cloud_scheme = saturation_adjust' 778 message_string = 'data_output_pr = ' // TRIM( data_output_pr(var_count) ) // & 779 ' is not available for' // ' cloud_scheme = saturation_adjust' 805 780 CALL message( 'check_parameters', 'PA0422', 1, 2, 0, 6, 0 ) 806 ENDIF 781 ENDIF 807 782 pr_index = 76 808 783 dopr_index(var_count) = pr_index … … 820 795 CASE ( 'qi' ) 821 796 IF ( .NOT. microphysics_ice_phase ) THEN 822 message_string = 'data_output_pr = ' // & 823 TRIM( data_output_pr(var_count) ) // & 824 ' is not implemented for' // & 825 ' microphysics_ice_phase = ".F."' 797 message_string = 'data_output_pr = ' // TRIM( data_output_pr(var_count) ) // & 798 ' is not implemented for' // ' microphysics_ice_phase = ".F."' 826 799 CALL message( 'check_parameters', 'PA0358', 1, 2, 0, 6, 0 ) 827 800 ENDIF … … 834 807 CASE ( 'qr' ) 835 808 IF ( .NOT. microphysics_seifert ) THEN 836 message_string = 'data_output_pr = ' // & 837 TRIM( data_output_pr(var_count) ) // & 838 ' is not implemented for' // & 839 ' cloud_scheme /= seifert_beheng' 809 message_string = 'data_output_pr = ' // TRIM( data_output_pr(var_count) ) // & 810 ' is not implemented for' // ' cloud_scheme /= seifert_beheng' 840 811 CALL message( 'check_parameters', 'PA0358', 1, 2, 0, 6, 0 ) 841 812 ENDIF … … 854 825 855 826 856 !------------------------------------------------------------------------------ !827 !--------------------------------------------------------------------------------------------------! 857 828 ! Description: 858 829 ! ------------ 859 830 !> Allocate bulk cloud module arrays and define pointers 860 !------------------------------------------------------------------------------ !831 !--------------------------------------------------------------------------------------------------! 861 832 SUBROUTINE bcm_init_arrays 862 833 863 USE indices, &834 USE indices, & 864 835 ONLY: nxlg, nxrg, nysg, nyng, nzb, nzt 865 836 … … 887 858 ! 888 859 !-- 3D-cloud drop water content, cloud drop concentration arrays 889 ALLOCATE( nc_1(nzb:nzt+1,nysg:nyng,nxlg:nxrg), &890 nc_2(nzb:nzt+1,nysg:nyng,nxlg:nxrg), &891 nc_3(nzb:nzt+1,nysg:nyng,nxlg:nxrg), &892 qc_1(nzb:nzt+1,nysg:nyng,nxlg:nxrg), &893 qc_2(nzb:nzt+1,nysg:nyng,nxlg:nxrg), &860 ALLOCATE( nc_1(nzb:nzt+1,nysg:nyng,nxlg:nxrg), & 861 nc_2(nzb:nzt+1,nysg:nyng,nxlg:nxrg), & 862 nc_3(nzb:nzt+1,nysg:nyng,nxlg:nxrg), & 863 qc_1(nzb:nzt+1,nysg:nyng,nxlg:nxrg), & 864 qc_2(nzb:nzt+1,nysg:nyng,nxlg:nxrg), & 894 865 qc_3(nzb:nzt+1,nysg:nyng,nxlg:nxrg) ) 895 866 ENDIF … … 898 869 ! 899 870 !-- 3D-rain water content, rain drop concentration arrays 900 ALLOCATE( nr_1(nzb:nzt+1,nysg:nyng,nxlg:nxrg), &901 nr_2(nzb:nzt+1,nysg:nyng,nxlg:nxrg), &902 nr_3(nzb:nzt+1,nysg:nyng,nxlg:nxrg), &903 qr_1(nzb:nzt+1,nysg:nyng,nxlg:nxrg), &904 qr_2(nzb:nzt+1,nysg:nyng,nxlg:nxrg), &871 ALLOCATE( nr_1(nzb:nzt+1,nysg:nyng,nxlg:nxrg), & 872 nr_2(nzb:nzt+1,nysg:nyng,nxlg:nxrg), & 873 nr_3(nzb:nzt+1,nysg:nyng,nxlg:nxrg), & 874 qr_1(nzb:nzt+1,nysg:nyng,nxlg:nxrg), & 875 qr_2(nzb:nzt+1,nysg:nyng,nxlg:nxrg), & 905 876 qr_3(nzb:nzt+1,nysg:nyng,nxlg:nxrg) ) 906 877 ENDIF … … 909 880 ! 910 881 !-- 3D-cloud drop water content, cloud drop concentration arrays 911 ALLOCATE( ni_1(nzb:nzt+1,nysg:nyng,nxlg:nxrg), &912 ni_2(nzb:nzt+1,nysg:nyng,nxlg:nxrg), &913 ni_3(nzb:nzt+1,nysg:nyng,nxlg:nxrg), &914 qi_1(nzb:nzt+1,nysg:nyng,nxlg:nxrg), &915 qi_2(nzb:nzt+1,nysg:nyng,nxlg:nxrg), &882 ALLOCATE( ni_1(nzb:nzt+1,nysg:nyng,nxlg:nxrg), & 883 ni_2(nzb:nzt+1,nysg:nyng,nxlg:nxrg), & 884 ni_3(nzb:nzt+1,nysg:nyng,nxlg:nxrg), & 885 qi_1(nzb:nzt+1,nysg:nyng,nxlg:nxrg), & 886 qi_2(nzb:nzt+1,nysg:nyng,nxlg:nxrg), & 916 887 qi_3(nzb:nzt+1,nysg:nyng,nxlg:nxrg) ) 917 888 ENDIF … … 940 911 ! 941 912 !-- Arrays needed for reasons of speed optimization for cache version. 942 !-- For the vector version the buffer arrays are not necessary, 943 !-- because the the fluxes can swapped directly inside the loops of the 944 !-- advection routines. 913 !-- For the vector version the buffer arrays are not necessary, because the the fluxes can 914 !-- swapped directly inside the loops of the advection routines. 945 915 IF ( loop_optimization /= 'vector' ) THEN 946 916 IF ( ws_scheme_sca ) THEN 947 917 IF ( microphysics_morrison ) THEN 948 ALLOCATE( flux_s_qc(nzb+1:nzt,0:threads_per_task-1), &949 diss_s_qc(nzb+1:nzt,0:threads_per_task-1), &950 flux_s_nc(nzb+1:nzt,0:threads_per_task-1), &918 ALLOCATE( flux_s_qc(nzb+1:nzt,0:threads_per_task-1), & 919 diss_s_qc(nzb+1:nzt,0:threads_per_task-1), & 920 flux_s_nc(nzb+1:nzt,0:threads_per_task-1), & 951 921 diss_s_nc(nzb+1:nzt,0:threads_per_task-1) ) 952 ALLOCATE( flux_l_qc(nzb+1:nzt,nys:nyn,0:threads_per_task-1), &953 diss_l_qc(nzb+1:nzt,nys:nyn,0:threads_per_task-1), &954 flux_l_nc(nzb+1:nzt,nys:nyn,0:threads_per_task-1), &922 ALLOCATE( flux_l_qc(nzb+1:nzt,nys:nyn,0:threads_per_task-1), & 923 diss_l_qc(nzb+1:nzt,nys:nyn,0:threads_per_task-1), & 924 flux_l_nc(nzb+1:nzt,nys:nyn,0:threads_per_task-1), & 955 925 diss_l_nc(nzb+1:nzt,nys:nyn,0:threads_per_task-1) ) 956 926 ENDIF 957 927 IF ( microphysics_seifert ) THEN 958 ALLOCATE( flux_s_qr(nzb+1:nzt,0:threads_per_task-1), &959 diss_s_qr(nzb+1:nzt,0:threads_per_task-1), &960 flux_s_nr(nzb+1:nzt,0:threads_per_task-1), &928 ALLOCATE( flux_s_qr(nzb+1:nzt,0:threads_per_task-1), & 929 diss_s_qr(nzb+1:nzt,0:threads_per_task-1), & 930 flux_s_nr(nzb+1:nzt,0:threads_per_task-1), & 961 931 diss_s_nr(nzb+1:nzt,0:threads_per_task-1) ) 962 ALLOCATE( flux_l_qr(nzb+1:nzt,nys:nyn,0:threads_per_task-1), &963 diss_l_qr(nzb+1:nzt,nys:nyn,0:threads_per_task-1), &964 flux_l_nr(nzb+1:nzt,nys:nyn,0:threads_per_task-1), &932 ALLOCATE( flux_l_qr(nzb+1:nzt,nys:nyn,0:threads_per_task-1), & 933 diss_l_qr(nzb+1:nzt,nys:nyn,0:threads_per_task-1), & 934 flux_l_nr(nzb+1:nzt,nys:nyn,0:threads_per_task-1), & 965 935 diss_l_nr(nzb+1:nzt,nys:nyn,0:threads_per_task-1) ) 966 936 ENDIF 967 937 IF ( microphysics_ice_phase ) THEN 968 ALLOCATE( flux_s_qi(nzb+1:nzt,0:threads_per_task-1), &969 diss_s_qi(nzb+1:nzt,0:threads_per_task-1), &970 flux_s_ni(nzb+1:nzt,0:threads_per_task-1), &938 ALLOCATE( flux_s_qi(nzb+1:nzt,0:threads_per_task-1), & 939 diss_s_qi(nzb+1:nzt,0:threads_per_task-1), & 940 flux_s_ni(nzb+1:nzt,0:threads_per_task-1), & 971 941 diss_s_ni(nzb+1:nzt,0:threads_per_task-1) ) 972 ALLOCATE( flux_l_qi(nzb+1:nzt,nys:nyn,0:threads_per_task-1), &973 diss_l_qi(nzb+1:nzt,nys:nyn,0:threads_per_task-1), &974 flux_l_ni(nzb+1:nzt,nys:nyn,0:threads_per_task-1), &942 ALLOCATE( flux_l_qi(nzb+1:nzt,nys:nyn,0:threads_per_task-1), & 943 diss_l_qi(nzb+1:nzt,nys:nyn,0:threads_per_task-1), & 944 flux_l_ni(nzb+1:nzt,nys:nyn,0:threads_per_task-1), & 975 945 diss_l_ni(nzb+1:nzt,nys:nyn,0:threads_per_task-1) ) 976 946 ENDIF … … 1002 972 1003 973 1004 !------------------------------------------------------------------------------ !974 !--------------------------------------------------------------------------------------------------! 1005 975 ! Description: 1006 976 ! ------------ 1007 977 !> Initialization of the bulk cloud module 1008 !------------------------------------------------------------------------------ !978 !--------------------------------------------------------------------------------------------------! 1009 979 SUBROUTINE bcm_init 1010 980 … … 1048 1018 ENDIF 1049 1019 ! 1050 !-- Liquid water content and precipitation amount 1051 !-- are zero at beginning of the simulation 1020 !-- Liquid water content and precipitation amount are zero at beginning of the simulation. 1052 1021 ql = 0.0_wp 1053 1022 qc = 0.0_wp … … 1076 1045 ENDIF ! Only if not read_restart_data 1077 1046 ! 1078 !-- constant for the sedimentation of cloud water (2-moment cloud physics) 1079 sed_qc_const = k_st * ( 3.0_wp / ( 4.0_wp * pi * rho_l ) & 1080 )**( 2.0_wp / 3.0_wp ) * & 1047 !-- Constant for the sedimentation of cloud water (2-moment cloud physics) 1048 sed_qc_const = k_st * ( 3.0_wp / ( 4.0_wp * pi * rho_l ) )**( 2.0_wp / 3.0_wp ) * & 1081 1049 EXP( 5.0_wp * LOG( sigma_gc )**2 ) 1082 1050 … … 1084 1052 !-- Calculate timestep according to precipitation 1085 1053 IF ( microphysics_seifert ) THEN 1086 dt_precipitation = c_sedimentation * MINVAL( dzu(nzb+2:nzt) ) / & 1087 w_precipitation 1054 dt_precipitation = c_sedimentation * MINVAL( dzu(nzb+2:nzt) ) / w_precipitation 1088 1055 ENDIF 1089 1056 … … 1122 1089 1123 1090 1124 !------------------------------------------------------------------------------ !1091 !--------------------------------------------------------------------------------------------------! 1125 1092 ! Description: 1126 1093 ! ------------ 1127 1094 !> Header output for bulk cloud module 1128 !------------------------------------------------------------------------------ !1095 !--------------------------------------------------------------------------------------------------! 1129 1096 SUBROUTINE bcm_header ( io ) 1130 1097 … … 1166 1133 1167 1134 1168 1 FORMAT ( //' Bulk cloud module information:'/ & 1169 ' ------------------------------------------'/ ) 1170 2 FORMAT ( '--> Bulk scheme with liquid water potential temperature and'/ & 1135 1 FORMAT ( //' Bulk cloud module information:'/ ' ------------------------------------------'/ ) 1136 2 FORMAT ( '--> Bulk scheme with liquid water potential temperature and'/ & 1171 1137 ' total water content is used.' ) 1172 1138 3 FORMAT ( '--> Condensation is parameterized via 0% - or 100% scheme.' ) … … 1191 1157 1192 1158 1193 !------------------------------------------------------------------------------ !1159 !--------------------------------------------------------------------------------------------------! 1194 1160 ! Description: 1195 1161 ! ------------ 1196 1162 !> Control of microphysics for all grid points 1197 !------------------------------------------------------------------------------ !1163 !--------------------------------------------------------------------------------------------------! 1198 1164 SUBROUTINE bcm_actions( location ) 1199 1165 … … 1230 1196 1231 1197 1232 !------------------------------------------------------------------------------ !1198 !--------------------------------------------------------------------------------------------------! 1233 1199 ! Description: 1234 1200 ! ------------ 1235 1201 !> Control of microphysics for grid points i,j 1236 !------------------------------------------------------------------------------ !1202 !--------------------------------------------------------------------------------------------------! 1237 1203 SUBROUTINE bcm_actions_ij( i, j, location ) 1238 1204 1239 1205 1240 INTEGER(iwp), INTENT(IN) :: i !< grid index in x-direction1241 INTEGER(iwp), INTENT(IN) :: j !< grid index in y-direction1242 1206 CHARACTER (LEN=*), INTENT(IN) :: location !< call location string 1243 INTEGER(iwp) :: dummy !< call location string 1244 1245 IF ( bulk_cloud_model ) dummy = i + j 1207 1208 INTEGER(iwp) :: dummy !< call location string 1209 1210 INTEGER(iwp), INTENT(IN) :: i !< grid index in x-direction 1211 INTEGER(iwp), INTENT(IN) :: j !< grid index in y-direction 1212 1213 1214 IF ( bulk_cloud_model ) dummy = i + j 1246 1215 1247 1216 SELECT CASE ( location ) … … 1276 1245 1277 1246 1278 !------------------------------------------------------------------------------ !1247 !--------------------------------------------------------------------------------------------------! 1279 1248 ! Description: 1280 1249 ! ------------ 1281 1250 !> Control of microphysics for all grid points 1282 !------------------------------------------------------------------------------ !1251 !--------------------------------------------------------------------------------------------------! 1283 1252 SUBROUTINE bcm_non_advective_processes 1284 1253 … … 1286 1255 CALL cpu_log( log_point(51), 'microphysics', 'start' ) 1287 1256 1288 IF ( .NOT. microphysics_sat_adjust .AND. & 1289 ( intermediate_timestep_count == 1 .OR. & 1290 call_microphysics_at_all_substeps ) ) & 1257 IF ( .NOT. microphysics_sat_adjust .AND. ( intermediate_timestep_count == 1 .OR. & 1258 call_microphysics_at_all_substeps ) ) & 1291 1259 THEN 1292 1260 … … 1294 1262 ! 1295 1263 !-- Calculate vertical profile of the hydrostatic pressure (hyp) 1296 hyp = barometric_formula(zu, pt_surface * & 1297 exner_function(surface_pressure * 100.0_wp), & 1298 surface_pressure * 100.0_wp) 1264 hyp = barometric_formula(zu, pt_surface * & 1265 exner_function(surface_pressure * 100.0_wp), surface_pressure * 100.0_wp) 1299 1266 d_exner = exner_function_invers(hyp) 1300 1267 exner = 1.0_wp / exner_function_invers(hyp) … … 1302 1269 ! 1303 1270 !-- Compute reference density 1304 rho_surface = ideal_gas_law_rho(surface_pressure * 100.0_wp, & 1305 pt_surface * & 1306 exner_function(surface_pressure * 100.0_wp)) 1271 rho_surface = ideal_gas_law_rho(surface_pressure * 100.0_wp, & 1272 pt_surface * exner_function(surface_pressure * 100.0_wp)) 1307 1273 ENDIF 1308 1274 … … 1320 1286 1321 1287 ! 1322 !-- Compute cloud physics 1288 !-- Compute cloud physics. 1323 1289 !-- Here the the simple kessler scheme is used. 1324 1290 IF ( microphysics_kessler ) THEN … … 1327 1293 1328 1294 ! 1329 !-- Here the seifert beheng scheme is used. Cloud concentration is assumed to 1330 !-- a constant value an qc a diagnostic value.1295 !-- Here the seifert beheng scheme is used. Cloud concentration is assumed to a constant value 1296 !-- an qc a diagnostic value. 1331 1297 ELSEIF ( microphysics_seifert .AND. .NOT. microphysics_morrison ) THEN 1332 1298 CALL adjust_cloud 1333 IF ( microphysics_ice_phase .AND. simulated_time > start_ice_microphysics ) &1334 CALL ice_nucleation1335 IF ( microphysics_ice_phase .AND. simulated_time > start_ice_microphysics ) &1336 CALL ice_deposition1299 IF ( microphysics_ice_phase .AND. simulated_time > start_ice_microphysics ) THEN 1300 CALL ice_nucleation 1301 CALL ice_deposition 1302 ENDIF 1337 1303 CALL autoconversion 1338 1304 CALL accretion … … 1341 1307 CALL sedimentation_rain 1342 1308 IF ( cloud_water_sedimentation ) CALL sedimentation_cloud 1343 IF ( microphysics_ice_phase .AND. simulated_time > start_ice_microphysics ) &1344 CALL adjust_ice1345 IF ( ice_crystal_sedimentation .AND. microphysics_ice_phase &1346 .AND. simulated_time > start_ice_microphysics ) CALL sedimentation_ice1347 1348 ! 1349 !-- Here the morrison scheme is used. No rain processes are considered and qr and nr 1350 !-- a re not allocated1309 IF ( microphysics_ice_phase .AND. simulated_time > start_ice_microphysics ) THEN 1310 CALL adjust_ice 1311 IF ( ice_crystal_sedimentation ) CALL sedimentation_ice 1312 ENDIF 1313 1314 ! 1315 !-- Here the morrison scheme is used. No rain processes are considered and qr and nr are not 1316 !-- allocated. 1351 1317 ELSEIF ( microphysics_morrison_no_rain .AND. .NOT. microphysics_seifert ) THEN 1352 1318 CALL activation 1353 1319 CALL condensation 1354 IF ( microphysics_ice_phase .AND. simulated_time > start_ice_microphysics ) & 1355 CALL adjust_ice 1356 IF ( microphysics_ice_phase .AND. simulated_time > start_ice_microphysics ) & 1357 CALL ice_nucleation 1358 IF ( microphysics_ice_phase .AND. simulated_time > start_ice_microphysics ) & 1359 CALL ice_deposition 1320 IF ( microphysics_ice_phase .AND. simulated_time > start_ice_microphysics ) THEN 1321 CALL adjust_ice 1322 CALL ice_nucleation 1323 CALL ice_deposition 1324 ENDIF 1360 1325 IF ( cloud_water_sedimentation ) CALL sedimentation_cloud 1361 1326 1362 1327 ! 1363 !-- Here the full morrison scheme is used and all processes of Seifert and Beheng are 1364 !-- included 1328 !-- Here the full morrison scheme is used and all processes of Seifert and Beheng are included 1365 1329 ELSEIF ( microphysics_morrison .AND. microphysics_seifert ) THEN 1366 1330 CALL adjust_cloud 1367 1331 CALL activation 1368 1332 CALL condensation 1369 IF ( microphysics_ice_phase .AND. simulated_time > start_ice_microphysics ) & 1370 CALL adjust_ice 1371 IF ( microphysics_ice_phase .AND. simulated_time > start_ice_microphysics ) & 1372 CALL ice_nucleation 1373 IF ( microphysics_ice_phase .AND. simulated_time > start_ice_microphysics ) & 1374 CALL ice_deposition 1333 IF ( microphysics_ice_phase .AND. simulated_time > start_ice_microphysics ) THEN 1334 CALL adjust_ice 1335 CALL ice_nucleation 1336 CALL ice_deposition 1337 ENDIF 1375 1338 CALL autoconversion 1376 1339 CALL accretion … … 1391 1354 1392 1355 1393 !------------------------------------------------------------------------------ !1356 !--------------------------------------------------------------------------------------------------! 1394 1357 ! Description: 1395 1358 ! ------------ 1396 1359 !> Control of microphysics for grid points i,j 1397 !------------------------------------------------------------------------------ !1360 !--------------------------------------------------------------------------------------------------! 1398 1361 SUBROUTINE bcm_non_advective_processes_ij( i, j ) 1399 1362 … … 1402 1365 INTEGER(iwp) :: j !< 1403 1366 1404 IF ( .NOT. microphysics_sat_adjust .AND. & 1405 ( intermediate_timestep_count == 1 .OR. & 1406 call_microphysics_at_all_substeps ) ) & 1367 IF ( .NOT. microphysics_sat_adjust .AND. ( intermediate_timestep_count == 1 .OR. & 1368 call_microphysics_at_all_substeps ) ) & 1407 1369 THEN 1408 1370 … … 1410 1372 ! 1411 1373 !-- Calculate vertical profile of the hydrostatic pressure (hyp) 1412 hyp = barometric_formula(zu, pt_surface * & 1413 exner_function(surface_pressure * 100.0_wp), & 1414 surface_pressure * 100.0_wp) 1374 hyp = barometric_formula(zu, pt_surface * & 1375 exner_function(surface_pressure * 100.0_wp), surface_pressure * 100.0_wp) 1415 1376 d_exner = exner_function_invers(hyp) 1416 1377 exner = 1.0_wp / exner_function_invers(hyp) … … 1418 1379 ! 1419 1380 !-- Compute reference density 1420 rho_surface = ideal_gas_law_rho(surface_pressure * 100.0_wp, & 1421 pt_surface * & 1422 exner_function(surface_pressure * 100.0_wp)) 1381 rho_surface = ideal_gas_law_rho(surface_pressure * 100.0_wp, & 1382 pt_surface * exner_function(surface_pressure * 100.0_wp)) 1423 1383 ENDIF 1424 1384 … … 1442 1402 1443 1403 ! 1444 !-- Here the seifert beheng scheme is used. Cloud concentration is assumed to 1445 !-- a constant value an qc a diagnostic value.1404 !-- Here the seifert beheng scheme is used. Cloud concentration is assumed to a constant value 1405 !-- an qc a diagnostic value. 1446 1406 ELSEIF ( microphysics_seifert .AND. .NOT. microphysics_morrison ) THEN 1447 1407 CALL adjust_cloud_ij( i,j ) 1448 IF ( microphysics_ice_phase .AND. simulated_time > start_ice_microphysics ) &1408 IF ( microphysics_ice_phase .AND. simulated_time > start_ice_microphysics ) THEN 1449 1409 CALL ice_nucleation_ij( i,j ) 1450 IF ( microphysics_ice_phase .AND. simulated_time > start_ice_microphysics ) &1451 1410 CALL ice_deposition_ij( i,j ) 1411 ENDIF 1452 1412 CALL autoconversion_ij( i,j ) 1453 1413 CALL accretion_ij( i,j ) … … 1456 1416 CALL sedimentation_rain_ij( i,j ) 1457 1417 IF ( cloud_water_sedimentation ) CALL sedimentation_cloud_ij( i,j ) 1458 IF ( microphysics_ice_phase .AND. simulated_time > start_ice_microphysics ) &1418 IF ( microphysics_ice_phase .AND. simulated_time > start_ice_microphysics ) THEN 1459 1419 CALL adjust_ice_ij ( i,j ) 1460 IF ( ice_crystal_sedimentation .AND. microphysics_ice_phase & 1461 .AND. simulated_time > start_ice_microphysics ) CALL sedimentation_ice_ij ( i,j ) 1462 ! 1463 !-- Here the morrison scheme is used. No rain processes are considered and qr and nr 1464 !-- are not allocated 1420 IF ( ice_crystal_sedimentation ) CALL sedimentation_ice_ij ( i,j ) 1421 ENDIF 1422 1423 ! 1424 !-- Here the morrison scheme is used. No rain processes are considered and qr and nr are not 1425 !-- allocated. 1465 1426 ELSEIF ( microphysics_morrison_no_rain .AND. .NOT. microphysics_seifert ) THEN 1466 1427 CALL activation_ij( i,j ) 1467 1428 CALL condensation_ij( i,j ) 1468 IF ( microphysics_ice_phase .AND. simulated_time > start_ice_microphysics ) &1429 IF ( microphysics_ice_phase .AND. simulated_time > start_ice_microphysics ) THEN 1469 1430 CALL adjust_ice_ij ( i,j ) 1470 IF ( microphysics_ice_phase .AND. simulated_time > start_ice_microphysics ) &1471 1431 CALL ice_nucleation_ij( i,j ) 1472 IF ( microphysics_ice_phase .AND. simulated_time > start_ice_microphysics ) &1473 1432 CALL ice_deposition_ij( i,j ) 1433 ENDIF 1474 1434 IF ( cloud_water_sedimentation ) CALL sedimentation_cloud_ij( i,j ) 1475 1435 1476 1436 ! 1477 !-- Here the full morrison scheme is used and all processes of Seifert and Beheng are 1478 !-- included 1437 !-- Here the full morrison scheme is used and all processes of Seifert and Beheng are included 1479 1438 ELSEIF ( microphysics_morrison .AND. microphysics_seifert ) THEN 1480 1439 CALL adjust_cloud_ij( i,j ) 1481 1440 CALL activation_ij( i,j ) 1482 1441 CALL condensation_ij( i,j ) 1483 IF ( microphysics_ice_phase .AND. simulated_time > start_ice_microphysics ) &1442 IF ( microphysics_ice_phase .AND. simulated_time > start_ice_microphysics ) THEN 1484 1443 CALL adjust_ice_ij ( i,j ) 1485 IF ( microphysics_ice_phase .AND. simulated_time > start_ice_microphysics ) &1486 1444 CALL ice_nucleation_ij( i,j ) 1487 IF ( microphysics_ice_phase .AND. simulated_time > start_ice_microphysics ) &1488 1445 CALL ice_deposition_ij( i,j ) 1446 ENDIF 1489 1447 CALL autoconversion_ij( i,j ) 1490 1448 CALL accretion_ij( i,j ) … … 1501 1459 1502 1460 END SUBROUTINE bcm_non_advective_processes_ij 1503 1504 1505 !------------------------------------------------------------------------------ !1461 1462 1463 !--------------------------------------------------------------------------------------------------! 1506 1464 ! Description: 1507 1465 ! ------------ 1508 1466 !> Control of microphysics for all grid points 1509 !------------------------------------------------------------------------------ !1467 !--------------------------------------------------------------------------------------------------! 1510 1468 SUBROUTINE bcm_exchange_horiz 1511 1469 1512 USE exchange_horiz_mod, &1470 USE exchange_horiz_mod, & 1513 1471 ONLY: exchange_horiz 1514 1472 1515 1473 1516 IF ( .NOT. microphysics_sat_adjust .AND. & 1517 ( intermediate_timestep_count == 1 .OR. & 1518 call_microphysics_at_all_substeps ) ) & 1474 IF ( .NOT. microphysics_sat_adjust .AND. ( intermediate_timestep_count == 1 .OR. & 1475 call_microphysics_at_all_substeps ) ) & 1519 1476 THEN 1520 1477 IF ( microphysics_morrison ) THEN … … 1539 1496 1540 1497 1541 !------------------------------------------------------------------------------ !1498 !--------------------------------------------------------------------------------------------------! 1542 1499 ! Description: 1543 1500 ! ------------ 1544 1501 !> Control of microphysics for all grid points 1545 !------------------------------------------------------------------------------ !1502 !--------------------------------------------------------------------------------------------------! 1546 1503 SUBROUTINE bcm_prognostic_equations 1547 1504 … … 1554 1511 1555 1512 ! 1556 !-- If required, calculate prognostic equations for cloud water content 1557 !-- and cloud drop concentration1513 !-- If required, calculate prognostic equations for cloud water content and cloud drop 1514 !-- concentration. 1558 1515 IF ( microphysics_morrison ) THEN 1559 1516 … … 1581 1538 IF ( timestep_scheme(1:5) == 'runge' ) THEN 1582 1539 IF ( ws_scheme_sca ) THEN 1583 CALL advec_s_ws( advc_flags_s, qc, 'qc', &1584 bc_dirichlet_l .OR. bc_radiation_l, &1585 bc_dirichlet_n .OR. bc_radiation_n, &1586 bc_dirichlet_r .OR. bc_radiation_r, &1540 CALL advec_s_ws( advc_flags_s, qc, 'qc', & 1541 bc_dirichlet_l .OR. bc_radiation_l, & 1542 bc_dirichlet_n .OR. bc_radiation_n, & 1543 bc_dirichlet_r .OR. bc_radiation_r, & 1587 1544 bc_dirichlet_s .OR. bc_radiation_s ) 1588 1545 ELSE … … 1594 1551 ENDIF 1595 1552 1596 CALL diffusion_s( qc, &1597 surf_def_h(0)%qcsws, surf_def_h(1)%qcsws, &1598 surf_def_h(2)%qcsws, &1599 surf_lsm_h%qcsws, surf_usm_h%qcsws, &1600 surf_def_v(0)%qcsws, surf_def_v(1)%qcsws, &1601 surf_def_v(2)%qcsws, surf_def_v(3)%qcsws, &1602 surf_lsm_v(0)%qcsws, surf_lsm_v(1)%qcsws, &1603 surf_lsm_v(2)%qcsws, surf_lsm_v(3)%qcsws, &1604 surf_usm_v(0)%qcsws, surf_usm_v(1)%qcsws, &1553 CALL diffusion_s( qc, & 1554 surf_def_h(0)%qcsws, surf_def_h(1)%qcsws, & 1555 surf_def_h(2)%qcsws, & 1556 surf_lsm_h%qcsws, surf_usm_h%qcsws, & 1557 surf_def_v(0)%qcsws, surf_def_v(1)%qcsws, & 1558 surf_def_v(2)%qcsws, surf_def_v(3)%qcsws, & 1559 surf_lsm_v(0)%qcsws, surf_lsm_v(1)%qcsws, & 1560 surf_lsm_v(2)%qcsws, surf_lsm_v(3)%qcsws, & 1561 surf_usm_v(0)%qcsws, surf_usm_v(1)%qcsws, & 1605 1562 surf_usm_v(2)%qcsws, surf_usm_v(3)%qcsws ) 1606 1563 … … 1612 1569 !DIR$ IVDEP 1613 1570 DO k = nzb+1, nzt 1614 qc_p(k,j,i) = qc(k,j,i) + ( dt_3d * ( sbt * tend(k,j,i) + & 1615 tsc(3) * tqc_m(k,j,i) ) & 1616 - tsc(5) * rdf_sc(k) * & 1617 qc(k,j,i) & 1618 ) & 1619 * MERGE( 1.0_wp, 0.0_wp, & 1620 BTEST( wall_flags_total_0(k,j,i), 0 ) & 1621 ) 1571 qc_p(k,j,i) = qc(k,j,i) + ( dt_3d * ( sbt * tend(k,j,i) + & 1572 tsc(3) * tqc_m(k,j,i) ) & 1573 - tsc(5) * rdf_sc(k) * & 1574 qc(k,j,i) & 1575 ) & 1576 * MERGE( 1.0_wp, 0.0_wp, BTEST( wall_flags_total_0(k,j,i), 0 ) & 1577 ) 1622 1578 IF ( qc_p(k,j,i) < 0.0_wp ) qc_p(k,j,i) = 0.0_wp 1623 1579 ENDDO … … 1641 1597 DO j = nys, nyn 1642 1598 DO k = nzb+1, nzt 1643 tqc_m(k,j,i) = -9.5625_wp * tend(k,j,i) & 1644 + 5.3125_wp * tqc_m(k,j,i) 1599 tqc_m(k,j,i) = -9.5625_wp * tend(k,j,i) + 5.3125_wp * tqc_m(k,j,i) 1645 1600 ENDDO 1646 1601 ENDDO … … 1673 1628 IF ( timestep_scheme(1:5) == 'runge' ) THEN 1674 1629 IF ( ws_scheme_sca ) THEN 1675 CALL advec_s_ws( advc_flags_s, nc, 'nc', &1676 bc_dirichlet_l .OR. bc_radiation_l, &1677 bc_dirichlet_n .OR. bc_radiation_n, &1678 bc_dirichlet_r .OR. bc_radiation_r, &1630 CALL advec_s_ws( advc_flags_s, nc, 'nc', & 1631 bc_dirichlet_l .OR. bc_radiation_l, & 1632 bc_dirichlet_n .OR. bc_radiation_n, & 1633 bc_dirichlet_r .OR. bc_radiation_r, & 1679 1634 bc_dirichlet_s .OR. bc_radiation_s ) 1680 1635 ELSE … … 1686 1641 ENDIF 1687 1642 1688 CALL diffusion_s( nc, &1689 surf_def_h(0)%ncsws, surf_def_h(1)%ncsws, &1690 surf_def_h(2)%ncsws, &1691 surf_lsm_h%ncsws, surf_usm_h%ncsws, &1692 surf_def_v(0)%ncsws, surf_def_v(1)%ncsws, &1693 surf_def_v(2)%ncsws, surf_def_v(3)%ncsws, &1694 surf_lsm_v(0)%ncsws, surf_lsm_v(1)%ncsws, &1695 surf_lsm_v(2)%ncsws, surf_lsm_v(3)%ncsws, &1696 surf_usm_v(0)%ncsws, surf_usm_v(1)%ncsws, &1643 CALL diffusion_s( nc, & 1644 surf_def_h(0)%ncsws, surf_def_h(1)%ncsws, & 1645 surf_def_h(2)%ncsws, & 1646 surf_lsm_h%ncsws, surf_usm_h%ncsws, & 1647 surf_def_v(0)%ncsws, surf_def_v(1)%ncsws, & 1648 surf_def_v(2)%ncsws, surf_def_v(3)%ncsws, & 1649 surf_lsm_v(0)%ncsws, surf_lsm_v(1)%ncsws, & 1650 surf_lsm_v(2)%ncsws, surf_lsm_v(3)%ncsws, & 1651 surf_usm_v(0)%ncsws, surf_usm_v(1)%ncsws, & 1697 1652 surf_usm_v(2)%ncsws, surf_usm_v(3)%ncsws ) 1698 1653 … … 1704 1659 !DIR$ IVDEP 1705 1660 DO k = nzb+1, nzt 1706 nc_p(k,j,i) = nc(k,j,i) + ( dt_3d * ( sbt * tend(k,j,i) + & 1707 tsc(3) * tnc_m(k,j,i) ) & 1708 - tsc(5) * rdf_sc(k) * & 1709 nc(k,j,i) & 1710 ) & 1711 * MERGE( 1.0_wp, 0.0_wp, & 1712 BTEST( wall_flags_total_0(k,j,i), 0 ) & 1661 nc_p(k,j,i) = nc(k,j,i) + ( dt_3d * ( sbt * tend(k,j,i) + & 1662 tsc(3) * tnc_m(k,j,i) ) & 1663 - tsc(5) * rdf_sc(k) * & 1664 nc(k,j,i) & 1665 ) & 1666 * MERGE( 1.0_wp, 0.0_wp, BTEST( wall_flags_total_0(k,j,i), 0 ) & 1713 1667 ) 1714 1668 IF ( nc_p(k,j,i) < 0.0_wp ) nc_p(k,j,i) = 0.0_wp … … 1733 1687 DO j = nys, nyn 1734 1688 DO k = nzb+1, nzt 1735 tnc_m(k,j,i) = -9.5625_wp * tend(k,j,i) & 1736 + 5.3125_wp * tnc_m(k,j,i) 1689 tnc_m(k,j,i) = -9.5625_wp * tend(k,j,i) + 5.3125_wp * tnc_m(k,j,i) 1737 1690 ENDDO 1738 1691 ENDDO … … 1746 1699 1747 1700 ! 1748 !-- If required, calculate prognostic equations for ice crystal content 1749 !-- and ice crystalconcentration1701 !-- If required, calculate prognostic equations for ice crystal content and ice crystal 1702 !-- concentration 1750 1703 IF ( microphysics_ice_phase ) THEN 1751 1704 … … 1773 1726 IF ( timestep_scheme(1:5) == 'runge' ) THEN 1774 1727 IF ( ws_scheme_sca ) THEN 1775 CALL advec_s_ws( advc_flags_s, qi, 'qi', &1776 bc_dirichlet_l .OR. bc_radiation_l, &1777 bc_dirichlet_n .OR. bc_radiation_n, &1778 bc_dirichlet_r .OR. bc_radiation_r, &1728 CALL advec_s_ws( advc_flags_s, qi, 'qi', & 1729 bc_dirichlet_l .OR. bc_radiation_l, & 1730 bc_dirichlet_n .OR. bc_radiation_n, & 1731 bc_dirichlet_r .OR. bc_radiation_r, & 1779 1732 bc_dirichlet_s .OR. bc_radiation_s ) 1780 1733 ELSE … … 1786 1739 ENDIF 1787 1740 1788 CALL diffusion_s( qi, &1789 surf_def_h(0)%qisws, surf_def_h(1)%qisws, &1790 surf_def_h(2)%qisws, &1791 surf_lsm_h%qisws, surf_usm_h%qisws, &1792 surf_def_v(0)%qisws, surf_def_v(1)%qisws, &1793 surf_def_v(2)%qisws, surf_def_v(3)%qisws, &1794 surf_lsm_v(0)%qisws, surf_lsm_v(1)%qisws, &1795 surf_lsm_v(2)%qisws, surf_lsm_v(3)%qisws, &1796 surf_usm_v(0)%qisws, surf_usm_v(1)%qisws, &1741 CALL diffusion_s( qi, & 1742 surf_def_h(0)%qisws, surf_def_h(1)%qisws, & 1743 surf_def_h(2)%qisws, & 1744 surf_lsm_h%qisws, surf_usm_h%qisws, & 1745 surf_def_v(0)%qisws, surf_def_v(1)%qisws, & 1746 surf_def_v(2)%qisws, surf_def_v(3)%qisws, & 1747 surf_lsm_v(0)%qisws, surf_lsm_v(1)%qisws, & 1748 surf_lsm_v(2)%qisws, surf_lsm_v(3)%qisws, & 1749 surf_usm_v(0)%qisws, surf_usm_v(1)%qisws, & 1797 1750 surf_usm_v(2)%qisws, surf_usm_v(3)%qisws ) 1798 1751 … … 1804 1757 !DIR$ IVDEP 1805 1758 DO k = nzb+1, nzt 1806 qi_p(k,j,i) = qi(k,j,i) + ( dt_3d * ( sbt * tend(k,j,i) + & 1807 tsc(3) * tqi_m(k,j,i) ) & 1808 - tsc(5) * rdf_sc(k) * & 1809 qi(k,j,i) & 1810 ) & 1811 * MERGE( 1.0_wp, 0.0_wp, & 1812 BTEST( wall_flags_total_0(k,j,i), 0 ) & 1759 qi_p(k,j,i) = qi(k,j,i) + ( dt_3d * ( sbt * tend(k,j,i) + & 1760 tsc(3) * tqi_m(k,j,i) ) & 1761 - tsc(5) * rdf_sc(k) * & 1762 qi(k,j,i) & 1763 ) & 1764 * MERGE( 1.0_wp, 0.0_wp, BTEST( wall_flags_total_0(k,j,i), 0 ) & 1813 1765 ) 1814 1766 IF ( qi_p(k,j,i) < 0.0_wp ) qi_p(k,j,i) = 0.0_wp … … 1833 1785 DO j = nys, nyn 1834 1786 DO k = nzb+1, nzt 1835 tqi_m(k,j,i) = -9.5625_wp * tend(k,j,i) & 1836 + 5.3125_wp * tqi_m(k,j,i) 1787 tqi_m(k,j,i) = -9.5625_wp * tend(k,j,i) + 5.3125_wp * tqi_m(k,j,i) 1837 1788 ENDDO 1838 1789 ENDDO … … 1865 1816 IF ( timestep_scheme(1:5) == 'runge' ) THEN 1866 1817 IF ( ws_scheme_sca ) THEN 1867 CALL advec_s_ws( advc_flags_s, ni, 'ni', &1868 bc_dirichlet_l .OR. bc_radiation_l, &1869 bc_dirichlet_n .OR. bc_radiation_n, &1870 bc_dirichlet_r .OR. bc_radiation_r, &1818 CALL advec_s_ws( advc_flags_s, ni, 'ni', & 1819 bc_dirichlet_l .OR. bc_radiation_l, & 1820 bc_dirichlet_n .OR. bc_radiation_n, & 1821 bc_dirichlet_r .OR. bc_radiation_r, & 1871 1822 bc_dirichlet_s .OR. bc_radiation_s ) 1872 1823 ELSE … … 1878 1829 ENDIF 1879 1830 1880 CALL diffusion_s( ni, &1881 surf_def_h(0)%nisws, surf_def_h(1)%nisws, &1882 surf_def_h(2)%nisws, &1883 surf_lsm_h%nisws, surf_usm_h%nisws, &1884 surf_def_v(0)%nisws, surf_def_v(1)%nisws, &1885 surf_def_v(2)%nisws, surf_def_v(3)%nisws, &1886 surf_lsm_v(0)%nisws, surf_lsm_v(1)%nisws, &1887 surf_lsm_v(2)%nisws, surf_lsm_v(3)%nisws, &1888 surf_usm_v(0)%nisws, surf_usm_v(1)%nisws, &1831 CALL diffusion_s( ni, & 1832 surf_def_h(0)%nisws, surf_def_h(1)%nisws, & 1833 surf_def_h(2)%nisws, & 1834 surf_lsm_h%nisws, surf_usm_h%nisws, & 1835 surf_def_v(0)%nisws, surf_def_v(1)%nisws, & 1836 surf_def_v(2)%nisws, surf_def_v(3)%nisws, & 1837 surf_lsm_v(0)%nisws, surf_lsm_v(1)%nisws, & 1838 surf_lsm_v(2)%nisws, surf_lsm_v(3)%nisws, & 1839 surf_usm_v(0)%nisws, surf_usm_v(1)%nisws, & 1889 1840 surf_usm_v(2)%nisws, surf_usm_v(3)%nisws ) 1890 1841 … … 1896 1847 !DIR$ IVDEP 1897 1848 DO k = nzb+1, nzt 1898 ni_p(k,j,i) = ni(k,j,i) + ( dt_3d * ( sbt * tend(k,j,i) + & 1899 tsc(3) * tni_m(k,j,i) ) & 1900 - tsc(5) * rdf_sc(k) * & 1901 ni(k,j,i) & 1902 ) & 1903 * MERGE( 1.0_wp, 0.0_wp, & 1904 BTEST( wall_flags_total_0(k,j,i), 0 ) & 1849 ni_p(k,j,i) = ni(k,j,i) + ( dt_3d * ( sbt * tend(k,j,i) + & 1850 tsc(3) * tni_m(k,j,i) ) & 1851 - tsc(5) * rdf_sc(k) * & 1852 ni(k,j,i) & 1853 ) & 1854 * MERGE( 1.0_wp, 0.0_wp, BTEST( wall_flags_total_0(k,j,i), 0 ) & 1905 1855 ) 1906 1856 IF ( ni_p(k,j,i) < 0.0_wp ) ni_p(k,j,i) = 0.0_wp … … 1925 1875 DO j = nys, nyn 1926 1876 DO k = nzb+1, nzt 1927 tni_m(k,j,i) = -9.5625_wp * tend(k,j,i) & 1928 + 5.3125_wp * tni_m(k,j,i) 1877 tni_m(k,j,i) = -9.5625_wp * tend(k,j,i) + 5.3125_wp * tni_m(k,j,i) 1929 1878 ENDDO 1930 1879 ENDDO … … 1938 1887 1939 1888 ! 1940 !-- If required, calculate prognostic equations for rain water content 1941 !-- and rain drop concentration1889 !-- If required, calculate prognostic equations for rain water content and rain drop 1890 !-- concentration. 1942 1891 IF ( microphysics_seifert ) THEN 1943 1892 … … 1965 1914 IF ( timestep_scheme(1:5) == 'runge' ) THEN 1966 1915 IF ( ws_scheme_sca ) THEN 1967 CALL advec_s_ws( advc_flags_s, qr, 'qr', &1968 bc_dirichlet_l .OR. bc_radiation_l, &1969 bc_dirichlet_n .OR. bc_radiation_n, &1970 bc_dirichlet_r .OR. bc_radiation_r, &1916 CALL advec_s_ws( advc_flags_s, qr, 'qr', & 1917 bc_dirichlet_l .OR. bc_radiation_l, & 1918 bc_dirichlet_n .OR. bc_radiation_n, & 1919 bc_dirichlet_r .OR. bc_radiation_r, & 1971 1920 bc_dirichlet_s .OR. bc_radiation_s ) 1972 1921 ELSE … … 1978 1927 ENDIF 1979 1928 1980 CALL diffusion_s( qr, &1981 surf_def_h(0)%qrsws, surf_def_h(1)%qrsws, &1982 surf_def_h(2)%qrsws, &1983 surf_lsm_h%qrsws, surf_usm_h%qrsws, &1984 surf_def_v(0)%qrsws, surf_def_v(1)%qrsws, &1985 surf_def_v(2)%qrsws, surf_def_v(3)%qrsws, &1986 surf_lsm_v(0)%qrsws, surf_lsm_v(1)%qrsws, &1987 surf_lsm_v(2)%qrsws, surf_lsm_v(3)%qrsws, &1988 surf_usm_v(0)%qrsws, surf_usm_v(1)%qrsws, &1929 CALL diffusion_s( qr, & 1930 surf_def_h(0)%qrsws, surf_def_h(1)%qrsws, & 1931 surf_def_h(2)%qrsws, & 1932 surf_lsm_h%qrsws, surf_usm_h%qrsws, & 1933 surf_def_v(0)%qrsws, surf_def_v(1)%qrsws, & 1934 surf_def_v(2)%qrsws, surf_def_v(3)%qrsws, & 1935 surf_lsm_v(0)%qrsws, surf_lsm_v(1)%qrsws, & 1936 surf_lsm_v(2)%qrsws, surf_lsm_v(3)%qrsws, & 1937 surf_usm_v(0)%qrsws, surf_usm_v(1)%qrsws, & 1989 1938 surf_usm_v(2)%qrsws, surf_usm_v(3)%qrsws ) 1990 1939 … … 1996 1945 !DIR$ IVDEP 1997 1946 DO k = nzb+1, nzt 1998 qr_p(k,j,i) = qr(k,j,i) + ( dt_3d * ( sbt * tend(k,j,i) + & 1999 tsc(3) * tqr_m(k,j,i) ) & 2000 - tsc(5) * rdf_sc(k) * & 2001 qr(k,j,i) & 2002 ) & 2003 * MERGE( 1.0_wp, 0.0_wp, & 2004 BTEST( wall_flags_total_0(k,j,i), 0 ) & 1947 qr_p(k,j,i) = qr(k,j,i) + ( dt_3d * ( sbt * tend(k,j,i) + & 1948 tsc(3) * tqr_m(k,j,i) ) & 1949 - tsc(5) * rdf_sc(k) * & 1950 qr(k,j,i) & 1951 ) & 1952 * MERGE( 1.0_wp, 0.0_wp, BTEST( wall_flags_total_0(k,j,i), 0 ) & 2005 1953 ) 2006 1954 IF ( qr_p(k,j,i) < 0.0_wp ) qr_p(k,j,i) = 0.0_wp … … 2025 1973 DO j = nys, nyn 2026 1974 DO k = nzb+1, nzt 2027 tqr_m(k,j,i) = -9.5625_wp * tend(k,j,i) & 2028 + 5.3125_wp * tqr_m(k,j,i) 1975 tqr_m(k,j,i) = -9.5625_wp * tend(k,j,i) + 5.3125_wp * tqr_m(k,j,i) 2029 1976 ENDDO 2030 1977 ENDDO … … 2057 2004 IF ( timestep_scheme(1:5) == 'runge' ) THEN 2058 2005 IF ( ws_scheme_sca ) THEN 2059 CALL advec_s_ws( advc_flags_s, nr, 'nr', &2060 bc_dirichlet_l .OR. bc_radiation_l, &2061 bc_dirichlet_n .OR. bc_radiation_n, &2062 bc_dirichlet_r .OR. bc_radiation_r, &2006 CALL advec_s_ws( advc_flags_s, nr, 'nr', & 2007 bc_dirichlet_l .OR. bc_radiation_l, & 2008 bc_dirichlet_n .OR. bc_radiation_n, & 2009 bc_dirichlet_r .OR. bc_radiation_r, & 2063 2010 bc_dirichlet_s .OR. bc_radiation_s ) 2064 2011 ELSE … … 2070 2017 ENDIF 2071 2018 2072 CALL diffusion_s( nr, &2073 surf_def_h(0)%nrsws, surf_def_h(1)%nrsws, &2074 surf_def_h(2)%nrsws, &2075 surf_lsm_h%nrsws, surf_usm_h%nrsws, &2076 surf_def_v(0)%nrsws, surf_def_v(1)%nrsws, &2077 surf_def_v(2)%nrsws, surf_def_v(3)%nrsws, &2078 surf_lsm_v(0)%nrsws, surf_lsm_v(1)%nrsws, &2079 surf_lsm_v(2)%nrsws, surf_lsm_v(3)%nrsws, &2080 surf_usm_v(0)%nrsws, surf_usm_v(1)%nrsws, &2019 CALL diffusion_s( nr, & 2020 surf_def_h(0)%nrsws, surf_def_h(1)%nrsws, & 2021 surf_def_h(2)%nrsws, & 2022 surf_lsm_h%nrsws, surf_usm_h%nrsws, & 2023 surf_def_v(0)%nrsws, surf_def_v(1)%nrsws, & 2024 surf_def_v(2)%nrsws, surf_def_v(3)%nrsws, & 2025 surf_lsm_v(0)%nrsws, surf_lsm_v(1)%nrsws, & 2026 surf_lsm_v(2)%nrsws, surf_lsm_v(3)%nrsws, & 2027 surf_usm_v(0)%nrsws, surf_usm_v(1)%nrsws, & 2081 2028 surf_usm_v(2)%nrsws, surf_usm_v(3)%nrsws ) 2082 2029 … … 2088 2035 !DIR$ IVDEP 2089 2036 DO k = nzb+1, nzt 2090 nr_p(k,j,i) = nr(k,j,i) + ( dt_3d * ( sbt * tend(k,j,i) + & 2091 tsc(3) * tnr_m(k,j,i) ) & 2092 - tsc(5) * rdf_sc(k) * & 2093 nr(k,j,i) & 2094 ) & 2095 * MERGE( 1.0_wp, 0.0_wp, & 2096 BTEST( wall_flags_total_0(k,j,i), 0 ) & 2037 nr_p(k,j,i) = nr(k,j,i) + ( dt_3d * ( sbt * tend(k,j,i) + & 2038 tsc(3) * tnr_m(k,j,i) ) & 2039 - tsc(5) * rdf_sc(k) * & 2040 nr(k,j,i) & 2041 ) & 2042 * MERGE( 1.0_wp, 0.0_wp, BTEST( wall_flags_total_0(k,j,i), 0 ) & 2097 2043 ) 2098 2044 IF ( nr_p(k,j,i) < 0.0_wp ) nr_p(k,j,i) = 0.0_wp … … 2132 2078 2133 2079 2134 !------------------------------------------------------------------------------ !2080 !--------------------------------------------------------------------------------------------------! 2135 2081 ! Description: 2136 2082 ! ------------ 2137 2083 !> Control of microphysics for grid points i,j 2138 !------------------------------------------------------------------------------ !2084 !--------------------------------------------------------------------------------------------------! 2139 2085 SUBROUTINE bcm_prognostic_equations_ij( i, j, i_omp_start, tn ) 2140 2086 2141 2087 2142 2088 INTEGER(iwp), INTENT(IN) :: i !< grid index in x-direction 2089 INTEGER(iwp), INTENT(IN) :: i_omp_start !< first loop index of i-loop in 2090 !< prognostic_equations 2143 2091 INTEGER(iwp), INTENT(IN) :: j !< grid index in y-direction 2144 2092 INTEGER(iwp) :: k !< grid index in z-direction 2145 INTEGER(iwp), INTENT(IN) :: i_omp_start !< first loop index of i-loop in prognostic_equations2146 2093 INTEGER(iwp), INTENT(IN) :: tn !< task number of openmp task 2147 2094 2148 2095 ! 2149 !-- If required, calculate prognostic equations for cloud water content 2150 !-- and cloud drop concentration2096 !-- If required, calculate prognostic equations for cloud water content and cloud drop 2097 !-- concentration. 2151 2098 IF ( microphysics_morrison ) THEN 2152 2099 ! … … 2156 2103 THEN 2157 2104 IF ( ws_scheme_sca ) THEN 2158 CALL advec_s_ws( advc_flags_s, i, j, qc, 'qc', flux_s_qc, &2159 diss_s_qc, flux_l_qc, diss_l_qc, &2160 i_omp_start, tn, &2161 bc_dirichlet_l .OR. bc_radiation_l, &2162 bc_dirichlet_n .OR. bc_radiation_n, &2163 bc_dirichlet_r .OR. bc_radiation_r, &2105 CALL advec_s_ws( advc_flags_s, i, j, qc, 'qc', flux_s_qc, & 2106 diss_s_qc, flux_l_qc, diss_l_qc, & 2107 i_omp_start, tn, & 2108 bc_dirichlet_l .OR. bc_radiation_l, & 2109 bc_dirichlet_n .OR. bc_radiation_n, & 2110 bc_dirichlet_r .OR. bc_radiation_r, & 2164 2111 bc_dirichlet_s .OR. bc_radiation_s ) 2165 2112 ELSE … … 2169 2116 CALL advec_s_up( i, j, qc ) 2170 2117 ENDIF 2171 CALL diffusion_s( i, j, qc, &2172 surf_def_h(0)%qcsws, surf_def_h(1)%qcsws, &2173 surf_def_h(2)%qcsws, &2174 surf_lsm_h%qcsws, surf_usm_h%qcsws, &2175 surf_def_v(0)%qcsws, surf_def_v(1)%qcsws, &2176 surf_def_v(2)%qcsws, surf_def_v(3)%qcsws, &2177 surf_lsm_v(0)%qcsws, surf_lsm_v(1)%qcsws, &2178 surf_lsm_v(2)%qcsws, surf_lsm_v(3)%qcsws, &2179 surf_usm_v(0)%qcsws, surf_usm_v(1)%qcsws, &2118 CALL diffusion_s( i, j, qc, & 2119 surf_def_h(0)%qcsws, surf_def_h(1)%qcsws, & 2120 surf_def_h(2)%qcsws, & 2121 surf_lsm_h%qcsws, surf_usm_h%qcsws, & 2122 surf_def_v(0)%qcsws, surf_def_v(1)%qcsws, & 2123 surf_def_v(2)%qcsws, surf_def_v(3)%qcsws, & 2124 surf_lsm_v(0)%qcsws, surf_lsm_v(1)%qcsws, & 2125 surf_lsm_v(2)%qcsws, surf_lsm_v(3)%qcsws, & 2126 surf_usm_v(0)%qcsws, surf_usm_v(1)%qcsws, & 2180 2127 surf_usm_v(2)%qcsws, surf_usm_v(3)%qcsws ) 2181 2128 … … 2183 2130 !-- Prognostic equation for cloud water content 2184 2131 DO k = nzb+1, nzt 2185 qc_p(k,j,i) = qc(k,j,i) + ( dt_3d * & 2186 ( tsc(2) * tend(k,j,i) + & 2187 tsc(3) * tqc_m(k,j,i) )& 2188 - tsc(5) * rdf_sc(k) & 2189 * qc(k,j,i) & 2190 ) & 2191 * MERGE( 1.0_wp, 0.0_wp, & 2192 BTEST( wall_flags_total_0(k,j,i), 0 )& 2132 qc_p(k,j,i) = qc(k,j,i) + ( dt_3d * & 2133 ( tsc(2) * tend(k,j,i) + & 2134 tsc(3) * tqc_m(k,j,i) ) & 2135 - tsc(5) * rdf_sc(k) & 2136 * qc(k,j,i) & 2137 ) & 2138 * MERGE( 1.0_wp, 0.0_wp, BTEST( wall_flags_total_0(k,j,i), 0 ) & 2193 2139 ) 2194 2140 IF ( qc_p(k,j,i) < 0.0_wp ) qc_p(k,j,i) = 0.0_wp … … 2204 2150 intermediate_timestep_count_max ) THEN 2205 2151 DO k = nzb+1, nzt 2206 tqc_m(k,j,i) = -9.5625_wp * tend(k,j,i) + & 2207 5.3125_wp * tqc_m(k,j,i) 2152 tqc_m(k,j,i) = -9.5625_wp * tend(k,j,i) + 5.3125_wp * tqc_m(k,j,i) 2208 2153 ENDDO 2209 2154 ENDIF … … 2215 2160 IF ( timestep_scheme(1:5) == 'runge' ) THEN 2216 2161 IF ( ws_scheme_sca ) THEN 2217 CALL advec_s_ws( advc_flags_s, i, j, nc, 'nc', flux_s_nc, &2218 diss_s_nc, flux_l_nc, diss_l_nc, &2219 i_omp_start, tn, &2220 bc_dirichlet_l .OR. bc_radiation_l, &2221 bc_dirichlet_n .OR. bc_radiation_n, &2222 bc_dirichlet_r .OR. bc_radiation_r, &2162 CALL advec_s_ws( advc_flags_s, i, j, nc, 'nc', flux_s_nc, & 2163 diss_s_nc, flux_l_nc, diss_l_nc, & 2164 i_omp_start, tn, & 2165 bc_dirichlet_l .OR. bc_radiation_l, & 2166 bc_dirichlet_n .OR. bc_radiation_n, & 2167 bc_dirichlet_r .OR. bc_radiation_r, & 2223 2168 bc_dirichlet_s .OR. bc_radiation_s ) 2224 2169 ELSE … … 2228 2173 CALL advec_s_up( i, j, nc ) 2229 2174 ENDIF 2230 CALL diffusion_s( i, j, nc, &2231 surf_def_h(0)%ncsws, surf_def_h(1)%ncsws, &2232 surf_def_h(2)%ncsws, &2233 surf_lsm_h%ncsws, surf_usm_h%ncsws, &2234 surf_def_v(0)%ncsws, surf_def_v(1)%ncsws, &2235 surf_def_v(2)%ncsws, surf_def_v(3)%ncsws, &2236 surf_lsm_v(0)%ncsws, surf_lsm_v(1)%ncsws, &2237 surf_lsm_v(2)%ncsws, surf_lsm_v(3)%ncsws, &2238 surf_usm_v(0)%ncsws, surf_usm_v(1)%ncsws, &2175 CALL diffusion_s( i, j, nc, & 2176 surf_def_h(0)%ncsws, surf_def_h(1)%ncsws, & 2177 surf_def_h(2)%ncsws, & 2178 surf_lsm_h%ncsws, surf_usm_h%ncsws, & 2179 surf_def_v(0)%ncsws, surf_def_v(1)%ncsws, & 2180 surf_def_v(2)%ncsws, surf_def_v(3)%ncsws, & 2181 surf_lsm_v(0)%ncsws, surf_lsm_v(1)%ncsws, & 2182 surf_lsm_v(2)%ncsws, surf_lsm_v(3)%ncsws, & 2183 surf_usm_v(0)%ncsws, surf_usm_v(1)%ncsws, & 2239 2184 surf_usm_v(2)%ncsws, surf_usm_v(3)%ncsws ) 2240 2185 … … 2242 2187 !-- Prognostic equation for cloud drop concentration 2243 2188 DO k = nzb+1, nzt 2244 nc_p(k,j,i) = nc(k,j,i) + ( dt_3d * & 2245 ( tsc(2) * tend(k,j,i) + & 2246 tsc(3) * tnc_m(k,j,i) )& 2247 - tsc(5) * rdf_sc(k) & 2248 * nc(k,j,i) & 2249 ) & 2250 * MERGE( 1.0_wp, 0.0_wp, & 2251 BTEST( wall_flags_total_0(k,j,i), 0 )& 2189 nc_p(k,j,i) = nc(k,j,i) + ( dt_3d * & 2190 ( tsc(2) * tend(k,j,i) + & 2191 tsc(3) * tnc_m(k,j,i) ) & 2192 - tsc(5) * rdf_sc(k) & 2193 * nc(k,j,i) & 2194 ) & 2195 * MERGE( 1.0_wp, 0.0_wp, BTEST( wall_flags_total_0(k,j,i), 0 ) & 2252 2196 ) 2253 2197 IF ( nc_p(k,j,i) < 0.0_wp ) nc_p(k,j,i) = 0.0_wp … … 2263 2207 intermediate_timestep_count_max ) THEN 2264 2208 DO k = nzb+1, nzt 2265 tnc_m(k,j,i) = -9.5625_wp * tend(k,j,i) + & 2266 5.3125_wp * tnc_m(k,j,i) 2209 tnc_m(k,j,i) = -9.5625_wp * tend(k,j,i) + 5.3125_wp * tnc_m(k,j,i) 2267 2210 ENDDO 2268 2211 ENDIF … … 2272 2215 2273 2216 ! 2274 !-- If required, calculate prognostic equations for ice crystal mixing ratio 2275 !-- and ice crystal concentration2217 !-- If required, calculate prognostic equations for ice crystal mixing ratio and ice crystal 2218 !-- concentration. 2276 2219 IF ( microphysics_ice_phase ) THEN 2277 2220 ! … … 2281 2224 THEN 2282 2225 IF ( ws_scheme_sca ) THEN 2283 CALL advec_s_ws( advc_flags_s, i, j, qi, 'qi', flux_s_qi, &2284 diss_s_qi, flux_l_qi, diss_l_qi, &2285 i_omp_start, tn, &2286 bc_dirichlet_l .OR. bc_radiation_l, &2287 bc_dirichlet_n .OR. bc_radiation_n, &2288 bc_dirichlet_r .OR. bc_radiation_r, &2226 CALL advec_s_ws( advc_flags_s, i, j, qi, 'qi', flux_s_qi, & 2227 diss_s_qi, flux_l_qi, diss_l_qi, & 2228 i_omp_start, tn, & 2229 bc_dirichlet_l .OR. bc_radiation_l, & 2230 bc_dirichlet_n .OR. bc_radiation_n, & 2231 bc_dirichlet_r .OR. bc_radiation_r, & 2289 2232 bc_dirichlet_s .OR. bc_radiation_s ) 2290 2233 ELSE … … 2294 2237 CALL advec_s_up( i, j, qi ) 2295 2238 ENDIF 2296 CALL diffusion_s( i, j, qi, &2297 surf_def_h(0)%qisws, surf_def_h(1)%qisws, &2298 surf_def_h(2)%qisws, &2299 surf_lsm_h%qisws, surf_usm_h%qisws, &2300 surf_def_v(0)%qisws, surf_def_v(1)%qisws, &2301 surf_def_v(2)%qisws, surf_def_v(3)%qisws, &2302 surf_lsm_v(0)%qisws, surf_lsm_v(1)%qisws, &2303 surf_lsm_v(2)%qisws, surf_lsm_v(3)%qisws, &2304 surf_usm_v(0)%qisws, surf_usm_v(1)%qisws, &2239 CALL diffusion_s( i, j, qi, & 2240 surf_def_h(0)%qisws, surf_def_h(1)%qisws, & 2241 surf_def_h(2)%qisws, & 2242 surf_lsm_h%qisws, surf_usm_h%qisws, & 2243 surf_def_v(0)%qisws, surf_def_v(1)%qisws, & 2244 surf_def_v(2)%qisws, surf_def_v(3)%qisws, & 2245 surf_lsm_v(0)%qisws, surf_lsm_v(1)%qisws, & 2246 surf_lsm_v(2)%qisws, surf_lsm_v(3)%qisws, & 2247 surf_usm_v(0)%qisws, surf_usm_v(1)%qisws, & 2305 2248 surf_usm_v(2)%qisws, surf_usm_v(3)%qisws ) 2306 2249 … … 2308 2251 !-- Prognostic equation for ice crystal mixing ratio 2309 2252 DO k = nzb+1, nzt 2310 qi_p(k,j,i) = qi(k,j,i) + ( dt_3d * & 2311 ( tsc(2) * tend(k,j,i) + & 2312 tsc(3) * tqi_m(k,j,i) )& 2313 - tsc(5) * rdf_sc(k) & 2314 * qi(k,j,i) & 2315 ) & 2316 * MERGE( 1.0_wp, 0.0_wp, & 2317 BTEST( wall_flags_total_0(k,j,i), 0 )& 2253 qi_p(k,j,i) = qi(k,j,i) + ( dt_3d * & 2254 ( tsc(2) * tend(k,j,i) + & 2255 tsc(3) * tqi_m(k,j,i) ) & 2256 - tsc(5) * rdf_sc(k) & 2257 * qi(k,j,i) & 2258 ) & 2259 * MERGE( 1.0_wp, 0.0_wp, BTEST( wall_flags_total_0(k,j,i), 0 ) & 2318 2260 ) 2319 2261 IF ( qi_p(k,j,i) < 0.0_wp ) qi_p(k,j,i) = 0.0_wp … … 2329 2271 intermediate_timestep_count_max ) THEN 2330 2272 DO k = nzb+1, nzt 2331 tqi_m(k,j,i) = -9.5625_wp * tend(k,j,i) + & 2332 5.3125_wp * tqi_m(k,j,i) 2273 tqi_m(k,j,i) = -9.5625_wp * tend(k,j,i) + 5.3125_wp * tqi_m(k,j,i) 2333 2274 ENDDO 2334 2275 ENDIF … … 2340 2281 IF ( timestep_scheme(1:5) == 'runge' ) THEN 2341 2282 IF ( ws_scheme_sca ) THEN 2342 CALL advec_s_ws( advc_flags_s, i, j, ni, 'ni', flux_s_ni, &2343 diss_s_ni, flux_l_ni, diss_l_ni, &2344 i_omp_start, tn, &2345 bc_dirichlet_l .OR. bc_radiation_l, &2346 bc_dirichlet_n .OR. bc_radiation_n, &2347 bc_dirichlet_r .OR. bc_radiation_r, &2283 CALL advec_s_ws( advc_flags_s, i, j, ni, 'ni', flux_s_ni, & 2284 diss_s_ni, flux_l_ni, diss_l_ni, & 2285 i_omp_start, tn, & 2286 bc_dirichlet_l .OR. bc_radiation_l, & 2287 bc_dirichlet_n .OR. bc_radiation_n, & 2288 bc_dirichlet_r .OR. bc_radiation_r, & 2348 2289 bc_dirichlet_s .OR. bc_radiation_s ) 2349 2290 ELSE … … 2353 2294 CALL advec_s_up( i, j, ni ) 2354 2295 ENDIF 2355 CALL diffusion_s( i, j, ni, &2356 surf_def_h(0)%nisws, surf_def_h(1)%nisws, &2357 surf_def_h(2)%nisws, &2358 surf_lsm_h%nisws, surf_usm_h%nisws, &2359 surf_def_v(0)%nisws, surf_def_v(1)%nisws, &2360 surf_def_v(2)%nisws, surf_def_v(3)%nisws, &2361 surf_lsm_v(0)%nisws, surf_lsm_v(1)%nisws, &2362 surf_lsm_v(2)%nisws, surf_lsm_v(3)%nisws, &2363 surf_usm_v(0)%nisws, surf_usm_v(1)%nisws, &2296 CALL diffusion_s( i, j, ni, & 2297 surf_def_h(0)%nisws, surf_def_h(1)%nisws, & 2298 surf_def_h(2)%nisws, & 2299 surf_lsm_h%nisws, surf_usm_h%nisws, & 2300 surf_def_v(0)%nisws, surf_def_v(1)%nisws, & 2301 surf_def_v(2)%nisws, surf_def_v(3)%nisws, & 2302 surf_lsm_v(0)%nisws, surf_lsm_v(1)%nisws, & 2303 surf_lsm_v(2)%nisws, surf_lsm_v(3)%nisws, & 2304 surf_usm_v(0)%nisws, surf_usm_v(1)%nisws, & 2364 2305 surf_usm_v(2)%nisws, surf_usm_v(3)%nisws ) 2365 2306 … … 2367 2308 !-- Prognostic equation for ice crystal concentration 2368 2309 DO k = nzb+1, nzt 2369 ni_p(k,j,i) = ni(k,j,i) + ( dt_3d * & 2370 ( tsc(2) * tend(k,j,i) + & 2371 tsc(3) * tni_m(k,j,i) )& 2372 - tsc(5) * rdf_sc(k) & 2373 * ni(k,j,i) & 2374 ) & 2375 * MERGE( 1.0_wp, 0.0_wp, & 2376 BTEST( wall_flags_total_0(k,j,i), 0 )& 2310 ni_p(k,j,i) = ni(k,j,i) + ( dt_3d * & 2311 ( tsc(2) * tend(k,j,i) + & 2312 tsc(3) * tni_m(k,j,i) ) & 2313 - tsc(5) * rdf_sc(k) & 2314 * ni(k,j,i) & 2315 ) & 2316 * MERGE( 1.0_wp, 0.0_wp, BTEST( wall_flags_total_0(k,j,i), 0 ) & 2377 2317 ) 2378 2318 IF ( ni_p(k,j,i) < 0.0_wp ) ni_p(k,j,i) = 0.0_wp … … 2388 2328 intermediate_timestep_count_max ) THEN 2389 2329 DO k = nzb+1, nzt 2390 tni_m(k,j,i) = -9.5625_wp * tend(k,j,i) + & 2391 5.3125_wp * tni_m(k,j,i) 2330 tni_m(k,j,i) = -9.5625_wp * tend(k,j,i) + 5.3125_wp * tni_m(k,j,i) 2392 2331 ENDDO 2393 2332 ENDIF … … 2397 2336 2398 2337 ! 2399 !-- If required, calculate prognostic equations for rain water content 2400 !-- and rain dropconcentration2338 !-- If required, calculate prognostic equations for rain water content and rain drop 2339 !-- concentration 2401 2340 IF ( microphysics_seifert ) THEN 2402 2341 ! 2403 !-- 2342 !-- Calculate prognostic equation for rain water content 2404 2343 tend(:,j,i) = 0.0_wp 2405 2344 IF ( timestep_scheme(1:5) == 'runge' ) & 2406 2345 THEN 2407 2346 IF ( ws_scheme_sca ) THEN 2408 CALL advec_s_ws( advc_flags_s, i, j, qr, 'qr', flux_s_qr, &2409 diss_s_qr, flux_l_qr, diss_l_qr, &2410 i_omp_start, tn, &2411 bc_dirichlet_l .OR. bc_radiation_l, &2412 bc_dirichlet_n .OR. bc_radiation_n, &2413 bc_dirichlet_r .OR. bc_radiation_r, &2347 CALL advec_s_ws( advc_flags_s, i, j, qr, 'qr', flux_s_qr, & 2348 diss_s_qr, flux_l_qr, diss_l_qr, & 2349 i_omp_start, tn, & 2350 bc_dirichlet_l .OR. bc_radiation_l, & 2351 bc_dirichlet_n .OR. bc_radiation_n, & 2352 bc_dirichlet_r .OR. bc_radiation_r, & 2414 2353 bc_dirichlet_s .OR. bc_radiation_s ) 2415 2354 ELSE … … 2419 2358 CALL advec_s_up( i, j, qr ) 2420 2359 ENDIF 2421 CALL diffusion_s( i, j, qr, &2422 surf_def_h(0)%qrsws, surf_def_h(1)%qrsws, &2423 surf_def_h(2)%qrsws, &2424 surf_lsm_h%qrsws, surf_usm_h%qrsws, &2425 surf_def_v(0)%qrsws, surf_def_v(1)%qrsws, &2426 surf_def_v(2)%qrsws, surf_def_v(3)%qrsws, &2427 surf_lsm_v(0)%qrsws, surf_lsm_v(1)%qrsws, &2428 surf_lsm_v(2)%qrsws, surf_lsm_v(3)%qrsws, &2429 surf_usm_v(0)%qrsws, surf_usm_v(1)%qrsws, &2360 CALL diffusion_s( i, j, qr, & 2361 surf_def_h(0)%qrsws, surf_def_h(1)%qrsws, & 2362 surf_def_h(2)%qrsws, & 2363 surf_lsm_h%qrsws, surf_usm_h%qrsws, & 2364 surf_def_v(0)%qrsws, surf_def_v(1)%qrsws, & 2365 surf_def_v(2)%qrsws, surf_def_v(3)%qrsws, & 2366 surf_lsm_v(0)%qrsws, surf_lsm_v(1)%qrsws, & 2367 surf_lsm_v(2)%qrsws, surf_lsm_v(3)%qrsws, & 2368 surf_usm_v(0)%qrsws, surf_usm_v(1)%qrsws, & 2430 2369 surf_usm_v(2)%qrsws, surf_usm_v(3)%qrsws ) 2431 2370 … … 2433 2372 !-- Prognostic equation for rain water content 2434 2373 DO k = nzb+1, nzt 2435 qr_p(k,j,i) = qr(k,j,i) + ( dt_3d * & 2436 ( tsc(2) * tend(k,j,i) + & 2437 tsc(3) * tqr_m(k,j,i) )& 2438 - tsc(5) * rdf_sc(k) & 2439 * qr(k,j,i) & 2440 ) & 2441 * MERGE( 1.0_wp, 0.0_wp, & 2442 BTEST( wall_flags_total_0(k,j,i), 0 )& 2374 qr_p(k,j,i) = qr(k,j,i) + ( dt_3d * & 2375 ( tsc(2) * tend(k,j,i) + & 2376 tsc(3) * tqr_m(k,j,i) ) & 2377 - tsc(5) * rdf_sc(k) & 2378 * qr(k,j,i) & 2379 ) & 2380 * MERGE( 1.0_wp, 0.0_wp, BTEST( wall_flags_total_0(k,j,i), 0 ) & 2443 2381 ) 2444 2382 IF ( qr_p(k,j,i) < 0.0_wp ) qr_p(k,j,i) = 0.0_wp … … 2454 2392 intermediate_timestep_count_max ) THEN 2455 2393 DO k = nzb+1, nzt 2456 tqr_m(k,j,i) = -9.5625_wp * tend(k,j,i) + & 2457 5.3125_wp * tqr_m(k,j,i) 2394 tqr_m(k,j,i) = -9.5625_wp * tend(k,j,i) + 5.3125_wp * tqr_m(k,j,i) 2458 2395 ENDDO 2459 2396 ENDIF … … 2465 2402 IF ( timestep_scheme(1:5) == 'runge' ) THEN 2466 2403 IF ( ws_scheme_sca ) THEN 2467 CALL advec_s_ws( advc_flags_s, i, j, nr, 'nr', flux_s_nr, &2468 diss_s_nr, flux_l_nr, diss_l_nr, &2469 i_omp_start, tn, &2470 bc_dirichlet_l .OR. bc_radiation_l, &2471 bc_dirichlet_n .OR. bc_radiation_n, &2472 bc_dirichlet_r .OR. bc_radiation_r, &2404 CALL advec_s_ws( advc_flags_s, i, j, nr, 'nr', flux_s_nr, & 2405 diss_s_nr, flux_l_nr, diss_l_nr, & 2406 i_omp_start, tn, & 2407 bc_dirichlet_l .OR. bc_radiation_l, & 2408 bc_dirichlet_n .OR. bc_radiation_n, & 2409 bc_dirichlet_r .OR. bc_radiation_r, & 2473 2410 bc_dirichlet_s .OR. bc_radiation_s ) 2474 2411 ELSE … … 2478 2415 CALL advec_s_up( i, j, nr ) 2479 2416 ENDIF 2480 CALL diffusion_s( i, j, nr, &2481 surf_def_h(0)%nrsws, surf_def_h(1)%nrsws, &2482 surf_def_h(2)%nrsws, &2483 surf_lsm_h%nrsws, surf_usm_h%nrsws, &2484 surf_def_v(0)%nrsws, surf_def_v(1)%nrsws, &2485 surf_def_v(2)%nrsws, surf_def_v(3)%nrsws, &2486 surf_lsm_v(0)%nrsws, surf_lsm_v(1)%nrsws, &2487 surf_lsm_v(2)%nrsws, surf_lsm_v(3)%nrsws, &2488 surf_usm_v(0)%nrsws, surf_usm_v(1)%nrsws, &2417 CALL diffusion_s( i, j, nr, & 2418 surf_def_h(0)%nrsws, surf_def_h(1)%nrsws, & 2419 surf_def_h(2)%nrsws, & 2420 surf_lsm_h%nrsws, surf_usm_h%nrsws, & 2421 surf_def_v(0)%nrsws, surf_def_v(1)%nrsws, & 2422 surf_def_v(2)%nrsws, surf_def_v(3)%nrsws, & 2423 surf_lsm_v(0)%nrsws, surf_lsm_v(1)%nrsws, & 2424 surf_lsm_v(2)%nrsws, surf_lsm_v(3)%nrsws, & 2425 surf_usm_v(0)%nrsws, surf_usm_v(1)%nrsws, & 2489 2426 surf_usm_v(2)%nrsws, surf_usm_v(3)%nrsws ) 2490 2427 … … 2492 2429 !-- Prognostic equation for rain drop concentration 2493 2430 DO k = nzb+1, nzt 2494 nr_p(k,j,i) = nr(k,j,i) + ( dt_3d * & 2495 ( tsc(2) * tend(k,j,i) + & 2496 tsc(3) * tnr_m(k,j,i) )& 2497 - tsc(5) * rdf_sc(k) & 2498 * nr(k,j,i) & 2499 ) & 2500 * MERGE( 1.0_wp, 0.0_wp, & 2501 BTEST( wall_flags_total_0(k,j,i), 0 )& 2431 nr_p(k,j,i) = nr(k,j,i) + ( dt_3d * & 2432 ( tsc(2) * tend(k,j,i) + & 2433 tsc(3) * tnr_m(k,j,i) ) & 2434 - tsc(5) * rdf_sc(k) & 2435 * nr(k,j,i) & 2436 ) & 2437 * MERGE( 1.0_wp, 0.0_wp, BTEST( wall_flags_total_0(k,j,i), 0 ) & 2502 2438 ) 2503 2439 IF ( nr_p(k,j,i) < 0.0_wp ) nr_p(k,j,i) = 0.0_wp … … 2513 2449 intermediate_timestep_count_max ) THEN 2514 2450 DO k = nzb+1, nzt 2515 tnr_m(k,j,i) = -9.5625_wp * tend(k,j,i) + & 2516 5.3125_wp * tnr_m(k,j,i) 2451 tnr_m(k,j,i) = -9.5625_wp * tend(k,j,i) + 5.3125_wp * tnr_m(k,j,i) 2517 2452 ENDDO 2518 2453 ENDIF … … 2524 2459 2525 2460 2526 !------------------------------------------------------------------------------ !2461 !--------------------------------------------------------------------------------------------------! 2527 2462 ! Description: 2528 2463 ! ------------ 2529 2464 !> Swapping of timelevels 2530 !------------------------------------------------------------------------------ !2465 !--------------------------------------------------------------------------------------------------! 2531 2466 SUBROUTINE bcm_swap_timelevel ( mod_count ) 2532 2467 … … 2577 2512 2578 2513 2579 !------------------------------------------------------------------------------ !2514 !--------------------------------------------------------------------------------------------------! 2580 2515 ! Description: Boundary conditions of the bulk cloud module variables 2581 !------------------------------------------------------------------------------ !2516 !--------------------------------------------------------------------------------------------------! 2582 2517 SUBROUTINE bcm_boundary_conditions 2583 2518 … … 2592 2527 IF ( microphysics_morrison ) THEN 2593 2528 ! 2594 !-- Surface conditions cloud water (Dirichlet) 2595 !-- Run loop over all non-natural and natural walls. Note, in wall-datatype 2596 !-- the k coordinate belongs to the atmospheric grid point, therefore, set2597 !-- qr_p and nr_p at upward (k-1) and downward-facing (k+1) walls2529 !-- Surface conditions cloud water (Dirichlet). 2530 !-- Run loop over all non-natural and natural walls. Note, in wall-datatype the k coordinate 2531 !-- belongs to the atmospheric grid point, therefore, set qr_p and nr_p at upward (k-1) and 2532 !-- downward-facing (k+1) walls. 2598 2533 DO l = 0, 1 2599 2534 !$OMP PARALLEL DO PRIVATE( i, j, k ) … … 2615 2550 IF ( microphysics_ice_phase ) THEN 2616 2551 ! 2617 !-- Surface conditions ice crysral (Dirichlet) 2618 !-- Run loop over all non-natural and natural walls. Note, in wall-datatype 2619 !-- the k coordinate belongs to the atmospheric grid point, therefore, set2620 !-- qr_p and nr_p at upward (k-1) anddownward-facing (k+1) walls2552 !-- Surface conditions ice crysral (Dirichlet). 2553 !-- Run loop over all non-natural and natural walls. Note, in wall-datatype the k coordinate 2554 !-- belongs to the atmospheric grid point, therefore, set qr_p and nr_p at upward (k-1) and 2555 !-- downward-facing (k+1) walls 2621 2556 DO l = 0, 1 2622 2557 !$OMP PARALLEL DO PRIVATE( i, j, k ) … … 2639 2574 IF ( microphysics_seifert ) THEN 2640 2575 ! 2641 !-- Surface conditions rain water (Dirichlet) 2642 !-- Run loop over all non-natural and natural walls. Note, in wall-datatype 2643 !-- the k coordinate belongs to the atmospheric grid point, therefore, set2644 !-- qr_p and nr_p at upward (k-1) anddownward-facing (k+1) walls2576 !-- Surface conditions rain water (Dirichlet). 2577 !-- Run loop over all non-natural and natural walls. Note, in wall-datatype the k coordinate 2578 !-- belongs to the atmospheric grid point, therefore, set qr_p and nr_p at upward (k-1) and 2579 !-- downward-facing (k+1) walls 2645 2580 DO l = 0, 1 2646 2581 !$OMP PARALLEL DO PRIVATE( i, j, k ) … … 2662 2597 ! 2663 2598 !-- Lateral boundary conditions for scalar quantities at the outflow. 2664 !-- Lateral oundary conditions for TKE and dissipation are set 2665 !-- in tcm_boundary_conds. 2599 !-- Lateral oundary conditions for TKE and dissipation are set in tcm_boundary_conds. 2666 2600 IF ( bc_radiation_s ) THEN 2667 2601 IF ( microphysics_morrison ) THEN … … 2720 2654 END SUBROUTINE bcm_boundary_conditions 2721 2655 2722 !------------------------------------------------------------------------------ !2656 !--------------------------------------------------------------------------------------------------! 2723 2657 ! 2724 2658 ! Description: 2725 2659 ! ------------ 2726 2660 !> Subroutine for averaging 3D data 2727 !------------------------------------------------------------------------------ !2661 !--------------------------------------------------------------------------------------------------! 2728 2662 SUBROUTINE bcm_3d_data_averaging( mode, variable ) 2729 2663 2730 USE control_parameters, &2664 USE control_parameters, & 2731 2665 ONLY: average_count_3d 2732 2666 … … 2790 2724 2791 2725 CASE ( 'nc' ) 2792 IF ( ALLOCATED( nc_av ) ) THEN2726 IF ( ALLOCATED( nc_av ) ) THEN 2793 2727 DO i = nxlg, nxrg 2794 2728 DO j = nysg, nyng … … 2801 2735 2802 2736 CASE ( 'nr' ) 2803 IF ( ALLOCATED( nr_av ) ) THEN2737 IF ( ALLOCATED( nr_av ) ) THEN 2804 2738 DO i = nxlg, nxrg 2805 2739 DO j = nysg, nyng … … 2812 2746 2813 2747 CASE ( 'prr' ) 2814 IF ( ALLOCATED( prr_av ) ) THEN2748 IF ( ALLOCATED( prr_av ) ) THEN 2815 2749 DO i = nxlg, nxrg 2816 2750 DO j = nysg, nyng … … 2823 2757 2824 2758 CASE ( 'qc' ) 2825 IF ( ALLOCATED( qc_av ) ) THEN2759 IF ( ALLOCATED( qc_av ) ) THEN 2826 2760 DO i = nxlg, nxrg 2827 2761 DO j = nysg, nyng … … 2834 2768 2835 2769 CASE ( 'ql' ) 2836 IF ( ALLOCATED( ql_av ) ) THEN2770 IF ( ALLOCATED( ql_av ) ) THEN 2837 2771 DO i = nxlg, nxrg 2838 2772 DO j = nysg, nyng … … 2845 2779 2846 2780 CASE ( 'qr' ) 2847 IF ( ALLOCATED( qr_av ) ) THEN2781 IF ( ALLOCATED( qr_av ) ) THEN 2848 2782 DO i = nxlg, nxrg 2849 2783 DO j = nysg, nyng … … 2865 2799 2866 2800 CASE ( 'nc' ) 2867 IF ( ALLOCATED( nc_av ) ) THEN2801 IF ( ALLOCATED( nc_av ) ) THEN 2868 2802 DO i = nxlg, nxrg 2869 2803 DO j = nysg, nyng 2870 2804 DO k = nzb, nzt+1 2871 nc_av(k,j,i) = nc_av(k,j,i) / REAL( average_count_3d, KIND =wp )2805 nc_av(k,j,i) = nc_av(k,j,i) / REAL( average_count_3d, KIND = wp ) 2872 2806 ENDDO 2873 2807 ENDDO … … 2876 2810 2877 2811 CASE ( 'nr' ) 2878 IF ( ALLOCATED( nr_av ) ) THEN2812 IF ( ALLOCATED( nr_av ) ) THEN 2879 2813 DO i = nxlg, nxrg 2880 2814 DO j = nysg, nyng 2881 2815 DO k = nzb, nzt+1 2882 nr_av(k,j,i) = nr_av(k,j,i) / REAL( average_count_3d, KIND =wp )2816 nr_av(k,j,i) = nr_av(k,j,i) / REAL( average_count_3d, KIND = wp ) 2883 2817 ENDDO 2884 2818 ENDDO … … 2887 2821 2888 2822 CASE ( 'prr' ) 2889 IF ( ALLOCATED( prr_av ) ) THEN2823 IF ( ALLOCATED( prr_av ) ) THEN 2890 2824 DO i = nxlg, nxrg 2891 2825 DO j = nysg, nyng 2892 2826 DO k = nzb, nzt+1 2893 prr_av(k,j,i) = prr_av(k,j,i) / REAL( average_count_3d, KIND =wp )2827 prr_av(k,j,i) = prr_av(k,j,i) / REAL( average_count_3d, KIND = wp ) 2894 2828 ENDDO 2895 2829 ENDDO … … 2898 2832 2899 2833 CASE ( 'qc' ) 2900 IF ( ALLOCATED( qc_av ) ) THEN2834 IF ( ALLOCATED( qc_av ) ) THEN 2901 2835 DO i = nxlg, nxrg 2902 2836 DO j = nysg, nyng 2903 2837 DO k = nzb, nzt+1 2904 qc_av(k,j,i) = qc_av(k,j,i) / REAL( average_count_3d, KIND =wp )2838 qc_av(k,j,i) = qc_av(k,j,i) / REAL( average_count_3d, KIND = wp ) 2905 2839 ENDDO 2906 2840 ENDDO … … 2909 2843 2910 2844 CASE ( 'ql' ) 2911 IF ( ALLOCATED( ql_av ) ) THEN2845 IF ( ALLOCATED( ql_av ) ) THEN 2912 2846 DO i = nxlg, nxrg 2913 2847 DO j = nysg, nyng 2914 2848 DO k = nzb, nzt+1 2915 ql_av(k,j,i) = ql_av(k,j,i) / REAL( average_count_3d, KIND =wp )2849 ql_av(k,j,i) = ql_av(k,j,i) / REAL( average_count_3d, KIND = wp ) 2916 2850 ENDDO 2917 2851 ENDDO … … 2920 2854 2921 2855 CASE ( 'qr' ) 2922 IF ( ALLOCATED( qr_av ) ) THEN2856 IF ( ALLOCATED( qr_av ) ) THEN 2923 2857 DO i = nxlg, nxrg 2924 2858 DO j = nysg, nyng 2925 2859 DO k = nzb, nzt+1 2926 qr_av(k,j,i) = qr_av(k,j,i) / REAL( average_count_3d, KIND =wp )2860 qr_av(k,j,i) = qr_av(k,j,i) / REAL( average_count_3d, KIND = wp ) 2927 2861 ENDDO 2928 2862 ENDDO … … 2940 2874 2941 2875 2942 !------------------------------------------------------------------------------ !2876 !--------------------------------------------------------------------------------------------------! 2943 2877 ! Description: 2944 2878 ! ------------ 2945 2879 !> Define 2D output variables. 2946 !------------------------------------------------------------------------------! 2947 SUBROUTINE bcm_data_output_2d( av, variable, found, grid, mode, local_pf, & 2948 two_d, nzb_do, nzt_do ) 2880 !--------------------------------------------------------------------------------------------------! 2881 SUBROUTINE bcm_data_output_2d( av, variable, found, grid, mode, local_pf, two_d, nzb_do, nzt_do ) 2949 2882 2950 2883 … … 2952 2885 2953 2886 CHARACTER (LEN=*), INTENT(INOUT) :: grid !< name of vertical grid 2954 CHARACTER (LEN=*), INTENT(IN) :: mode !< either 'xy', 'xz' or 'yz'2955 CHARACTER (LEN=*), INTENT(IN) :: variable !< name of variable2887 CHARACTER (LEN=*), INTENT(IN) :: mode !< either 'xy', 'xz' or 'yz' 2888 CHARACTER (LEN=*), INTENT(IN) :: variable !< name of variable 2956 2889 2957 2890 INTEGER(iwp), INTENT(IN) :: av !< flag for (non-)average output … … 2960 2893 2961 2894 INTEGER(iwp) :: flag_nr !< number of masking flag 2962 2963 2895 INTEGER(iwp) :: i !< loop index along x-direction 2964 2896 INTEGER(iwp) :: j !< loop index along y-direction 2965 2897 INTEGER(iwp) :: k !< loop index along z-direction 2966 2898 2899 LOGICAL :: resorted !< flag if output is already resorted 2900 2967 2901 LOGICAL, INTENT(INOUT) :: found !< flag if output variable is found 2968 LOGICAL, INTENT(INOUT) :: two_d !< flag parameter that indicates 2D variables (horizontal cross sections) 2969 LOGICAL :: resorted !< flag if output is already resorted 2902 LOGICAL, INTENT(INOUT) :: two_d !< flag parameter that indicates 2D variables 2903 !< (horizontal cross sections) 2904 2970 2905 2971 2906 REAL(wp), PARAMETER :: fill_value = -999.0_wp !< value for the _FillValue attribute 2972 2907 2973 2908 REAL(wp), DIMENSION(nxl:nxr,nys:nyn,nzb_do:nzt_do), INTENT(INOUT) :: local_pf !< local 2974 !< array to which output data is resorted to2909 !< array to which output data is resorted to 2975 2910 2976 2911 REAL(wp), DIMENSION(:,:,:), POINTER :: to_be_resorted !< points to selected output variable … … 2988 2923 to_be_resorted => nc 2989 2924 ELSE 2990 IF ( .NOT. ALLOCATED( nc_av ) ) THEN2925 IF ( .NOT. ALLOCATED( nc_av ) ) THEN 2991 2926 ALLOCATE( nc_av(nzb:nzt+1,nysg:nyng,nxlg:nxrg) ) 2992 2927 nc_av = REAL( fill_value, KIND = wp ) … … 3000 2935 to_be_resorted => ni 3001 2936 ELSE 3002 IF ( .NOT. ALLOCATED( ni_av ) ) THEN2937 IF ( .NOT. ALLOCATED( ni_av ) ) THEN 3003 2938 ALLOCATE( ni_av(nzb:nzt+1,nysg:nyng,nxlg:nxrg) ) 3004 2939 ni_av = REAL( fill_value, KIND = wp ) … … 3012 2947 to_be_resorted => nr 3013 2948 ELSE 3014 IF ( .NOT. ALLOCATED( nr_av ) ) THEN2949 IF ( .NOT. ALLOCATED( nr_av ) ) THEN 3015 2950 ALLOCATE( nr_av(nzb:nzt+1,nysg:nyng,nxlg:nxrg) ) 3016 2951 nr_av = REAL( fill_value, KIND = wp ) … … 3043 2978 ENDDO 3044 2979 ELSE 3045 IF ( .NOT. ALLOCATED( prr_av ) ) THEN2980 IF ( .NOT. ALLOCATED( prr_av ) ) THEN 3046 2981 ALLOCATE( prr_av(nzb:nzt+1,nysg:nyng,nxlg:nxrg) ) 3047 2982 prr_av = REAL( fill_value, KIND = wp ) … … 3063 2998 to_be_resorted => qc 3064 2999 ELSE 3065 IF ( .NOT. ALLOCATED( qc_av ) ) THEN3000 IF ( .NOT. ALLOCATED( qc_av ) ) THEN 3066 3001 ALLOCATE( qc_av(nzb:nzt+1,nysg:nyng,nxlg:nxrg) ) 3067 3002 qc_av = REAL( fill_value, KIND = wp ) … … 3075 3010 to_be_resorted => qi 3076 3011 ELSE 3077 IF ( .NOT. ALLOCATED( qi_av ) ) THEN3012 IF ( .NOT. ALLOCATED( qi_av ) ) THEN 3078 3013 ALLOCATE( qi_av(nzb:nzt+1,nysg:nyng,nxlg:nxrg) ) 3079 3014 qi_av = REAL( fill_value, KIND = wp ) … … 3087 3022 to_be_resorted => ql 3088 3023 ELSE 3089 IF ( .NOT. ALLOCATED( ql_av ) ) THEN3024 IF ( .NOT. ALLOCATED( ql_av ) ) THEN 3090 3025 ALLOCATE( ql_av(nzb:nzt+1,nysg:nyng,nxlg:nxrg) ) 3091 3026 ql_av = REAL( fill_value, KIND = wp ) … … 3099 3034 to_be_resorted => qr 3100 3035 ELSE 3101 IF ( .NOT. ALLOCATED( qr_av ) ) THEN3036 IF ( .NOT. ALLOCATED( qr_av ) ) THEN 3102 3037 ALLOCATE( qr_av(nzb:nzt+1,nysg:nyng,nxlg:nxrg) ) 3103 3038 qr_av = REAL( fill_value, KIND = wp ) … … 3117 3052 DO j = nys, nyn 3118 3053 DO k = nzb_do, nzt_do 3119 local_pf(i,j,k) = MERGE( &3120 to_be_resorted(k,j,i),&3121 REAL( fill_value, KIND = wp ),&3122 BTEST( wall_flags_total_0(k,j,i), flag_nr )&3123 )3054 local_pf(i,j,k) = MERGE( & 3055 to_be_resorted(k,j,i), & 3056 REAL( fill_value, KIND = wp ), & 3057 BTEST( wall_flags_total_0(k,j,i), flag_nr ) & 3058 ) 3124 3059 ENDDO 3125 3060 ENDDO … … 3130 3065 3131 3066 3132 !------------------------------------------------------------------------------ !3067 !--------------------------------------------------------------------------------------------------! 3133 3068 ! Description: 3134 3069 ! ------------ 3135 3070 !> Define 3D output variables. 3136 !------------------------------------------------------------------------------ !3071 !--------------------------------------------------------------------------------------------------! 3137 3072 SUBROUTINE bcm_data_output_3d( av, variable, found, local_pf, nzb_do, nzt_do ) 3138 3073 … … 3142 3077 CHARACTER (LEN=*), INTENT(IN) :: variable !< name of variable 3143 3078 3144 INTEGER(iwp), INTENT(IN) :: av !< flag for (non-)average output 3145 INTEGER(iwp), INTENT(IN) :: nzb_do !< lower limit of the data output (usually 0) 3146 INTEGER(iwp), INTENT(IN) :: nzt_do !< vertical upper limit of the data output (usually nz_do3d) 3079 INTEGER(iwp), INTENT(IN) :: av !< flag for (non-)average output 3080 INTEGER(iwp), INTENT(IN) :: nzb_do !< lower limit of the data output (usually 0) 3081 INTEGER(iwp), INTENT(IN) :: nzt_do !< vertical upper limit of the data output 3082 !< (usually nz_do3d) 3147 3083 3148 3084 INTEGER(iwp) :: flag_nr !< number of masking flag 3149 3150 3085 INTEGER(iwp) :: i !< loop index along x-direction 3151 3086 INTEGER(iwp) :: j !< loop index along y-direction 3152 3087 INTEGER(iwp) :: k !< loop index along z-direction 3153 3088 3089 LOGICAL :: resorted !< flag if output is already resorted 3090 3154 3091 LOGICAL, INTENT(INOUT) :: found !< flag if output variable is found 3155 LOGICAL :: resorted !< flag if output is already resorted3156 3092 3157 3093 REAL(wp) :: fill_value = -999.0_wp !< value for the _FillValue attribute 3158 3094 3159 3095 REAL(sp), DIMENSION(nxl:nxr,nys:nyn,nzb_do:nzt_do), INTENT(INOUT) :: local_pf !< local 3160 !< array to which output data is resorted to3096 !< array to which output data is resorted to 3161 3097 3162 3098 REAL(wp), DIMENSION(:,:,:), POINTER :: to_be_resorted !< points to selected output variable … … 3185 3121 to_be_resorted => ni 3186 3122 ELSE 3187 IF ( .NOT. ALLOCATED( ni_av ) ) THEN3123 IF ( .NOT. ALLOCATED( ni_av ) ) THEN 3188 3124 ALLOCATE( ni_av(nzb:nzt+1,nysg:nyng,nxlg:nxrg) ) 3189 3125 ni_av = REAL( fill_value, KIND = wp ) … … 3196 3132 to_be_resorted => nr 3197 3133 ELSE 3198 IF ( .NOT. ALLOCATED( nr_av ) ) THEN3134 IF ( .NOT. ALLOCATED( nr_av ) ) THEN 3199 3135 ALLOCATE( nr_av(nzb:nzt+1,nysg:nyng,nxlg:nxrg) ) 3200 3136 nr_av = REAL( fill_value, KIND = wp ) … … 3213 3149 ENDDO 3214 3150 ELSE 3215 IF ( .NOT. ALLOCATED( prr_av ) ) THEN3151 IF ( .NOT. ALLOCATED( prr_av ) ) THEN 3216 3152 ALLOCATE( prr_av(nzb:nzt+1,nysg:nyng,nxlg:nxrg) ) 3217 3153 prr_av = REAL( fill_value, KIND = wp ) … … 3231 3167 to_be_resorted => qc 3232 3168 ELSE 3233 IF ( .NOT. ALLOCATED( qc_av ) ) THEN3169 IF ( .NOT. ALLOCATED( qc_av ) ) THEN 3234 3170 ALLOCATE( qc_av(nzb:nzt+1,nysg:nyng,nxlg:nxrg) ) 3235 3171 qc_av = REAL( fill_value, KIND = wp ) … … 3242 3178 to_be_resorted => qi 3243 3179 ELSE 3244 IF ( .NOT. ALLOCATED( qi_av ) ) THEN3180 IF ( .NOT. ALLOCATED( qi_av ) ) THEN 3245 3181 ALLOCATE( qi_av(nzb:nzt+1,nysg:nyng,nxlg:nxrg) ) 3246 3182 qi_av = REAL( fill_value, KIND = wp ) … … 3253 3189 to_be_resorted => ql 3254 3190 ELSE 3255 IF ( .NOT. ALLOCATED( ql_av ) ) THEN3191 IF ( .NOT. ALLOCATED( ql_av ) ) THEN 3256 3192 ALLOCATE( ql_av(nzb:nzt+1,nysg:nyng,nxlg:nxrg) ) 3257 3193 ql_av = REAL( fill_value, KIND = wp ) … … 3264 3200 to_be_resorted => qr 3265 3201 ELSE 3266 IF ( .NOT. ALLOCATED( qr_av ) ) THEN3202 IF ( .NOT. ALLOCATED( qr_av ) ) THEN 3267 3203 ALLOCATE( qr_av(nzb:nzt+1,nysg:nyng,nxlg:nxrg) ) 3268 3204 qr_av = REAL( fill_value, KIND = wp ) … … 3281 3217 DO j = nys, nyn 3282 3218 DO k = nzb_do, nzt_do 3283 local_pf(i,j,k) = MERGE( &3284 to_be_resorted(k,j,i), &3285 REAL( fill_value, KIND = wp ), &3286 BTEST( wall_flags_total_0(k,j,i), flag_nr ) &3287 )3219 local_pf(i,j,k) = MERGE( & 3220 to_be_resorted(k,j,i), & 3221 REAL( fill_value, KIND = wp ), & 3222 BTEST( wall_flags_total_0(k,j,i), flag_nr ) & 3223 ) 3288 3224 ENDDO 3289 3225 ENDDO … … 3294 3230 3295 3231 3296 !------------------------------------------------------------------------------ !3232 !--------------------------------------------------------------------------------------------------! 3297 3233 ! Description: 3298 3234 ! ------------ 3299 3235 !> Read module-specific global restart data (Fortran binary format). 3300 !------------------------------------------------------------------------------ !3236 !--------------------------------------------------------------------------------------------------! 3301 3237 SUBROUTINE bcm_rrd_global_ftn( found ) 3302 3238 3303 3239 3304 USE control_parameters, &3240 USE control_parameters, & 3305 3241 ONLY: length, restart_string 3306 3242 … … 3379 3315 3380 3316 3381 !------------------------------------------------------------------------------ !3317 !--------------------------------------------------------------------------------------------------! 3382 3318 ! Description: 3383 3319 ! ------------ 3384 3320 !> Read module-specific global restart data (MPI-IO). 3385 !------------------------------------------------------------------------------ !3321 !--------------------------------------------------------------------------------------------------! 3386 3322 SUBROUTINE bcm_rrd_global_mpi 3387 3323 … … 3410 3346 3411 3347 3412 !------------------------------------------------------------------------------ !3348 !--------------------------------------------------------------------------------------------------! 3413 3349 ! Description: 3414 3350 ! ------------ 3415 3351 !> Read module-specific local restart data arrays (Fortran binary format). 3416 !------------------------------------------------------------------------------! 3417 SUBROUTINE bcm_rrd_local_ftn( k, nxlf, nxlc, nxl_on_file, nxrf, nxrc, & 3418 nxr_on_file, nynf, nync, nyn_on_file, nysf, & 3419 nysc, nys_on_file, tmp_2d, tmp_3d, found ) 3352 !--------------------------------------------------------------------------------------------------! 3353 SUBROUTINE bcm_rrd_local_ftn( k, nxlf, nxlc, nxl_on_file, nxrf, nxrc, nxr_on_file, nynf, nync, & 3354 nyn_on_file, nysf, nysc, nys_on_file, tmp_2d, tmp_3d, found ) 3420 3355 3421 3356 … … 3446 3381 3447 3382 REAL(wp), DIMENSION(nys_on_file-nbgp:nyn_on_file+nbgp,nxl_on_file-nbgp:nxr_on_file+nbgp) :: tmp_2d !< 3383 3448 3384 REAL(wp), DIMENSION(nzb:nzt+1,nys_on_file-nbgp:nyn_on_file+nbgp,nxl_on_file-nbgp:nxr_on_file+nbgp) :: tmp_3d !< 3449 3385 … … 3455 3391 CASE ( 'nc' ) 3456 3392 IF ( k == 1 ) READ ( 13 ) tmp_3d 3457 nc(:,nysc-nbgp:nync+nbgp,nxlc-nbgp:nxrc+nbgp) = &3393 nc(:,nysc-nbgp:nync+nbgp,nxlc-nbgp:nxrc+nbgp) = & 3458 3394 tmp_3d(:,nysf-nbgp:nynf+nbgp,nxlf-nbgp:nxrf+nbgp) 3459 3395 … … 3463 3399 ENDIF 3464 3400 IF ( k == 1 ) READ ( 13 ) tmp_3d 3465 nc_av(:,nysc-nbgp:nync+nbgp,nxlc-nbgp:nxrc+nbgp) = &3401 nc_av(:,nysc-nbgp:nync+nbgp,nxlc-nbgp:nxrc+nbgp) = & 3466 3402 tmp_3d(:,nysf-nbgp:nynf+nbgp,nxlf-nbgp:nxrf+nbgp) 3467 3403 3468 3404 CASE ( 'ni' ) 3469 3405 IF ( k == 1 ) READ ( 13 ) tmp_3d 3470 ni(:,nysc-nbgp:nync+nbgp,nxlc-nbgp:nxrc+nbgp) = &3406 ni(:,nysc-nbgp:nync+nbgp,nxlc-nbgp:nxrc+nbgp) = & 3471 3407 tmp_3d(:,nysf-nbgp:nynf+nbgp,nxlf-nbgp:nxrf+nbgp) 3472 3408 … … 3476 3412 ENDIF 3477 3413 IF ( k == 1 ) READ ( 13 ) tmp_3d 3478 ni_av(:,nysc-nbgp:nync+nbgp,nxlc-nbgp:nxrc+nbgp) = &3414 ni_av(:,nysc-nbgp:nync+nbgp,nxlc-nbgp:nxrc+nbgp) = & 3479 3415 tmp_3d(:,nysf-nbgp:nynf+nbgp,nxlf-nbgp:nxrf+nbgp) 3480 3416 3481 3417 CASE ( 'nr' ) 3482 3418 IF ( k == 1 ) READ ( 13 ) tmp_3d 3483 nr(:,nysc-nbgp:nync+nbgp,nxlc-nbgp:nxrc+nbgp) = &3419 nr(:,nysc-nbgp:nync+nbgp,nxlc-nbgp:nxrc+nbgp) = & 3484 3420 tmp_3d(:,nysf-nbgp:nynf+nbgp,nxlf-nbgp:nxrf+nbgp) 3485 3421 … … 3489 3425 ENDIF 3490 3426 IF ( k == 1 ) READ ( 13 ) tmp_3d 3491 nr_av(:,nysc-nbgp:nync+nbgp,nxlc-nbgp:nxrc+nbgp) = &3427 nr_av(:,nysc-nbgp:nync+nbgp,nxlc-nbgp:nxrc+nbgp) = & 3492 3428 tmp_3d(:,nysf-nbgp:nynf+nbgp,nxlf-nbgp:nxrf+nbgp) 3493 3429 3494 3430 CASE ( 'precipitation_amount' ) 3495 3431 IF ( k == 1 ) READ ( 13 ) tmp_2d 3496 precipitation_amount(nysc-nbgp:nync+nbgp, & 3497 nxlc-nbgp:nxrc+nbgp) = & 3498 tmp_2d(nysf-nbgp:nynf+nbgp,nxlf-nbgp:nxrf+nbgp) 3432 precipitation_amount(nysc-nbgp:nync+nbgp, nxlc-nbgp:nxrc+nbgp) = & 3433 tmp_2d(nysf-nbgp:nynf+nbgp,nxlf-nbgp:nxrf+nbgp) 3499 3434 3500 3435 CASE ( 'prr' ) … … 3503 3438 ENDIF 3504 3439 IF ( k == 1 ) READ ( 13 ) tmp_3d 3505 prr(:,nysc-nbgp:nync+nbgp,nxlc-nbgp:nxrc+nbgp) = &3440 prr(:,nysc-nbgp:nync+nbgp,nxlc-nbgp:nxrc+nbgp) = & 3506 3441 tmp_3d(:,nysf-nbgp:nynf+nbgp,nxlf-nbgp:nxrf+nbgp) 3507 3442 … … 3511 3446 ENDIF 3512 3447 IF ( k == 1 ) READ ( 13 ) tmp_3d 3513 prr_av(:,nysc-nbgp:nync+nbgp,nxlc-nbgp:nxrc+nbgp) = &3448 prr_av(:,nysc-nbgp:nync+nbgp,nxlc-nbgp:nxrc+nbgp) = & 3514 3449 tmp_3d(:,nysf-nbgp:nynf+nbgp,nxlf-nbgp:nxrf+nbgp) 3515 3450 3516 3451 CASE ( 'qc' ) 3517 3452 IF ( k == 1 ) READ ( 13 ) tmp_3d 3518 qc(:,nysc-nbgp:nync+nbgp,nxlc-nbgp:nxrc+nbgp) = &3453 qc(:,nysc-nbgp:nync+nbgp,nxlc-nbgp:nxrc+nbgp) = & 3519 3454 tmp_3d(:,nysf-nbgp:nynf+nbgp,nxlf-nbgp:nxrf+nbgp) 3520 3455 3521 3456 CASE ( 'qi' ) 3522 3457 IF ( k == 1 ) READ ( 13 ) tmp_3d 3523 qi(:,nysc-nbgp:nync+nbgp,nxlc-nbgp:nxrc+nbgp) = &3458 qi(:,nysc-nbgp:nync+nbgp,nxlc-nbgp:nxrc+nbgp) = & 3524 3459 tmp_3d(:,nysf-nbgp:nynf+nbgp,nxlf-nbgp:nxrf+nbgp) 3525 3460 … … 3529 3464 ENDIF 3530 3465 IF ( k == 1 ) READ ( 13 ) tmp_3d 3531 qi_av(:,nysc-nbgp:nync+nbgp,nxlc-nbgp:nxrc+nbgp) = &3466 qi_av(:,nysc-nbgp:nync+nbgp,nxlc-nbgp:nxrc+nbgp) = & 3532 3467 tmp_3d(:,nysf-nbgp:nynf+nbgp,nxlf-nbgp:nxrf+nbgp) 3533 3468 … … 3537 3472 ENDIF 3538 3473 IF ( k == 1 ) READ ( 13 ) tmp_3d 3539 qc_av(:,nysc-nbgp:nync+nbgp,nxlc-nbgp:nxrc+nbgp) = &3474 qc_av(:,nysc-nbgp:nync+nbgp,nxlc-nbgp:nxrc+nbgp) = & 3540 3475 tmp_3d(:,nysf-nbgp:nynf+nbgp,nxlf-nbgp:nxrf+nbgp) 3541 3476 3542 3477 CASE ( 'ql' ) 3543 3478 IF ( k == 1 ) READ ( 13 ) tmp_3d 3544 ql(:,nysc-nbgp:nync+nbgp,nxlc-nbgp:nxrc+nbgp) = &3479 ql(:,nysc-nbgp:nync+nbgp,nxlc-nbgp:nxrc+nbgp) = & 3545 3480 tmp_3d(:,nysf-nbgp:nynf+nbgp,nxlf-nbgp:nxrf+nbgp) 3546 3481 … … 3550 3485 ENDIF 3551 3486 IF ( k == 1 ) READ ( 13 ) tmp_3d 3552 ql_av(:,nysc-nbgp:nync+nbgp,nxlc-nbgp:nxrc+nbgp) = &3487 ql_av(:,nysc-nbgp:nync+nbgp,nxlc-nbgp:nxrc+nbgp) = & 3553 3488 tmp_3d(:,nysf-nbgp:nynf+nbgp,nxlf-nbgp:nxrf+nbgp) 3554 3489 3555 3490 CASE ( 'qr' ) 3556 3491 IF ( k == 1 ) READ ( 13 ) tmp_3d 3557 qr(:,nysc-nbgp:nync+nbgp,nxlc-nbgp:nxrc+nbgp) = &3492 qr(:,nysc-nbgp:nync+nbgp,nxlc-nbgp:nxrc+nbgp) = & 3558 3493 tmp_3d(:,nysf-nbgp:nynf+nbgp,nxlf-nbgp:nxrf+nbgp) 3559 3494 … … 3563 3498 ENDIF 3564 3499 IF ( k == 1 ) READ ( 13 ) tmp_3d 3565 qr_av(:,nysc-nbgp:nync+nbgp,nxlc-nbgp:nxrc+nbgp) = &3500 qr_av(:,nysc-nbgp:nync+nbgp,nxlc-nbgp:nxrc+nbgp) = & 3566 3501 tmp_3d(:,nysf-nbgp:nynf+nbgp,nxlf-nbgp:nxrf+nbgp) 3567 3502 ! … … 3576 3511 3577 3512 3578 !------------------------------------------------------------------------------ !3513 !--------------------------------------------------------------------------------------------------! 3579 3514 ! Description: 3580 3515 ! ------------ 3581 3516 !> Read module-specific local restart data arrays (MPI-IO). 3582 !------------------------------------------------------------------------------ !3517 !--------------------------------------------------------------------------------------------------! 3583 3518 SUBROUTINE bcm_rrd_local_mpi 3584 3519 … … 3678 3613 3679 3614 3680 !------------------------------------------------------------------------------ !3615 !--------------------------------------------------------------------------------------------------! 3681 3616 ! Description: 3682 3617 ! ------------ 3683 3618 !> This routine writes the respective restart data for the bulk cloud module. 3684 !------------------------------------------------------------------------------ !3619 !--------------------------------------------------------------------------------------------------! 3685 3620 SUBROUTINE bcm_wrd_global 3686 3621 … … 3745 3680 WRITE ( 14 ) ice_crystal_sedimentation 3746 3681 3747 ELSEIF ( restart_data_format_output(1:3) == 'mpi' ) THEN3682 ELSEIF ( TRIM( restart_data_format_output(1:3) ) == 'mpi' ) THEN 3748 3683 3749 3684 CALL wrd_mpi_io( 'c_sedimentation', c_sedimentation ) … … 3771 3706 3772 3707 3773 !------------------------------------------------------------------------------ !3708 !--------------------------------------------------------------------------------------------------! 3774 3709 ! Description: 3775 3710 ! ------------ 3776 3711 !> This routine writes the respective restart data for the bulk cloud module. 3777 !------------------------------------------------------------------------------ !3712 !--------------------------------------------------------------------------------------------------! 3778 3713 SUBROUTINE bcm_wrd_local 3779 3714 … … 3868 3803 ENDIF 3869 3804 3870 ELSEIF ( restart_data_format_output(1:3) == 'mpi' ) THEN3805 ELSEIF ( TRIM( restart_data_format_output(1:3) ) == 'mpi' ) THEN 3871 3806 3872 3807 IF ( ALLOCATED( prr ) ) CALL wrd_mpi_io( 'prr', prr ) … … 3900 3835 END SUBROUTINE bcm_wrd_local 3901 3836 3902 !------------------------------------------------------------------------------ !3837 !--------------------------------------------------------------------------------------------------! 3903 3838 ! Description: 3904 3839 ! ------------ 3905 !> Adjust number of raindrops to avoid nonlinear effects in sedimentation and 3906 !> evaporation of rain drops due to too small or too big weights 3907 !> of rain drops (Stevens and Seifert, 2008). 3908 !------------------------------------------------------------------------------! 3840 !> Adjust number of raindrops to avoid nonlinear effects in sedimentation and evaporation of rain 3841 !> drops due to too small or too big weights of rain drops (Stevens and Seifert, 2008). 3842 !--------------------------------------------------------------------------------------------------! 3909 3843 SUBROUTINE adjust_cloud 3910 3844 … … 3938 3872 ENDIF 3939 3873 3940 IF ( microphysics_morrison ) THEN3874 IF ( microphysics_morrison ) THEN 3941 3875 IF ( qc(k,j,i) <= eps_sb ) THEN 3942 3876 qc(k,j,i) = 0.0_wp … … 3957 3891 END SUBROUTINE adjust_cloud 3958 3892 3959 !------------------------------------------------------------------------------ !3893 !--------------------------------------------------------------------------------------------------! 3960 3894 ! Description: 3961 3895 ! ------------ 3962 !> Adjust number of raindrops to avoid nonlinear effects in 3963 !> sedimentation and evaporation of rain drops due to too small or 3964 !> too big weights of rain drops (Stevens and Seifert, 2008). 3965 !> The same procedure is applied to cloud droplets if they are determined 3966 !> prognostically. Call for grid point i,j 3967 !------------------------------------------------------------------------------! 3896 !> Adjust number of raindrops to avoid nonlinear effects in sedimentation and evaporation of rain 3897 !> drops due to too small or too big weights of rain drops (Stevens and Seifert, 2008). 3898 !> The same procedure is applied to cloud droplets if they are determined prognostically. Call for 3899 !> grid point i,j 3900 !--------------------------------------------------------------------------------------------------! 3968 3901 SUBROUTINE adjust_cloud_ij( i, j ) 3969 3902 … … 3981 3914 flag = MERGE( 1.0_wp, 0.0_wp, BTEST( wall_flags_total_0(k,j,i), 0 ) ) 3982 3915 3983 IF ( .NOT. 3916 IF ( .NOT. microphysics_morrison_no_rain ) THEN 3984 3917 IF ( qr(k,j,i) <= eps_sb ) THEN 3985 3918 qr(k,j,i) = 0.0_wp … … 3987 3920 ELSE 3988 3921 ! 3989 !-- Adjust number of raindrops to avoid nonlinear effects in 3990 !-- sedimentation and evaporation of rain drops due to too small or3991 !-- too big weights of rain drops(Stevens and Seifert, 2008).3922 !-- Adjust number of raindrops to avoid nonlinear effects in sedimentation and 3923 !-- evaporation of rain drops due to too small or too big weights of rain drops 3924 !-- (Stevens and Seifert, 2008). 3992 3925 IF ( nr(k,j,i) * xrmin > qr(k,j,i) * hyrho(k) ) THEN 3993 3926 nr(k,j,i) = qr(k,j,i) * hyrho(k) / xrmin * flag … … 3998 3931 ENDIF 3999 3932 4000 IF ( microphysics_morrison ) THEN3933 IF ( microphysics_morrison ) THEN 4001 3934 IF ( qc(k,j,i) <= eps_sb ) THEN 4002 3935 qc(k,j,i) = 0.0_wp … … 4013 3946 END SUBROUTINE adjust_cloud_ij 4014 3947 4015 !------------------------------------------------------------------------------ !3948 !--------------------------------------------------------------------------------------------------! 4016 3949 ! Description: 4017 3950 ! ------------ 4018 !> Adjust number of ice crystal to avoid nonlinear effects in sedimentation and 4019 !> evaporation of ice crytals due to too small or too big weights 4020 !> of ice crytals (Stevens and Seifert, 2008). 4021 !------------------------------------------------------------------------------! 3951 !> Adjust number of ice crystal to avoid nonlinear effects in sedimentation and evaporation of ice 3952 !> crytals due to too small or too big weights of ice crytals (Stevens and Seifert, 2008). 3953 !--------------------------------------------------------------------------------------------------! 4022 3954 SUBROUTINE adjust_ice 4023 3955 … … 4054 3986 END SUBROUTINE adjust_ice 4055 3987 4056 !------------------------------------------------------------------------------ !3988 !--------------------------------------------------------------------------------------------------! 4057 3989 ! Description: 4058 3990 ! ------------ 4059 !> Adjust number of of ice crystal to avoid nonlinear effects in 4060 !> sedimentation and evaporation of ice crystals due to too small or 4061 !> too big weights of ice crytals (Stevens and Seifert, 2008). 4062 !> The same procedure is applied to cloud droplets if they are determined 4063 !> prognostically. Call for grid point i,j 4064 !------------------------------------------------------------------------------! 3991 !> Adjust number of of ice crystal to avoid nonlinear effects in sedimentation and evaporation of 3992 !> ice crystals due to too small or too big weights of ice crytals (Stevens and Seifert, 2008). 3993 !> The same procedure is applied to cloud droplets if they are determined prognostically. Call for 3994 !> grid point i,j 3995 !--------------------------------------------------------------------------------------------------! 4065 3996 SUBROUTINE adjust_ice_ij( i, j ) 4066 3997 … … 4090 4021 4091 4022 4092 !------------------------------------------------------------------------------ !4023 !--------------------------------------------------------------------------------------------------! 4093 4024 ! Description: 4094 4025 ! ------------ 4095 4026 !> Calculate number of activated condensation nucleii after simple activation 4096 4027 !> scheme of Twomey, 1959. 4097 !------------------------------------------------------------------------------ !4028 !--------------------------------------------------------------------------------------------------! 4098 4029 SUBROUTINE activation 4099 4030 … … 4108 4039 REAL(wp) :: beta_act !< 4109 4040 REAL(wp) :: bfactor !< 4041 REAL(wp) :: flag !< flag to indicate first grid level above 4110 4042 REAL(wp) :: k_act !< 4111 4043 REAL(wp) :: n_act !< … … 4116 4048 REAL(wp) :: sigma_act !< 4117 4049 4118 REAL(wp) :: flag !< flag to indicate first grid level above4119 4050 4120 4051 CALL cpu_log( log_point_s(65), 'activation', 'start' ) … … 4131 4062 CALL supersaturation ( i, j, k ) 4132 4063 ! 4133 !-- Prescribe parameters for activation 4134 !-- (see: Bott + Trautmann, 2002, Atm. Res., 64) 4064 !-- Prescribe parameters for activation (see: Bott + Trautmann, 2002, Atm. Res., 64) 4135 4065 k_act = 0.7_wp 4136 4066 activ = 0.0_wp 4137 4067 4138 4068 4139 IF ( sat > 0.0 .AND. .NOT. curvature_solution_effects_bulk )THEN4069 IF ( sat > 0.0 .AND. .NOT. curvature_solution_effects_bulk ) THEN 4140 4070 ! 4141 4071 !-- Compute the number of activated Aerosols … … 4143 4073 n_act = na_init * sat**k_act 4144 4074 ! 4145 !-- Compute the number of cloud droplets 4146 !-- (see: Morrison + Grabowski, 2007, JAS, 64) 4075 !-- Compute the number of cloud droplets (see: Morrison + Grabowski, 2007, JAS, 64) 4147 4076 ! activ = MAX( n_act - nc(k,j,i), 0.0_wp) / dt_micro 4148 4077 … … 4151 4080 !-- (see: Khairoutdinov + Kogan, 2000, Mon. Wea. Rev., 128) 4152 4081 sat_max = 1.0_wp / 100.0_wp 4153 activ = MAX( 0.0_wp, ( (na_init + nc(k,j,i) ) * MIN & 4154 ( 1.0_wp, ( sat / sat_max )**k_act) - nc(k,j,i) ) ) / & 4155 dt_micro 4156 ELSEIF ( sat > 0.0 .AND. curvature_solution_effects_bulk ) THEN 4157 ! 4158 !-- Curvature effect (afactor) with surface tension 4159 !-- parameterization by Straka (2009) 4082 activ = MAX( 0.0_wp, ( (na_init + nc(k,j,i) ) * & 4083 MIN( 1.0_wp, ( sat / sat_max )**k_act) - nc(k,j,i) ) ) / dt_micro 4084 ELSEIF ( sat > 0.0 .AND. curvature_solution_effects_bulk ) THEN 4085 ! 4086 !-- Curvature effect (afactor) with surface tension parameterization by Straka (2009) 4160 4087 sigma = 0.0761_wp - 0.000155_wp * ( t_l - 273.15_wp ) 4161 4088 afactor = 2.0_wp * sigma / ( rho_l * r_v * t_l ) 4162 4089 ! 4163 4090 !-- Solute effect (bfactor) 4164 bfactor = vanthoff * molecular_weight_of_water * & 4165 rho_s / ( molecular_weight_of_solute * rho_l ) 4166 4167 ! 4168 !-- Prescribe power index that describes the soluble fraction 4169 !-- of an aerosol particle (beta) 4170 !-- (see: Morrison + Grabowski, 2007, JAS, 64) 4091 bfactor = vanthoff * molecular_weight_of_water * rho_s / & 4092 ( molecular_weight_of_solute * rho_l ) 4093 4094 ! 4095 !-- Prescribe power index that describes the soluble fraction of an aerosol particle 4096 !-- (beta) (see: Morrison + Grabowski, 2007, JAS, 64) 4171 4097 beta_act = 0.5_wp 4172 4098 sigma_act = sigma_bulk**( 1.0_wp + beta_act ) 4173 4099 ! 4174 !-- Calculate mean geometric supersaturation (s_0) with 4175 !-- parameterization by Khvorostyanov and Curry (2006) 4176 s_0 = dry_aerosol_radius **(- ( 1.0_wp + beta_act ) ) * & 4177 ( 4.0_wp * afactor**3 / ( 27.0_wp * bfactor ) )**0.5_wp 4178 4179 ! 4180 !-- Calculate number of activated CCN as a function of 4181 !-- supersaturation and taking Koehler theory into account 4182 !-- (see: Khvorostyanov + Curry, 2006, J. Geo. Res., 111) 4183 n_ccn = ( na_init / 2.0_wp ) * ( 1.0_wp - ERF( & 4184 LOG( s_0 / sat ) / ( SQRT(2.0_wp) * LOG(sigma_act) ) ) ) 4100 !-- Calculate mean geometric supersaturation (s_0) with parameterization by 4101 !-- Khvorostyanov and Curry (2006) 4102 s_0 = dry_aerosol_radius **(- ( 1.0_wp + beta_act ) ) * ( 4.0_wp * afactor**3 / & 4103 ( 27.0_wp * bfactor ) )**0.5_wp 4104 4105 ! 4106 !-- Calculate number of activated CCN as a function of supersaturation and taking 4107 !-- Koehler theory into account (see: Khvorostyanov + Curry, 2006, J. Geo. Res., 111) 4108 n_ccn = ( na_init / 2.0_wp ) * ( 1.0_wp - ERF( & 4109 LOG( s_0 / sat ) / ( SQRT(2.0_wp) * LOG(sigma_act) ) ) ) 4185 4110 activ = MAX( ( n_ccn - nc(k,j,i) ) / dt_micro, 0.0_wp ) 4186 4111 ENDIF … … 4196 4121 END SUBROUTINE activation 4197 4122 4198 !------------------------------------------------------------------------------ !4123 !--------------------------------------------------------------------------------------------------! 4199 4124 ! Description: 4200 4125 ! ------------ 4201 !> Calculate number of activated condensation nucleii after simple activation 4202 !> scheme ofTwomey, 1959.4203 !------------------------------------------------------------------------------ !4126 !> Calculate number of activated condensation nucleii after simple activation scheme of 4127 !> Twomey, 1959. 4128 !--------------------------------------------------------------------------------------------------! 4204 4129 SUBROUTINE activation_ij( i, j ) 4205 4130 … … 4231 4156 CALL supersaturation ( i, j, k ) 4232 4157 ! 4233 !-- Prescribe parameters for activation 4234 !-- (see: Bott + Trautmann, 2002, Atm. Res., 64) 4158 !-- Prescribe parameters for activation (see: Bott + Trautmann, 2002, Atm. Res., 64) 4235 4159 k_act = 0.7_wp 4236 4160 activ = 0.0_wp … … 4250 4174 !-- (see: Khairoutdinov + Kogan, 2000, Mon. Wea. Rev., 128) 4251 4175 sat_max = 0.8_wp / 100.0_wp 4252 activ = MAX( 0.0_wp, ( (na_init + nc(k,j,i) ) * MIN & 4253 ( 1.0_wp, ( sat / sat_max )**k_act) - nc(k,j,i) ) ) / & 4254 dt_micro 4176 activ = MAX( 0.0_wp, ( (na_init + nc(k,j,i) ) * & 4177 MIN( 1.0_wp, ( sat / sat_max )**k_act) - nc(k,j,i) ) ) / dt_micro 4255 4178 4256 4179 nc(k,j,i) = MIN( (nc(k,j,i) + activ * dt_micro), na_init) 4257 ELSEIF ( sat > 0.0 .AND. curvature_solution_effects_bulk ) THEN 4258 ! 4259 !-- Curvature effect (afactor) with surface tension 4260 !-- parameterization by Straka (2009) 4180 ELSEIF ( sat > 0.0 .AND. curvature_solution_effects_bulk ) THEN 4181 ! 4182 !-- Curvature effect (afactor) with surface tension parameterization by Straka (2009) 4261 4183 sigma = 0.0761_wp - 0.000155_wp * ( t_l - 273.15_wp ) 4262 4184 afactor = 2.0_wp * sigma / ( rho_l * r_v * t_l ) 4263 4185 ! 4264 4186 !-- Solute effect (bfactor) 4265 bfactor = vanthoff * molecular_weight_of_water * & 4266 rho_s / ( molecular_weight_of_solute * rho_l ) 4267 4268 ! 4269 !-- Prescribe power index that describes the soluble fraction 4270 !-- of an aerosol particle (beta). 4271 !-- (see: Morrison + Grabowski, 2007, JAS, 64) 4187 bfactor = vanthoff * molecular_weight_of_water * rho_s / & 4188 ( molecular_weight_of_solute * rho_l ) 4189 4190 ! 4191 !-- Prescribe power index that describes the soluble fraction of an aerosol particle 4192 !-- (beta). (see: Morrison + Grabowski, 2007, JAS, 64) 4272 4193 beta_act = 0.5_wp 4273 4194 sigma_act = sigma_bulk**( 1.0_wp + beta_act ) 4274 4195 ! 4275 !-- Calculate mean geometric supersaturation (s_0) with 4276 !-- parameterization by Khvorostyanov and Curry (2006) 4277 s_0 = dry_aerosol_radius **(- ( 1.0_wp + beta_act ) ) * & 4278 ( 4.0_wp * afactor**3 / ( 27.0_wp * bfactor ) )**0.5_wp 4279 4280 ! 4281 !-- Calculate number of activated CCN as a function of 4282 !-- supersaturation and taking Koehler theory into account 4283 !-- (see: Khvorostyanov + Curry, 2006, J. Geo. Res., 111) 4284 n_ccn = ( na_init / 2.0_wp ) * ( 1.0_wp - ERF( & 4285 LOG( s_0 / sat ) / ( SQRT(2.0_wp) * LOG(sigma_act) ) ) ) 4196 !-- Calculate mean geometric supersaturation (s_0) with parameterization by Khvorostyanov 4197 !-- and Curry (2006) 4198 s_0 = dry_aerosol_radius **(- ( 1.0_wp + beta_act ) ) * & 4199 ( 4.0_wp * afactor**3 / ( 27.0_wp * bfactor ) )**0.5_wp 4200 4201 ! 4202 !-- Calculate number of activated CCN as a function of supersaturation and taking Koehler 4203 !-- theory into account (see: Khvorostyanov + Curry, 2006, J. Geo. Res., 111) 4204 n_ccn = ( na_init / 2.0_wp ) * ( 1.0_wp - ERF( & 4205 LOG( s_0 / sat ) / ( SQRT(2.0_wp) * LOG(sigma_act) ) ) ) 4286 4206 activ = MAX( ( n_ccn ) / dt_micro, 0.0_wp ) 4287 4207 … … 4293 4213 END SUBROUTINE activation_ij 4294 4214 4295 !------------------------------------------------------------------------------ !4215 !--------------------------------------------------------------------------------------------------! 4296 4216 ! Description: 4297 4217 ! ------------ 4298 !> Calculate ice nucleation by applying the deposition-condensation formula as 4299 !> given byMeyers et al 1992 and as described in Seifert and Beheng 20064300 !------------------------------------------------------------------------------ !4218 !> Calculate ice nucleation by applying the deposition-condensation formula as given by 4219 !> Meyers et al 1992 and as described in Seifert and Beheng 2006 4220 !--------------------------------------------------------------------------------------------------! 4301 4221 SUBROUTINE ice_nucleation 4302 4222 … … 4326 4246 CALL supersaturation_ice ( i, j, k ) 4327 4247 nucle = 0.0_wp 4328 IF ( sat_ice >= 0.05_wp .OR. ql(k,j,i) >= 0.001E-3_wp ) THEN4248 IF ( sat_ice >= 0.05_wp .OR. ql(k,j,i) >= 0.001E-3_wp ) THEN 4329 4249 ! 4330 4250 !-- Calculate ice nucleation … … 4364 4284 4365 4285 4366 !------------------------------------------------------------------------------ !4286 !--------------------------------------------------------------------------------------------------! 4367 4287 ! Description: 4368 4288 ! ------------ 4369 !> Calculate ice nucleation by applying the deposition-condensation formula as 4370 !> given by Meyers et al 1992 and as described in Seifert and Beheng 20064371 !------------------------------------------------------------------------------ !4289 !> Calculate ice nucleation by applying the deposition-condensation formula as given by 4290 !> Meyers et al 1992 and as described in Seifert and Beheng 2006. 4291 !--------------------------------------------------------------------------------------------------! 4372 4292 SUBROUTINE ice_nucleation_ij( i, j ) 4373 4293 … … 4393 4313 CALL supersaturation_ice ( i, j, k ) 4394 4314 nucle = 0.0_wp 4395 IF ( sat_ice >= 0.05_wp .OR. ql(k,j,i) >= 0.001E-3_wp ) THEN4315 IF ( sat_ice >= 0.05_wp .OR. ql(k,j,i) >= 0.001E-3_wp ) THEN 4396 4316 ! 4397 4317 !-- Calculate ice nucleation … … 4409 4329 CALL supersaturation_ice ( i, j, k ) 4410 4330 nucle = 0.0_wp 4411 IF ( sat_ice > 0.0 ) THEN4331 IF ( sat_ice > 0.0 ) THEN 4412 4332 ! 4413 4333 !-- Calculate ice nucleation … … 4422 4342 END SUBROUTINE ice_nucleation_ij 4423 4343 4424 !------------------------------------------------------------------------------ !4344 !--------------------------------------------------------------------------------------------------! 4425 4345 ! Description: 4426 4346 ! ------------ 4427 !> Calculate condensation rate for cloud water content (after Khairoutdinov and 4428 !> Kogan, 2000). 4429 !------------------------------------------------------------------------------! 4347 !> Calculate condensation rate for cloud water content (after Khairoutdinov and Kogan, 2000). 4348 !--------------------------------------------------------------------------------------------------! 4430 4349 SUBROUTINE condensation 4431 4350 … … 4455 4374 flag = MERGE( 1.0_wp, 0.0_wp, BTEST( wall_flags_total_0(k,j,i), 0 ) ) 4456 4375 ! 4457 !-- Call calculation of supersaturation 4376 !-- Call calculation of supersaturation 4458 4377 CALL supersaturation ( i, j, k ) 4459 4378 ! 4460 !-- Actual temperature, t_l is calculated directly before 4461 !-- in supersaturation 4379 !-- Actual temperature, t_l is calculated directly before in supersaturation 4462 4380 IF ( microphysics_ice_phase ) THEN 4463 4381 temp = t_l + lv_d_cp * ql(k,j,i) + ls_d_cp * qi(k,j,i) … … 4466 4384 ENDIF 4467 4385 4468 g_fac = 1.0_wp / ( ( l_v / ( r_v * temp ) - 1.0_wp ) * &4469 l_v / ( thermal_conductivity_l * temp )&4470 + r_v * temp / ( diff_coeff_l * e_s ) &4471 4386 g_fac = 1.0_wp / ( ( l_v / ( r_v * temp ) - 1.0_wp ) * & 4387 l_v / ( thermal_conductivity_l * temp ) & 4388 + r_v * temp / ( diff_coeff_l * e_s ) & 4389 ) 4472 4390 ! 4473 4391 !-- Mean weight of cloud drops … … 4475 4393 ! 4476 4394 !-- Calculating mean radius of cloud droplets assuming gamma distribution with shape 4477 !-- parameter nu=1 (Seifert and Beheng, 2006). Tuning factor alpha_rc (int orduced4478 !-- in Seifert and Stevens, 2010 ) is switched off. Minimum radius is set to 1 µm4395 !-- parameter nu=1 (Seifert and Beheng, 2006). Tuning factor alpha_rc (introduced 4396 !-- in Seifert and Stevens, 2010 ) is switched off. Minimum radius is set to 1õm 4479 4397 !-- following (Seifert and Beheng, 2006, Kogan and Khairoutdinov, 2000, 4480 4398 !-- Seifert and Stevens, 2010) 4481 rc = MAX( alpha_rc * GAMMA( nu + 1.33_wp) / GAMMA(nu + 1.0_wp) *&4482 ( 3.0_wp * qc(k,j,i) /&4399 rc = MAX( alpha_rc * GAMMA( nu + 1.33_wp ) / GAMMA( nu + 1.0_wp ) * & 4400 ( 3.0_wp * qc(k,j,i) / & 4483 4401 ( 4.0_wp * pi * rho_l * ( nu + 2.0_wp ) * nc(k,j,i) ) & 4484 )**0.33_wp, 1.0E-6_wp )4402 )**0.33_wp, 1.0E-6_wp ) 4485 4403 ! 4486 4404 !-- Condensation needs only to be calculated in supersaturated regions … … 4491 4409 !-- 2007, and Seifert and Stevens, 2010) 4492 4410 cond = 4.0_wp * pi * nc(k,j,i) * g_fac * sat * rc / hyrho(k) 4493 IF ( microphysics_seifert ) THEN4411 IF ( microphysics_seifert ) THEN 4494 4412 cond_max = q(k,j,i) - q_s - qc(k,j,i) - qr(k,j,i) 4495 ELSEIF ( microphysics_morrison_no_rain ) THEN4496 cond_max = q(k,j,i) - q_s - qc(k,j,i) 4413 ELSEIF ( microphysics_morrison_no_rain ) THEN 4414 cond_max = q(k,j,i) - q_s - qc(k,j,i) 4497 4415 ENDIF 4498 4416 cond = MIN( cond, cond_max / dt_micro ) 4499 4417 4500 4418 qc(k,j,i) = qc(k,j,i) + cond * dt_micro * flag 4501 ELSEIF ( sat < 0.0_wp ) THEN4419 ELSEIF ( sat < 0.0_wp ) THEN 4502 4420 evap = 4.0_wp * pi * nc(k,j,i) * g_fac * sat * rc / hyrho(k) 4503 4421 evap = MAX( evap, -qc(k,j,i) / dt_micro ) … … 4516 4434 END SUBROUTINE condensation 4517 4435 4518 !------------------------------------------------------------------------------ !4436 !--------------------------------------------------------------------------------------------------! 4519 4437 ! Description: 4520 4438 ! ------------ 4521 !> Calculate condensation rate for cloud water content (after Khairoutdinov and 4522 !> Kogan, 2000). 4523 !------------------------------------------------------------------------------! 4439 !> Calculate condensation rate for cloud water content (after Khairoutdinov and Kogan, 2000). 4440 !--------------------------------------------------------------------------------------------------! 4524 4441 SUBROUTINE condensation_ij( i, j ) 4525 4442 … … 4548 4465 CALL supersaturation ( i, j, k ) 4549 4466 ! 4550 !-- Actual temperature, t_l is calculated directly before 4551 !-- in supersaturation 4467 !-- Actual temperature, t_l is calculated directly before in supersaturation 4552 4468 IF ( microphysics_ice_phase ) THEN 4553 4469 temp = t_l + lv_d_cp * ql(k,j,i) + ls_d_cp * qi(k,j,i) … … 4556 4472 ENDIF 4557 4473 4558 g_fac = 1.0_wp / ( ( l_v / ( r_v * temp ) - 1.0_wp ) * &4559 l_v / ( thermal_conductivity_l * temp )&4560 + r_v * temp / ( diff_coeff_l * e_s ) &4474 g_fac = 1.0_wp / ( ( l_v / ( r_v * temp ) - 1.0_wp ) * & 4475 l_v / ( thermal_conductivity_l * temp ) & 4476 + r_v * temp / ( diff_coeff_l * e_s ) & 4561 4477 ) 4562 4478 ! 4563 4479 !-- Mean weight of cloud drops 4564 IF ( nc(k,j,i) <= 0.0_wp) CYCLE4480 IF ( nc(k,j,i) <= 0.0_wp) CYCLE 4565 4481 ! 4566 4482 !-- Calculating mean radius of cloud droplets assuming gamma distribution with shape 4567 !-- parameter nu=1 (Seifert and Beheng, 2006). Tuning factor alpha_rc (int orduced4568 !-- in Seifert and Stevens, 2010 ) is switched off. Minimum radius is set to 1 µm following4483 !-- parameter nu=1 (Seifert and Beheng, 2006). Tuning factor alpha_rc (introduced 4484 !-- in Seifert and Stevens, 2010 ) is switched off. Minimum radius is set to 1õm following 4569 4485 !-- (Seifert and Beheng, 2006, Kogan and Khairoutdinov, 2000, Seifert and Stevens, 2010) 4570 rc = MAX( alpha_rc * GAMMA( nu + 1.33_wp) / GAMMA(nu + 1.0_wp) *&4571 ( 3.0_wp * qc(k,j,i) / ( 4.0_wp * pi * rho_l * ( nu + 2.0_wp ) * nc(k,j,i) )&4572 )**0.33_wp, 1.0E-6_wp )4486 rc = MAX( alpha_rc * GAMMA( nu + 1.33_wp ) / GAMMA( nu + 1.0_wp ) * & 4487 ( 3.0_wp * qc(k,j,i) / ( 4.0_wp * pi * rho_l * ( nu + 2.0_wp ) * nc(k,j,i) ) & 4488 )**0.33_wp, 1.0E-6_wp ) 4573 4489 ! 4574 4490 !-- Condensation needs only to be calculated in supersaturated regions … … 4579 4495 !-- and Seifert and Stevens, 2010) 4580 4496 cond = 4.0_wp * pi * nc(k,j,i) * g_fac * sat * rc / hyrho(k) 4581 IF ( microphysics_seifert ) THEN4497 IF ( microphysics_seifert ) THEN 4582 4498 cond_max = q(k,j,i) - q_s - qc(k,j,i) - qr(k,j,i) 4583 ELSEIF ( microphysics_morrison_no_rain ) THEN4584 cond_max = q(k,j,i) - q_s - qc(k,j,i) 4499 ELSEIF ( microphysics_morrison_no_rain ) THEN 4500 cond_max = q(k,j,i) - q_s - qc(k,j,i) 4585 4501 ENDIF 4586 4502 cond = MIN( cond, cond_max / dt_micro ) 4587 4503 4588 4504 qc(k,j,i) = qc(k,j,i) + cond * dt_micro * flag 4589 ELSEIF ( sat < 0.0_wp ) THEN4505 ELSEIF ( sat < 0.0_wp ) THEN 4590 4506 evap = 4.0_wp * pi * nc(k,j,i) * g_fac * sat * rc / hyrho(k) 4591 4507 evap = MAX( evap, -qc(k,j,i) / dt_micro ) … … 4597 4513 END SUBROUTINE condensation_ij 4598 4514 4599 !------------------------------------------------------------------------------ !4515 !--------------------------------------------------------------------------------------------------! 4600 4516 ! Description: 4601 4517 ! ------------ 4602 !> Calculate the growth of ice particles by water vapor deposition (after 4603 !> Seifert and Beheng, 2006). 4604 !------------------------------------------------------------------------------! 4518 !> Calculate the growth of ice particles by water vapor deposition (after Seifert and Beheng, 2006). 4519 !--------------------------------------------------------------------------------------------------! 4605 4520 SUBROUTINE ice_deposition 4606 4521 … … 4611 4526 REAL(wp) :: ac = 0.09_wp !< parameter for ice capacitance 4612 4527 REAL(wp) :: bc = 0.33_wp !< parameter for ice capacitance 4613 REAL(wp) :: fac_gamma = 0.76_wp !< parameter to describe spectral4614 !< distribution, here following gamma4615 !< size distribution with µ =1/3 and nu=04616 4528 REAL(wp) :: deposition_rate !< depositions rate 4617 4529 REAL(wp) :: deposition_rate_max !< maximum deposition rate 4530 REAL(wp) :: fac_gamma = 0.76_wp !< parameter to describe spectral distribution, here 4531 !< following gamma size distribution with µ =1/3 and nu=0 4532 REAL(wp) :: flag !< flag to indicate first grid level above 4533 REAL(wp) :: gfac_dep !< factor 4618 4534 REAL(wp) :: sublimation_rate !< sublimations rate 4619 REAL(wp) :: gfac_dep !< factor4620 4535 REAL(wp) :: temp !< actual temperature 4621 4536 REAL(wp) :: xi !< mean mass of ice crystal 4622 REAL(wp) :: flag !< flag to indicate first grid level above4623 4537 4624 4538 CALL cpu_log( log_point_s(95), 'ice deposition', 'start' ) … … 4637 4551 temp = t_l + lv_d_cp * ql(k,j,i) + ls_d_cp * qi(k,j,i) 4638 4552 4639 IF ( temp >= 273.15_wp ) CYCLE 4640 ! 4641 !-- calculating gfac_dep ( 1/ (Fk + Fd) ) see e.g. 4642 !-- Rogers and Yau, 1989 4643 gfac_dep = 1.0_wp / ( ( l_s / ( r_v * temp ) - 1.0_wp ) * & 4644 l_s / ( thermal_conductivity_l * temp ) & 4645 + r_v * temp / ( diff_coeff_l * e_si ) & 4646 ) 4647 ! 4648 !-- If there is nothing nucleated, than there is also no 4649 !-- deposition (above -38°C) 4650 IF ( ni(k,j,i) <= 0.0_wp ) CYCLE 4553 IF ( temp >= 273.15_wp ) CYCLE 4554 ! 4555 !-- calculating gfac_dep ( 1/ (Fk + Fd) ) see e.g. Rogers and Yau, 1989 4556 gfac_dep = 1.0_wp / ( ( l_s / ( r_v * temp ) - 1.0_wp ) * & 4557 l_s / ( thermal_conductivity_l * temp ) & 4558 + r_v * temp / ( diff_coeff_l * e_si ) & 4559 ) 4560 ! 4561 !-- If there is nothing nucleated, than there is also no deposition (above -38°C) 4562 IF ( ni(k,j,i) <= 0.0_wp ) CYCLE 4651 4563 ! 4652 4564 !-- calculate mean mass of ice crystal … … 4654 4566 xi = MAX( ( qi(k,j,i) * hyrho(k) / ni(k,j,i)), ximin ) 4655 4567 ! 4656 !-- Condensation needs only to be calculated in supersaturated 4657 !-- regions (regarding ice) 4568 !-- Condensation needs only to be calculated in supersaturated regions (regarding ice) 4658 4569 IF ( sat_ice > 0.0_wp ) THEN 4659 4570 ! 4660 !-- Calculate deposition rate assuming ice crystal shape as 4661 !-- prescribed in Ovchinnikov et al., 2014 and a gamma size 4662 !-- distribution according to Seifert and Beheng with to 4663 !-- µ =1/3 and nu=0 4664 deposition_rate = 4.0_wp * pi * sat_ice * gfac_dep * & 4665 fac_gamma * ac * xi**bc * ni(k,j,i) 4666 IF ( microphysics_seifert ) THEN 4667 deposition_rate_max = q(k,j,i) - & 4668 q_si - qr(k,j,i) - qi(k,j,i) 4571 !-- Calculate deposition rate assuming ice crystal shape as prescribed in 4572 !-- Ovchinnikov et al., 2014 and a gamma size distribution according to 4573 !-- Seifert and Beheng with µ =1/3 and nu=0 4574 deposition_rate = 4.0_wp * pi * sat_ice * gfac_dep * fac_gamma * ac * xi**bc * & 4575 ni(k,j,i) 4576 IF ( microphysics_seifert ) THEN 4577 deposition_rate_max = q(k,j,i) - q_si - qr(k,j,i) - qi(k,j,i) 4669 4578 ELSEIF ( microphysics_morrison_no_rain ) THEN 4670 deposition_rate_max = q(k,j,i) - & 4671 q_si - qc(k,j,i) - qi(k,j,i) 4579 deposition_rate_max = q(k,j,i) - q_si - qc(k,j,i) - qi(k,j,i) 4672 4580 ENDIF 4673 deposition_rate = MIN( deposition_rate, & 4674 deposition_rate_max / dt_micro ) 4675 4581 deposition_rate = MIN( deposition_rate, deposition_rate_max / dt_micro ) 4676 4582 qi(k,j,i) = qi(k,j,i) + deposition_rate * dt_micro * flag 4677 ELSEIF ( sat_ice < 0.0_wp ) THEN 4678 sublimation_rate = 4.0_wp * pi * sat_ice * gfac_dep * & 4679 fac_gamma * ac * xi**bc * ni(k,j,i) 4680 sublimation_rate = MAX( sublimation_rate, & 4681 -qi(k,j,i) / dt_micro ) 4583 ELSEIF ( sat_ice < 0.0_wp ) THEN 4584 sublimation_rate = 4.0_wp * pi * sat_ice * gfac_dep * fac_gamma * ac * xi**bc * & 4585 ni(k,j,i) 4586 sublimation_rate = MAX( sublimation_rate, - qi(k,j,i) / dt_micro ) 4682 4587 qi(k,j,i) = qi(k,j,i) + sublimation_rate * dt_micro * flag 4683 4588 ENDIF … … 4690 4595 END SUBROUTINE ice_deposition 4691 4596 4692 !------------------------------------------------------------------------------ !4597 !--------------------------------------------------------------------------------------------------! 4693 4598 ! Description: 4694 4599 ! ------------ 4695 !> Calculate condensation rate for cloud water content (after Khairoutdinov and 4696 !> Kogan, 2000). 4697 !------------------------------------------------------------------------------! 4600 !> Calculate condensation rate for cloud water content (after Khairoutdinov and Kogan, 2000). 4601 !--------------------------------------------------------------------------------------------------! 4698 4602 SUBROUTINE ice_deposition_ij( i, j ) 4699 4603 … … 4704 4608 REAL(wp) :: ac = 0.09_wp !< parameter for ice capacitance 4705 4609 REAL(wp) :: bc = 0.33_wp !< parameter for ice capacitance 4706 REAL(wp) :: fac_gamma = 0.76_wp !< parameter to describe spectral4707 !< distribution, here following gamma4708 !< size distribution with nu=1, v=04709 4610 REAL(wp) :: deposition_rate !< depositions rate 4710 4611 REAL(wp) :: deposition_rate_max !< maximum deposition rate 4612 REAL(wp) :: fac_gamma = 0.76_wp !< parameter to describe spectral distribution, here 4613 !< following gamma size distribution with nu=1, v=0 4614 REAL(wp) :: flag !< flag to indicate first grid level above 4615 REAL(wp) :: gfac_dep !< factor 4711 4616 REAL(wp) :: sublimation_rate !< sublimations rate 4712 REAL(wp) :: gfac_dep !< factor4713 4617 REAL(wp) :: temp !< actual temperature 4714 4618 REAL(wp) :: xi !< mean mass of ice crystal 4715 REAL(wp) :: flag !< flag to indicate first grid level above4716 4619 4717 4620 DO k = nzb+1, nzt … … 4721 4624 ! 4722 4625 !-- Call calculation of supersaturation over a plane ice surface 4723 CALL supersaturation_ice ( i, j, k)4626 CALL supersaturation_ice (i,j,k) 4724 4627 ! 4725 4628 !-- Actual temperature: 4726 4629 temp = t_l + lv_d_cp * ql(k,j,i) + ls_d_cp * qi(k,j,i) 4727 4630 4728 IF ( temp >= 273.15_wp ) CYCLE4631 IF ( temp >= 273.15_wp ) CYCLE 4729 4632 ! 4730 4633 !-- calculating gfac_dep ( 1/ (Fk + Fd) ) see e.g. 4731 4634 !-- Rogers and Yau, 1989 4732 gfac_dep = 1.0_wp / ( ( l_s / ( r_v * temp ) - 1.0_wp ) * & 4733 l_s / ( thermal_conductivity_l * temp ) & 4734 + r_v * temp / ( diff_coeff_l * e_si ) & 4735 ) 4736 ! 4737 !-- If there is nothing nucleated, than there is also no 4738 !-- deposition (above -38°C) 4739 IF ( ni(k,j,i) <= 0.0_wp ) CYCLE 4635 gfac_dep = 1.0_wp / ( ( l_s / ( r_v * temp ) - 1.0_wp ) * & 4636 l_s / ( thermal_conductivity_l * temp ) & 4637 + r_v * temp / ( diff_coeff_l * e_si ) & 4638 ) 4639 ! 4640 !-- If there is nothing nucleated, than there is also no deposition (above -38°C) 4641 IF ( ni(k,j,i) <= 0.0_wp ) CYCLE 4740 4642 ! 4741 4643 !-- calculate mean mass of ice crystal … … 4743 4645 xi = MAX( ( qi(k,j,i) * hyrho(k) / ni(k,j,i)), ximin ) 4744 4646 ! 4745 !-- Condensation needs only to be calculated in supersaturated 4746 !-- regions (regarding ice) 4647 !-- Condensation needs only to be calculated in supersaturated regions (regarding ice) 4747 4648 IF ( sat_ice > 0.0_wp ) THEN 4748 4649 ! 4749 !-- Calculate deposition rate assuming ice crystal shape as 4750 !-- prescribed in Ovchinnikov et al., 2014 and a gamma size 4751 !-- distribution according to Seifert and Beheng with to 4752 !-- µ =1/3 and nu=0 4753 deposition_rate = 4.0_wp * pi * sat_ice * gfac_dep * & 4754 fac_gamma * ac * xi**bc * ni(k,j,i) 4755 IF ( microphysics_seifert ) THEN 4756 deposition_rate_max = q(k,j,i) - & 4757 q_si - qr(k,j,i) - qi(k,j,i) 4758 ELSEIF ( microphysics_morrison_no_rain ) THEN 4759 deposition_rate_max = q(k,j,i) - & 4760 q_si - qc(k,j,i) - qi(k,j,i) 4761 ENDIF 4762 deposition_rate = MIN( deposition_rate, & 4763 deposition_rate_max / dt_micro ) 4650 !-- Calculate deposition rate assuming ice crystal shape as prescribed in 4651 !-- Ovchinnikov et al., 2014 and a gamma size distribution according to 4652 !-- Seifert and Beheng with µ =1/3 and nu=0 4653 deposition_rate = 4.0_wp * pi * sat_ice * gfac_dep * fac_gamma * ac * xi**bc * & 4654 ni(k,j,i) 4655 IF ( microphysics_seifert ) THEN 4656 deposition_rate_max = q(k,j,i) - q_si - qr(k,j,i) - qi(k,j,i) 4657 ELSEIF ( microphysics_morrison_no_rain ) THEN 4658 deposition_rate_max = q(k,j,i) - q_si - qc(k,j,i) - qi(k,j,i) 4659 ENDIF 4660 deposition_rate = MIN( deposition_rate, deposition_rate_max / dt_micro ) 4764 4661 4765 4662 qi(k,j,i) = qi(k,j,i) + deposition_rate * dt_micro * flag 4766 ELSEIF ( sat_ice < 0.0_wp ) THEN 4767 sublimation_rate = 4.0_wp * pi * sat_ice * gfac_dep * & 4768 fac_gamma * ac * xi**bc * ni(k,j,i) 4769 sublimation_rate = MAX( sublimation_rate, & 4770 -qi(k,j,i) / dt_micro ) 4663 ELSEIF ( sat_ice < 0.0_wp ) THEN 4664 sublimation_rate = 4.0_wp * pi * sat_ice * gfac_dep * fac_gamma * ac * xi**bc * & 4665 ni(k,j,i) 4666 sublimation_rate = MAX( sublimation_rate, - qi(k,j,i) / dt_micro ) 4771 4667 qi(k,j,i) = qi(k,j,i) + sublimation_rate * dt_micro * flag 4772 4668 ENDIF … … 4776 4672 4777 4673 4778 !------------------------------------------------------------------------------ !4674 !--------------------------------------------------------------------------------------------------! 4779 4675 ! Description: 4780 4676 ! ------------ 4781 4677 !> Autoconversion rate (Seifert and Beheng, 2006). 4782 !------------------------------------------------------------------------------ !4678 !--------------------------------------------------------------------------------------------------! 4783 4679 SUBROUTINE autoconversion 4784 4680 … … 4814 4710 flag = MERGE( 1.0_wp, 0.0_wp, BTEST( wall_flags_total_0(k,j,i), 0 ) ) 4815 4711 4816 IF ( microphysics_morrison ) THEN4712 IF ( microphysics_morrison ) THEN 4817 4713 nc_auto = nc(k,j,i) 4818 4714 ELSE … … 4826 4722 !-- Intern time scale of coagulation (Seifert and Beheng, 2006): 4827 4723 !-- (1.0_wp - qc(k,j,i) / ( qc(k,j,i) + qr(k,j,i) )) 4828 tau_cloud = MAX( 1.0_wp - qc(k,j,i) / ( qr(k,j,i) + & 4829 qc(k,j,i) ), 0.0_wp ) 4724 tau_cloud = MAX( 1.0_wp - qc(k,j,i) / ( qr(k,j,i) + qc(k,j,i) ), 0.0_wp ) 4830 4725 ! 4831 4726 !-- Universal function for autoconversion process 4832 4727 !-- (Seifert and Beheng, 2006): 4833 phi_au = 600.0_wp * tau_cloud**0.68_wp * & 4834 ( 1.0_wp - tau_cloud**0.68_wp )**3 4728 phi_au = 600.0_wp * tau_cloud**0.68_wp * ( 1.0_wp - tau_cloud**0.68_wp )**3 4835 4729 ! 4836 4730 !-- Shape parameter of gamma distribution (Geoffroy et al., 2010): … … 4839 4733 ! 4840 4734 !-- Mean weight of cloud droplets: 4841 xc = MAX( hyrho(k) * qc(k,j,i) / nc_auto, xcmin) 4842 ! 4843 !-- Parameterized turbulence effects on autoconversion (Seifert,4844 !-- Nuijens and Stevens, 2010)4735 xc = MAX( hyrho(k) * qc(k,j,i) / nc_auto, xcmin) 4736 ! 4737 !-- Parameterized turbulence effects on autoconversion 4738 !-- (Seifert, Nuijens and Stevens, 2010) 4845 4739 IF ( collision_turbulence ) THEN 4846 4740 ! … … 4852 4746 sigma_cc = ( c_1 + c_2 * nu_c ) / ( 1.0_wp + c_3 * nu_c ) 4853 4747 ! 4854 !-- Mixing length (neglecting distance to ground and 4855 !-- stratification) 4748 !-- Mixing length (neglecting distance to ground and stratification) 4856 4749 l_mix = ( dx * dy * dzu(k) )**( 1.0_wp / 3.0_wp ) 4857 4750 ! 4858 !-- Limit dissipation rate according to Seifert, Nuijens and 4859 !-- Stevens (2010) 4751 !-- Limit dissipation rate according to Seifert, Nuijens and Stevens (2010) 4860 4752 dissipation = MIN( 0.06_wp, diss(k,j,i) ) 4861 4753 ! 4862 4754 !-- Compute Taylor-microscale Reynolds number: 4863 re_lambda = 6.0_wp / 11.0_wp * & 4864 ( l_mix / c_const )**( 2.0_wp / 3.0_wp ) * & 4865 SQRT( 15.0_wp / kin_vis_air ) * & 4866 dissipation**( 1.0_wp / 6.0_wp ) 4867 ! 4868 !-- The factor of 1.0E4 is needed to convert the dissipation 4869 !-- rate from m2 s-3 to cm2 s-3. 4870 k_au = k_au * ( 1.0_wp + & 4871 dissipation * 1.0E4_wp * & 4872 ( re_lambda * 1.0E-3_wp )**0.25_wp * & 4873 ( alpha_cc * EXP( -1.0_wp * ( ( rc - & 4874 r_cc ) / & 4875 sigma_cc )**2 & 4876 ) + beta_cc & 4877 ) & 4755 re_lambda = 6.0_wp / 11.0_wp * ( l_mix / c_const )**( 2.0_wp / 3.0_wp ) * & 4756 SQRT( 15.0_wp / kin_vis_air ) * dissipation**( 1.0_wp / 6.0_wp ) 4757 ! 4758 !-- The factor of 1.0E4 is needed to convert the dissipation rate from m2 s-3 to 4759 !-- cm2 s-3. 4760 k_au = k_au * ( 1.0_wp + & 4761 dissipation * 1.0E4_wp * & 4762 ( re_lambda * 1.0E-3_wp )**0.25_wp * & 4763 ( alpha_cc * EXP( -1.0_wp * ( ( rc - & 4764 r_cc ) / & 4765 sigma_cc )**2 & 4766 ) + beta_cc & 4767 ) & 4878 4768 ) 4879 4769 ENDIF 4880 4770 ! 4881 4771 !-- Autoconversion rate (Seifert and Beheng, 2006): 4882 autocon = k_au * ( nu_c + 2.0_wp ) * ( nu_c + 4.0_wp ) / & 4883 ( nu_c + 1.0_wp )**2 * qc(k,j,i)**2 * xc**2 * & 4884 ( 1.0_wp + phi_au / ( 1.0_wp - tau_cloud )**2 ) * & 4885 rho_surface 4772 autocon = k_au * ( nu_c + 2.0_wp ) * ( nu_c + 4.0_wp ) / & 4773 ( nu_c + 1.0_wp )**2 * qc(k,j,i)**2 * xc**2 * & 4774 ( 1.0_wp + phi_au / ( 1.0_wp - tau_cloud )**2 ) * rho_surface 4886 4775 autocon = MIN( autocon, qc(k,j,i) / dt_micro ) 4887 4776 4888 4777 qr(k,j,i) = qr(k,j,i) + autocon * dt_micro * flag 4889 4778 qc(k,j,i) = qc(k,j,i) - autocon * dt_micro * flag 4890 nr(k,j,i) = nr(k,j,i) + autocon / x0 * hyrho(k) * dt_micro & 4891 * flag 4892 IF ( microphysics_morrison ) THEN 4893 nc(k,j,i) = nc(k,j,i) - MIN( nc(k,j,i), 2.0_wp * & 4894 autocon / x0 * hyrho(k) * dt_micro * flag ) 4779 nr(k,j,i) = nr(k,j,i) + autocon / x0 * hyrho(k) * dt_micro * flag 4780 IF ( microphysics_morrison ) THEN 4781 nc(k,j,i) = nc(k,j,i) - MIN( nc(k,j,i), 2.0_wp * & 4782 autocon / x0 * hyrho(k) * dt_micro * flag ) 4895 4783 ENDIF 4896 4784 … … 4906 4794 4907 4795 4908 !------------------------------------------------------------------------------ !4796 !--------------------------------------------------------------------------------------------------! 4909 4797 ! Description: 4910 4798 ! ------------ 4911 4799 !> Autoconversion rate (Seifert and Beheng, 2006). Call for grid point i,j 4912 !------------------------------------------------------------------------------ !4800 !--------------------------------------------------------------------------------------------------! 4913 4801 SUBROUTINE autoconversion_ij( i, j ) 4914 4802 … … 4951 4839 !-- Intern time scale of coagulation (Seifert and Beheng, 2006): 4952 4840 !-- (1.0_wp - qc(k,j,i) / ( qc(k,j,i) + qr(k,j,i) )) 4953 tau_cloud = MAX( 1.0_wp - qc(k,j,i) / ( qr(k,j,i) + qc(k,j,i) ), & 4954 0.0_wp ) 4955 ! 4956 !-- Universal function for autoconversion process 4957 !-- (Seifert and Beheng, 2006): 4841 tau_cloud = MAX( 1.0_wp - qc(k,j,i) / ( qr(k,j,i) + qc(k,j,i) ), 0.0_wp ) 4842 ! 4843 !-- Universal function for autoconversion process (Seifert and Beheng, 2006): 4958 4844 phi_au = 600.0_wp * tau_cloud**0.68_wp * ( 1.0_wp - tau_cloud**0.68_wp )**3 4959 4845 ! … … 4965 4851 xc = hyrho(k) * qc(k,j,i) / nc_auto 4966 4852 ! 4967 !-- Parameterized turbulence effects on autoconversion (Seifert, 4968 !-- Nuijens and Stevens, 2010) 4853 !-- Parameterized turbulence effects on autoconversion (Seifert, Nuijens and Stevens, 2010) 4969 4854 IF ( collision_turbulence ) THEN 4970 4855 ! … … 4979 4864 l_mix = ( dx * dy * dzu(k) )**( 1.0_wp / 3.0_wp ) 4980 4865 ! 4981 !-- Limit dissipation rate according to Seifert, Nuijens and 4982 !-- Stevens (2010) 4866 !-- Limit dissipation rate according to Seifert, Nuijens and Stevens (2010) 4983 4867 dissipation = MIN( 0.06_wp, diss(k,j,i) ) 4984 4868 ! 4985 4869 !-- Compute Taylor-microscale Reynolds number: 4986 re_lambda = 6.0_wp / 11.0_wp * & 4987 ( l_mix / c_const )**( 2.0_wp / 3.0_wp ) * & 4988 SQRT( 15.0_wp / kin_vis_air ) * & 4989 dissipation**( 1.0_wp / 6.0_wp ) 4990 ! 4991 !-- The factor of 1.0E4 is needed to convert the dissipation rate 4992 !-- from m2 s-3 to cm2 s-3. 4993 k_au = k_au * ( 1.0_wp + & 4994 dissipation * 1.0E4_wp * & 4995 ( re_lambda * 1.0E-3_wp )**0.25_wp * & 4996 ( alpha_cc * EXP( -1.0_wp * ( ( rc - r_cc ) / & 4997 sigma_cc )**2 & 4998 ) + beta_cc & 4999 ) & 4870 re_lambda = 6.0_wp / 11.0_wp * ( l_mix / c_const )**( 2.0_wp / 3.0_wp ) * & 4871 SQRT( 15.0_wp / kin_vis_air ) * dissipation**( 1.0_wp / 6.0_wp ) 4872 ! 4873 !-- The factor of 1.0E4 is needed to convert the dissipation rate from m2 s-3 to 4874 !-- cm2 s-3. 4875 k_au = k_au * ( 1.0_wp + & 4876 dissipation * 1.0E4_wp * & 4877 ( re_lambda * 1.0E-3_wp )**0.25_wp * & 4878 ( alpha_cc * EXP( -1.0_wp * ( ( rc - r_cc ) / & 4879 sigma_cc )**2 & 4880 ) + beta_cc & 4881 ) & 5000 4882 ) 5001 4883 ENDIF 5002 4884 ! 5003 4885 !-- Autoconversion rate (Seifert and Beheng, 2006): 5004 autocon = k_au * ( nu_c + 2.0_wp ) * ( nu_c + 4.0_wp ) / & 5005 ( nu_c + 1.0_wp )**2 * qc(k,j,i)**2 * xc**2 * & 5006 ( 1.0_wp + phi_au / ( 1.0_wp - tau_cloud )**2 ) * & 5007 rho_surface 4886 autocon = k_au * ( nu_c + 2.0_wp ) * ( nu_c + 4.0_wp ) / & 4887 ( nu_c + 1.0_wp )**2 * qc(k,j,i)**2 * xc**2 * & 4888 ( 1.0_wp + phi_au / ( 1.0_wp - tau_cloud )**2 ) * rho_surface 5008 4889 autocon = MIN( autocon, qc(k,j,i) / dt_micro ) 5009 5010 4890 qr(k,j,i) = qr(k,j,i) + autocon * dt_micro * flag 5011 4891 qc(k,j,i) = qc(k,j,i) - autocon * dt_micro * flag 5012 4892 nr(k,j,i) = nr(k,j,i) + autocon / x0 * hyrho(k) * dt_micro * flag 5013 IF ( microphysics_morrison ) THEN5014 nc(k,j,i) = nc(k,j,i) - MIN( nc(k,j,i), 2.0_wp * &5015 4893 IF ( microphysics_morrison ) THEN 4894 nc(k,j,i) = nc(k,j,i) - MIN( nc(k,j,i), 2.0_wp * & 4895 autocon / x0 * hyrho(k) * dt_micro * flag ) 5016 4896 ENDIF 5017 4897 … … 5023 4903 5024 4904 5025 !------------------------------------------------------------------------------ !4905 !--------------------------------------------------------------------------------------------------! 5026 4906 ! Description: 5027 4907 ! ------------ 5028 4908 !> Autoconversion process (Kessler, 1969). 5029 !------------------------------------------------------------------------------ !4909 !--------------------------------------------------------------------------------------------------! 5030 4910 SUBROUTINE autoconversion_kessler 5031 4911 … … 5059 4939 qc(k,j,i) = qc(k,j,i) - dqdt_precip * dt_micro * flag 5060 4940 q(k,j,i) = q(k,j,i) - dqdt_precip * dt_micro * flag 5061 pt(k,j,i) = pt(k,j,i) + dqdt_precip * dt_micro * lv_d_cp * &5062 d_exner(k) 4941 pt(k,j,i) = pt(k,j,i) + dqdt_precip * dt_micro * lv_d_cp * & 4942 d_exner(k) * flag 5063 4943 5064 4944 ! … … 5072 4952 END SUBROUTINE autoconversion_kessler 5073 4953 5074 !------------------------------------------------------------------------------ !4954 !--------------------------------------------------------------------------------------------------! 5075 4955 ! Description: 5076 4956 ! ------------ 5077 4957 !> Autoconversion process (Kessler, 1969). 5078 !------------------------------------------------------------------------------ !4958 !--------------------------------------------------------------------------------------------------! 5079 4959 SUBROUTINE autoconversion_kessler_ij( i, j ) 5080 4960 … … 5087 4967 INTEGER(iwp) :: k_wall !< topography top index 5088 4968 5089 REAL(wp) :: dqdt_precip !<4969 REAL(wp) :: dqdt_precip !< 5090 4970 REAL(wp) :: flag !< flag to indicate first grid level above surface 5091 4971 … … 5106 4986 qc(k,j,i) = qc(k,j,i) - dqdt_precip * dt_micro * flag 5107 4987 q(k,j,i) = q(k,j,i) - dqdt_precip * dt_micro * flag 5108 pt(k,j,i) = pt(k,j,i) + dqdt_precip * dt_micro * lv_d_cp * d_exner(k) & 5109 * flag 4988 pt(k,j,i) = pt(k,j,i) + dqdt_precip * dt_micro * lv_d_cp * d_exner(k) * flag 5110 4989 5111 4990 ! … … 5118 4997 5119 4998 5120 !------------------------------------------------------------------------------ !4999 !--------------------------------------------------------------------------------------------------! 5121 5000 ! Description: 5122 5001 ! ------------ 5123 5002 !> Accretion rate (Seifert and Beheng, 2006). 5124 !------------------------------------------------------------------------------ !5003 !--------------------------------------------------------------------------------------------------! 5125 5004 SUBROUTINE accretion 5126 5005 … … 5149 5028 flag = MERGE( 1.0_wp, 0.0_wp, BTEST( wall_flags_total_0(k,j,i), 0 ) ) 5150 5029 5151 IF ( microphysics_morrison ) THEN5030 IF ( microphysics_morrison ) THEN 5152 5031 nc_accr = nc(k,j,i) 5153 5032 ELSE … … 5155 5034 ENDIF 5156 5035 5157 IF ( ( qc(k,j,i) > eps_sb ) .AND. ( qr(k,j,i) > eps_sb ) &5158 .AND. ( nc_accr > eps_mr ) )THEN5036 IF ( ( qc(k,j,i) > eps_sb ) .AND. ( qr(k,j,i) > eps_sb ) & 5037 .AND. ( nc_accr > eps_mr ) ) THEN 5159 5038 ! 5160 5039 !-- Intern time scale of coagulation (Seifert and Beheng, 2006): … … 5169 5048 xc = MAX( (hyrho(k) * qc(k,j,i) / nc_accr), xcmin) 5170 5049 ! 5171 !-- Parameterized turbulence effects on autoconversion (Seifert,5172 !-- Nuijens and Stevens, 2010). The factor of 1.0E4 is needed to5173 !-- convertthe dissipation rate (diss) from m2 s-3 to cm2 s-3.5050 !-- Parameterized turbulence effects on autoconversion 5051 !-- (Seifert, Nuijens and Stevens, 2010). The factor of 1.0E4 is needed to convert 5052 !-- the dissipation rate (diss) from m2 s-3 to cm2 s-3. 5174 5053 IF ( collision_turbulence ) THEN 5175 k_cr = k_cr0 * ( 1.0_wp + 0.05_wp * & 5176 MIN( 600.0_wp, & 5177 diss(k,j,i) * 1.0E4_wp )**0.25_wp & 5054 k_cr = k_cr0 * ( 1.0_wp + 0.05_wp * & 5055 MIN( 600.0_wp, diss(k,j,i) * 1.0E4_wp )**0.25_wp & 5178 5056 ) 5179 5057 ELSE … … 5182 5060 ! 5183 5061 !-- Accretion rate (Seifert and Beheng, 2006): 5184 accr = k_cr * qc(k,j,i) * qr(k,j,i) * phi_ac * & 5185 SQRT( rho_surface * hyrho(k) ) 5062 accr = k_cr * qc(k,j,i) * qr(k,j,i) * phi_ac * SQRT( rho_surface * hyrho(k) ) 5186 5063 accr = MIN( accr, qc(k,j,i) / dt_micro ) 5187 5188 5064 qr(k,j,i) = qr(k,j,i) + accr * dt_micro * flag 5189 5065 qc(k,j,i) = qc(k,j,i) - accr * dt_micro * flag 5190 5066 IF ( microphysics_morrison ) THEN 5191 nc(k,j,i) = nc(k,j,i) - MIN( nc(k,j,i), &5192 accr / xc * hyrho(k) * dt_micro * flag)5067 nc(k,j,i) = nc(k,j,i) - MIN( nc(k,j,i), & 5068 accr / xc * hyrho(k) * dt_micro * flag) 5193 5069 ENDIF 5194 5070 … … 5203 5079 END SUBROUTINE accretion 5204 5080 5205 !------------------------------------------------------------------------------ !5081 !--------------------------------------------------------------------------------------------------! 5206 5082 ! Description: 5207 5083 ! ------------ 5208 5084 !> Accretion rate (Seifert and Beheng, 2006). Call for grid point i,j 5209 !------------------------------------------------------------------------------ !5085 !--------------------------------------------------------------------------------------------------! 5210 5086 SUBROUTINE accretion_ij( i, j ) 5211 5087 … … 5229 5105 !-- Predetermine flag to mask topography 5230 5106 flag = MERGE( 1.0_wp, 0.0_wp, BTEST( wall_flags_total_0(k,j,i), 0 ) ) 5231 IF ( microphysics_morrison ) THEN5107 IF ( microphysics_morrison ) THEN 5232 5108 nc_accr = nc(k,j,i) 5233 5109 ELSE … … 5235 5111 ENDIF 5236 5112 5237 IF ( ( qc(k,j,i) > eps_sb ) .AND. ( qr(k,j,i) > eps_sb ) .AND. &5238 ( nc_accr > eps_mr ) ) THEN5113 IF ( ( qc(k,j,i) > eps_sb ) .AND. ( qr(k,j,i) > eps_sb ) .AND. & 5114 ( nc_accr > eps_mr ) ) THEN 5239 5115 ! 5240 5116 !-- Intern time scale of coagulation (Seifert and Beheng, 2006): 5241 5117 tau_cloud = 1.0_wp - qc(k,j,i) / ( qc(k,j,i) + qr(k,j,i) ) 5242 5118 ! 5243 !-- Universal function for accretion process 5244 !-- (Seifert and Beheng, 2001): 5119 !-- Universal function for accretion process (Seifert and Beheng, 2001): 5245 5120 phi_ac = ( tau_cloud / ( tau_cloud + 5.0E-5_wp ) )**4 5246 5121 … … 5249 5124 xc = MAX( (hyrho(k) * qc(k,j,i) / nc_accr), xcmin) 5250 5125 ! 5251 !-- Parameterized turbulence effects on autoconversion (Seifert,5252 !-- Nuijens and Stevens, 2010). The factor of 1.0E4 is needed to5253 !-- convert thedissipation rate (diss) from m2 s-3 to cm2 s-3.5126 !-- Parameterized turbulence effects on autoconversion 5127 !-- (Seifert, Nuijens and Stevens, 2010). The factor of 1.0E4 is needed to convert the 5128 !-- dissipation rate (diss) from m2 s-3 to cm2 s-3. 5254 5129 IF ( collision_turbulence ) THEN 5255 k_cr = k_cr0 * ( 1.0_wp + 0.05_wp * & 5256 MIN( 600.0_wp, & 5257 diss(k,j,i) * 1.0E4_wp )**0.25_wp & 5130 k_cr = k_cr0 * ( 1.0_wp + 0.05_wp * & 5131 MIN( 600.0_wp, diss(k,j,i) * 1.0E4_wp )**0.25_wp & 5258 5132 ) 5259 5133 ELSE … … 5262 5136 ! 5263 5137 !-- Accretion rate (Seifert and Beheng, 2006): 5264 accr = k_cr * qc(k,j,i) * qr(k,j,i) * phi_ac * & 5265 SQRT( rho_surface * hyrho(k) ) 5138 accr = k_cr * qc(k,j,i) * qr(k,j,i) * phi_ac * SQRT( rho_surface * hyrho(k) ) 5266 5139 accr = MIN( accr, qc(k,j,i) / dt_micro ) 5267 5268 5140 qr(k,j,i) = qr(k,j,i) + accr * dt_micro * flag 5269 5141 qc(k,j,i) = qc(k,j,i) - accr * dt_micro * flag 5270 5142 IF ( microphysics_morrison ) THEN 5271 nc(k,j,i) = nc(k,j,i) - MIN( nc(k,j,i), accr / xc * & 5272 hyrho(k) * dt_micro * flag & 5273 ) 5143 nc(k,j,i) = nc(k,j,i) - MIN( nc(k,j,i), accr / xc * hyrho(k) * dt_micro * flag ) 5274 5144 ENDIF 5275 5145 … … 5282 5152 5283 5153 5284 !------------------------------------------------------------------------------ !5154 !--------------------------------------------------------------------------------------------------! 5285 5155 ! Description: 5286 5156 ! ------------ 5287 5157 !> Collisional breakup rate (Seifert, 2008). 5288 !------------------------------------------------------------------------------ !5158 !--------------------------------------------------------------------------------------------------! 5289 5159 SUBROUTINE selfcollection_breakup 5290 5160 … … 5313 5183 ! 5314 5184 !-- Selfcollection rate (Seifert and Beheng, 2001): 5315 selfcoll = k_rr * nr(k,j,i) * qr(k,j,i) * & 5316 SQRT( hyrho(k) * rho_surface ) 5185 selfcoll = k_rr * nr(k,j,i) * qr(k,j,i) * SQRT( hyrho(k) * rho_surface ) 5317 5186 ! 5318 5187 !-- Weight averaged diameter of rain drops: 5319 dr = ( hyrho(k) * qr(k,j,i) / & 5320 nr(k,j,i) * dpirho_l )**( 1.0_wp / 3.0_wp ) 5188 dr = ( hyrho(k) * qr(k,j,i) / nr(k,j,i) * dpirho_l )**( 1.0_wp / 3.0_wp ) 5321 5189 ! 5322 5190 !-- Collisional breakup rate (Seifert, 2008): … … 5341 5209 5342 5210 5343 !------------------------------------------------------------------------------ !5211 !--------------------------------------------------------------------------------------------------! 5344 5212 ! Description: 5345 5213 ! ------------ 5346 5214 !> Collisional breakup rate (Seifert, 2008). Call for grid point i,j 5347 !------------------------------------------------------------------------------ !5215 !--------------------------------------------------------------------------------------------------! 5348 5216 SUBROUTINE selfcollection_breakup_ij( i, j ) 5349 5217 … … 5390 5258 5391 5259 5392 !------------------------------------------------------------------------------ !5260 !--------------------------------------------------------------------------------------------------! 5393 5261 ! Description: 5394 5262 ! ------------ 5395 !> Evaporation of precipitable water. Condensation is neglected for 5396 !> precipitable water. 5397 !------------------------------------------------------------------------------! 5263 !> Evaporation of precipitable water. Condensation is neglected for precipitable water. 5264 !--------------------------------------------------------------------------------------------------! 5398 5265 SUBROUTINE evaporation_rain 5399 5266 … … 5430 5297 5431 5298 ! 5432 !-- Call calculation of supersaturation 5299 !-- Call calculation of supersaturation 5433 5300 CALL supersaturation ( i, j, k ) 5434 5301 ! … … 5439 5306 temp = t_l + lv_d_cp * ( qc(k,j,i) + qr(k,j,i) ) 5440 5307 5441 g_evap = 1.0_wp / ( ( l_v / ( r_v * temp ) - 1.0_wp ) * &5442 l_v / ( thermal_conductivity_l * temp )&5443 + r_v * temp / ( diff_coeff_l * e_s ) &5308 g_evap = 1.0_wp / ( ( l_v / ( r_v * temp ) - 1.0_wp ) * & 5309 l_v / ( thermal_conductivity_l * temp ) & 5310 + r_v * temp / ( diff_coeff_l * e_s ) & 5444 5311 ) 5445 5312 ! … … 5456 5323 !-- Shape parameter of gamma distribution (Milbrandt and Yau, 5457 5324 !-- 2005; Stevens and Seifert, 2008): 5458 mu_r = 10.0_wp * ( 1.0_wp + TANH( 1.2E3_wp * & 5459 ( dr - 1.4E-3_wp ) ) ) 5325 mu_r = 10.0_wp * ( 1.0_wp + TANH( 1.2E3_wp * ( dr - 1.4E-3_wp ) ) ) 5460 5326 ! 5461 5327 !-- Slope parameter of gamma distribution (Seifert, 2008): 5462 lambda_r = ( ( mu_r + 3.0_wp ) * ( mu_r + 2.0_wp ) * & 5463 ( mu_r + 1.0_wp ) & 5328 lambda_r = ( ( mu_r + 3.0_wp ) * ( mu_r + 2.0_wp ) * ( mu_r + 1.0_wp ) & 5464 5329 )**( 1.0_wp / 3.0_wp ) / dr 5465 5330 … … 5467 5332 mu_r_5d2 = mu_r + 2.5_wp 5468 5333 5469 f_vent = a_vent * gamm( mu_r_2 ) * & 5470 lambda_r**( -mu_r_2 ) + b_vent * & 5471 schmidt_p_1d3 * SQRT( a_term / kin_vis_air ) *& 5472 gamm( mu_r_5d2 ) * lambda_r**( -mu_r_5d2 ) * & 5473 ( 1.0_wp - & 5474 0.5_wp * ( b_term / a_term ) * & 5475 ( lambda_r / ( c_term + lambda_r ) & 5476 )**mu_r_5d2 - & 5477 0.125_wp * ( b_term / a_term )**2 * & 5478 ( lambda_r / ( 2.0_wp * c_term + lambda_r ) & 5479 )**mu_r_5d2 - & 5480 0.0625_wp * ( b_term / a_term )**3 * & 5481 ( lambda_r / ( 3.0_wp * c_term + lambda_r ) & 5482 )**mu_r_5d2 - & 5483 0.0390625_wp * ( b_term / a_term )**4 * & 5484 ( lambda_r / ( 4.0_wp * c_term + lambda_r ) & 5485 )**mu_r_5d2 & 5334 f_vent = a_vent * gamm( mu_r_2 ) * & 5335 lambda_r**( -mu_r_2 ) + b_vent * & 5336 schmidt_p_1d3 * SQRT( a_term / kin_vis_air ) * & 5337 gamm( mu_r_5d2 ) * lambda_r**( -mu_r_5d2 ) * & 5338 ( 1.0_wp - & 5339 0.5_wp * ( b_term / a_term ) * & 5340 ( lambda_r / ( c_term + lambda_r ) )**mu_r_5d2 - & 5341 0.125_wp * ( b_term / a_term )**2 * & 5342 ( lambda_r / ( 2.0_wp * c_term + lambda_r ) )**mu_r_5d2 - & 5343 0.0625_wp * ( b_term / a_term )**3 * & 5344 ( lambda_r / ( 3.0_wp * c_term + lambda_r ) )**mu_r_5d2 - & 5345 0.0390625_wp * ( b_term / a_term )**4 * & 5346 ( lambda_r / ( 4.0_wp * c_term + lambda_r ) )**mu_r_5d2 & 5486 5347 ) 5487 5348 … … 5492 5353 nr_0 = nr(k,j,i) * dr 5493 5354 ENDIF 5494 ! 5495 !-- Evaporation rate of rain water content (Seifert and 5496 !-- Beheng, 2006): 5497 evap = 2.0_wp * pi * nr_0 * g_evap * f_vent * sat / & 5498 hyrho(k) 5355 ! 5356 !-- Evaporation rate of rain water content (Seifert and Beheng, 2006): 5357 evap = 2.0_wp * pi * nr_0 * g_evap * f_vent * sat / hyrho(k) 5499 5358 evap = MAX( evap, -qr(k,j,i) / dt_micro ) 5500 evap_nr = MAX( c_evap * evap / xr * hyrho(k), & 5501 -nr(k,j,i) / dt_micro ) 5502 5359 evap_nr = MAX( c_evap * evap / xr * hyrho(k), - nr(k,j,i) / dt_micro ) 5503 5360 qr(k,j,i) = qr(k,j,i) + evap * dt_micro * flag 5504 5361 nr(k,j,i) = nr(k,j,i) + evap_nr * dt_micro * flag … … 5516 5373 5517 5374 5518 !------------------------------------------------------------------------------ !5375 !--------------------------------------------------------------------------------------------------! 5519 5376 ! Description: 5520 5377 ! ------------ 5521 !> Evaporation of precipitable water. Condensation is neglected for 5522 !> precipitable water. Call forgrid point i,j5523 !------------------------------------------------------------------------------ !5378 !> Evaporation of precipitable water. Condensation is neglected for precipitable water. Call for 5379 !> grid point i,j 5380 !--------------------------------------------------------------------------------------------------! 5524 5381 SUBROUTINE evaporation_rain_ij( i, j ) 5525 5382 … … 5560 5417 temp = t_l + lv_d_cp * ( qc(k,j,i) + qr(k,j,i) ) 5561 5418 5562 g_evap = 1.0_wp / ( ( l_v / ( r_v * temp ) - 1.0_wp ) * l_v /&5563 ( thermal_conductivity_l * temp ) +&5564 r_v * temp / ( diff_coeff_l * e_s )&5419 g_evap = 1.0_wp / ( ( l_v / ( r_v * temp ) - 1.0_wp ) * & 5420 l_v / ( thermal_conductivity_l * temp ) & 5421 + r_v * temp / ( diff_coeff_l * e_s ) & 5565 5422 ) 5566 5423 ! … … 5580 5437 ! 5581 5438 !-- Slope parameter of gamma distribution (Seifert, 2008): 5582 lambda_r = ( ( mu_r + 3.0_wp ) * ( mu_r + 2.0_wp ) * & 5583 ( mu_r + 1.0_wp ) & 5439 lambda_r = ( ( mu_r + 3.0_wp ) * ( mu_r + 2.0_wp ) * ( mu_r + 1.0_wp ) & 5584 5440 )**( 1.0_wp / 3.0_wp ) / dr 5585 5441 … … 5587 5443 mu_r_5d2 = mu_r + 2.5_wp 5588 5444 5589 f_vent = a_vent * gamm( mu_r_2 ) * lambda_r**( -mu_r_2 ) + & 5590 b_vent * schmidt_p_1d3 * & 5591 SQRT( a_term / kin_vis_air ) * gamm( mu_r_5d2 ) * & 5592 lambda_r**( -mu_r_5d2 ) * & 5593 ( 1.0_wp - & 5594 0.5_wp * ( b_term / a_term ) * & 5595 ( lambda_r / ( c_term + lambda_r ) & 5596 )**mu_r_5d2 - & 5597 0.125_wp * ( b_term / a_term )**2 * & 5598 ( lambda_r / ( 2.0_wp * c_term + lambda_r ) & 5599 )**mu_r_5d2 - & 5600 0.0625_wp * ( b_term / a_term )**3 * & 5601 ( lambda_r / ( 3.0_wp * c_term + lambda_r ) & 5602 )**mu_r_5d2 - & 5603 0.0390625_wp * ( b_term / a_term )**4 * & 5604 ( lambda_r / ( 4.0_wp * c_term + lambda_r ) & 5605 )**mu_r_5d2 & 5445 f_vent = a_vent * gamm( mu_r_2 ) * lambda_r**( -mu_r_2 ) + & 5446 b_vent * schmidt_p_1d3 * & 5447 SQRT( a_term / kin_vis_air ) * gamm( mu_r_5d2 ) * & 5448 lambda_r**( -mu_r_5d2 ) * & 5449 ( 1.0_wp - & 5450 0.5_wp * ( b_term / a_term ) * & 5451 ( lambda_r / ( c_term + lambda_r ) )**mu_r_5d2 - & 5452 0.125_wp * ( b_term / a_term )**2 * & 5453 ( lambda_r / ( 2.0_wp * c_term + lambda_r ) )**mu_r_5d2 - & 5454 0.0625_wp * ( b_term / a_term )**3 * & 5455 ( lambda_r / ( 3.0_wp * c_term + lambda_r ) )**mu_r_5d2 - & 5456 0.0390625_wp * ( b_term / a_term )**4 * & 5457 ( lambda_r / ( 4.0_wp * c_term + lambda_r ) )**mu_r_5d2 & 5606 5458 ) 5607 5459 5608 nr_0 = nr(k,j,i) * lambda_r**( mu_r + 1.0_wp ) / & 5609 gamm( mu_r + 1.0_wp ) 5460 nr_0 = nr(k,j,i) * lambda_r**( mu_r + 1.0_wp ) / gamm( mu_r + 1.0_wp ) 5610 5461 ELSE 5611 5462 f_vent = 1.0_wp … … 5616 5467 evap = 2.0_wp * pi * nr_0 * g_evap * f_vent * sat / hyrho(k) 5617 5468 evap = MAX( evap, -qr(k,j,i) / dt_micro ) 5618 evap_nr = MAX( c_evap * evap / xr * hyrho(k), & 5619 -nr(k,j,i) / dt_micro ) 5620 5469 evap_nr = MAX( c_evap * evap / xr * hyrho(k), - nr(k,j,i) / dt_micro ) 5621 5470 qr(k,j,i) = qr(k,j,i) + evap * dt_micro * flag 5622 5471 nr(k,j,i) = nr(k,j,i) + evap_nr * dt_micro * flag … … 5630 5479 5631 5480 5632 !------------------------------------------------------------------------------ !5481 !--------------------------------------------------------------------------------------------------! 5633 5482 ! Description: 5634 5483 ! ------------ 5635 5484 !> Sedimentation of cloud droplets (Ackermann et al., 2009, MWR). 5636 !------------------------------------------------------------------------------ !5485 !--------------------------------------------------------------------------------------------------! 5637 5486 SUBROUTINE sedimentation_cloud 5638 5487 … … 5647 5496 REAL(wp) :: nc_sedi !< 5648 5497 5498 REAL(wp), DIMENSION(nzb:nzt+1) :: sed_nc !< 5649 5499 REAL(wp), DIMENSION(nzb:nzt+1) :: sed_qc !< 5650 REAL(wp), DIMENSION(nzb:nzt+1) :: sed_nc !<5651 5500 5652 5501 … … 5663 5512 flag = MERGE( 1.0_wp, 0.0_wp, BTEST( wall_flags_total_0(k,j,i), 0 ) ) 5664 5513 5665 IF ( microphysics_morrison ) THEN5514 IF ( microphysics_morrison ) THEN 5666 5515 nc_sedi = nc(k,j,i) 5667 5516 ELSE … … 5670 5519 5671 5520 ! 5672 !-- Sedimentation fluxes for number concentration are only calculated 5673 !-- for cloud_scheme ='morrison'5674 IF ( microphysics_morrison ) THEN5521 !-- Sedimentation fluxes for number concentration are only calculated for cloud_scheme = 5522 !-- 'morrison' 5523 IF ( microphysics_morrison ) THEN 5675 5524 IF ( qc(k,j,i) > eps_sb .AND. nc(k,j,i) > eps_mr ) THEN 5676 sed_nc(k) = sed_qc_const * & 5677 ( qc(k,j,i) * hyrho(k) )**( 2.0_wp / 3.0_wp ) * & 5678 ( nc(k,j,i) )**( 1.0_wp / 3.0_wp ) 5525 sed_nc(k) = sed_qc_const * ( qc(k,j,i) * hyrho(k) )**( 2.0_wp / 3.0_wp ) * & 5526 ( nc(k,j,i) )**( 1.0_wp / 3.0_wp ) 5679 5527 ELSE 5680 5528 sed_nc(k) = 0.0_wp 5681 5529 ENDIF 5682 5530 5683 sed_nc(k) = MIN( sed_nc(k), hyrho(k) * dzu(k+1) * &5684 nc(k,j,i) / dt_micro + sed_nc(k+1) &5531 sed_nc(k) = MIN( sed_nc(k), hyrho(k) * dzu(k+1) * & 5532 nc(k,j,i) / dt_micro + sed_nc(k+1) & 5685 5533 ) * flag 5686 5534 5687 nc(k,j,i) = nc(k,j,i) + ( sed_nc(k+1) - sed_nc(k) ) * &5688 ddzu(k+1) /hyrho(k) * dt_micro * flag5535 nc(k,j,i) = nc(k,j,i) + ( sed_nc(k+1) - sed_nc(k) ) * ddzu(k+1) / & 5536 hyrho(k) * dt_micro * flag 5689 5537 ENDIF 5690 5538 5691 5539 IF ( qc(k,j,i) > eps_sb .AND. nc_sedi > eps_mr ) THEN 5692 sed_qc(k) = sed_qc_const * nc_sedi**( -2.0_wp / 3.0_wp ) * & 5693 ( qc(k,j,i) * hyrho(k) )**( 5.0_wp / 3.0_wp ) * & 5694 flag 5540 sed_qc(k) = sed_qc_const * nc_sedi**( -2.0_wp / 3.0_wp ) * & 5541 ( qc(k,j,i) * hyrho(k) )**( 5.0_wp / 3.0_wp ) * flag 5695 5542 ELSE 5696 5543 sed_qc(k) = 0.0_wp 5697 5544 ENDIF 5698 5545 5699 sed_qc(k) = MIN( sed_qc(k), hyrho(k) * dzu(k+1) * q(k,j,i) / & 5700 dt_micro + sed_qc(k+1) & 5546 sed_qc(k) = MIN( sed_qc(k), hyrho(k) * dzu(k+1) * q(k,j,i) / dt_micro + sed_qc(k+1)& 5701 5547 ) * flag 5702 5548 5703 q(k,j,i) = q(k,j,i) + ( sed_qc(k+1) - sed_qc(k) ) * &5549 q(k,j,i) = q(k,j,i) + ( sed_qc(k+1) - sed_qc(k) ) * & 5704 5550 ddzu(k+1) / hyrho(k) * dt_micro * flag 5705 qc(k,j,i) = qc(k,j,i) + ( sed_qc(k+1) - sed_qc(k) ) * &5551 qc(k,j,i) = qc(k,j,i) + ( sed_qc(k+1) - sed_qc(k) ) * & 5706 5552 ddzu(k+1) / hyrho(k) * dt_micro * flag 5707 pt(k,j,i) = pt(k,j,i) - ( sed_qc(k+1) - sed_qc(k) ) * &5708 ddzu(k+1) / hyrho(k) * lv_d_cp * &5709 d_exner(k) * dt_micro 5553 pt(k,j,i) = pt(k,j,i) - ( sed_qc(k+1) - sed_qc(k) ) * & 5554 ddzu(k+1) / hyrho(k) * lv_d_cp * & 5555 d_exner(k) * dt_micro * flag 5710 5556 5711 5557 ! 5712 5558 !-- Compute the precipitation rate due to cloud (fog) droplets 5713 5559 IF ( call_microphysics_at_all_substeps ) THEN 5714 prr(k,j,i) = prr(k,j,i) + sed_qc(k) / hyrho(k) &5715 * weight_substep(intermediate_timestep_count) &5560 prr(k,j,i) = prr(k,j,i) + sed_qc(k) / hyrho(k) & 5561 * weight_substep(intermediate_timestep_count) & 5716 5562 * flag 5717 5563 ELSE … … 5728 5574 5729 5575 5730 !------------------------------------------------------------------------------ !5576 !--------------------------------------------------------------------------------------------------! 5731 5577 ! Description: 5732 5578 ! ------------ 5733 5579 !> Sedimentation of cloud droplets (Ackermann et al., 2009, MWR). 5734 5580 !> Call for grid point i,j 5735 !------------------------------------------------------------------------------ !5581 !--------------------------------------------------------------------------------------------------! 5736 5582 SUBROUTINE sedimentation_cloud_ij( i, j ) 5737 5583 … … 5756 5602 !-- Predetermine flag to mask topography 5757 5603 flag = MERGE( 1.0_wp, 0.0_wp, BTEST( wall_flags_total_0(k,j,i), 0 ) ) 5758 IF ( microphysics_morrison ) THEN5604 IF ( microphysics_morrison ) THEN 5759 5605 nc_sedi = nc(k,j,i) 5760 5606 ELSE … … 5762 5608 ENDIF 5763 5609 ! 5764 !-- Sedimentation fluxes for number concentration are only calculated 5765 !-- for cloud_scheme ='morrison'5766 IF ( microphysics_morrison ) THEN5610 !-- Sedimentation fluxes for number concentration are only calculated for cloud_scheme = 5611 !-- 'morrison' 5612 IF ( microphysics_morrison ) THEN 5767 5613 IF ( qc(k,j,i) > eps_sb .AND. nc(k,j,i) > eps_mr ) THEN 5768 sed_nc(k) = sed_qc_const * & 5769 ( qc(k,j,i) * hyrho(k) )**( 2.0_wp / 3.0_wp ) * & 5614 sed_nc(k) = sed_qc_const * ( qc(k,j,i) * hyrho(k) )**( 2.0_wp / 3.0_wp ) * & 5770 5615 ( nc(k,j,i) )**( 1.0_wp / 3.0_wp ) 5771 5616 ELSE … … 5773 5618 ENDIF 5774 5619 5775 sed_nc(k) = MIN( sed_nc(k), hyrho(k) * dzu(k+1) * &5776 nc(k,j,i) / dt_micro + sed_nc(k+1) &5620 sed_nc(k) = MIN( sed_nc(k), hyrho(k) * dzu(k+1) * & 5621 nc(k,j,i) / dt_micro + sed_nc(k+1) & 5777 5622 ) * flag 5778 5623 5779 nc(k,j,i) = nc(k,j,i) + ( sed_nc(k+1) - sed_nc(k) ) * &5780 ddzu(k+1) /hyrho(k) * dt_micro * flag5624 nc(k,j,i) = nc(k,j,i) + ( sed_nc(k+1) - sed_nc(k) ) * ddzu(k+1) / & 5625 hyrho(k) * dt_micro * flag 5781 5626 ENDIF 5782 5627 5783 5628 IF ( qc(k,j,i) > eps_sb .AND. nc_sedi > eps_mr ) THEN 5784 sed_qc(k) = sed_qc_const * nc_sedi**( -2.0_wp / 3.0_wp ) *&5629 sed_qc(k) = sed_qc_const * nc_sedi**( -2.0_wp / 3.0_wp ) * & 5785 5630 ( qc(k,j,i) * hyrho(k) )**( 5.0_wp / 3.0_wp ) * flag 5786 5631 ELSE … … 5788 5633 ENDIF 5789 5634 5790 sed_qc(k) = MIN( sed_qc(k), hyrho(k) * dzu(k+1) * q(k,j,i) / & 5791 dt_micro + sed_qc(k+1) & 5635 sed_qc(k) = MIN( sed_qc(k), hyrho(k) * dzu(k+1) * q(k,j,i) / dt_micro + sed_qc(k+1) & 5792 5636 ) * flag 5793 5637 5794 q(k,j,i) = q(k,j,i) + ( sed_qc(k+1) - sed_qc(k) ) * ddzu(k+1) / & 5795 hyrho(k) * dt_micro * flag 5796 qc(k,j,i) = qc(k,j,i) + ( sed_qc(k+1) - sed_qc(k) ) * ddzu(k+1) / & 5797 hyrho(k) * dt_micro * flag 5798 pt(k,j,i) = pt(k,j,i) - ( sed_qc(k+1) - sed_qc(k) ) * ddzu(k+1) / & 5799 hyrho(k) * lv_d_cp * d_exner(k) * dt_micro & 5800 * flag 5638 q(k,j,i) = q(k,j,i) + ( sed_qc(k+1) - sed_qc(k) ) * & 5639 ddzu(k+1) / hyrho(k) * dt_micro * flag 5640 qc(k,j,i) = qc(k,j,i) + ( sed_qc(k+1) - sed_qc(k) ) * & 5641 ddzu(k+1) / hyrho(k) * dt_micro * flag 5642 pt(k,j,i) = pt(k,j,i) - ( sed_qc(k+1) - sed_qc(k) ) * & 5643 ddzu(k+1) / hyrho(k) * lv_d_cp * d_exner(k) * dt_micro * flag 5801 5644 5802 5645 ! 5803 5646 !-- Compute the precipitation rate of cloud (fog) droplets 5804 5647 IF ( call_microphysics_at_all_substeps ) THEN 5805 prr(k,j,i) = prr(k,j,i) + sed_qc(k) / hyrho(k) * &5806 5648 prr(k,j,i) = prr(k,j,i) + sed_qc(k) / hyrho(k) * & 5649 weight_substep(intermediate_timestep_count) * flag 5807 5650 ELSE 5808 5651 prr(k,j,i) = prr(k,j,i) + sed_qc(k) / hyrho(k) * flag … … 5813 5656 END SUBROUTINE sedimentation_cloud_ij 5814 5657 5815 !------------------------------------------------------------------------------ !5658 !--------------------------------------------------------------------------------------------------! 5816 5659 ! Description: 5817 5660 ! ------------ 5818 5661 !> Sedimentation of ice crystals 5819 !------------------------------------------------------------------------------ !5662 !--------------------------------------------------------------------------------------------------! 5820 5663 SUBROUTINE sedimentation_ice 5821 5664 … … 5824 5667 INTEGER(iwp) :: k !< loop index 5825 5668 5826 REAL(wp) :: flag !< flag to indicate first grid level 5827 REAL(wp) :: av = 6.39_wp !< parameter for calculating fall speed 5828 REAL(wp) :: bv = 0.1666_wp !< parameter (1/6) 5829 REAL(wp) :: xi = 0.0_wp !< mean mass of ice crystal 5830 REAL(wp) :: vi = 0.0_wp !< mean fall speed of ice crystal 5831 REAL(wp) :: factor_sed_gamma_k0 = 0.76_wp !< factor for zeroth moment and 5832 !< µ =1/3 and nu=0 5833 REAL(wp) :: factor_sed_gamma_k1 = 1.61_wp !< factor for first moment and 5834 !< µ =1/3 and nu=0 5669 REAL(wp) :: av = 6.39_wp !< parameter for calculating fall speed 5670 REAL(wp) :: bv = 0.1666_wp !< parameter (1/6) 5671 REAL(wp) :: factor_sed_gamma_k0 = 0.76_wp !< factor for zeroth moment and µ =1/3 and nu=0 5672 REAL(wp) :: factor_sed_gamma_k1 = 1.61_wp !< factor for first moment and µ =1/3 and nu=0 5673 REAL(wp) :: flag !< flag to indicate first grid level 5674 REAL(wp) :: xi = 0.0_wp !< mean mass of ice crystal 5675 REAL(wp) :: vi = 0.0_wp !< mean fall speed of ice crystal 5835 5676 5836 5677 REAL(wp), DIMENSION(nzb:nzt+1) :: sed_ni !< sedimentation rate zeroth moment … … 5846 5687 DO k = nzt, nzb+1, -1 5847 5688 5848 IF ( ni(k,j,i) <= 0.0_wp ) THEN5689 IF ( ni(k,j,i) <= 0.0_wp ) THEN 5849 5690 xi = 0.0_wp 5850 5691 ELSE … … 5853 5694 ENDIF 5854 5695 ! 5855 !-- calculate fall speed of ice crystal5696 !-- Calculate fall speed of ice crystal 5856 5697 vi = av * xi**bv 5857 5698 ! … … 5859 5700 flag = MERGE( 1.0_wp, 0.0_wp, BTEST( wall_flags_total_0(k,j,i), 0 ) ) 5860 5701 ! 5861 !-- Calculate sedimentation rate for each grid box, factors are 5862 !-- calculated using 5702 !-- Calculate sedimentation rate for each grid box, factors are calculated using !> explanation missing eventually 5863 5703 IF ( qi(k,j,i) > eps_sb .AND. ni(k,j,i) >= 0.0_wp ) THEN 5864 5704 sed_qi(k) = qi(k,j,i) * vi * factor_sed_gamma_k1 * flag … … 5870 5710 ! 5871 5711 !-- Calculate sedimentation: divergence of sedimentation flux 5872 sed_qi(k) = MIN( sed_qi(k), hyrho(k) * dzu(k+1) * q(k,j,i) / & 5873 dt_micro + sed_qi(k+1) & 5712 sed_qi(k) = MIN( sed_qi(k), hyrho(k) * dzu(k+1) * q(k,j,i) / dt_micro + sed_qi(k+1)& 5874 5713 ) * flag 5875 5714 5876 q(k,j,i) = q(k,j,i) + ( sed_qi(k+1) - sed_qi(k) ) * ddzu(k+1) &5715 q(k,j,i) = q(k,j,i) + ( sed_qi(k+1) - sed_qi(k) ) * ddzu(k+1) & 5877 5716 / hyrho(k) * dt_micro * flag 5878 qi(k,j,i) = qi(k,j,i) + ( sed_qi(k+1) - sed_qi(k) ) * ddzu(k+1) &5717 qi(k,j,i) = qi(k,j,i) + ( sed_qi(k+1) - sed_qi(k) ) * ddzu(k+1) & 5879 5718 / hyrho(k) * dt_micro * flag 5880 ni(k,j,i) = ni(k,j,i) + ( sed_ni(k+1) - sed_ni(k) ) * ddzu(k+1) &5719 ni(k,j,i) = ni(k,j,i) + ( sed_ni(k+1) - sed_ni(k) ) * ddzu(k+1) & 5881 5720 / hyrho(k) * dt_micro * flag 5882 5721 5883 pt(k,j,i) = pt(k,j,i) - ( sed_qi(k+1) - sed_qi(k) ) * ddzu(k+1) &5884 / hyrho(k) * l_s / c_p * d_exner(k) * &5722 pt(k,j,i) = pt(k,j,i) - ( sed_qi(k+1) - sed_qi(k) ) * ddzu(k+1) & 5723 / hyrho(k) * l_s / c_p * d_exner(k) * & 5885 5724 dt_micro * flag 5886 5725 ! 5887 5726 !-- Compute the precipitation rate of cloud (fog) droplets 5888 5727 IF ( call_microphysics_at_all_substeps ) THEN 5889 prr(k,j,i) = prr(k,j,i) + sed_qi(k) / hyrho(k) * & 5890 weight_substep(intermediate_timestep_count) * & 5891 flag 5728 prr(k,j,i) = prr(k,j,i) + sed_qi(k) / hyrho(k) * & 5729 weight_substep(intermediate_timestep_count) * flag 5892 5730 ELSE 5893 5731 prr(k,j,i) = prr(k,j,i) + sed_qi(k) / hyrho(k) * flag … … 5903 5741 5904 5742 5905 !------------------------------------------------------------------------------ !5743 !--------------------------------------------------------------------------------------------------! 5906 5744 ! Description: 5907 5745 ! ------------ 5908 5746 !> Sedimentation of ice crystals 5909 !------------------------------------------------------------------------------ !5747 !--------------------------------------------------------------------------------------------------! 5910 5748 SUBROUTINE sedimentation_ice_ij( i, j ) 5911 5749 … … 5914 5752 INTEGER(iwp) :: k !< 5915 5753 5916 REAL(wp) :: flag !< flag to indicate first grid level5917 5754 REAL(wp) :: av = 6.39_wp !< parameter for calculating fall speed 5918 5755 REAL(wp) :: bv = 0.1666_wp !< 5756 REAL(wp) :: factor_sed_gamma_k0 = 0.76_wp 5757 REAL(wp) :: factor_sed_gamma_k1 = 1.61_wp 5758 REAL(wp) :: flag !< flag to indicate first grid level 5919 5759 REAL(wp) :: xi = 0.0_wp !< mean mass of ice crystal 5920 5760 REAL(wp) :: vi = 0.0_wp !< mean fall speed of ice crystal 5921 REAL(wp) :: factor_sed_gamma_k0 = 0.76_wp5922 REAL(wp) :: factor_sed_gamma_k1 = 1.61_wp5923 5761 5924 5762 REAL(wp), DIMENSION(nzb:nzt+1) :: sed_ni !< … … 5929 5767 5930 5768 DO k = nzt, nzb+1, -1 5931 IF ( ni(k,j,i) <= 0.0_wp ) THEN5769 IF ( ni(k,j,i) <= 0.0_wp ) THEN 5932 5770 xi = 0.0_wp 5933 5771 ELSE … … 5966 5804 ENDIF 5967 5805 5968 sed_qi(k) = MIN( sed_qi(k), hyrho(k) * dzu(k+1) * q(k,j,i) / & 5969 dt_micro + sed_qi(k+1) & 5806 sed_qi(k) = MIN( sed_qi(k), hyrho(k) * dzu(k+1) * q(k,j,i) / dt_micro + sed_qi(k+1) & 5970 5807 ) * flag 5971 5808 5972 q(k,j,i) = q(k,j,i) + ( sed_qi(k+1) - sed_qi(k) ) * ddzu(k+1) / &5809 q(k,j,i) = q(k,j,i) + ( sed_qi(k+1) - sed_qi(k) ) * ddzu(k+1) / & 5973 5810 hyrho(k) * dt_micro * flag 5974 qi(k,j,i) = qi(k,j,i) + ( sed_qi(k+1) - sed_qi(k) ) * ddzu(k+1) / &5811 qi(k,j,i) = qi(k,j,i) + ( sed_qi(k+1) - sed_qi(k) ) * ddzu(k+1) / & 5975 5812 hyrho(k) * dt_micro * flag 5976 ni(k,j,i) = ni(k,j,i) + ( sed_ni(k+1) - sed_ni(k) ) * ddzu(k+1) / &5813 ni(k,j,i) = ni(k,j,i) + ( sed_ni(k+1) - sed_ni(k) ) * ddzu(k+1) / & 5977 5814 hyrho(k) * dt_micro * flag 5978 pt(k,j,i) = pt(k,j,i) - ( sed_qi(k+1) - sed_qi(k) ) * ddzu(k+1) / & 5979 hyrho(k) * l_s / c_p * d_exner(k) * dt_micro & 5980 * flag 5815 pt(k,j,i) = pt(k,j,i) - ( sed_qi(k+1) - sed_qi(k) ) * ddzu(k+1) / & 5816 hyrho(k) * l_s / c_p * d_exner(k) * dt_micro * flag 5981 5817 ! 5982 5818 !-- Compute the precipitation rate of cloud (fog) droplets 5983 5819 IF ( call_microphysics_at_all_substeps ) THEN 5984 prr(k,j,i) = prr(k,j,i) + sed_qi(k) / hyrho(k) * &5985 5820 prr(k,j,i) = prr(k,j,i) + sed_qi(k) / hyrho(k) * & 5821 weight_substep(intermediate_timestep_count) * flag 5986 5822 ELSE 5987 5823 prr(k,j,i) = prr(k,j,i) + sed_qi(k) / hyrho(k) * flag … … 5994 5830 5995 5831 5996 !------------------------------------------------------------------------------ !5832 !--------------------------------------------------------------------------------------------------! 5997 5833 ! Description: 5998 5834 ! ------------ 5999 5835 !> Computation of sedimentation flux. Implementation according to Stevens 6000 5836 !> and Seifert (2008). Code is based on UCLA-LES. 6001 !------------------------------------------------------------------------------ !5837 !--------------------------------------------------------------------------------------------------! 6002 5838 SUBROUTINE sedimentation_rain 6003 5839 … … 6046 5882 ! 6047 5883 !-- Weight averaged diameter of rain drops: 6048 dr = ( hyrho(k) * qr(k,j,i) / & 6049 nr(k,j,i) * dpirho_l )**( 1.0_wp / 3.0_wp ) 5884 dr = ( hyrho(k) * qr(k,j,i) / nr(k,j,i) * dpirho_l )**( 1.0_wp / 3.0_wp ) 6050 5885 ! 6051 5886 !-- Shape parameter of gamma distribution (Milbrandt and Yau, 2005; 6052 5887 !-- Stevens and Seifert, 2008): 6053 mu_r = 10.0_wp * ( 1.0_wp + TANH( 1.2E3_wp * & 6054 ( dr - 1.4E-3_wp ) ) ) 5888 mu_r = 10.0_wp * ( 1.0_wp + TANH( 1.2E3_wp * ( dr - 1.4E-3_wp ) ) ) 6055 5889 ! 6056 5890 !-- Slope parameter of gamma distribution (Seifert, 2008): 6057 lambda_r = ( ( mu_r + 3.0_wp ) * ( mu_r + 2.0_wp ) * &5891 lambda_r = ( ( mu_r + 3.0_wp ) * ( mu_r + 2.0_wp ) * & 6058 5892 ( mu_r + 1.0_wp ) )**( 1.0_wp / 3.0_wp ) / dr 6059 5893 6060 w_nr(k) = MAX( 0.1_wp, MIN( 20.0_wp, &6061 a_term - b_term * ( 1.0_wp + &6062 c_term / &6063 lambda_r )**( -1.0_wp * &6064 ( mu_r + 1.0_wp ) ) &6065 ) &5894 w_nr(k) = MAX( 0.1_wp, MIN( 20.0_wp, & 5895 a_term - b_term * ( 1.0_wp + & 5896 c_term / & 5897 lambda_r )**( -1.0_wp * & 5898 ( mu_r + 1.0_wp ) ) & 5899 ) & 6066 5900 ) * flag 6067 5901 6068 w_qr(k) = MAX( 0.1_wp, MIN( 20.0_wp, &6069 a_term - b_term * ( 1.0_wp + &6070 c_term / &6071 lambda_r )**( -1.0_wp * &6072 ( mu_r + 4.0_wp ) ) &6073 ) &5902 w_qr(k) = MAX( 0.1_wp, MIN( 20.0_wp, & 5903 a_term - b_term * ( 1.0_wp + & 5904 c_term / & 5905 lambda_r )**( -1.0_wp * & 5906 ( mu_r + 4.0_wp ) ) & 5907 ) & 6074 5908 ) * flag 6075 5909 ELSE … … 6108 5942 flag = MERGE( 1.0_wp, 0.0_wp, BTEST( wall_flags_total_0(k,j,i), 0 ) ) 6109 5943 6110 c_nr(k) = 0.25_wp * ( w_nr(k-1) + & 6111 2.0_wp * w_nr(k) + w_nr(k+1) ) * & 5944 c_nr(k) = 0.25_wp * ( w_nr(k-1) + 2.0_wp * w_nr(k) + w_nr(k+1) ) * & 6112 5945 dt_micro * ddzu(k) * flag 6113 c_qr(k) = 0.25_wp * ( w_qr(k-1) + & 6114 2.0_wp * w_qr(k) + w_qr(k+1) ) * & 5946 c_qr(k) = 0.25_wp * ( w_qr(k-1) + 2.0_wp * w_qr(k) + w_qr(k+1) ) * & 6115 5947 dt_micro * ddzu(k) * flag 6116 5948 ENDDO … … 6128 5960 d_max = MAX( qr(k+1,j,i), qr(k,j,i), qr(k-1,j,i) ) - qr(k,j,i) 6129 5961 6130 qr_slope(k) = SIGN(1.0_wp, d_mean) * MIN ( 2.0_wp * d_min, & 6131 2.0_wp * d_max, & 6132 ABS( d_mean ) ) & 5962 qr_slope(k) = SIGN(1.0_wp, d_mean) * MIN ( 2.0_wp * d_min, 2.0_wp * d_max, & 5963 ABS( d_mean ) ) & 6133 5964 * flag 6134 5965 … … 6137 5968 d_max = MAX( nr(k+1,j,i), nr(k,j,i), nr(k-1,j,i) ) - nr(k,j,i) 6138 5969 6139 nr_slope(k) = SIGN(1.0_wp, d_mean) * MIN ( 2.0_wp * d_min, & 6140 2.0_wp * d_max, & 5970 nr_slope(k) = SIGN(1.0_wp, d_mean) * MIN ( 2.0_wp * d_min, 2.0_wp * d_max, & 6141 5971 ABS( d_mean ) ) 6142 5972 ENDDO … … 6165 5995 c_run = MIN( 1.0_wp, c_nr(k) ) 6166 5996 DO WHILE ( c_run > 0.0_wp .AND. k_run <= nzt ) 6167 flux = flux + hyrho(k_run) * & 6168 ( nr(k_run,j,i) + nr_slope(k_run) * & 6169 ( 1.0_wp - c_run ) * 0.5_wp ) * c_run * dzu(k_run) & 6170 * flag 5997 flux = flux + hyrho(k_run) * ( nr(k_run,j,i) + nr_slope(k_run) * & 5998 ( 1.0_wp - c_run ) * 0.5_wp ) * c_run * dzu(k_run) * flag 6171 5999 z_run = z_run + dzu(k_run) * flag 6172 6000 k_run = k_run + 1 * flag 6173 c_run = MIN( 1.0_wp, c_nr(k_run) - z_run * ddzu(k_run) ) & 6174 * flag 6001 c_run = MIN( 1.0_wp, c_nr(k_run) - z_run * ddzu(k_run) ) * flag 6175 6002 ENDDO 6176 6003 ! 6177 !-- It is not allowed to sediment more rain drop number density than 6178 !-- available 6179 flux = MIN( flux, & 6180 hyrho(k) * dzu(k+1) * nr(k,j,i) + sed_nr(k+1) * & 6181 dt_micro & 6182 ) 6004 !-- It is not allowed to sediment more rain drop number density than available. 6005 flux = MIN( flux, hyrho(k) * dzu(k+1) * nr(k,j,i) + sed_nr(k+1) * dt_micro ) 6183 6006 6184 6007 sed_nr(k) = flux / dt_micro * flag 6185 nr(k,j,i) = nr(k,j,i) + ( sed_nr(k+1) - sed_nr(k) ) * &6008 nr(k,j,i) = nr(k,j,i) + ( sed_nr(k+1) - sed_nr(k) ) * & 6186 6009 ddzu(k+1) / hyrho(k) * dt_micro * flag 6187 6010 ! 6188 !-- Sum up all rain water content which contributes to the flux 6189 !-- through k-1/2 6011 !-- Sum up all rain water content which contributes to the flux through k-1/2 6190 6012 flux = 0.0_wp 6191 6013 z_run = 0.0_wp ! height above z(k) … … 6195 6017 DO WHILE ( c_run > 0.0_wp .AND. k_run <= nzt ) 6196 6018 6197 flux = flux + hyrho(k_run) * ( qr(k_run,j,i) + &6198 qr_slope(k_run) * ( 1.0_wp - c_run ) * &6019 flux = flux + hyrho(k_run) * ( qr(k_run,j,i) + & 6020 qr_slope(k_run) * ( 1.0_wp - c_run ) * & 6199 6021 0.5_wp ) * c_run * dzu(k_run) * flag 6200 6022 z_run = z_run + dzu(k_run) * flag 6201 6023 k_run = k_run + 1 * flag 6202 c_run = MIN( 1.0_wp, c_qr(k_run) - z_run * ddzu(k_run) ) &6024 c_run = MIN( 1.0_wp, c_qr(k_run) - z_run * ddzu(k_run) ) & 6203 6025 * flag 6204 6026 6205 6027 ENDDO 6206 6028 ! 6207 !-- It is not allowed to sediment more rain water content than 6208 !-- available 6209 flux = MIN( flux, & 6210 hyrho(k) * dzu(k) * qr(k,j,i) + sed_qr(k+1) * & 6211 dt_micro & 6212 ) 6029 !-- It is not allowed to sediment more rain water content than available. 6030 flux = MIN( flux, hyrho(k) * dzu(k) * qr(k,j,i) + sed_qr(k+1) * dt_micro ) 6213 6031 6214 6032 sed_qr(k) = flux / dt_micro * flag 6215 6033 6216 qr(k,j,i) = qr(k,j,i) + ( sed_qr(k+1) - sed_qr(k) ) * &6034 qr(k,j,i) = qr(k,j,i) + ( sed_qr(k+1) - sed_qr(k) ) * & 6217 6035 ddzu(k+1) / hyrho(k) * dt_micro * flag 6218 q(k,j,i) = q(k,j,i) + ( sed_qr(k+1) - sed_qr(k) ) * &6036 q(k,j,i) = q(k,j,i) + ( sed_qr(k+1) - sed_qr(k) ) * & 6219 6037 ddzu(k+1) / hyrho(k) * dt_micro * flag 6220 pt(k,j,i) = pt(k,j,i) - ( sed_qr(k+1) - sed_qr(k) ) * &6221 ddzu(k+1) / hyrho(k) * lv_d_cp * &6038 pt(k,j,i) = pt(k,j,i) - ( sed_qr(k+1) - sed_qr(k) ) * & 6039 ddzu(k+1) / hyrho(k) * lv_d_cp * & 6222 6040 d_exner(k) * dt_micro * flag 6223 6041 ! 6224 6042 !-- Compute the rain rate 6225 6043 IF ( call_microphysics_at_all_substeps ) THEN 6226 prr(k,j,i) = prr(k,j,i) + sed_qr(k) / hyrho(k) & 6227 * weight_substep(intermediate_timestep_count) & 6228 * flag 6044 prr(k,j,i) = prr(k,j,i) + sed_qr(k) / hyrho(k) & 6045 * weight_substep(intermediate_timestep_count) * flag 6229 6046 ELSE 6230 6047 prr(k,j,i) = prr(k,j,i) + sed_qr(k) / hyrho(k) * flag … … 6240 6057 6241 6058 6242 !------------------------------------------------------------------------------ !6059 !--------------------------------------------------------------------------------------------------! 6243 6060 ! Description: 6244 6061 ! ------------ 6245 6062 !> Computation of sedimentation flux. Implementation according to Stevens 6246 6063 !> and Seifert (2008). Code is based on UCLA-LES. Call for grid point i,j 6247 !------------------------------------------------------------------------------ !6064 !--------------------------------------------------------------------------------------------------! 6248 6065 SUBROUTINE sedimentation_rain_ij( i, j ) 6249 6066 … … 6258 6075 INTEGER(iwp) :: surf_s !< Start index of surface elements at (j,i)-gridpoint 6259 6076 6260 REAL(wp) :: c_run 6261 REAL(wp) :: d_max 6262 REAL(wp) :: d_mean 6263 REAL(wp) :: d_min 6264 REAL(wp) :: dr 6265 REAL(wp) :: flux 6266 REAL(wp) :: flag 6267 REAL(wp) :: lambda_r 6268 REAL(wp) :: mu_r 6269 REAL(wp) :: z_run 6077 REAL(wp) :: c_run !< 6078 REAL(wp) :: d_max !< 6079 REAL(wp) :: d_mean !< 6080 REAL(wp) :: d_min !< 6081 REAL(wp) :: dr !< 6082 REAL(wp) :: flux !< 6083 REAL(wp) :: flag !< flag to indicate first grid level above surface 6084 REAL(wp) :: lambda_r !< 6085 REAL(wp) :: mu_r !< 6086 REAL(wp) :: z_run !< 6270 6087 6271 6088 REAL(wp), DIMENSION(nzb:nzt+1) :: c_nr !< … … 6295 6112 ! 6296 6113 !-- Slope parameter of gamma distribution (Seifert, 2008): 6297 lambda_r = ( ( mu_r + 3.0_wp ) * ( mu_r + 2.0_wp ) * &6114 lambda_r = ( ( mu_r + 3.0_wp ) * ( mu_r + 2.0_wp ) * & 6298 6115 ( mu_r + 1.0_wp ) )**( 1.0_wp / 3.0_wp ) / dr 6299 6116 6300 w_nr(k) = MAX( 0.1_wp, MIN( 20.0_wp, & 6301 a_term - b_term * ( 1.0_wp + & 6302 c_term / lambda_r )**( -1.0_wp * & 6303 ( mu_r + 1.0_wp ) ) & 6304 ) & 6117 w_nr(k) = MAX( 0.1_wp, MIN( 20.0_wp, & 6118 a_term - b_term * ( 1.0_wp + c_term / lambda_r & 6119 )**( -1.0_wp * ( mu_r + 1.0_wp ) ) & 6120 ) & 6305 6121 ) * flag 6306 w_qr(k) = MAX( 0.1_wp, MIN( 20.0_wp, & 6307 a_term - b_term * ( 1.0_wp + & 6308 c_term / lambda_r )**( -1.0_wp * & 6309 ( mu_r + 4.0_wp ) ) & 6310 ) & 6122 w_qr(k) = MAX( 0.1_wp, MIN( 20.0_wp, & 6123 a_term - b_term * ( 1.0_wp + c_term / lambda_r & 6124 )**( -1.0_wp * ( mu_r + 4.0_wp ) ) & 6125 ) & 6311 6126 ) * flag 6312 6127 ELSE … … 6345 6160 flag = MERGE( 1.0_wp, 0.0_wp, BTEST( wall_flags_total_0(k,j,i), 0 ) ) 6346 6161 6347 c_nr(k) = 0.25_wp * ( w_nr(k-1) + 2.0_wp * w_nr(k) + w_nr(k+1) ) * &6162 c_nr(k) = 0.25_wp * ( w_nr(k-1) + 2.0_wp * w_nr(k) + w_nr(k+1) ) * & 6348 6163 dt_micro * ddzu(k) * flag 6349 c_qr(k) = 0.25_wp * ( w_qr(k-1) + 2.0_wp * w_qr(k) + w_qr(k+1) ) * &6164 c_qr(k) = 0.25_wp * ( w_qr(k-1) + 2.0_wp * w_qr(k) + w_qr(k+1) ) * & 6350 6165 dt_micro * ddzu(k) * flag 6351 6166 ENDDO … … 6363 6178 d_max = MAX( qr(k+1,j,i), qr(k,j,i), qr(k-1,j,i) ) - qr(k,j,i) 6364 6179 6365 qr_slope(k) = SIGN(1.0_wp, d_mean) * MIN ( 2.0_wp * d_min, & 6366 2.0_wp * d_max, & 6180 qr_slope(k) = SIGN(1.0_wp, d_mean) * MIN ( 2.0_wp * d_min, 2.0_wp * d_max, & 6367 6181 ABS( d_mean ) ) * flag 6368 6182 … … 6371 6185 d_max = MAX( nr(k+1,j,i), nr(k,j,i), nr(k-1,j,i) ) - nr(k,j,i) 6372 6186 6373 nr_slope(k) = SIGN(1.0_wp, d_mean) * MIN ( 2.0_wp * d_min, & 6374 2.0_wp * d_max, & 6187 nr_slope(k) = SIGN(1.0_wp, d_mean) * MIN ( 2.0_wp * d_min, 2.0_wp * d_max, & 6375 6188 ABS( d_mean ) ) * flag 6376 6189 ENDDO … … 6392 6205 flag = MERGE( 1.0_wp, 0.0_wp, BTEST( wall_flags_total_0(k,j,i), 0 ) ) 6393 6206 ! 6394 !-- Sum up all rain drop number densities which contribute to the flux 6395 !-- through k-1/2 6207 !-- Sum up all rain drop number densities which contribute to the flux through k-1/2 6396 6208 flux = 0.0_wp 6397 6209 z_run = 0.0_wp ! height above z(k) … … 6399 6211 c_run = MIN( 1.0_wp, c_nr(k) ) 6400 6212 DO WHILE ( c_run > 0.0_wp .AND. k_run <= nzt ) 6401 flux = flux + hyrho(k_run) * &6402 ( nr(k_run,j,i) + nr_slope(k_run) * ( 1.0_wp - c_run ) * &6403 0.5_wp ) * c_run * dzu(k_run)* flag6213 flux = flux + hyrho(k_run) * & 6214 ( nr(k_run,j,i) + nr_slope(k_run) * ( 1.0_wp - c_run ) * 0.5_wp ) * & 6215 c_run * dzu(k_run) * flag 6404 6216 z_run = z_run + dzu(k_run) * flag 6405 6217 k_run = k_run + 1 * flag … … 6407 6219 ENDDO 6408 6220 ! 6409 !-- It is not allowed to sediment more rain drop number density than 6410 !-- available 6411 flux = MIN( flux, & 6412 hyrho(k) * dzu(k+1) * nr(k,j,i) + sed_nr(k+1) * dt_micro ) 6221 !-- It is not allowed to sediment more rain drop number density than available. 6222 flux = MIN( flux, hyrho(k) * dzu(k+1) * nr(k,j,i) + sed_nr(k+1) * dt_micro ) 6413 6223 6414 6224 sed_nr(k) = flux / dt_micro * flag 6415 nr(k,j,i) = nr(k,j,i) + ( sed_nr(k+1) - sed_nr(k) ) * ddzu(k+1) / &6225 nr(k,j,i) = nr(k,j,i) + ( sed_nr(k+1) - sed_nr(k) ) * ddzu(k+1) / & 6416 6226 hyrho(k) * dt_micro * flag 6417 6227 ! … … 6425 6235 DO WHILE ( c_run > 0.0_wp .AND. k_run <= nzt ) 6426 6236 6427 flux = flux + hyrho(k_run) * &6428 ( qr(k_run,j,i) + qr_slope(k_run) * ( 1.0_wp - c_run ) * &6429 0.5_wp ) * c_run * dzu(k_run)* flag6237 flux = flux + hyrho(k_run) * & 6238 ( qr(k_run,j,i) + qr_slope(k_run) * ( 1.0_wp - c_run ) * 0.5_wp ) * & 6239 c_run * dzu(k_run) * flag 6430 6240 z_run = z_run + dzu(k_run) * flag 6431 6241 k_run = k_run + 1 * flag … … 6434 6244 ENDDO 6435 6245 ! 6436 !-- It is not allowed to sediment more rain water content than available 6437 flux = MIN( flux, & 6438 hyrho(k) * dzu(k) * qr(k,j,i) + sed_qr(k+1) * dt_micro ) 6246 !-- It is not allowed to sediment more rain water content than available. 6247 flux = MIN( flux, hyrho(k) * dzu(k) * qr(k,j,i) + sed_qr(k+1) * dt_micro ) 6439 6248 6440 6249 sed_qr(k) = flux / dt_micro * flag 6441 6250 6442 qr(k,j,i) = qr(k,j,i) + ( sed_qr(k+1) - sed_qr(k) ) * ddzu(k+1) / &6251 qr(k,j,i) = qr(k,j,i) + ( sed_qr(k+1) - sed_qr(k) ) * ddzu(k+1) / & 6443 6252 hyrho(k) * dt_micro * flag 6444 q(k,j,i) = q(k,j,i) + ( sed_qr(k+1) - sed_qr(k) ) * ddzu(k+1) / &6253 q(k,j,i) = q(k,j,i) + ( sed_qr(k+1) - sed_qr(k) ) * ddzu(k+1) / & 6445 6254 hyrho(k) * dt_micro * flag 6446 pt(k,j,i) = pt(k,j,i) - ( sed_qr(k+1) - sed_qr(k) ) * ddzu(k+1) / & 6447 hyrho(k) * lv_d_cp * d_exner(k) * dt_micro & 6448 * flag 6255 pt(k,j,i) = pt(k,j,i) - ( sed_qr(k+1) - sed_qr(k) ) * ddzu(k+1) / & 6256 hyrho(k) * lv_d_cp * d_exner(k) * dt_micro * flag 6449 6257 ! 6450 6258 !-- Compute the rain rate 6451 6259 IF ( call_microphysics_at_all_substeps ) THEN 6452 prr(k,j,i) = prr(k,j,i) + sed_qr(k) / hyrho(k) &6260 prr(k,j,i) = prr(k,j,i) + sed_qr(k) / hyrho(k) & 6453 6261 * weight_substep(intermediate_timestep_count) * flag 6454 6262 ELSE … … 6461 6269 6462 6270 6463 !------------------------------------------------------------------------------ !6271 !--------------------------------------------------------------------------------------------------! 6464 6272 ! Description: 6465 6273 ! ------------ 6466 !> Computation of the precipitation amount due to gravitational settling of 6467 !> rain and cloud (fog)droplets6468 !------------------------------------------------------------------------------ !6274 !> Computation of the precipitation amount due to gravitational settling of rain and cloud (fog) 6275 !> droplets 6276 !--------------------------------------------------------------------------------------------------! 6469 6277 SUBROUTINE calc_precipitation_amount 6470 6278 … … 6476 6284 INTEGER(iwp) :: m !< running index surface elements 6477 6285 6478 IF ( ( dt_do2d_xy - time_do2d_xy ) < precipitation_amount_interval .AND. &6479 ( .NOT. call_microphysics_at_all_substeps .OR. &6480 intermediate_timestep_count == intermediate_timestep_count_max ) ) &6286 IF ( ( dt_do2d_xy - time_do2d_xy ) < precipitation_amount_interval .AND. & 6287 ( .NOT. call_microphysics_at_all_substeps .OR. & 6288 intermediate_timestep_count == intermediate_timestep_count_max ) ) & 6481 6289 THEN 6482 6290 ! 6483 !-- Run over all upward-facing surface elements, i.e. non-natural, 6484 !-- natural and urban 6291 !-- Run over all upward-facing surface elements, i.e. non-natural, natural and urban 6485 6292 DO m = 1, bc_h(0)%ns 6486 6293 i = bc_h(0)%i(m) 6487 6294 j = bc_h(0)%j(m) 6488 6295 k = bc_h(0)%k(m) 6489 precipitation_amount(j,i) = precipitation_amount(j,i) + & 6490 prr(k,j,i) * hyrho(k) * dt_3d 6296 precipitation_amount(j,i) = precipitation_amount(j,i) + prr(k,j,i) * hyrho(k) * dt_3d 6491 6297 ENDDO 6492 6298 … … 6496 6302 6497 6303 6498 !------------------------------------------------------------------------------ !6304 !--------------------------------------------------------------------------------------------------! 6499 6305 ! Description: 6500 6306 ! ------------ 6501 !> This subroutine computes the precipitation amount due to gravitational 6502 !> settling of rain and cloud(fog) droplets6503 !------------------------------------------------------------------------------ !6307 !> This subroutine computes the precipitation amount due to gravitational settling of rain and cloud 6308 !> (fog) droplets 6309 !--------------------------------------------------------------------------------------------------! 6504 6310 SUBROUTINE calc_precipitation_amount_ij( i, j ) 6505 6311 … … 6513 6319 INTEGER(iwp) :: surf_s !< Start index of surface elements at (j,i)-gridpoint 6514 6320 6515 IF ( ( dt_do2d_xy - time_do2d_xy ) < precipitation_amount_interval .AND. &6516 ( .NOT. call_microphysics_at_all_substeps .OR. &6517 intermediate_timestep_count == intermediate_timestep_count_max ) ) &6321 IF ( ( dt_do2d_xy - time_do2d_xy ) < precipitation_amount_interval .AND. & 6322 ( .NOT. call_microphysics_at_all_substeps .OR. & 6323 intermediate_timestep_count == intermediate_timestep_count_max ) ) & 6518 6324 THEN 6519 6325 … … 6522 6328 DO m = surf_s, surf_e 6523 6329 k = bc_h(0)%k(m) 6524 precipitation_amount(j,i) = precipitation_amount(j,i) + & 6525 prr(k,j,i) * hyrho(k) * dt_3d 6330 precipitation_amount(j,i) = precipitation_amount(j,i) + prr(k,j,i) * hyrho(k) * dt_3d 6526 6331 ENDDO 6527 6332 … … 6531 6336 6532 6337 6533 !------------------------------------------------------------------------------ !6338 !--------------------------------------------------------------------------------------------------! 6534 6339 ! Description: 6535 6340 ! ------------ 6536 !> Computation of the diagnostic supersaturation sat, actual liquid water 6537 ! < temperature t_l andsaturation water vapor mixing ratio q_s6538 !------------------------------------------------------------------------------ !6341 !> Computation of the diagnostic supersaturation sat, actual liquid water temperature t_l and 6342 !> saturation water vapor mixing ratio q_s 6343 !--------------------------------------------------------------------------------------------------! 6539 6344 SUBROUTINE supersaturation ( i,j,k ) 6540 6345 … … 6559 6364 alpha = rd_d_rv * lv_d_rd * lv_d_cp / ( t_l * t_l ) 6560 6365 ! 6561 !-- Correction of the approximated value 6562 !-- (see: Cuijpers + Duynkerke, 1993, JAS, 23) 6366 !-- Correction of the approximated value (see: Cuijpers + Duynkerke, 1993, JAS, 23) 6563 6367 q_s = q_s * ( 1.0_wp + alpha * q(k,j,i) ) / ( 1.0_wp + alpha * q_s ) 6564 6368 6565 IF ( .NOT. microphysics_ice_phase ) THEN6566 IF ( microphysics_seifert ) THEN6369 IF ( .NOT. microphysics_ice_phase ) THEN 6370 IF ( microphysics_seifert ) THEN 6567 6371 sat = ( q(k,j,i) - qr(k,j,i) - qc(k,j,i) ) / q_s - 1.0_wp 6568 ELSEIF ( microphysics_morrison_no_rain ) THEN6372 ELSEIF ( microphysics_morrison_no_rain ) THEN 6569 6373 sat = ( q(k,j,i) - qc(k,j,i) ) / q_s - 1.0_wp 6570 6374 ENDIF 6571 6375 ELSE 6572 IF ( microphysics_seifert ) THEN6376 IF ( microphysics_seifert ) THEN 6573 6377 sat = ( q(k,j,i) - qr(k,j,i) - qc(k,j,i) - qi(k,j,i) ) / q_s - 1.0_wp 6574 ELSEIF ( microphysics_morrison_no_rain ) THEN6378 ELSEIF ( microphysics_morrison_no_rain ) THEN 6575 6379 sat = ( q(k,j,i) - qc(k,j,i) - qi(k,j,i) ) / q_s - 1.0_wp 6576 6380 ENDIF … … 6579 6383 END SUBROUTINE supersaturation 6580 6384 6581 !------------------------------------------------------------------------------ !6385 !--------------------------------------------------------------------------------------------------! 6582 6386 ! Description: 6583 6387 ! ------------ 6584 !> Computation of the diagnostic supersaturation sat, actual liquid water 6585 ! < temperature t_l andsaturation water vapor mixing ratio q_s6586 !------------------------------------------------------------------------------ !6388 !> Computation of the diagnostic supersaturation sat, actual liquid water temperature t_l and 6389 !> saturation water vapor mixing ratio q_s 6390 !--------------------------------------------------------------------------------------------------! 6587 6391 SUBROUTINE supersaturation_ice ( i, j, k ) 6588 6392 … … 6600 6404 temp = t_l + lv_d_cp * ql(k,j,i) + ls_d_cp * qi(k,j,i) 6601 6405 ! 6602 !-- Calculate water vapor saturation pressure with formular using actual 6603 !-- temperature 6406 !-- Calculate water vapor saturation pressure with formular using actual temperature 6604 6407 e_si = magnus_ice( temp ) 6605 6408 ! … … 6608 6411 ! 6609 6412 !-- Current vapor pressure 6610 e_a = ( q(k,j,i) - qr(k,j,i) - qc(k,j,i) - qi(k,j,i) ) * hyp(k) / &6413 e_a = ( q(k,j,i) - qr(k,j,i) - qc(k,j,i) - qi(k,j,i) ) * hyp(k) / & 6611 6414 ( ( q(k,j,i) - qr(k,j,i) - qc(k,j,i) - qi(k,j,i) ) + rd_d_rv ) 6612 6415 ! 6613 6416 !-- Supersaturation: 6614 !-- Not in case of microphysics_kessler or microphysics_sat_adjust 6615 !-- since qr is unallocated 6417 !-- Not in case of microphysics_kessler or microphysics_sat_adjust since qr is unallocated 6616 6418 sat_ice = e_a / e_si - 1.0_wp 6617 6419 … … 6619 6421 6620 6422 6621 !------------------------------------------------------------------------------ !6423 !--------------------------------------------------------------------------------------------------! 6622 6424 ! Description: 6623 6425 ! ------------ 6624 !> Calculation of the liquid water content (0%-or-100%-scheme). This scheme is 6625 !> used by the one and the two moment cloud physics scheme. Using the two moment6626 !> scheme, this calculation results in thecloud water content.6627 !------------------------------------------------------------------------------ !6426 !> Calculation of the liquid water content (0%-or-100%-scheme). This scheme is used by the one and 6427 !> the two moment cloud physics scheme. Using the two moment scheme, this calculation results in the 6428 !> cloud water content. 6429 !--------------------------------------------------------------------------------------------------! 6628 6430 SUBROUTINE calc_liquid_water_content 6629 6431 … … 6646 6448 !-- Compute the liquid water content 6647 6449 IF ( .NOT. microphysics_ice_phase ) THEN 6648 IF ( microphysics_seifert .AND. .NOT. & 6649 microphysics_morrison ) THEN 6450 IF ( microphysics_seifert .AND. .NOT. microphysics_morrison ) THEN 6650 6451 !-- Seifert and Beheng scheme: saturation adjustment 6651 6452 IF ( ( q(k,j,i) - q_s - qr(k,j,i) ) > 0.0_wp ) THEN … … 6659 6460 ! 6660 6461 !-- Morrison scheme: explicit condensation (see above) 6661 ELSEIF ( microphysics_morrison .AND. & 6662 microphysics_seifert ) THEN 6462 ELSEIF ( microphysics_morrison .AND. microphysics_seifert ) THEN 6663 6463 ql(k,j,i) = qc(k,j,i) + qr(k,j,i) * flag 6464 ! 6664 6465 !-- Morrison without rain: explicit condensation 6665 ELSEIF ( microphysics_morrison .AND. & 6666 .NOT. microphysics_seifert ) THEN 6466 ELSEIF ( microphysics_morrison .AND. .NOT. microphysics_seifert ) THEN 6667 6467 ql(k,j,i) = qc(k,j,i) 6468 ! 6668 6469 !-- Kessler and saturation adjustment scheme 6669 6470 ELSE … … 6676 6477 ENDIF 6677 6478 ENDIF 6678 !-- Calculations of liquid water content in case of mixed-phase 6679 !-- cloud microphyics 6479 !-- Calculations of liquid water content in case of mixed-phase cloud microphyics 6680 6480 ELSE 6681 IF ( microphysics_seifert .AND. & 6682 .NOT. microphysics_morrison ) & 6481 IF ( microphysics_seifert .AND. .NOT. microphysics_morrison ) & 6683 6482 THEN 6684 6483 ! 6685 6484 !-- Seifert and Beheng scheme: saturation adjustment 6686 IF ( ( q(k,j,i) & 6687 - q_s - qr(k,j,i) - qi(k,j,i) ) > 0.0_wp ) THEN 6688 qc(k,j,i) = ( q(k,j,i) - q_s - qr(k,j,i) - qi(k,j,i) )& 6689 * flag 6485 IF ( ( q(k,j,i) - q_s - qr(k,j,i) - qi(k,j,i) ) > 0.0_wp ) THEN 6486 qc(k,j,i) = ( q(k,j,i) - q_s - qr(k,j,i) - qi(k,j,i) ) * flag 6690 6487 ql(k,j,i) = ( qc(k,j,i) + qr(k,j,i) ) * flag 6691 6488 ELSE … … 6696 6493 ql(k,j,i) = qr(k,j,i) * flag 6697 6494 ENDIF 6495 ! 6698 6496 !-- Morrison scheme: explicit condensation (see above) 6699 ELSEIF ( microphysics_morrison .AND. & 6700 microphysics_seifert ) THEN 6497 ELSEIF ( microphysics_morrison .AND. microphysics_seifert ) THEN 6701 6498 ql(k,j,i) = qc(k,j,i) + qr(k,j,i) * flag 6499 ! 6702 6500 !-- Morrison without rain: explicit condensation 6703 ELSEIF ( microphysics_morrison .AND. & 6704 .NOT. microphysics_seifert ) THEN 6501 ELSEIF ( microphysics_morrison .AND. .NOT. microphysics_seifert ) THEN 6705 6502 ql(k,j,i) = qc(k,j,i) 6503 ! 6706 6504 !-- Kessler and saturation adjustment scheme 6707 6505 ELSE … … 6721 6519 END SUBROUTINE calc_liquid_water_content 6722 6520 6723 !------------------------------------------------------------------------------ !6521 !--------------------------------------------------------------------------------------------------! 6724 6522 ! Description: 6725 6523 ! ------------ 6726 6524 !> This function computes the gamma function (Press et al., 1992). 6727 !> The gamma function is needed for the calculation of the evaporation 6728 !> of rain drops. 6729 !------------------------------------------------------------------------------! 6525 !> The gamma function is needed for the calculation of the evaporation of rain drops. 6526 !--------------------------------------------------------------------------------------------------! 6730 6527 FUNCTION gamm( xx ) 6731 6528 … … 6743 6540 6744 6541 REAL(wp), PARAMETER :: stp = 2.5066282746310005_wp !< 6745 REAL(wp), PARAMETER :: cof(6) = (/ 76.18009172947146_wp, &6746 -86.50532032941677_wp, &6747 24.01409824083091_wp, &6748 -1.231739572450155_wp, &6749 0.1208650973866179E-2_wp, &6542 REAL(wp), PARAMETER :: cof(6) = (/ 76.18009172947146_wp, & 6543 -86.50532032941677_wp, & 6544 24.01409824083091_wp, & 6545 -1.231739572450155_wp, & 6546 0.1208650973866179E-2_wp, & 6750 6547 -0.5395239384953E-5_wp /) !< 6751 6548 … … 6762 6559 6763 6560 ! 6764 !-- Until this point the algorithm computes the logarithm of the gamma 6765 !-- function. Hence, theexponential function is used.6766 ! 6561 !-- Until this point the algorithm computes the logarithm of the gamma function. Hence, the 6562 !-- exponential function is used. 6563 ! gamm = EXP( tmp + LOG( stp * ser / x_gamm ) ) 6767 6564 gamm = EXP( tmp ) * stp * ser / x_gamm 6768 6565 -
palm/trunk/SOURCE/buoyancy.f90
r4360 r4542 1 1 !> @file buoyancy.f90 2 !------------------------------------------------------------------------------ !2 !--------------------------------------------------------------------------------------------------! 3 3 ! This file is part of the PALM model system. 4 4 ! 5 ! PALM is free software: you can redistribute it and/or modify it under the 6 ! terms of the GNU General Public License as published by the Free Software7 ! Foundation, either version 3 of the License, or (at your option) any later8 ! version.9 ! 10 ! PALM is distributed in the hope that it will be useful, but WITHOUT ANY11 ! WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR12 ! A PARTICULAR PURPOSE. See the GNU General Public License for more details.13 ! 14 ! You should have received a copy of the GNU General Public License along with15 ! PALM. If not, see <http://www.gnu.org/licenses/>.5 ! PALM is free software: you can redistribute it and/or modify it under the terms of the GNU General 6 ! Public License as published by the Free Software Foundation, either version 3 of the License, or 7 ! (at your option) any later version. 8 ! 9 ! PALM is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the 10 ! implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General 11 ! Public License for more details. 12 ! 13 ! You should have received a copy of the GNU General Public License along with PALM. If not, see 14 ! <http://www.gnu.org/licenses/>. 15 ! 16 16 ! 17 17 ! Copyright 1997-2020 Leibniz Universitaet Hannover 18 !------------------------------------------------------------------------------ !18 !--------------------------------------------------------------------------------------------------! 19 19 ! 20 20 ! Current revisions: … … 25 25 ! ----------------- 26 26 ! $Id$ 27 ! file re-formatted to follow the PALM coding standard 28 ! 29 ! 4360 2020-01-07 11:25:50Z suehring 27 30 ! Corrected "Former revisions" section 28 ! 31 ! 29 32 ! 3725 2019-02-07 10:11:02Z raasch 30 33 ! unused variables removed 31 ! 34 ! 32 35 ! 3655 2019-01-07 16:51:22Z knoop 33 36 ! nopointer option removed … … 41 44 !> Buoyancy term of the third component of the equation of motion. 42 45 !> @attention Humidity is not regarded when using a sloping surface! 43 !------------------------------------------------------------------------------ !46 !--------------------------------------------------------------------------------------------------! 44 47 MODULE buoyancy_mod 45 48 46 USE basic_constants_and_equations_mod, &49 USE basic_constants_and_equations_mod, & 47 50 ONLY: g 48 51 49 USE arrays_3d, &52 USE arrays_3d, & 50 53 ONLY: pt, pt_slope_ref, ref_state, tend 51 54 52 USE control_parameters, &53 ONLY: atmos_ocean_sign, cos_alpha_surface, message_string, pt_surface, &54 s in_alpha_surface, sloping_surface55 USE control_parameters, & 56 ONLY: atmos_ocean_sign, cos_alpha_surface, message_string, pt_surface, sin_alpha_surface, & 57 sloping_surface 55 58 56 59 USE kinds … … 67 70 68 71 69 !------------------------------------------------------------------------------ !72 !--------------------------------------------------------------------------------------------------! 70 73 ! Description: 71 74 ! ------------ 72 75 !> Call for all grid points 73 !------------------------------------------------------------------------------ !76 !--------------------------------------------------------------------------------------------------! 74 77 SUBROUTINE buoyancy( var, wind_component ) 75 78 76 USE indices, &79 USE indices, & 77 80 ONLY: nxl, nxlu, nxr, nyn, nys, nzb, nzt 78 81 … … 84 87 INTEGER(iwp) :: k !< 85 88 INTEGER(iwp) :: wind_component !< 86 89 87 90 REAL(wp), DIMENSION(:,:,:), POINTER :: var 88 91 … … 98 101 DO j = nys, nyn 99 102 DO k = nzb+1, nzt-1 100 tend(k,j,i) = tend(k,j,i) + atmos_ocean_sign * g * 0.5_wp * &101 (&102 ( var(k,j,i) - ref_state(k) ) / ref_state(k) +&103 ( var(k+1,j,i) - ref_state(k+1) ) / ref_state(k+1)&104 )103 tend(k,j,i) = tend(k,j,i) + atmos_ocean_sign * g * 0.5_wp * & 104 ( & 105 ( var(k,j,i) - ref_state(k) ) / ref_state(k) + & 106 ( var(k+1,j,i) - ref_state(k+1) ) / ref_state(k+1) & 107 ) 105 108 ENDDO 106 109 ENDDO … … 109 112 ELSE 110 113 ! 111 !-- Buoyancy term for a surface with a slope in x-direction. The equations 112 ! -- for both the u andw velocity-component contain proportionate terms.114 !-- Buoyancy term for a surface with a slope in x-direction. The equations for both the u and 115 ! w velocity-component contain proportionate terms. 113 116 !-- Temperature field at time t=0 serves as environmental temperature. 114 !-- Reference temperature (pt_surface) is the one at the lower left corner 115 !-- of the totaldomain.117 !-- Reference temperature (pt_surface) is the one at the lower left corner of the total 118 !-- domain. 116 119 IF ( wind_component == 1 ) THEN 117 120 … … 119 122 DO j = nys, nyn 120 123 DO k = nzb+1, nzt-1 121 tend(k,j,i) = tend(k,j,i) + g * sin_alpha_surface * &122 0.5_wp * ( ( pt(k,j,i-1) + pt(k,j,i) )&123 - ( pt_slope_ref(k,i-1) + pt_slope_ref(k,i) )&124 ) / pt_surface124 tend(k,j,i) = tend(k,j,i) + g * sin_alpha_surface * & 125 0.5_wp * ( ( pt(k,j,i-1) + pt(k,j,i) ) & 126 - ( pt_slope_ref(k,i-1) + pt_slope_ref(k,i) ) & 127 ) / pt_surface 125 128 ENDDO 126 129 ENDDO … … 132 135 DO j = nys, nyn 133 136 DO k = nzb+1, nzt-1 134 tend(k,j,i) = tend(k,j,i) + g * cos_alpha_surface * &135 0.5_wp * ( ( pt(k,j,i) + pt(k+1,j,i) )&136 - ( pt_slope_ref(k,i) + pt_slope_ref(k+1,i) )&137 ) / pt_surface137 tend(k,j,i) = tend(k,j,i) + g * cos_alpha_surface * & 138 0.5_wp * ( ( pt(k,j,i) + pt(k+1,j,i) ) & 139 - ( pt_slope_ref(k,i) + pt_slope_ref(k+1,i) ) & 140 ) / pt_surface 138 141 ENDDO 139 142 ENDDO … … 141 144 142 145 ELSE 143 144 WRITE( message_string, * ) 'no term for component "', & 145 wind_component,'"' 146 147 WRITE( message_string, * ) 'no term for component "', wind_component, '"' 146 148 CALL message( 'buoyancy', 'PA0159', 1, 2, 0, 6, 0 ) 147 149 … … 153 155 154 156 155 !------------------------------------------------------------------------------ !157 !--------------------------------------------------------------------------------------------------! 156 158 ! Description: 157 159 ! ------------ 158 160 !> Call for grid point i,j 159 !> @attention PGI-compiler creates SIGFPE if opt>1 is used! Therefore, opt=1 is 160 !> forced bycompiler-directive.161 !------------------------------------------------------------------------------ !161 !> @attention PGI-compiler creates SIGFPE if opt>1 is used! Therefore, opt=1 is forced by 162 !> compiler-directive. 163 !--------------------------------------------------------------------------------------------------! 162 164 !pgi$r opt=1 163 165 SUBROUTINE buoyancy_ij( i, j, var, wind_component ) 164 166 165 167 166 USE indices, &168 USE indices, & 167 169 ONLY: nzb, nzt 168 170 … … 173 175 INTEGER(iwp) :: k !< 174 176 INTEGER(iwp) :: wind_component !< 175 177 176 178 REAL(wp), DIMENSION(:,:,:), POINTER :: var 177 179 … … 181 183 !-- Normal case: horizontal surface 182 184 DO k = nzb+1, nzt-1 183 tend(k,j,i) = tend(k,j,i) + atmos_ocean_sign * g * 0.5_wp * ( &184 ( var(k,j,i) - ref_state(k) ) / ref_state(k) +&185 ( var(k+1,j,i) - ref_state(k+1) ) / ref_state(k+1)&185 tend(k,j,i) = tend(k,j,i) + atmos_ocean_sign * g * 0.5_wp * ( & 186 ( var(k,j,i) - ref_state(k) ) / ref_state(k) + & 187 ( var(k+1,j,i) - ref_state(k+1) ) / ref_state(k+1) & 186 188 ) 187 189 ENDDO … … 189 191 ELSE 190 192 ! 191 !-- Buoyancy term for a surface with a slope in x-direction. The equations 192 !-- for both the u andw velocity-component contain proportionate terms.193 !-- Buoyancy term for a surface with a slope in x-direction. The equations for both the u and 194 !-- w velocity-component contain proportionate terms. 193 195 !-- Temperature field at time t=0 serves as environmental temperature. 194 !-- Reference temperature (pt_surface) is the one at the lower left corner 195 !-- of the totaldomain.196 !-- Reference temperature (pt_surface) is the one at the lower left corner of the total 197 !-- domain. 196 198 IF ( wind_component == 1 ) THEN 197 199 198 200 DO k = nzb+1, nzt-1 199 tend(k,j,i) = tend(k,j,i) + g * sin_alpha_surface * &200 0.5_wp * ( ( pt(k,j,i-1) + pt(k,j,i) )&201 - ( pt_slope_ref(k,i-1) + pt_slope_ref(k,i) )&202 ) / pt_surface201 tend(k,j,i) = tend(k,j,i) + g * sin_alpha_surface * & 202 0.5_wp * ( ( pt(k,j,i-1) + pt(k,j,i) ) & 203 - ( pt_slope_ref(k,i-1) + pt_slope_ref(k,i) ) & 204 ) / pt_surface 203 205 ENDDO 204 206 … … 206 208 207 209 DO k = nzb+1, nzt-1 208 tend(k,j,i) = tend(k,j,i) + g * cos_alpha_surface * &209 0.5_wp * ( ( pt(k,j,i) + pt(k+1,j,i) )&210 - ( pt_slope_ref(k,i) + pt_slope_ref(k+1,i) )&211 ) / pt_surface210 tend(k,j,i) = tend(k,j,i) + g * cos_alpha_surface * & 211 0.5_wp * ( ( pt(k,j,i) + pt(k+1,j,i) ) & 212 - ( pt_slope_ref(k,i) + pt_slope_ref(k+1,i) ) & 213 ) / pt_surface 212 214 ENDDO 213 215 214 216 ELSE 215 217 216 WRITE( message_string, * ) 'no term for component "', & 217 wind_component,'"' 218 WRITE( message_string, * ) 'no term for component "', wind_component, '"' 218 219 CALL message( 'buoyancy', 'PA0159', 1, 2, 0, 6, 0 ) 219 220 -
palm/trunk/SOURCE/calc_mean_profile.f90
r4360 r4542 1 1 !> @file calc_mean_profile.f90 2 !------------------------------------------------------------------------------ !2 !--------------------------------------------------------------------------------------------------! 3 3 ! This file is part of the PALM model system. 4 4 ! 5 ! PALM is free software: you can redistribute it and/or modify it under the 6 ! terms of the GNU General Public License as published by the Free Software 7 ! Foundation, either version 3 of the License, or (at your option) any later 8 ! version. 5 ! PALM is free software: you can redistribute it and/or modify it under the terms of the GNU General 6 ! Public License as published by the Free Software Foundation, either version 3 of the License, or 7 ! (at your option) any later version. 9 8 ! 10 ! PALM is distributed in the hope that it will be useful, but WITHOUT ANY 11 ! WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR12 ! A PARTICULAR PURPOSE. See the GNU GeneralPublic License for more details.9 ! PALM is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the 10 ! implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General 11 ! Public License for more details. 13 12 ! 14 ! You should have received a copy of the GNU General Public License along with 15 ! PALM. If not, see <http://www.gnu.org/licenses/>. 13 ! You should have received a copy of the GNU General Public License along with PALM. If not, see 14 ! <http://www.gnu.org/licenses/>. 15 ! 16 16 ! 17 17 ! Copyright 1997-2020 Leibniz Universitaet Hannover 18 !------------------------------------------------------------------------------ !18 !--------------------------------------------------------------------------------------------------! 19 19 ! 20 20 ! Current revisions: … … 25 25 ! ----------------- 26 26 ! $Id$ 27 ! file re-formatted to follow the PALM coding standard 28 ! 29 ! 4360 2020-01-07 11:25:50Z suehring 27 30 ! Introduction of wall_flags_total_0, which currently sets bits based on static 28 31 ! topography information used in wall_flags_static_0 29 ! 32 ! 30 33 ! 4329 2019-12-10 15:46:36Z motisi 31 34 ! Renamed wall_flags_0 to wall_flags_static_0 32 ! 35 ! 33 36 ! 4182 2019-08-22 15:20:23Z scharf 34 37 ! Corrected "Former revisions" section 35 ! 38 ! 36 39 ! 3655 2019-01-07 16:51:22Z knoop 37 40 ! nopointer option removed 38 ! 41 ! 39 42 ! 1365 2014-04-22 15:03:56Z boeske 40 43 ! Initial revision … … 47 50 !------------------------------------------------------------------------------! 48 51 MODULE calc_mean_profile_mod 49 52 50 53 51 54 PRIVATE … … 58 61 CONTAINS 59 62 60 !------------------------------------------------------------------------------ !63 !--------------------------------------------------------------------------------------------------! 61 64 ! Description: 62 65 ! ------------ 63 66 !> @todo Missing subroutine description. 64 !------------------------------------------------------------------------------ !67 !--------------------------------------------------------------------------------------------------! 65 68 SUBROUTINE calc_mean_profile( var, pr ) 66 69 67 USE control_parameters, &70 USE control_parameters, & 68 71 ONLY: intermediate_timestep_count 69 72 70 USE indices, & 71 ONLY: ngp_2dh_s_inner, nxl, nxr, nyn, nys, nzb, nzb, nzt, & 72 wall_flags_total_0 73 USE indices, & 74 ONLY: ngp_2dh_s_inner, nxl, nxr, nyn, nys, nzb, nzb, nzt, wall_flags_total_0 73 75 74 76 USE kinds … … 76 78 USE pegrid 77 79 78 USE statistics, &80 USE statistics, & 79 81 ONLY: flow_statistics_called, hom, sums, sums_l 80 82 81 83 82 84 IMPLICIT NONE 83 85 84 86 INTEGER(iwp) :: i !< 85 87 INTEGER(iwp) :: j !< 86 88 INTEGER(iwp) :: k !< 87 INTEGER(iwp) :: pr !< 89 INTEGER(iwp) :: pr !< 88 90 !$ INTEGER(iwp) :: omp_get_thread_num !< 89 91 INTEGER(iwp) :: tn !< 90 92 91 93 REAL(wp), DIMENSION(:,:,:), POINTER :: var 92 94 93 95 ! 94 !-- Computation of the horizontally averaged profile of variable var, unless 95 !-- already done by the relevant call from flow_statistics. The calculation 96 !-- is done only for the first respective intermediate timestep in order to 97 !-- spare communication time and to produce identical model results with jobs 98 !-- which are calling flow_statistics at different time intervals. At 96 !-- Computation of the horizontally averaged profile of variable var, unless already done by the 97 !-- relevant call from flow_statistics. The calculation is done only for the first respective 98 !-- intermediate timestep in order to spare communication time and to produce identical model 99 !-- results with jobs which are calling flow_statistics at different time intervals. At 99 100 !-- initialization, intermediate_timestep_count = 0 is considered as well. 100 101 101 IF ( .NOT. flow_statistics_called .AND. & 102 intermediate_timestep_count <= 1 ) THEN 102 IF ( .NOT. flow_statistics_called .AND. intermediate_timestep_count <= 1 ) THEN 103 103 104 104 ! … … 112 112 DO j = nys, nyn 113 113 DO k = nzb, nzt+1 114 sums_l(k,pr,tn) = sums_l(k,pr,tn) + var(k,j,i) & 115 * MERGE( 1.0_wp, 0.0_wp, & 116 BTEST( wall_flags_total_0(k,j,i), 22 ) ) 114 sums_l(k,pr,tn) = sums_l(k,pr,tn) + var(k,j,i) * MERGE( 1.0_wp, 0.0_wp, & 115 BTEST( wall_flags_total_0(k,j,i), 22 ) ) 117 116 ENDDO 118 117 ENDDO … … 127 126 128 127 IF ( collective_wait ) CALL MPI_BARRIER( comm2d, ierr ) 129 CALL MPI_ALLREDUCE( sums_l(nzb,pr,0), sums(nzb,pr), nzt+2-nzb, 130 MPI_REAL, MPI_SUM, comm2d,ierr )128 CALL MPI_ALLREDUCE( sums_l(nzb,pr,0), sums(nzb,pr), nzt+2-nzb, MPI_REAL, MPI_SUM, comm2d,& 129 ierr ) 131 130 132 131 #else -
palm/trunk/SOURCE/check_for_restart.f90
r4360 r4542 1 1 !> @file check_for_restart.f90 2 !------------------------------------------------------------------------------ !2 !--------------------------------------------------------------------------------------------------! 3 3 ! This file is part of the PALM model system. 4 4 ! 5 ! PALM is free software: you can redistribute it and/or modify it under the 6 ! terms of the GNU General Public License as published by the Free Software 7 ! Foundation, either version 3 of the License, or (at your option) any later 8 ! version. 9 ! 10 ! PALM is distributed in the hope that it will be useful, but WITHOUT ANY 11 ! WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR 12 ! A PARTICULAR PURPOSE. See the GNU General Public License for more details. 13 ! 14 ! You should have received a copy of the GNU General Public License along with 15 ! PALM. If not, see <http://www.gnu.org/licenses/>. 5 ! PALM is free software: you can redistribute it and/or modify it under the terms of the GNU General 6 ! Public License as published by the Free Software Foundation, either version 3 of the License, or 7 ! (at your option) any later version. 8 ! 9 ! PALM is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the 10 ! implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General 11 ! Public License for more details. 12 ! 13 ! You should have received a copy of the GNU General Public License along with PALM. If not, see 14 ! <http://www.gnu.org/licenses/>. 16 15 ! 17 16 ! Copyright 1997-2020 Leibniz Universitaet Hannover 18 !------------------------------------------------------------------------------ !17 !--------------------------------------------------------------------------------------------------! 19 18 ! 20 19 ! Current revisions: … … 25 24 ! ----------------- 26 25 ! $Id$ 26 ! file re-formatted to follow the PALM coding standard 27 ! 28 ! 4360 2020-01-07 11:25:50Z suehring 27 29 ! Corrected "Former revisions" section 28 ! 30 ! 29 31 ! 3655 2019-01-07 16:51:22Z knoop 30 32 ! Error messages revised … … 36 38 ! Description: 37 39 ! ------------ 38 !> Set stop flag, if restart is neccessary because of expiring cpu-time or 39 !> if it is forced by user 40 !------------------------------------------------------------------------------! 40 !> Set stop flag, if restart is neccessary because of expiring cpu-time or if it is forced by user. 41 !--------------------------------------------------------------------------------------------------! 41 42 SUBROUTINE check_for_restart 42 43 44 USE control_parameters, & 45 ONLY: coupling_mode, dt_restart, end_time, message_string, & 46 run_description_header, simulated_time, terminate_coupled, & 47 terminate_coupled_remote, terminate_run, & 48 termination_time_needed, time_restart, & 49 time_since_reference_point, write_binary 43 44 45 USE control_parameters, & 46 ONLY: coupling_mode, dt_restart, end_time, message_string, run_description_header, & 47 simulated_time, terminate_coupled, terminate_coupled_remote, terminate_run, & 48 termination_time_needed, time_restart, time_since_reference_point, write_binary 50 49 51 50 USE kinds … … 53 52 USE pegrid 54 53 55 USE pmc_interface, &54 USE pmc_interface, & 56 55 ONLY: comm_world_nesting, cpl_id, nested_run 57 56 … … 80 79 81 80 ! 82 !-- Set the global communicator to be used (depends on the mode in which PALM is 83 !-- running) 81 !-- Set the global communicator to be used (depends on the mode in which PALM is running) 84 82 IF ( nested_run ) THEN 85 83 global_communicator = comm_world_nesting … … 90 88 #if defined( __parallel ) 91 89 ! 92 !-- Make a logical OR for all processes. Stop the model run if at least 93 !-- one process has reached thetime limit.90 !-- Make a logical OR for all processes. Stop the model run if at least one process has reached the 91 !-- time limit. 94 92 IF ( collective_wait ) CALL MPI_BARRIER( global_communicator, ierr ) 95 CALL MPI_ALLREDUCE( terminate_run_l, terminate_run, 1, MPI_LOGICAL, &96 MPI_LOR,global_communicator, ierr )93 CALL MPI_ALLREDUCE( terminate_run_l, terminate_run, 1, MPI_LOGICAL, MPI_LOR, & 94 global_communicator, ierr ) 97 95 #else 98 96 terminate_run = terminate_run_l … … 102 100 !-- Output that job will be terminated 103 101 IF ( terminate_run .AND. myid == 0 ) THEN 104 WRITE( message_string, * ) 'run will be terminated because it is ', &105 'running out of job cpu limit & ',&106 'remaining time: ', remaining_time, ' s &',&107 'termination time needed:', termination_time_needed, ' s'102 WRITE( message_string, * ) 'run will be terminated because it is ', & 103 'running out of job cpu limit & ', & 104 'remaining time: ', remaining_time, ' s &', & 105 'termination time needed:', termination_time_needed, ' s' 108 106 CALL message( 'check_for_restart', 'PA0163', 0, 1, 0, 6, 0 ) 109 107 ENDIF 110 108 111 109 ! 112 !-- In case of coupled runs inform the remote model of the termination 113 !-- and its reason, provided the remote model has not already been 114 !-- informed of another termination reason (terminate_coupled > 0) before, 115 !-- or vice versa (terminate_coupled_remote > 0). 116 IF ( terminate_run .AND. TRIM( coupling_mode ) /= 'uncoupled' .AND. & 110 !-- In case of coupled runs inform the remote model of the termination and its reason, provided the 111 !-- remote model has not already been informed of another termination reason (terminate_coupled > 0) 112 !-- before, or vice versa (terminate_coupled_remote > 0). 113 IF ( terminate_run .AND. TRIM( coupling_mode ) /= 'uncoupled' .AND. & 117 114 terminate_coupled == 0 .AND. terminate_coupled_remote == 0 ) THEN 118 115 … … 121 118 #if defined( __parallel ) 122 119 IF ( myid == 0 ) THEN 123 CALL MPI_SENDRECV( terminate_coupled, 1, MPI_INTEGER, &124 target_id, 0, &125 terminate_coupled_remote, 1, MPI_INTEGER, &126 target_id, 0, &120 CALL MPI_SENDRECV( terminate_coupled, 1, MPI_INTEGER, & 121 target_id, 0, & 122 terminate_coupled_remote, 1, MPI_INTEGER, & 123 target_id, 0, & 127 124 comm_inter, status, ierr ) 128 125 ENDIF 129 CALL MPI_BCAST( terminate_coupled_remote, 1, MPI_INTEGER, 0, comm2d, & 130 ierr ) 131 #endif 132 ENDIF 133 134 135 ! 136 !-- Check if a flag file exists that forces a termination of the model 126 CALL MPI_BCAST( terminate_coupled_remote, 1, MPI_INTEGER, 0, comm2d, ierr ) 127 #endif 128 ENDIF 129 130 131 ! 132 !-- Check if a flag file exists that forces a termination of the model. 137 133 IF ( myid == 0 ) THEN 138 134 INQUIRE(FILE="DO_STOP_NOW", EXIST=do_stop_now) … … 143 139 terminate_run_l = .TRUE. 144 140 145 WRITE( message_string, * ) 'run will be terminated because user ', &146 'forced a job finalization using a flag',&147 'file:',&148 '&DO_STOP_NOW: ', do_stop_now,&149 '&DO_RESTART_NOW: ', do_restart_now141 WRITE( message_string, * ) 'run will be terminated because user ', & 142 'forced a job finalization using a flag', & 143 'file:', & 144 '&DO_STOP_NOW: ', do_stop_now, & 145 '&DO_RESTART_NOW: ', do_restart_now 150 146 CALL message( 'check_for_restart', 'PA0398', 0, 0, 0, 6, 0 ) 151 147 … … 156 152 #if defined( __parallel ) 157 153 ! 158 !-- Make a logical OR for all processes. Stop the model run if a flag file has 159 !-- been detected above. 154 !-- Make a logical OR for all processes. Stop the model run if a flag file has been detected above. 160 155 IF ( collective_wait ) CALL MPI_BARRIER( global_communicator, ierr ) 161 CALL MPI_ALLREDUCE( terminate_run_l, terminate_run, 1, MPI_LOGICAL, &162 MPI_LOR,global_communicator, ierr )156 CALL MPI_ALLREDUCE( terminate_run_l, terminate_run, 1, MPI_LOGICAL, MPI_LOR, & 157 global_communicator, ierr ) 163 158 #else 164 159 terminate_run = terminate_run_l … … 166 161 167 162 ! 168 !-- In case of coupled runs inform the remote model of the termination 169 !-- and its reason, provided the remote model has not already been 170 !-- informed of another termination reason (terminate_coupled > 0) before, 171 !-- or vice versa (terminate_coupled_remote > 0). 172 IF ( terminate_run .AND. coupling_mode /= 'uncoupled' .AND. & 163 !-- In case of coupled runs inform the remote model of the termination and its reason, provided the 164 !-- remote model has not already been informed of another termination reason (terminate_coupled > 0) 165 !-- before, or vice versa (terminate_coupled_remote > 0). 166 IF ( terminate_run .AND. coupling_mode /= 'uncoupled' .AND. & 173 167 terminate_coupled == 0 .AND. terminate_coupled_remote == 0 ) THEN 174 168 … … 177 171 #if defined( __parallel ) 178 172 IF ( myid == 0 ) THEN 179 CALL MPI_SENDRECV( terminate_coupled, 1, MPI_INTEGER, & 180 target_id, 0, & 181 terminate_coupled_remote, 1, MPI_INTEGER, & 182 target_id, 0, & 183 comm_inter, status, ierr ) 184 ENDIF 185 CALL MPI_BCAST( terminate_coupled_remote, 1, MPI_INTEGER, 0, & 186 comm2d, ierr ) 173 CALL MPI_SENDRECV( terminate_coupled, 1, MPI_INTEGER, & 174 target_id, 0, & 175 terminate_coupled_remote, 1, MPI_INTEGER, & 176 target_id, 0, & 177 comm_inter, status, ierr ) 178 ENDIF 179 CALL MPI_BCAST( terminate_coupled_remote, 1, MPI_INTEGER, 0, comm2d, ierr ) 187 180 #endif 188 181 … … 191 184 ! 192 185 !-- Set the stop flag also, if restart is forced by user settings 193 IF ( time_restart /= 9999999.9_wp .AND. & 194 time_restart < time_since_reference_point ) THEN 195 196 ! 197 !-- Restart is not neccessary, if the end time of the run (given by 198 !-- the user) has been reached 186 IF ( time_restart /= 9999999.9_wp .AND. time_restart < time_since_reference_point ) THEN 187 188 ! 189 !-- Restart is not neccessary, if the end time of the run (given by the user) has been reached. 199 190 IF ( simulated_time < end_time ) THEN 200 191 terminate_run = .TRUE. 201 192 ! 202 !-- Increment restart time, if forced by user, otherwise set restart 203 !-- time to default (no user restart)193 !-- Increment restart time, if forced by user, otherwise set restart time to default (no user 194 !-- restart). 204 195 IF ( dt_restart /= 9999999.9_wp ) THEN 205 196 time_restart = time_restart + dt_restart … … 208 199 ENDIF 209 200 210 WRITE( message_string, * ) 'run will be terminated due to user ', &211 'settings of ',&212 'restart_time / dt_restart, ',&213 'new restart time is: ', time_restart, ' s'201 WRITE( message_string, * ) 'run will be terminated due to user ', & 202 'settings of ', & 203 'restart_time / dt_restart, ', & 204 'new restart time is: ', time_restart, ' s' 214 205 CALL message( 'check_for_restart', 'PA0164', 0, 0, 0, 6, 0 ) 215 216 ! 217 !-- In case of coupled runs inform the remote model of the termination 218 !-- and its reason, provided the remote model has not already been 219 !-- informed of another termination reason (terminate_coupled > 0) before, 220 !-- or vice versa (terminate_coupled_remote > 0). 221 IF ( coupling_mode /= 'uncoupled' .AND. terminate_coupled == 0 & 206 207 ! 208 !-- In case of coupled runs inform the remote model of the termination and its reason, 209 !-- provided the remote model has not already been informed of another termination reason 210 !-- (terminate_coupled > 0) before, or vice versa (terminate_coupled_remote > 0). 211 IF ( coupling_mode /= 'uncoupled' .AND. terminate_coupled == 0 & 222 212 .AND. terminate_coupled_remote == 0 ) THEN 223 213 … … 229 219 #if defined( __parallel ) 230 220 IF ( myid == 0 ) THEN 231 CALL MPI_SENDRECV( terminate_coupled, 1, MPI_INTEGER, &232 target_id, 0, &233 terminate_coupled_remote, 1, MPI_INTEGER, &234 target_id, 0, &235 comm_inter, status, ierr ) 221 CALL MPI_SENDRECV( terminate_coupled, 1, MPI_INTEGER, & 222 target_id, 0, & 223 terminate_coupled_remote, 1, MPI_INTEGER, & 224 target_id, 0, & 225 comm_inter, status, ierr ) 236 226 ENDIF 237 CALL MPI_BCAST( terminate_coupled_remote, 1, MPI_INTEGER, 0, & 238 comm2d, ierr ) 227 CALL MPI_BCAST( terminate_coupled_remote, 1, MPI_INTEGER, 0, comm2d, ierr ) 239 228 #endif 240 229 ENDIF … … 245 234 246 235 ! 247 !-- If the run is stopped, set a flag file which is necessary to initiate 248 !-- the start of a continuation run, except if the user forced to stop the 249 !-- run without restart 250 IF ( terminate_run .AND. myid == 0 .AND. cpl_id == 1 .AND. & 251 .NOT. do_stop_now) THEN 236 !-- If the run is stopped, set a flag file which is necessary to initiate the start of a 237 !-- continuation run, except if the user forced to stop the run without restart. 238 IF ( terminate_run .AND. myid == 0 .AND. cpl_id == 1 .AND. .NOT. do_stop_now) THEN 252 239 253 240 OPEN ( 90, FILE='CONTINUE_RUN', FORM='FORMATTED' ) -
palm/trunk/SOURCE/chemistry_model_mod.f90
r4535 r4542 27 27 ! ----------------- 28 28 ! $Id$ 29 ! redundant if statement removed 30 ! 31 ! 4535 2020-05-15 12:07:23Z raasch 29 32 ! bugfix for restart data format query 30 33 ! … … 3062 3065 3063 3066 3064 CHARACTER (LEN=20) :: spc_name_av !<3065 3066 3067 INTEGER(iwp) :: lsp !< 3067 3068 INTEGER(iwp) :: k !< … … 3087 3088 3088 3089 3089 IF ( ALLOCATED( chem_species ) ) THEN 3090 3091 DO lsp = 1, nspec 3092 3093 !< for time-averaged chemical conc. 3094 spc_name_av = TRIM( chem_species(lsp)%name )//'_av' 3095 3096 IF ( restart_string(1:length) == TRIM( chem_species(lsp)%name) ) & 3097 THEN 3098 !< read data into tmp_3d 3099 IF ( k == 1 ) READ ( 13 ) tmp_3d 3100 !< fill ..%conc in the restart run 3101 chem_species(lsp)%conc(:,nysc-nbgp:nync+nbgp, & 3102 nxlc-nbgp:nxrc+nbgp) = & 3103 tmp_3d(:,nysf-nbgp:nynf+nbgp,nxlf-nbgp:nxrf+nbgp) 3104 found = .TRUE. 3105 ELSEIF (restart_string(1:length) == spc_name_av ) THEN 3106 IF ( k == 1 ) READ ( 13 ) tmp_3d 3107 chem_species(lsp)%conc_av(:,nysc-nbgp:nync+nbgp, & 3108 nxlc-nbgp:nxrc+nbgp) = & 3109 tmp_3d(:,nysf-nbgp:nynf+nbgp,nxlf-nbgp:nxrf+nbgp) 3110 found = .TRUE. 3111 ENDIF 3112 3113 ENDDO 3114 3115 ENDIF 3090 DO lsp = 1, nspec 3091 3092 IF ( restart_string(1:length) == TRIM( chem_species(lsp)%name) ) THEN 3093 3094 IF ( k == 1 ) READ ( 13 ) tmp_3d 3095 chem_species(lsp)%conc(:,nysc-nbgp:nync+nbgp,nxlc-nbgp:nxrc+nbgp) = & 3096 tmp_3d(:,nysf-nbgp:nynf+nbgp,nxlf-nbgp:nxrf+nbgp) 3097 found = .TRUE. 3098 3099 ELSEIF (restart_string(1:length) == TRIM( chem_species(lsp)%name ) // '_av' ) THEN 3100 3101 IF ( k == 1 ) READ ( 13 ) tmp_3d 3102 chem_species(lsp)%conc_av(:,nysc-nbgp:nync+nbgp,nxlc-nbgp:nxrc+nbgp) = & 3103 tmp_3d(:,nysf-nbgp:nynf+nbgp,nxlf-nbgp:nxrf+nbgp) 3104 found = .TRUE. 3105 3106 ENDIF 3107 3108 ENDDO 3116 3109 3117 3110 … … 3128 3121 IMPLICIT NONE 3129 3122 3130 INTEGER(iwp) :: lsp !< 3131 3132 IF ( ALLOCATED( chem_species ) ) THEN 3133 3134 DO lsp = 1, nspec 3135 3136 CALL rrd_mpi_io( TRIM( chem_species(lsp)%name ), chem_species(lsp)%conc ) 3137 CALL rrd_mpi_io( TRIM( chem_species(lsp)%name )//'_av', chem_species(lsp)%conc_av ) 3138 3139 ENDDO 3140 3141 ENDIF 3123 INTEGER(iwp) :: lsp !< 3124 3125 3126 DO lsp = 1, nspec 3127 3128 CALL rrd_mpi_io( TRIM( chem_species(lsp)%name ), chem_species(lsp)%conc ) 3129 CALL rrd_mpi_io( TRIM( chem_species(lsp)%name )//'_av', chem_species(lsp)%conc_av ) 3130 3131 ENDDO 3142 3132 3143 3133 END SUBROUTINE chem_rrd_local_mpi
Note: See TracChangeset
for help on using the changeset viewer.