diff --git a/.gitignore b/.gitignore index 280e4c4..47dced5 100644 --- a/.gitignore +++ b/.gitignore @@ -42,3 +42,6 @@ qr_acr*dat # CM1 processes the .F files into .f90 during the build process so we should ignore # these too *.f90 + +# Claude Code machine-specific settings (netCDF/HDF5 paths differ per machine) +.claude/settings.local.json diff --git a/CLAUDE.md b/CLAUDE.md new file mode 100644 index 0000000..0b7c180 --- /dev/null +++ b/CLAUDE.md @@ -0,0 +1,90 @@ +# CM1 r21.0 — P3 microphysics working copy + +CM1 (Bryan cloud model) with heavy local modifications to the P3 (Predicted +Particle Properties) microphysics scheme. Working branch `P3_work`; main branch +is `master`. Several sibling worktrees of the same repo exist under +`~/Projects/cm1r21.0*` — check `git worktree list` before assuming a path. + +## Building + +```bash +cd src && make +``` + +Links the executable to `run/cm1.exe`. + +- `src/Makefile` is the **active** build config — a copy of one of the + `Makefile_` variants with the hardware section uncommented. Current + settings: `mpif90` (gfortran), `-ffree-form -ffree-line-length-none -O2 + -finline-functions`, `-DMPI`. Variants in the tree: `Makefile_laptop_mpi`, + `Makefile_laptop_single`, `Makefile_bell`, `Makefile_derecho`. +- The laptop Makefiles need `NETCDFC_DIR`, `NETCDF4_DIR` and `HDF5_DIR` in the + environment. These are Homebrew prefixes on this machine and are supplied to + Claude Code via `.claude/settings.local.json` (gitignored, machine-specific). + Without them the netCDF-using files fail with `Cannot open module file + 'netcdf.mod'`. `Makefile_bell` uses different variable names + (`NETCDF_FORTRAN_HOME` etc.); `Makefile_derecho` uses `NETCDF`. +- Debug builds (used for FP-trap hunts) swap `OPTS` for + `-O0 -g -ffpe-trap=invalid -fcheck=bounds` and require a full rebuild. + +### Generated files — never edit these + +- `src/*.f90` — cpp output from the corresponding `.F`. Edit only the `.F`. +- `run/onefile.F` — a concatenation of all sources, regenerated by every `make`. + Gitignored. Grep hits here are duplicates of `src/`; ignore them. + +## P3 configurations (`ptype` in `¶m2`) + +All are 2-moment cloud water and rain. Ice-category count, moment count and +liquid-fraction prediction are baked into the ptype: + +| ptype | ice cats | ice moments | liqFrac | +|-------|----------|-------------|---------| +| 50–53 | 1–2 | 1–3 mom | no | +| 54, 56, 57 | 2, 3, 4 | 3-mom | no | +| 60–63 | 1, 2, 3, 4 | 3-mom | yes | +| 64, 65 | 5, 6 | 3-mom | no | +| 66, 67 | 5, 6 | 3-mom | yes | + +Adding or changing a P3 configuration touches, at minimum: `src/param.F` +(ptype range tests, `param_mp` name, the `p3_init` dispatch, and the +`numq`/`qname`/`qunit`/`qmag`/`cloudvar`/`np3a`/`np3o` block), `src/mp_driver.F` +(the per-ptype `p3a` pack/unpack and `mp_p3_wrapper_wrf` call), +`src/writeout.F` (per-category diagnostic output), and +`src/radiation_driver.F` (effective-radius ptype list). + +Scheme options live in the `&p3_params` namelist group (declared and broadcast +in `param.F`, applied in `p3_init`). With `p3_cat_init_new = .true.` the +destination category for each of the six ice-initiation mechanisms is set by +`p3_catdest__n`, where `N` is the number of ice categories in the +active configuration — so ptype 57 reads the `_n4` values, 64/66 the `_n5` +values, and 65/67 the `_n6` values. + +## Running + +`run/` needs the P3 lookup tables (`p3_lookupTable_1.dat-v6.7-{2,3}momI`, +`p3_lookupTable_2.dat-v6.1`) alongside `cm1.exe` and `namelist.input`. +`run/namelist.input` is a default/reference copy — it does **not** track the +configuration of any particular production run. + +Note that older executables will refuse a namelist containing `&p3_params` +keys they were not compiled with (`Cannot match namelist object name ...`), so +A/B runs against an older binary need the newer keys stripped. + +## Category-swap / bit-reproducibility investigation + +`NOTES.md` and `p3_category_swap_audit.md` are the running record of a long +investigation into why permuting P3 ice-category destination assignments broke +bit-identity. Read `NOTES.md` before touching category reductions or the +tendency-application code — several fixes there are load-bearing. In-tree +tooling kept from that work: + +- `p3_chksum` / `p3_chkpts` in `&p3_params` — per-timestep field checksums and + per-point raw dumps, written PRE and POST each `p3_main` call. +- `compare_p3_chksum.py` and `decode_point.sh` in the repo root. +- `qsum_invariant` in `&p3_params` — permutation-invariant host-side moisture + sums; needed for swap/invariance runs, default off. + +The general fix pattern for a category-order dependence is: replace a +fixed-slot-order category sum with a double-precision accumulate-then-round, or +a value-sorted `sortsumq` on the host side. diff --git a/NOTES.md b/NOTES.md new file mode 100644 index 0000000..a3e60f6 --- /dev/null +++ b/NOTES.md @@ -0,0 +1,922 @@ +# NOTES: P3 category-swap divergence investigation (session record) + +Companion file to `p3_category_swap_audit.md` (the full audit report). This file +records the follow-up discussion and the practical plan, for continuing work in +Claude Code. Newest entries first. + +Build/run conventions that used to live only in people's heads are now in +`CLAUDE.md` (active Makefile, required netCDF/HDF5 environment variables, +generated files that must not be edited, the P3 ptype table). + +--- + +## UPDATE (2026-07-27) — new P3 configurations; state of the tree since 07-20 + +### New ptypes 64-67: 5- and 6-ice-category configurations + +Four new P3 configurations, taking the next free ptype numbers so existing ones +are untouched: + +| ptype | ice cats | ice moments | liqFrac | equivalent to | +|-------|----------|-------------|---------|---------------| +| 64 | 5 | 3-mom | no | ptype 57 + 1 category | +| 65 | 6 | 3-mom | no | ptype 57 + 2 categories | +| 66 | 5 | 3-mom | yes | ptype 63 + 1 category | +| 67 | 6 | 3-mom | yes | ptype 63 + 2 categories | + +P3's core was already generic in `nCat` — per-category arrays are allocatable, +`deltaD_init` already had `case (5)` and `case (6:)`, and `lookupTable_2` is +indexed by size/rime/density bins rather than by category — so the work was in +the category-destination dispatch and the CM1-side plumbing. The one real gap: +with `cat_init_new = .true.` the six `iice_dest` dispatch blocks only had +`nCat == 2/3/4` branches, so at nCat>4 `iice_dest` would have been left unset. +`catdest_*_n5` / `_n6` were added throughout (module vars, `p3_init` optional +args + clamping, all six dispatch sites, `param.F` namelist plumbing). + +**The `_n5`/`_n6` defaults are a science choice that should be reviewed before +these ptypes are used in anger.** They continue the progressive split of the +`_n2..._n4` series so that no category is left without a source: at nCat=5 +deposition nucleation moves to its own category (5), and at nCat=6 homogeneous +freezing of rain moves to its own as well (6). Everything else keeps its `_n4` +value. Consequence: **ptype 64 is not literally "ptype 57 with an inert 5th +category"** — depnuc moves from cat 4 to cat 5. Override via `&p3_params` +(`p3_catdest__n5` / `_n6`) if a different assignment is wanted. + +Also in this change: `mp_p3_wrapper_wrf` gained the `_5`/`_6` argument sets; +`diag_effi_ave`'s hard-coded `nCat<=4` expressions became a sequential loop +(same accumulation order, so nCat<=4 is unchanged bit-for-bit); `writeout.F` +gained `p3_{vmi,dmi,rhoi,dhmax}5/6`; ptype lists extended in `param.F`, +`writeout.F` and `radiation_driver.F`; `README.namelist` now documents 54, 56, +57 and 60-67 (it had only covered 50-53). + +Verification performed: full build clean; all four ptypes run with the expected +`numq`/`nqs2`/`qname` tables; a 2400 s ptype-65 run populates all six categories +(qi5 via deposition nucleation, qi6 via homogeneous rain freezing) and emits all +24 per-category diagnostics; **a 2400 s ptype-57 run is bit-identical +(`cm1out_s/u/v/w/stats`) against a binary built from the parent commit** — the +existing configurations are unaffected. + +Gotcha for A/B work: older executables reject a namelist containing `&p3_params` +keys they were not compiled with (`Cannot match namelist object name ...`), so +comparisons against an older binary need the new `_n5`/`_n6` keys stripped. + +### DEFERRED — swap variance has returned (smaller than before) + +Swapped-destination runs are once again showing some variance. Per DTD it is +**not as serious as the pre-fix divergence** and the investigation is +**deliberately deferred**. It may or may not be related to +`log_iceice_interaction` now defaulting to `.true.` (see below) — that is the +first hypothesis to test, not an established cause. No onset timestep, point or +field pattern has been recorded yet. + +When picking this up, the method from the 2026-07-20 handoff still applies +(`p3_chksum` bisection → `p3_chkpts` bracket → walk the tendency backwards), +and the ice-ice-specific guidance near the end of that section names the prime +suspects if interaction is indeed implicated. + +### Tree changes since NOTES.md was last updated (07-21 → 07-25) + +NOTES.md previously ended at commit `11300ba`. Four commits landed after it that +this file did not record: + +- `137e439` — Makefile for Bell. +- `b7dcda3` — manual merge of the NSSL3M_Feb_2025 branch. Mostly + `module_mp_nssl_2mom.F` plus a new `hail` accumulation array threaded through + `mp_driver.F` / `param.F` / `writeout.F` (`output_hail`). It also reverted + three earlier DTD changes to P3 — **all three reversions were deliberate + (confirmed by DTD 2026-07-27)**, recorded here only so they are not later + mistaken for merge accidents: + - the `pdefq` loops that ran ahead of every P3 call site in `mp_driver.F` are + now commented out (5 sites); + - `dbrk` went back to `600.e-6` (was `3000.e-6`, "Mod by DTD"); + - the scaled-mean-rain-size gate in `find_lookupTable_indices_1b` + (`module_mp_p3.F` ~12354) went back to `nr.gt.0` (was `nr.gt.nsmall`). + Note this is a lookup-index gate, distinct from the process-block and + sedimentation gates that the §2.1 fixes below moved onto `nsmall`. +- `84b472e` — `log_maxnsmall` back to `.true.` by default. +- `861737d` + `cd0ecce` — **per-category max-Ni limiter**, back-ported from a + later P3 version. `max_total_Ni` renamed `max_Ni`; new `impose_max_Ni` does a + straight `min(nitot, max_Ni*inv_rho)` per category, replacing the old + proportional across-all-categories rescaling (which could shrink the number of + a category that was already small, producing unrealistic mean sizes and + reflectivity). Called at the three sites where `impose_max_total_Ni` had been + commented out. Set `p3_nimax = -1` in the namelist (or `max_Ni` negative in + code) to disable the limiter entirely; the namelist value overrides the + in-code default. Note the maximum *total* concentration is now up to + `nCat*max_Ni`. + +### `log_iceice_interaction` now defaults `.true.` + +Both the `param.F` default and `run/namelist.input` now enable ice-ice +interaction. **The 2026-07-20 bit-identity result below was obtained with it +OFF.** The `iice_loop3` cross-category transfer and clip/densify code was +restructured to be invariant-*ready*, but that path has never been verified +under a swap test, so swap runs with interaction on are exercising untested +ground — a plausible connection to the deferred variance above. + +Also note `run/namelist.input` is a default/reference copy and does **not** +track the configuration of any particular production run. + +--- + +## HANDOFF — current status & next steps (2026-07-20) + +**BUG FOUND AND FIXED (2026-07-20, p3_nanpoison FP-trap hunt):** the seed of +the category-swap divergence is a **stale-scalar bug**: `iice_loop2` +(pre-update mu_i for 3-moment ice, module_mp_p3.F ~5122) read the plain +scalar `f1pr16` (mass-weighted mean particle density) for EVERY category — +but a scalar only retains the value of whichever category LAST ran the +lookup in `iice_loop1`. So `mu_i_s(iice)` (feeds the post-update `zitot` +adjustment via `calculate_mu_change`/`G_of_mu`) used the wrong species' +density for all but one category, and *which* species leaked depended on +category slot order — exactly what the destination swap changes. Consistent +with every observation: onset where two categories first coexist, flips in +ice moments only (incl. the lone pure-zitot onset record), immune to all +four §3 order-invariance switches. FIX: per-category `f1pr16_s(nCat)` array +saved inside each category's own lookup block (-1 sentinel = no lookup this +step); `iice_loop2` consumes `f1pr16_s(iice)` and keeps `mu_i_initial` +when the category's lookup did not run. Affects all 3-moment nCat>1 runs +(physics fix, not just bit-reproducibility). **Trap-hunt COMPLETE: the post-fix rerun traps nothing** — the full +poisoned set (f1pr01–38, lookup weights/indices, rhop, mu_i) has exactly +one stale consumer, now fixed. + +**CONFIRMATION RUNS (2026-07-20) — INVESTIGATION CLOSED:** + +1. *Fix only, all switches off:* onset still itimestep=175 (physics-pinned: + first coexistence of the swapped slots' contents) but at a DIFFERENT + point with a different, sparser signature — (49,19,32), fields + `qitot_1 zitot_1 zitot_4` (zitot-first = finest-ulp fields; magnitude + masking). Old seed gone; new seed = the §3 category-sum reductions, + as predicted. +2. *Fix + all four dp switches:* onset MOVED for the first time — t=176, + lone `qr` POST flip at (46,22,23) in the riming levels, PRE clean. + Lone-shared-field flip = the fingerprint of the `iice_loop3` sequential + per-category shared-field updates (the audit's "largest §3 contributor", + deliberately unswitched). + +**Final mechanism hierarchy of the category-swap divergence** (each layer +isolated empirically by eliminating the one above it): +1. Stale `f1pr16` scalar in iice_loop2's 3-moment mu_i computation — + GENUINE BUG, fixed (commit 32f7eb6). Affects the physics of all + 3-moment nCat>1 runs. Report upstream. +2. Category-sum reductions (`epsi_tot`, conservation-limiter sums, + `sum(nitot)` in dep. nucleation, entry-clip accumulation) — inherent + roundoff; suppressible via p3_clipdp/epsdp/limdp/nucdp. +3. Sequential per-category updates of shared fields (`iice_loop3`, + post-update clip loops) — inherent roundoff; the remaining floor. + +**Upstream-reportable finds from this investigation:** (a) the stale +f1pr16/mu_i bug; (b) `iparamice_in` silently overwritten by the default in +p3_init; (c) 0/0 NaNs in `diag_effi_ave` at ice-free points (wrapper); +(d) 0/0 in the zidep compound conditional (non-short-circuiting .and.). + +--- + +## SWAP-DIVERGENCE SEED #2 — turbulence total-water sum (FOUND & FIXED, 2026-07-20) + +After the §4(c) restructure below AND `qsum_invariant=.true.`, a swap pair (cats +3↔4, IOP12 ptype-57, 8 ranks) still diverged — but far later (first divergence +t=179 vs the old t=175) and in a single field: **`birim_3` (rime volume)** on a +PRE line, host-side, at coexistence onset. A long instrumented bisection (temp +debug in solve1/solve2, since removed) walked it down: + +- first divergence is a ~1-ULP difference in `qten(birim)` (the subgrid + turbulence tendency), NOT advection — `advs` was transparent; +- with the full birim field column bit-identical and `rho`/`rr` clean, the + differing input was the **eddy diffusivity `khh`/`khv`** at the point (dumped + directly: `khh(26)`,`khv(26)`,`dum7(26)` differed ~1–2 ULP; `rho`,`rr`, + `khh(27)`,`khv(27)` identical); +- config is `cm1setup=1` LES, `sgsmodel=1` (prognostic-TKE closure), so + `kmh=cme·√tk·lenscl` and the diffusivity rides on the subgrid TKE, whose + buoyancy production uses N² from `calcnm`. + +**ROOT CAUSE:** `calcnm` (turb.F ~5026) built total water `qt` with a **raw +slot-order sum** `do n: qt=qt+qa(...,n)` over `nqv + nql1:nql2 + nqs1:nqs2`. The +solid range `nqs1:nqs2 = 4:7` is the four ice masses; the swap exchanges the +*contents* of slots 6/7, so the fixed-order FP sum differs by 1 ULP → +`qt`→`thv`→`nm`(N²)→TKE→`khh/khv`→`turbs`→`qten(birim)`→divergence. This is the +SAME class `qsum_invariant` fixes, but a **second, independent moisture sum the +prior agent's conversion missed** — it had only converted the turb *driver*'s +`dum7 = Σql+Σqi` (turb.F 432–488), not `calcnm`'s own `qt`. + +Explains every observation: it's the diffusivity (not density); at k=26 (ice +level); at t=179 (first coexistence of the swapped ice masses — before that one +slot is 0 and order is moot); birim is just the canary (smallest field reveals +the ~1-ULP diffusivity error first while qitot's larger `qten` masks it). + +**FIX (turb.F, calcnm ~5026):** `qt` now uses `sortsumq` for the liquid and +solid ranges when `qsum_invariant` (matching the `dum7` treatment): `qt = qa(nqv) ++ sortsumq(qa(nql1:nql2)) + sortsumq(qa(nqs1:nqs2))`, guarded `if(nql1.gt.0)` / +`if(nqs1.gt.0 .and. iice.eq.1)`; raw loop retained for `qsum_invariant=.false.`. +Compiles + links clean. **To verify: rerun the swap pair** (with +`qsum_invariant=.true.`) — expect the t=179 birim divergence to vanish and the +pair to go bit-identical (or onset to jump dramatically later, exposing the next +seed if any). All temporary solve1/solve2 debug probes have been removed. + +**RESULT of the calcnm fix (verified):** the t=179 `birim_3` seed is GONE. +Onset moved to **t=185 POST, `nitot_4`** (back inside p3_main), PRE trailing at +t=186 — i.e. host turbulence cleared, next seed is microphysics-internal. + +## SWAP-DIVERGENCE SEED #3 — Hallett-Mossop accumulation (FOUND & FIXED) + +The t=185 `nitot_4` POST seed is the **Hallett-Mossop rime-splintering** block +(module_mp_p3.F `iice_loop_HM`, ~line 4020): it loops over SOURCE categories and +accumulates splinter production into the fixed destination slot in slot order — +`qrmul(iice_dest)=qrmul(iice_dest)+dum2` / `nimul(iice_dest)=…+dum1`. `iice_dest` +is `catdest_rimesplinter_n4` = cat 4 (runA) / cat 3 (runB, swapped), and the +source cats 3/4 contributions are exchanged by the swap, so the fixed-order FP +sum differs by 1 ULP. `nimul` feeds `nitot` (iice_loop3) → `nitot(iice_dest)` +diverges = `nitot_4`(A)/`nitot_3`(B). Same category-sum class; my §4(c) +restructure missed it because it accumulates into a *destination* index, not a +shared field. **FIX:** accumulate `qrmul_dp`/`nimul_dp` in double precision over +the source loop, apply to `iice_dest` once after (always-on). Compiles + links +clean. + +## RESULT — BIT-IDENTITY ACHIEVED (2026-07-20) + +After the HM fix, the swap pair (cats 3↔4, `qsum_invariant=.true.`) is +**bit-identical every step out to t=200** (as far as run). Combined with the +earlier no-swap control (also bit-identical), both acceptance tests #1 and #2 +pass. The full set of category-relabeling seeds, peeled in order: +1. stale `f1pr16` scalar in iice_loop2 (genuine physics bug) — prior session. +2. §3 in-scheme category sums + sequential shared-field updates — §4(c) + restructure of `iice_loop3` + clip loops; `clipdp/epsdp/limdp/nucdp` made + permanent (this session, module_mp_p3.F). +3. host buoyancy/theta_rho sums — `qsum_invariant` (prior session). +4. host turbulence total water `qt` in `calcnm` (turb.F) — this session. +5. Hallett-Mossop `nimul`/`qrmul` accumulation into `iice_dest` (module_mp_p3.F) + — this session. + +Each is an FP-non-associative category reduction; the fix pattern throughout is +double-precision accumulate + round once (or value-sorted `sortsumq` host-side). +**Upstream-reportable order-dependencies found:** the stale `f1pr16`/mu_i bug +(#1), the `calcnm` qt sum (#4), and the HM destination accumulation (#5). + +Remaining (not needed for this config, would matter elsewhere): `compute_SCPF` +`sum(Qitot)` if SCPF active; `sum(qlcon)/sum(qlevp)` liqFrac satadj lines; +diagnostic-only host sums (statpack/writeout/etc.). Ice-ice interaction is +restructured to be invariant-ready but remains disabled by default. + +## SESSION WRAP-UP / HANDOFF (2026-07-20) + +**Diagnostic switches removed** (committed cleanup): `p3_clipdp / p3_epsdp / +p3_limdp / p3_nucdp` (their dp paths are now permanent/unconditional) and +`p3_nanpoison` (stale-state hunt complete) — deleted from `module_mp_p3.F`, +`param.F` (decl / `use` / namelist group / MPI_BCAST / assignment) and +`run/namelist.input`. **KEPT:** `qsum_invariant` (needed for host-side +invariance; runtime default still `.false.` in namelist — set `.true.` for +invariant/swap runs) and the `p3_chksum` / `p3_chkpts` checksum + per-point-dump +instrumentation (+ `compare_p3_chksum.py`, `decode_point.sh`) for future +divergence hunts. + +**Physics-sanity check (acceptance test #3) — DEFERRED, do later if wanted:** +build a pre-restructure binary from commit `ad03ca7`, run one no-swap case each +(this-branch vs pre-restructure), confirm they differ only at roundoff. Verifies +the dp-restructuring didn't change the science. Not done this session. + +**If swap divergence returns (e.g. when you enable `log_iceice_interaction`):** +the method that worked, in order — +1. `p3_chksum=.true.` both runs, `compare_p3_chksum.py runA runB --swap 3 4` → + first divergent timestep/tag/field. PRE-first = host-side; POST-first = + inside p3_main. +2. `p3_chkpts=.true.` on a short restart bracket around that step → + `--pattern 'p3_chkpts_*.out'` → exact (i,j,k)+field. `decode_point.sh` to see + magnitudes (1 ULP = roundoff/order-dependence). +3. If it's a tendency (not a field) that first differs, instrument the tendency + array at that global point and walk it *backwards* through its contributors + /coefficients until you hit the array that differs — that names the guilty + reduction (this is how the `calcnm` khh/khv seed was found; temp probes went + in solve1/solve2, all since removed). +4. The fix is almost always: replace a fixed-slot-order category sum with a + double-precision accumulate-then-round, or host-side `sortsumq`. + +For **ice-ice interaction specifically**: the `iice_loop3` cross-category +transfer + clip/densify is already restructured to dp-accumulate (invariant- +ready, exact no-op while disabled), and the two conservation-limiter `qicol` +`sources`/`sinks` sums were made dp. If divergence still appears with it on, the +prime suspects are any remaining `qicol`/`nicol` category sums or the `icecat_ +destination` selection — start the checksum bisection there. + +--- + +## NEXT PROJECT — permutation-invariant tendency application (fresh session) + +**IMPLEMENTED (2026-07-20, Claude Code):** the §4(c) restructure below is done +in `src/module_mp_p3.F` (compiles + links clean with the production +`-O2 -finline-functions` MPI build). What changed: + +- **`iice_loop3` (main item, ~line 5141):** the six SHARED prognostic fields + updated once per category in slot order — `qc, nc, qr, nr, qv, th` — are now + accumulated over ice categories in double precision (`dqc_dp … dth_dp`, new + declarations near line 2524) and applied to each field ONCE after the loop + (`field = sngl(dble(field) + dfield_dp)`). Each category's increment is still + formed in single precision exactly as before, so only the cross-category + accumulation changed → result is now independent of category slot order. The + per-category array fields (`qitot/qirim/birim/qiliq/nitot`, and the disabled + ice-ice interaction block) are slot-local and stayed in the loop. Verified no + statement reads any of the six shared fields mid-loop, so deferral is a + roundoff-level change only. +- **Post-`iice_loop3` clip loops:** same dp-accumulate-apply-once treatment for + (a) the liquid-fraction shed clip (`clipsum_qr/nr/th`), (b) the small-value + clip (`clipsum_qv/th`), and (c) the ice clip in `iice_loop_final_diagnostics` + (`clipsum_qv/th`, applied right after the loop). The non-per-category qc/qr + single clips between them were already order-independent and left as-is. +- **Diagnostic switches `p3_clipdp/epsdp/limdp/nucdp` made PERMANENT:** every + `if (log_*dp) … else … endif` in `p3_main` was collapsed to the + double-precision (invariant) branch unconditionally — entry clip, epsi_tot/ + epsiw_tot accumulation, all five conservation-limiter sums, and the + `sum(nitot)` in deposition nucleation. Per the user's decision, the four + `log_*dp` module vars + their `param.F`/`namelist.input` plumbing are KEPT as + **readable no-ops** (documented at the declarations, ~line 89) so existing + namelists still load; setting them now has no effect. Full retirement (delete + from `param.F` + `namelist.input`) deferred until run-dir namelists are cleaned. + +- **Ice-ice interaction block made READY for invariance (2026-07-20, currently + still disabled via `log_iceice_interaction=.false.`):** the cross-category + collection transfers inside `iice_loop3` used to update `qitot/qirim/birim/ + qiliq/nitot` of both collector and collectee in slot order, and the + per-category clipping (`qirim<0`) and wet-growth/melt densification ran + mid-loop on *partially*-transferred fields — an order dependence that is NOT + just roundoff. Restructured so the transfers accumulate into per-category + double-precision accumulators (`qitot_col_dp … nitot_col_dp`, dimension nCat), + applied once after the loop, and the clipping/densification moved to a single + post-loop pass over categories that sees the fully-accumulated fields. Also + made the two conservation-limiter `qicol`/`nicol` `catcoll` sums (the "ice" + and "qiliq" `sources`/`sinks` blocks) double-precision. **All of these are + exact no-ops when `log_iceice_interaction=.false.`** (every `*_col_dp` and the + `qicol` sums are zero, and `sngl(dble(x)+0.d0)==x`), so the current + ice-off runs are byte-identical to before this change; when interaction is + enabled they are category-order-invariant. The `qicol/nicol` rates themselves + are computed per category-pair (slot-covariant), so no change was needed + there. Runtime default left disabled per request. + +Residual (deliberately out of scope, per the plan): host-side sums (covered by +`qsum_invariant`); the `sum(qlcon)/sum(qlevp)` in the qv_tmp/t_tmp +saturation-adjustment lines (liqFrac-only, identically zero in this config — +not part of the `log_limdp` coverage that was converted); `ze_ice` reflectivity +accumulation in the final-diagnostics loop (diagnostic output only, not +prognostic); the ice-ice interaction cross-category updates (feature disabled). +Any one surviving order-sensitive prognostic reduction would still eventually +diverge — these are believed inert for the swap config but should be confirmed +by the acceptance tests before declaring bit-identity. + +**Not yet run:** the three acceptance tests below (no-swap identity, swap +no-p3_main-divergence, physics-sanity vs pre-restructure). Build the pre-change +binary from git (commit `ad03ca7`) for test 3. + +--- + +Goal: audit §4 option (c) — restructure so per-category tendencies are +applied to shared fields in ONE fused, category-order-invariant update per +grid point, making p3_main bit-identical under category relabeling (given +the diagnostic switches' sites are also made invariant permanently). + +Scope (in module_mp_p3.F, p3_main): +- `iice_loop3` (~line 5155): qc/nc/qr/nr/qv/th each updated once per + category in slot order → accumulate all per-category increments (they + are already computed into per-category rate arrays) in double precision + and apply each shared field once after the loop. This is the main item. +- The post-update clipping loops after iice_loop3 (liquid-fraction shed + clip, small-value clip, final-diagnostics clip near end of p3_main) — + same qv/th sequential-accumulation pattern as the entry clip. +- Decide the fate of the diagnostic switches: recommend converting + p3_clipdp/epsdp/limdp/nucdp code paths into the permanent (always-on) + implementation and retiring the namelist switches, so invariance is not + config-dependent. (Formal invariance would need value-sorted sums — + audit option (b); dp-accumulate-round-once is the pragmatic standard.) +- NOT in scope: host-side sums (qsum_invariant switch already exists), + per-category-independent code (sedimentation per category, lookups). + +Acceptance tests (all tooling in repo root, conventions in HANDOFF above): +1. No-swap pair (identical namelists) still bit-identical every step + (p3_chksum diff clean). +2. Swap pair with restructured code: NO divergence originating in p3_main + (PRE lines may eventually diverge via the host unless + qsum_invariant=.true.; with it on, expect bit-identity or a dramatic + onset delay). +3. Physics sanity: no-swap run vs pre-restructure run differs only at + roundoff (solutions statistically indistinguishable). + +Suggested opening prompt for the new session: +> Read NOTES.md (HANDOFF and "NEXT PROJECT" sections) and +> p3_category_swap_audit.md §3-4. Implement the permutation-invariant +> tendency application described in NEXT PROJECT. +Two benign latent bugs also found and fixed by the trap: 0/0 in +`diag_effi_ave` at ice-free points (wrapper), and a non-short-circuit +`qiliq/qitot` 0/0 in the zidep conditional. + +**Where things stand (superseded by the above):** mechanism was narrowed via +elimination; full evidence chain in "RESOLVED" and "Follow-up" sections +below. + +- Swap divergence originates INSIDE `p3_main` (host dynamics cleared; PRE + checksums and `w`/`p` clean at onset). Entry clipping pass also CLEARED + (fires everywhere in the undershoot halo but no `qv` flips at onset — a + clip order-flip is necessarily a visible 1-ulp `qv` change). +- Onset: itimestep=175 (1312.5 s), 158 points in one anvil blob (i=42–50, + j=18–27, k=25–38), ~85 columns seeding near-independently, ≤1 level of + same-call sedimentation smear. Real slot-3/4 ice coexistence first appears + regionally at exactly t=175. Source-point PRE decode: comparable masses + (~4e-11) but number concentrations lopsided by 6 orders (homocloud 3.8e+2 + vs rimesplinter 3.1e-4) → category sums = dominant term + near-ulp small + terms = maximally flip-prone. Flips visible only in small-magnitude ice + fields (sub-ulp in qv/th) — matches the ice-field-only onset census. +- **Single-switch A/B results (2026-07-20): onset UNCHANGED under `p3_epsdp` + alone and `p3_limdp` alone** — same first timestep/point/fields; only the + downstream divergent-record counts differ (expected: different roundoff + growth paths). Interpretation caveats discovered afterward: + (1) the one-at-a-time protocol is FLAWED if multiple reductions flip the + same points — each single-switch run leaves the other mechanisms live, so + an unchanged onset does not exonerate the switched site; + (2) `sum(nitot)` in deposition nucleation was unswitched in ALL runs, is + live in this config (iparamice=1 Cooper, T<258.15 K, supi>=0.05, + destination cat 1 via dn1), and its flip propagates to ALL categories' + qidep through the satadj limiter ratio when it binds — `p3_limdp` does NOT + protect against this (invariant summation of already-flipped qinuc inputs); + (3) the k=33 topmost source record of the dry decoded column flips cats + 2+4 (all components), locally, where nucleation cannot fire (RH_i≈35%) — + so at least that column is NOT nucleation-seeded. +- **COMBINED-RUN RESULT (2026-07-20): onset STILL unchanged with ALL FOUR + invariance switches enabled** (`p3_clipdp/p3_epsdp/p3_limdp/p3_nucdp`) in + both members of the pair — same first timestep/point/fields. Every known + §3 order-of-operations reduction is now excluded as the seed. Remaining + explanation: §2-class stale per-category state (a work variable inherited + across iice_loop1 iterations, making a species' physics depend on which + category slot preceded it — exactly what a slot swap changes). +- **Next experiment (pending): the NaN-poison stale-state hunt.** New switch + `p3_nanpoison = .true.` in `&p3_params`: at the top of EVERY iice_loop1 + iteration, all per-category work variables are poisoned — f1pr01–f1pr10, + f1pr13–f1pr19, f1pr22–f1pr38 (reals, signaling NaN via bit pattern), + lookup interpolation weights dum1/dum3/dum4/dum5/dum6/dum7, rhop, mu_i + (signaling NaN), and lookup indices dumi/dumj/dumii/dumjj/dumll/dumzz + (huge sentinel). Any consumption before being set in that same category + iteration traps. Deliberate per-iteration defaults (Eii_fact=1, tmp1=0) + are NOT poisoned. + **Run recipe (single run, no A/B needed — the stale path executes + regardless of destination namelist):** + 1. Debug build: in the Makefile set + `OPTS = -ffree-form -ffree-line-length-none -O0 -g -ffpe-trap=invalid -fcheck=bounds` + (drop -O2/-finline; rebuild everything). + 2. `p3_nanpoison = .true.` in the namelist (bracket restart config is + fine and fastest; full run also works). + 3. Run SERIALLY under lldb (macOS/arm64: gfortran's trap handler loops + instead of terminating, but lldb stops at the exact line): + `lldb -- ./cm1.exe` then `run`; at each stop lldb shows file:line + (verified working on this machine: EXC_BAD_INSTRUCTION at the exact + consuming statement). `bt` for the call stack, `process continue` to + resume past stops judged benign, `frame variable iice` etc. to inspect. + 4. Integer-index stale use surfaces as a -fcheck=bounds error (aborts + with file:line) rather than an FP trap. + Interpretation: a stop inside process-rate code consuming a poisoned + value = the stale path, and the backtrace names the guilty line. If the + run completes with NO stops, the poisoned set is exonerated and the next + tier of scratch (tmp*/dum2/etc.) gets poisoned. Note other CM1 modules + may trap benignly with global -ffpe-trap; only stops in module_mp_p3 + category code are of interest — continue past others. +- **Latent bug found in passing (unrelated to divergence, fix someday):** + `p3_init` line ~328 applies optional `iparamice_in`, then line ~360 + unconditionally overwrites `iparamice = 1` — a host-passed Meyers + selection would be silently ignored (CM1 never passes it, so currently + benign). + +**Conventions (do not lose these):** +- Reference run = "runA" = the rs→4/chf→3 destination config + (`.../IOP12_..._rs4_dn1_chf3_rhf2_noii_test/`); ALWAYS the first argument + to `compare_p3_chksum.py` and the file used for decodes. In that numbering: + cat1=depnuc, cat2=rain-freezing, cat3=homocloud, cat4=rime-splinter. +- Compare: `./compare_p3_chksum.py runA runB --swap 3 4 [--pattern + 'p3_chkpts_*.out'] [--all]`. Decode: `./decode_point.sh + ` (both scripts in repo root). +- Onset baseline to compare against: t=175, 158 points, field-pattern + histogram and spatial blob recorded in the Follow-up section. + +--- + +--- + +## Context + +Testing multi-category P3 (`module_mp_p3.F`, CM1 host, WRF-style wrapper) with +`cat_init_new = .true.` (fixed `catdest_*` destination categories per initiation +process), ice-ice interaction and merging disabled, nCat = 4. Swapping the +destination category numbers for rime splintering vs. deposition nucleation +(3/4 vs. 4/3) should theoretically leave results unchanged, but simulations are +identical for several minutes and then diverge. + +## RESOLVED — Investigation outcome (2026-07-19) + +The swap-divergence mechanism was isolated with the Phase-1 checksum and +Phase-2 per-point instrumentation (below), using a restart-bracketed swap +pair (IOP12 case, ptype=57: nCat=4, 3-mom; this pair swapped the +homocloud/rimesplinter destinations 3<->4, dirname `..._rs4_dn1_chf3_...`; +ice-ice interaction and merging off; `qsum_invariant=.false.`; restart at +1300 s, dtl=7.5 s). + +**Findings:** + +1. **The seed is inside `p3_main`.** First divergence: itimestep=175 + (1312.5 s), a POST record at global (i,j,k)=(47,19,32) on rank 0003, + flipping all components of ice categories 2 and 3. Every PRE record at + t=175 matched bit-for-bit (earliest PRE divergence is t=176), and the + `w`/`p` checksums never diverged — so both runs handed `p3_main` + bit-identical inputs and got different outputs. Host dynamics exonerated + as the seed (even with `qsum_invariant` off). +2. **The seed point held no physical ice.** Decoding the PRE point-dump at + (47,19,32): all four categories sub-threshold, mostly *negative* + (advection undershoot halo; with `advwenos=2` WENO is applied only on the + final RK stage — `adv.F` line 77 — and WENO is not positive-definite; + undershoots ~1e-5 relative, e.g. nc = -1.2e4 against ~1e9). Both slots 3 + AND 4 were nonzero (-1.7e-12 / -3.8e-9). The first order-sensitive + operation such values meet is the **entry clipping pass** (sequential + per-category qv/th compensation, a §3 site) — the most plausible specific + seed site. +3. **Divergence began at the first timestep the swapped slots' contents + overlapped anywhere.** Coexistence scan (first PRE record with both + qitot_3 and qitot_4 nonzero): t=175, global (46,19,24) — same timestep as + the first divergence; no coexistence earlier in the bracket window. The + scan reports the lowest-k match; the seed point itself was also + coexistent (item 2), and not every coexistence point flips a bit + (reversing a+b changes the rounding only ~half the time), which is why + the first flip sits inside, not at the scan-order corner of, the + coexistence patch. + +**Conclusion:** the category-swap divergence is fully explained by the +report's §3 in-scheme order-of-operations roundoff, triggered at the first +overlap of swapped-slot contents. "Coexistence" requires only nonzero slot +contents — advection undershoot halos qualify — so seeding occurs where the +two species' halos merely overlap, well before (and more extensively than) +physical ice coexistence. No evidence of any residual §2-class bug, and no +host-side seeding was observed. The remaining choice is scientific, not +diagnostic: (a) accept last-bit sensitivity under relabeling and treat swap +pairs as ensemble members, or (b) pursue bit-identity via the +permutation-invariance program — invariant reductions inside `p3_main` +(entry clipping pass, `epsi_tot`, conservation-limiter sums, `iice_loop3`; +see "Permutation-invariance options" below) plus `qsum_invariant=.true.` +host-side. + +## Audit conclusions (see report for full detail and line numbers) + +Two distinct causes were identified: + +1. **Genuine bug (report §2.1):** the `qitot_notsmall_1` gate (line 2871) + requires `nitot > nsmall` *strictly*, while the clipping pass (line 2653) + floors `nitot` to exactly `nsmall`. When the gate is skipped, downstream + process blocks (collection 3104/3115, melting 3305/3331, wet growth 3359, + self-collection 3287, `epsi` 3413) still execute under weaker conditions and + consume **stale `f1pr*` lookup scalars and `Eii_fact`** left over from + whichever category was processed previously — an ordering-dependent + contamination. `f1pr*` are never reset per category iteration. + +2. **Structural order-of-operations roundoff (report §3):** reductions over + categories (`sum(qidep)`, `sum(nitot)` in deposition nucleation, conservation + limiter ratios, `epsi_tot` accumulation) and sequential per-category updates + of shared fields (`qc/qr/qv/th` in `iice_loop3`, clipping loops) combine the + same values in a different order after the swap. FP addition is not + associative → last-bit differences → chaotic growth. Bit-identity under a + category permutation is impossible without making these reductions + permutation-invariant. Also applies host-side: CM1's buoyancy/loading sum + over moist scalars in slot order. + +Cleared: interaction/merge gating, `catdest_*` coverage of all six initiation +processes, sedimentation independence, `impose_max_total_Ni` (commented out), +per-process rate arrays (no destination overwrites). + +## Plan: fix items (2.1)/(2.2) first — **DONE, verified in updated module_mp_p3.F (13,018 lines)** + +Verified implemented (new line numbers): + +- Gate 2873: `nitot .ge. nsmall` (was strict `>`); matching `.ge. nsmall` checks + added to all downstream process blocks (collection 3107/3118, T>0 collection + 3146–3175, ice-ice gate 3202, self-collection 3290, melting 3308/3334, wet + growth 3362, epsi 3416, refreezing 3462, HM 3712, dep/sub 3928/3975) and to + the sedimentation gates (5587, 5681, 5785, 5934). Extra `nc`/`nr ≥ nsmall` + checks added alongside. +- `Eii_fact(iice) = 1.0` default at top of `iice_loop1` (2871); `tmp1 = 0.` + before the rime-fraction block (3067). +- NOT done (optional/defensive): resetting `f1pr01–f1pr38` per category + iteration. With aligned gates, all known stale paths are closed; the + NaN-poisoning + FP-trap test remains the definitive check if paranoid. + +**Separate bug found during re-testing:** NaNs appearing ~3000 s into a run, +traced to divide-by-zero in Seifert–Beheng autoconversion (`iparam=1`): +`(1.-dum)**2` denominator blows up as `dum → 1` (qc negligible vs qr). Fixed +with `if (dum < 1.)` guard; `qc_not_small_1` gate now also requires +`nc*iSCF ≥ nsmall`; `isnan` traps added (custom `isnan(x) = x /= x` at 11664). +Switching to default `iparam=3` going forward. `log_debug` off. + +Two minor code observations for later cleanup: +- The `isnan` traps call plain `stop`, which under MPI may not cleanly + terminate all ranks (prefer the host's abort, e.g. MPI_Abort via CM1's + stopcm1 mechanism, if these are kept long-term). +- A custom `x /= x` NaN test can be optimized away under fast-math-style + compiler flags; fine under default gfortran/ifort settings. + +**Status: swap-test divergence persists after these fixes** — consistent with +the report's prediction that the §3 order-of-operations sites are sufficient +on their own. Next step: the §4 program (Phase 1/2 instrumentation below, then +the double-precision A/B test), keeping in mind the CM1 buoyancy-sum ceiling +noted under "CM1-specific notes." + +Original agreed fix list (retained for reference): + +- **Gate consistency (2.1):** change line 2871 (and sedimentation gates 5393, + 5487, 5740 for consistency) to `nitot(i,k,iice) .ge. nsmall`, or make every + downstream consumer of `f1pr*` require the exact same predicate as the gate + (e.g., per-category logical `log_lookupFresh(iice)`). +- **Defaults (2.2):** `Eii_fact(iice) = 1.` is the correct default (matches the + `qirim <= 0` else-branch, i.e., "unrimed / no shutoff"), and `tmp1 = 0.` + before the `if (qirim > 0.)` block (Fr = 0 → `Eii_fact = 1`, consistent). + Caveats discussed: + - Initialize **per category iteration** (top of `iice_loop1`), not once per + column; the hazard is per-(i,k), per-category. + - Set `tmp1 = 0.` immediately before use — it is a reused scratch variable. + - These defaults alone do NOT fix stale `f1pr03/04/05/14` consumption + (`nislf`, collection, melting); the gate alignment is still required. + `Eii_fact = 1` alone would enable self-collection with a wrong lookup value. +- Defensive: reset all `f1pr01–f1pr38` at the top of each `iice_loop1` + iteration. To *prove* the stale path fires: initialize them (and `Eii_fact`, + `tmp1`) to signaling NaNs and compile with FP trapping + (`-ffpe-trap=invalid` / `-fpe0`). + +## Q&A: does `sum()` depend on element order? + +`sum()` is deterministic for fixed contents in fixed slots (same array → same +bits; the earlier DTD fix at line 4477–4481 addressed a different, worse issue: +re-summing a partially modified array). But the swap experiment **permutes the +contents** of the summed arrays. FP addition is commutative but not +associative; `sum()` evaluates in fixed positional order, so +`((a1+a2)+a3)+a4` vs `((a1+a2)+a4)+a3` can differ in the last bit. + +Concrete single-precision example — summing {16777216 (=2^24), 5, 2}, where +float spacing is 2.0: + +- `(2^24 + 5) + 2` → rounds to 16777220, then +2 → **16777222** +- `(2^24 + 2) + 5` → exact 16777218, then +5 → 16777223 → rounds → **16777224** + +Same mechanism applies to the sequential shared-field updates in `iice_loop3` +(a loop-form sum). Note: the Fortran standard doesn't specify `sum()` +evaluation order (optimizers may use vectorized partial sums), but that's +irrelevant when both runs use the same binary. + +## Diagnostic workflow: checksums + bisection + +**Phase 1 — find first divergent timestep.** — **IMPLEMENTED (Claude Code +session, 2026-07-19):** + +- `bitsum` / `bitsum2` (rank-2 wrapper) added to `module_mp_p3.F` just after + `mp_p3_wrapper_wrf`. +- Checksum writer (internal subroutine `chksum_write` of `mp_p3_wrapper_wrf`) + called **twice per (itimestep, j)**: a `PRE ` line immediately before + `p3_main` (state entering microphysics) and a `POST` line after it. Each + line: `itimestep, j, tag`, then hex (Z16.16) checksums of + `qv, th, qc, nc_loc, qr, qnr, w, p`, then per ice category + `qitot, qirim, nitot, birim` (+ `zitot` if 3-moment, + `qiliq` if liqFrac), + hashed over the `(its:ite,kts:kte)` tile. Flushed once per timestep. +- **j-labeling fix + w/p fields (2026-07-19, second pass):** CM1 calls this + wrapper once per model j-slab with 2D slabs (`jts=jte=1`), so the wrapper's + internal loop `j` is always 1 — the first version labeled every line + `j=1` (symptom: multiple identical `(itimestep, 1, tag)` records per + timestep). Fixed: lines now use the true model j from the optional + `j_index` argument (DTD's debug arg), which is now passed at **all** P3 + call sites in `mp_driver.F` (previously only ptype 57/63). Same fix + applied to the per-point dump's local/global j columns. In the same + format change, `w` and `p` (inputs to `p3_main`, untouched by it) were + added after `qnr` in both file formats: a divergence in `w`/`p` — even on + a POST line — is host-seeded (buoyancy/pressure path), invisible to the + moisture/theta hashes. Checksum files written by the earlier code are NOT + comparable with the updated script (it aborts on the category-column + count); rerun after rebuilding. +- PRE/POST interpretation when diffing two runs: first divergence appearing on + a `PRE` line → the seed entered between the previous `POST` and this call, + i.e. on the host side (dynamics/advection — with `qsum_invariant=.true.` in + both runs this would implicate a host-side sum the audit missed); `PRE` + still matching while the same step's `POST` diverges → the seed is inside + `p3_main` (the §2/§3 mechanisms). Without `qsum_invariant`, a PRE-first + divergence may just be the buoyancy loading sum flipping a bit first and + does not by itself clear the microphysics (report §4 caveat). +- Output goes to per-rank file `p3_chksum_NNNN.out` (NNNN = MPI rank), + **replaced at the start of each run** (incl. restarts — move files aside + before a restart-based Phase-2 bracket run). +- Runtime switch: new namelist option `p3_chksum = .true.` in `&p3_params` + (default `.false.`; declared/broadcast in `param.F`, which sets the public + module switches `log_chksum` and `chksum_myid` after `p3_init`). +- Usage: run A and B with `p3_chksum=.true.`, then compare with + `compare_p3_chksum.py` (repo root), which applies the category mapping to + run B before comparing and names the first divergent + timestep/j-slab/tag/field. Two files compare a single rank; two run + directories compare every rank pair and add a simulation-wide summary + (earliest divergence across ranks, ordered by itimestep / j / PRE-before- + POST, plus per-tag earliest and totals): + + ``` + ./compare_p3_chksum.py runA/p3_chksum_0000.out runB/p3_chksum_0000.out --swap 3 4 + ./compare_p3_chksum.py runA runB --swap 3 4 # all ranks + summary + ``` + + (`--map 1,2,4,3` for arbitrary permutations, `--ncat` if not 4, `--all` to + list every divergent line; exit 0 = bit-identical under the mapping. + Verified against synthetic files: pure swap → identical under mapping; a + single poisoned value → localized to the exact timestep/j/tag/field.) + A plain `diff` also works for the no-swap validation runs (identity + mapping). + +Original design sketch (bitwise, position-weighted XOR hash per field per +timestep, printed from the wrapper after `p3_main`): + +```fortran +function bitsum(arr) result(cs) + real, intent(in) :: arr(:) + integer(8) :: cs + integer(4) :: bits(size(arr)) + integer :: n + bits = transfer(arr, bits) ! reinterpret bits; no rounding + cs = 0 + do n = 1, size(arr) + cs = ieor(cs, int(bits(n),8) * int(n,8)) + enddo +end function +``` + +Print `itimestep, j, bitsum(qv), bitsum(th), bitsum(qc), bitsum(qr), ...` and +hash each `qitot(:,:,iice)` slice separately. Diff the two runs' logs; first +mismatch = first divergent timestep. + +Caveats: +- Compare ice categories **under the swap mapping** (cat 3 of run A vs cat 4 of + run B for the swapped species); otherwise trivially "divergent." +- Same processor count/decomposition both runs; compare rank-to-rank. + +**Phase 2 — find first divergent (i,k,j) and field.** — **IMPLEMENTED +(Claude Code session, 2026-07-19)** as a per-point dump in the wrapper +(replaces the raw-binary-dump plan below): + +- New namelist option `p3_chkpts = .true.` in `&p3_params` (default + `.false.`), independent of `p3_chksum`. Internal subroutine `chkpts_write` + of `mp_p3_wrapper_wrf` writes, PRE and POST every `p3_main` call, one line + per tile point to per-rank file `p3_chkpts_NNNN.out`: + `itimestep, tag, i j k (local), i j k (full grid)`, then the raw 32-bit + bit patterns (hex Z8.8, no hashing — lossless) of + `qv th qc nc qr qnr` + per category `qitot qirim nitot birim` + (+`zitot`/`qiliq`). Full-grid index = local + (`myi1`-1)/(`myj1`-1), + passed from `param.F` via module vars `chksum_i0`/`chksum_j0`; k is not + decomposed (local k = full-grid k). +- **Large output** (~all points × ~26 fields × 2 tags per step per rank): + enable only for short restart-bracketing runs around the first divergent + timestep found with `p3_chksum`. CM1 `rstfrq` restarts are + bit-reproducible for identical config/decomposition. +- `compare_p3_chksum.py` auto-detects the per-point format (same swap + mapping, same modes) and reports the exact first divergent point with + local and full-grid coordinates; directory mode: + `./compare_p3_chksum.py runA runB --swap 3 4 --pattern 'p3_chkpts_*.out'`. + +Original design sketch (raw unformatted dumps + numpy bitwise compare): + +```python +import numpy as np +a = np.fromfile('A/p3dump_...bin', dtype=np.float32) +b = np.fromfile('B/p3dump_...bin', dtype=np.float32) +d = np.argwhere(a.view(np.int32) != b.view(np.int32)) +``` + +Interpretation: first-diff relative magnitude ~1e-7 → order-of-operations +seeding; larger jump, or located where a category sits at `nitot == nsmall` → +the stale-`f1pr*` bug. Pre- vs post-`p3_main` tells whether the seed is inside +microphysics or in the host (but in CM1 a pre-call divergence may just be the +buoyancy scalar sum flipping a bit first — it does not by itself clear or +implicate the microphysics). + +**Phase 3 — instrument the point.** Targeted prints of individual process +rates (`qccol`, `qidep`, `qrmlt`, `epsi_tot`, conservation `ratio`s) guarded by +`if (i==i0 .and. k==k0 .and. it==it0)`; diff between runs. + +**Discriminating test for the roundoff class:** double-precision build. If +divergence onset is delayed dramatically → roundoff seeding; barely changed → +logic bug. + +## CM1-specific notes + +- No per-rank `rsl.out` files; either run serial for diagnosis or write + checksums to per-rank files (filename with `myid`). +- `radopt = 0` (no radiation) removes the `diag_effi_ave` → radiation pathway. +- CM1's buoyancy/loading term sums moist scalars over the scalar index in fixed + loop order → host-side permutation sensitivity independent of P3. Even a + fully fixed microphysics will not give bit-identity under the swap unless + this is addressed too. + - **IMPLEMENTED (Claude Code session, 2026-07-19):** new namelist option + `qsum_invariant = .true.` in `&p3_params` (default `.false.`) replaces the + order-sensitive moist-scalar sums in the **prognostic** dynamics path with + permutation-invariant sorted sums (new pure function `sortsumq` in the + `input` module, `input.F`: ascending insertion sort then sum — invariant + to which slot holds which value; ties commute). Sites converted: + - `solve2.F` RK-loop misc block: `dum2` (Σ liquid) / `dum3` (Σ solid) → + buoyancy `dum8`, theta_rho `t11`, `thterm`, `t22` (every RK stage); + - `solve1.F` cvm block (`eqtset=2` + `idiss=1`/`rterm=1`): `dum2`/`dum3` + for moist cv in dissipative heating / rterm; + - `turb.F` (GHB 210521 block): `dum7` = Σql + Σqi feeding the subgrid + turbulence buoyancy terms. + Liquid and solid ranges are each sorted internally (sufficient: the swap + permutes only ice slots). **Not** converted (diagnostic-only, cannot feed + back on prognostic fields): `statpack` (`getqli`), `writeout` + (`calccpch`), `domaindiag`, `azimavg`, `hifrq`, `parcel`, `pdcomp`, + `init3d` (runs once, identically), the `qbudget` energy-budget sums in + `solve1.F`, and `getcvm` in `misclibs.F` (called only from non-P3 + microphysics branches: Kessler/Goddard/Morrison/ptype 6). So diagnostic + output files may still differ bitwise between swapped runs; the Phase-1 + checksums and prognostic state will not, once all in-scheme (P3 §3) + sources are also controlled. + - Test interpretation: run the swap pair with `qsum_invariant=.true.` in + both. Any remaining divergence in the Phase-1 checksums is seeded inside + `p3_main` (P3 §2/§3), not by the host dynamics. Combined with a future + P3-internal permutation-invariance pass, this switch is also the host-side + half of full bit-identity. + +## MPI reproducibility on laptop (OpenMPI / mpirun) + +- Which physical cores ranks land on is irrelevant to the bits; binding + affects speed only. What matters: **same `-np`**, and set `nodex`/`nodey` + explicitly and identically in `namelist.input` (`nodex*nodey = np`). +- Same executable/build for both runs (swap should be namelist-only). +- If built with OpenMP: `OMP_NUM_THREADS=1` (threaded FP reductions are the one + genuine source of run-to-run nondeterminism). +- CM1's feedback-relevant global reduction (adaptive-dt CFL check) is a `max` + — exact and order-independent; global sums are diagnostics only. +- **Validate first:** run the identical configuration twice (no swap) and + confirm checksums match bit-for-bit every timestep. Prefer `-np 1` for the + definitive comparison runs if feasible. + +## Follow-up: entry-clip seed test (2026-07-19, post-RESOLVED) + +Close reading of the current entry clipping pass (line ~2834) showed its gate +is an `.or.` — `qitot < qsmall` (negative undershoots included) always trips +the qv/th add-back, regardless of the `nitot < nsmall` leg (which *adds* +trigger cases rather than guarding). So the clip runs its order-dependent +per-category qv/th accumulation at every undershoot-halo point, making it the +first operation in `p3_main` able to differ between swap runs. (Also +confirmed: the melt-small-ice block at ~2863 is dead code with qsmall=1e-12 — +`qitot>=qsmall .and. qitot<1.e-12` is unsatisfiable; orphaned by the DTD +threshold change.) + +New namelist option **`p3_clipdp = .true.`** in `&p3_params` (default +`.false.`; module switch `log_clipdp`): the clip's per-category qv/th +increments are accumulated in double precision and applied once after the +category loop — practically order-invariant. Test protocol: enable in BOTH +swap runs, rerun the restart bracket. If the first divergence moves later in +time or to a different site/field pattern, the entry clip was the seed; the +new site identifies the next §3 reduction in line. Note the switch changes +results at roundoff level vs. the default path (fine for A/B use; not +intended as a permanent fix by itself). + +**UPDATE (t=175 onset census, per-point dumps):** the clip is EXONERATED as +the seed — of the 158 divergent points at t=175 (one coherent anvil blob, +i=42–50, j=18–27, k=25–38, ~85 columns seeding near-independently with ≤1 +level of same-call sedimentation smear), none flips `qv`, and a clip +order-flip is by construction a visible 1-ulp `qv` change. `p3_clipdp` rerun +deprioritized. Decoded PRE at a source point (47,19,33): REAL coexistence — +qitot_3 (homocloud) 4.5e-11 with nitot 3.8e+2, qitot_4 (rimesplinter) +3.5e-11 with nitot 3.1e-4, qitot_2 4.3e-12 with nitot 9.3e-5 (cat 1 clipped +via negative nitot). Masses comparable; NUMBERS lopsided by ~6 orders → the +category sums are one dominant (cat-3) term plus small terms at relative +1e-7–1e-6 = exactly the flip-prone near-ulp regime. Remaining suspects: the +`epsi_tot` accumulation and/or the conservation-limiter sums. Flips land +visibly only in small-magnitude fields (ice categories), staying sub-ulp in +qv/th — which is why the onset census shows ice-field-only records. +(Label convention rediscovered the hard way: the compare script's category +numbers follow the FIRST argument (reference run); keep runA = rs4/chf3 +first in every command. In that convention cat1=depnuc, cat2=rainfreeze, +cat3=homocloud, cat4=rimesplinter.) + +**A/B discriminator switches (implemented, compile-checked):** +`p3_epsdp = .true.` — `epsi_tot`/`epsiw_tot` accumulated over categories in +double precision (deferred, applied after `iice_loop1`). +`p3_limdp = .true.` — the conservation-limiter category sums +(`sum(qidep)+sum(qinuc)`, `sum(qisub)`, and the cloud/rain/vapor +sinks/sources expressions) evaluated in double precision, rounded once. +Protocol: enable ONE at a time in BOTH members of the swap pair, rerun the +bracket, compare onset. Whichever switch delays/moves the first divergence +identifies the seeding reduction (both may contribute). NOT converted +(inactive in this config, would matter for other configs): `sum(qlcon)`/ +`sum(qlevp)` in the qv_tmp/t_tmp saturation-adjustment lines (liqFrac-only +arrays, identically zero here), the `qicol` catcoll sums (ice-ice +interaction off), and `sum(nitot)` in deposition nucleation (next candidate +if neither switch moves the onset). + +## Permutation-invariance options (if pursuing full invariance later) + +(a) accumulate category reductions and shared-field tendencies in double +precision, round once (practical, not formally invariant); (b) sum categories +in value-sorted order (formally slot-permutation-invariant; ties harmless); +(c) restructure so per-category tendencies are stored in arrays and applied to +shared fields in one fused expression (fixes `iice_loop3` and clipping loops, +the largest contributors). Any single surviving order-sensitive reduction will +still eventually diverge. + +## Handoff to Claude Code + +This local Cowork session can't be resumed in the Claude Code CLI (each surface +keeps its own session history; `--teleport` applies to cloud sessions only). +Plan: copy `p3_category_swap_audit.md` and this `NOTES.md` into the CM1 source +directory, start `claude` there, and prompt e.g.: + +> Read p3_category_swap_audit.md and NOTES.md. The report section 2.1/2.2 +> fixes are already implemented in src/module_mp_p3.F. Add the Phase-1 +> checksum instrumentation described in NOTES.md. diff --git a/README.namelist b/README.namelist index 8453750..2db565b 100644 --- a/README.namelist +++ b/README.namelist @@ -483,10 +483,30 @@ (ptype 26 or 27) (Note: P3 = Predicted Particle Property bulk microphysics scheme) + (options 50-54,56,57,60-67 use namelist p3_params, see below) 50 = P3 1-ice category, 1-moment cloud water 51 = P3 1-ice category plus double-moment cloud water 52 = P3 2-ice categories plus double-moment cloud water 53 = P3 1-ice category, 3-moment ice, plus double-moment cloud water + 54 = P3 2-ice categories, 3-moment ice + 56 = P3 3-ice categories, 3-moment ice + 57 = P3 4-ice categories, 3-moment ice + 60 = P3 1-ice category, 3-moment ice, predicted liquid fraction + 61 = P3 2-ice categories, 3-moment ice, predicted liquid fraction + 62 = P3 3-ice categories, 3-moment ice, predicted liquid fraction + 63 = P3 4-ice categories, 3-moment ice, predicted liquid fraction + 64 = P3 5-ice categories, 3-moment ice (as 57, but 5 categories) + 65 = P3 6-ice categories, 3-moment ice (as 57, but 6 categories) + 66 = P3 5-ice categories, 3-moment ice, predicted liquid fraction + (as 63, but 5 categories) + 67 = P3 6-ice categories, 3-moment ice, predicted liquid fraction + (as 63, but 6 categories) + (All P3 multi-category options use double-moment cloud water. With + p3_cat_init_new = .true. the destination category for each ice + initiation mechanism is set by the p3_catdest_* namelist variables; + the _nN suffix selects the value used when the configuration has N + ice categories, so ptypes 64/66 use the _n5 values and 65/67 the _n6 + values.) 55 = Jensen's ISHMAEL (Ice-Spheroids Habit Model with Aspect-ratio Evolution) nssl_3moment - logical (default = .false.) Works with ptype 26 and 27 to turn on diff --git a/compare_p3_chksum.py b/compare_p3_chksum.py new file mode 100755 index 0000000..9553b19 --- /dev/null +++ b/compare_p3_chksum.py @@ -0,0 +1,296 @@ +#!/usr/bin/env python3 +""" +Compare P3 divergence-diagnosis output files (see NOTES.md), applying an +ice-category permutation to run B before comparing, so a category-swap +experiment can be diffed under the swap mapping. + +Two file formats are auto-detected per line (both from mp_p3_wrapper_wrf in +module_mp_p3.F, tag = 'PRE' entering p3_main / 'POST' after): + + p3_chksum_NNNN.out (Phase 1, slab checksums; namelist p3_chksum): + itimestep j tag + + p3_chkpts_NNNN.out (Phase 2, per-point raw bit patterns; namelist p3_chkpts): + itimestep tag i j k (local) i j k (full grid) + +Field order in both: qv th qc nc qr qnr w p, then per ice category +qitot qirim nitot birim [zitot] [qiliq]. (w and p are inputs to p3_main and +unchanged by it: a divergence in them, even on a POST line, is host-seeded.) + +Modes, chosen by the positional arguments: + + single rank: both arguments are files + ./compare_p3_chksum.py runA/p3_chksum_0000.out runB/p3_chksum_0000.out --swap 3 4 + ./compare_p3_chksum.py runA/p3_chkpts_0000.out runB/p3_chkpts_0000.out --swap 3 4 + + whole simulation: both arguments are directories; every file matching + --pattern in A is paired with the same-named file in B (rank to rank), and + a simulation-wide summary is printed after the per-rank results + ./compare_p3_chksum.py runA runB --swap 3 4 + ./compare_p3_chksum.py runA runB --swap 3 4 --pattern 'p3_chkpts_*.out' + +The mapping means: category 3 of run A is compared against category 4 of run +B, and vice versa (--map 1,2,4,3 for arbitrary permutations; --swap 3 4 is +shorthand for exactly that). + +Output: per rank, the first divergent record (for point files: the exact +local and full-grid i,j,k) and per-tag firsts; in directory mode also the +simulation-wide earliest divergence (chronological order: itimestep, then j, +then PRE before POST, then k, i for point files) and overall counts. +Use --all to list every divergent record. + +Exit status: 0 if identical under the mapping, 1 if divergent, 2 on usage or +format errors. +""" + +import argparse +import glob +import os +import sys + +NSCALAR = 8 +SCALAR_NAMES = ["qv", "th", "qc", "nc", "qr", "qnr", "w", "p"] +CAT_BASE_NAMES = ["qitot", "qirim", "nitot", "birim"] +TAGS = ("PRE", "POST") +TAG_ORDER = {"PRE": 0, "POST": 1} # execution order within one (itimestep, j) + + +def cat_field_names(percat): + """Field names within one category group, by group width.""" + # Written order: base 4, then zitot (if 3-moment ice), then qiliq (if + # liquid-fraction ice). A width of 5 is assumed to be base+zitot (the + # 3-moment configs, e.g. ptype 56/57); base+qiliq-only configs would be + # mislabeled but still compared correctly. + names = list(CAT_BASE_NAMES) + if percat >= 5: + names.append("zitot") + if percat >= 6: + names.append("qiliq") + return names[:percat] + + +def read_records(path): + """Yield (lineno, key, tag, [hex value tokens]). + + key identifies the record and is compared between runs: + slab checksum line: (itimestep, j, tag) [3 tokens] + per-point line: (itimestep, tag, i, j, k, ig, jg, kg) [8 tokens] + """ + with open(path) as f: + for lineno, line in enumerate(f, 1): + line = line.strip() + if not line or line.startswith("#"): + continue + tok = line.split() + if len(tok) > 1 and tok[1] in TAGS: # per-point format + nkey, tag = 8, tok[1] + elif len(tok) > 2 and tok[2] in TAGS: # slab-checksum format + nkey, tag = 3, tok[2] + else: + sys.exit(f"{path}:{lineno}: unrecognized record format") + if len(tok) < nkey + NSCALAR: + sys.exit(f"{path}:{lineno}: too few columns ({len(tok)})") + yield lineno, tuple(tok[:nkey]), tag, tok[nkey:] + + +def describe(key): + """Human-readable location of a record.""" + if len(key) == 3: + it, j, tag = key + return f"itimestep={it} j={j} {tag}" + it, tag, i, j, k, ig, jg, kg = key + return (f"itimestep={it} {tag} local (i,j,k)=({i},{j},{k}) " + f"full grid ({ig},{jg},{kg})") + + +def divergence_key(div): + """Chronological sort key for a divergence (key_tuple, fields).""" + key = div[0] + if len(key) == 3: + it, j, tag = key + return (int(it), int(j), TAG_ORDER.get(tag, 2), 0, 0) + it, tag, i, j, k = key[:5] + return (int(it), int(j), TAG_ORDER.get(tag, 2), int(k), int(i)) + + +def compare_pair(file_a, file_b, mapping, ncat, list_all, label=""): + """Compare one rank's pair of files. Returns a summary dict.""" + percat = None + field_names = None + ndiff = 0 + first = None + first_by_tag = {} + nlines = 0 + prefix = f"rank {label} " if label else "" + + for rec_a, rec_b in zip(read_records(file_a), read_records(file_b)): + lineno_a, key_a, tag_a, vals_a = rec_a + lineno_b, key_b, tag_b, vals_b = rec_b + + if key_a != key_b: + sys.exit(f"record mismatch at {file_a}:{lineno_a} {key_a} vs " + f"{file_b}:{lineno_b} {key_b} -- different " + f"configs/domains?") + if len(vals_a) != len(vals_b): + sys.exit(f"column-count mismatch at line {lineno_a}: " + f"{len(vals_a)} vs {len(vals_b)}") + + if percat is None: + ncatcols = len(vals_a) - NSCALAR + if ncatcols % ncat != 0: + sys.exit(f"{file_a}: {ncatcols} category columns not " + f"divisible by ncat={ncat}; check --ncat") + percat = ncatcols // ncat + field_names = SCALAR_NAMES + [ + f"{name}_{c}" for c in range(1, ncat + 1) + for name in cat_field_names(percat)] + + # reorder run B's category groups under the mapping + vals_b_mapped = vals_b[:NSCALAR] + for c in range(ncat): + src = mapping[c] - 1 + beg = NSCALAR + src * percat + vals_b_mapped += vals_b[beg:beg + percat] + + nlines += 1 + if vals_a != vals_b_mapped: + ndiff += 1 + bad = [field_names[i] for i, (a, b) + in enumerate(zip(vals_a, vals_b_mapped)) if a != b] + info = (key_a, bad) + if first is None: + first = info + first_by_tag.setdefault(tag_a, info) + if list_all: + print(f"DIFF {prefix}{describe(key_a)} " + f"fields: {' '.join(bad)}") + + if nlines == 0: + sys.exit(f"no data records found in {file_a} / {file_b}") + + return {"label": label, "nlines": nlines, "ndiff": ndiff, + "first": first, "first_by_tag": first_by_tag, "percat": percat} + + +def report_pair(res, verbose=True): + """Print the summary for one rank pair. Returns True if divergent.""" + if res["first"] is None: + if verbose: + print(f" {res['nlines']} records: IDENTICAL under the mapping") + return False + key, bad = res["first"] + print(f" first divergence: {describe(key)} fields: {' '.join(bad)}") + for tag in sorted(res["first_by_tag"]): + key, bad = res["first_by_tag"][tag] + print(f" first {tag:<4} divergence: {describe(key)} " + f"fields: {' '.join(bad)}") + print(f" {res['ndiff']} of {res['nlines']} records differ") + return True + + +def rank_files(rundir, pattern): + """Map rank label -> path, for files matching pattern in rundir.""" + out = {} + for path in glob.glob(os.path.join(rundir, pattern)): + base = os.path.basename(path) + label = os.path.splitext(base)[0].rsplit("_", 1)[-1] + out[label] = path + if not out: + sys.exit(f"no files matching {pattern} found in {rundir}") + return out + + +def main(): + ap = argparse.ArgumentParser( + description=__doc__, formatter_class=argparse.RawDescriptionHelpFormatter) + ap.add_argument("a", help="run A: output file, or run directory") + ap.add_argument("b", help="run B: output file, or run directory " + "(gets the mapping)") + ap.add_argument("--ncat", type=int, default=4, + help="number of ice categories (default 4)") + grp = ap.add_mutually_exclusive_group() + grp.add_argument("--swap", nargs=2, type=int, metavar=("C1", "C2"), + help="swap two categories of run B, e.g. --swap 3 4") + grp.add_argument("--map", dest="catmap", + help="full permutation for run B, e.g. --map 1,2,4,3") + ap.add_argument("--all", action="store_true", + help="list every divergent record, not just the first") + ap.add_argument("--pattern", default="p3_chksum_*.out", + help="directory mode: filename glob per rank " + "(default p3_chksum_*.out; use p3_chkpts_*.out " + "for the per-point dumps)") + args = ap.parse_args() + + ncat = args.ncat + mapping = list(range(1, ncat + 1)) # identity: A cat i <-> B cat i + if args.swap: + c1, c2 = args.swap + if not (1 <= c1 <= ncat and 1 <= c2 <= ncat): + sys.exit(f"--swap categories must be in 1..{ncat}") + mapping[c1 - 1], mapping[c2 - 1] = c2, c1 + elif args.catmap: + mapping = [int(x) for x in args.catmap.split(",")] + if sorted(mapping) != list(range(1, ncat + 1)): + sys.exit(f"--map must be a permutation of 1..{ncat}") + + a_isdir, b_isdir = os.path.isdir(args.a), os.path.isdir(args.b) + if a_isdir != b_isdir: + sys.exit("give two files or two directories, not a mix") + + if not a_isdir: + # ----- single-rank mode ----- + res = compare_pair(args.a, args.b, mapping, ncat, args.all) + print(f"compared {res['nlines']} records (ncat={ncat}, " + f"{res['percat']} fields/category, B-mapping {mapping})") + divergent = report_pair(res, verbose=False) + if not divergent: + print("IDENTICAL under the mapping") + sys.exit(1 if divergent else 0) + + # ----- whole-simulation mode: pair up ranks ----- + files_a = rank_files(args.a, args.pattern) + files_b = rank_files(args.b, args.pattern) + only_a = sorted(set(files_a) - set(files_b)) + only_b = sorted(set(files_b) - set(files_a)) + if only_a or only_b: + sys.exit(f"rank sets differ: only in A: {only_a or '-'}, " + f"only in B: {only_b or '-'} -- same decomposition required") + + results = [] + for label in sorted(files_a): + print(f"rank {label}:") + res = compare_pair(files_a[label], files_b[label], + mapping, ncat, args.all, label=label) + report_pair(res) + results.append(res) + + nranks = len(results) + nlines = sum(r["nlines"] for r in results) + ndiff = sum(r["ndiff"] for r in results) + bad_ranks = [r for r in results if r["first"] is not None] + + print(f"\n=== simulation-wide ({nranks} ranks, {nlines} records, " + f"ncat={ncat}, {results[0]['percat']} fields/category, " + f"B-mapping {mapping}) ===") + if not bad_ranks: + print("IDENTICAL under the mapping on every rank") + sys.exit(0) + + earliest = min(bad_ranks, key=lambda r: divergence_key(r["first"])) + key, bad = earliest["first"] + print(f"earliest divergence: rank {earliest['label']} {describe(key)} " + f"fields: {' '.join(bad)}") + # per-tag earliest across ranks + for tag in sorted({t for r in bad_ranks for t in r["first_by_tag"]}): + cand = [(r["label"], r["first_by_tag"][tag]) for r in bad_ranks + if tag in r["first_by_tag"]] + label, (key, bad) = min(cand, key=lambda c: divergence_key(c[1])) + print(f" earliest {tag:<4} divergence: rank {label} " + f"{describe(key)} fields: {' '.join(bad)}") + print(f"{len(bad_ranks)} of {nranks} ranks divergent; " + f"{ndiff} of {nlines} records differ") + sys.exit(1) + + +if __name__ == "__main__": + main() diff --git a/decode_point.sh b/decode_point.sh new file mode 100755 index 0000000..210177d --- /dev/null +++ b/decode_point.sh @@ -0,0 +1,15 @@ +#!/bin/bash +# Decode one record of a p3_chkpts_NNNN.out per-point dump (see NOTES.md) +# into named field values (raw 32-bit patterns -> floats). +# usage: ./decode_point.sh +awk -v it=$2 -v tg=$3 -v i=$4 -v j=$5 -v k=$6 \ + '$1==it && $2==tg && $3==i && $4==j && $5==k' "$1" | python3 -c ' +import struct, sys +names = (["qv","th","qc","nc","qr","qnr","w","p"] + + [f"{n}_{c}" for c in range(1,5) for n in ["qitot","qirim","nitot","birim","zitot"]]) +data = sys.stdin.read().split() +if not data: sys.exit("no matching record") +for n, h in zip(names, data[8:]): + v = struct.unpack(">f", bytes.fromhex(h))[0] + print(f"{n:10s} {v:.9e}") +' diff --git a/p3_category_swap_audit.md b/p3_category_swap_audit.md new file mode 100644 index 0000000..6135ed0 --- /dev/null +++ b/p3_category_swap_audit.md @@ -0,0 +1,140 @@ +# Audit: Why swapping `iice_dest` category numbers changes P3 solutions + +> **STATUS UPDATE (post-fix revision of module_mp_p3.F, 13,018 lines — verified):** +> The fixes for Sections 2.1 and 2.2 below have been **implemented and verified** in the +> updated source: +> - Gate at (new) line 2873 changed to `nitot(i,k,iice) .ge. nsmall`, and matching +> `.ge. nsmall` number-concentration checks added to all downstream process blocks +> (collection 3107/3118, T>0 collection 3146–3175, ice-ice gate 3202, self-collection +> 3290, melting 3308/3334, wet growth 3362, epsi 3416, refreezing 3462, HM 3712, +> dep/sub 3928/3975) and to the sedimentation gates (5587, 5681, 5785, 5934). +> Additional `nc`/`nr ≥ nsmall` checks added alongside. +> - `Eii_fact(iice) = 1.0` default at top of `iice_loop1` (line 2871); `tmp1 = 0.` +> initialized before the rime-fraction block (line 3067). +> - Separate issue found and fixed: divide-by-zero in Seifert–Beheng autoconversion +> (`iparam=1`) when `dum → 1` (the `(1.-dum)**2` denominator), a rare trigger that +> produced NaNs ~3000 s into one run. Guarded with `if (dum < 1.)`, the +> `qc_not_small_1` gate now also requires `nc*iSCF ≥ nsmall`, and `isnan` traps were +> added. Default `iparam=3` is used going forward. +> - `f1pr*` scalars are still not defensively reset per category iteration; with the +> aligned gates all *known* stale-consumption paths are closed, but the NaN-poisoning +> test remains available as a definitive check. +> +> **Result: swap-test divergence persists after these fixes.** This is consistent with +> this report's prediction that the Section 3 order-of-operations sites are sufficient +> on their own to break bit-identity. Next step is the Section 4 program: Phase 1/2 +> checksum instrumentation to locate the first divergent timestep/point and measure the +> seed magnitude, and the double-precision A/B test to confirm the roundoff mechanism. +> Line numbers in the body below refer to the **original** audited file (12,823 lines). + +**File audited:** `module_mp_p3.F` (12,823 lines) +**Configuration assumed:** `cat_init_new = .true.` (fixed `catdest_*` destinations), `log_iceice_interaction = .false.`, category merging off (merging is disabled under `cat_init_new`, line 6074), `nCat = 4`, swap of `catdest_depnuc_n4` and `catdest_rimesplinter_n4` (3↔4 vs 4↔3). + +--- + +## 1. Bottom line + +The audit found **both** things you were hoping to distinguish between: + +1. **A genuine bug class** — stale/uninitialized work variables (`f1pr*`, `Eii_fact`, `tmp1`) that leak from one category's lookup-table retrieval into another category's process rates, in a way that depends on category *ordering*. This is a real defect and should be fixed. + +2. **A structural property of the code** — many reductions over categories and sequential updates of shared fields are performed in category-index order. Under a pure content-swap of categories 3 and 4, these combine *the same physical numbers in a different order*, which changes the last bit of the result. In single precision, in a moist convective simulation, a 1-ulp difference amplifies to visible divergence within minutes. + +Even after fixing item 1, **bit-identical results under a category permutation are not achievable with the code as structured** unless the category reductions are made permutation-invariant (Section 4 explains how, and how to test which class is responsible for what you're seeing). + +The "identical for several minutes, then divergence" signature is consistent with either class: nothing differs until the *first* time step and grid point at which the two swapped ice species (or the edge case in Section 2.1) coexist in a single sum or shared-field update; from then on the perturbation grows chaotically. + +--- + +## 2. Genuine bugs (asymmetric, order-dependent behavior) + +### 2.1 Stale `f1pr*` lookup values consumed when `nitot == nsmall` exactly (most likely "real bug") + +This is the strongest candidate for a true defect. + +The main per-category lookup-table block is gated at line 2871: + +```fortran +qitot_notsmall_1: if (qitot(i,k,iice).ge.qsmall .and. nitot(i,k,iice) > nsmall ) then ! ERM added nitot check +``` + +Note the **strict** `> nsmall`. But the clipping pass earlier (line 2653) floors number concentration to **exactly** `nsmall` whenever `qitot ≥ qsmall` and `nitot < nsmall`: + +```fortran +nitot(i,k,iice) = Max (nitot(i,k,iice), nsmall) ! ERM +``` + +So any category arriving with `qitot ≥ qsmall` (=1e-12) and depleted number gets `nitot == nsmall` (=1e-8) exactly, and the `qitot_notsmall_1` block is **skipped** — no lookup-table calls, no refresh of `f1pr01…f1pr38`, no `Eii_fact(iice)`, no `diam_ice` update. + +However, the downstream process-rate blocks for that same category use *weaker* conditions and still execute: + +- **Cloud collection** (line 3104): `qitot ≥ qsmall .and. nitot > 0.` → computes `qccol`, `nccol` using `f1pr04`. +- **Rain collection** (line 3115): same gate → uses `f1pr07`, `f1pr08`, `f1pr36`. +- **Melting** (lines 3305/3331): `qitot − qiliq ≥ qsmall .and. T > 273.15` — **no nitot condition at all** → uses `f1pr05`, `f1pr14` (or `f1pr24–f1pr27`). +- **Wet growth** (line 3359): uses `f1pr05`, `f1pr14`. +- **Ice self-collection** (line 3287): `qitot ≥ qsmall` → uses `f1pr03` and `Eii_fact(iice)`. +- **Vapor relaxation timescale** (line 3413): `qitot ≥ qsmall` → `epsi(iice)` from `f1pr05`, `f1pr14`, which feeds `epsi_tot` and hence `xx`, `aaa`, and the deposition/condensation rates of **all** species at that grid point. + +The `f1pr*` variables are **plain scalars, never reset per category iteration** (grep confirms no `f1pr04 = 0.` style initializations; only the `-99` sentinels for `f1pr07/08` when `qr < qsmall`). So the affected category computes its rates using the lookup values of **whichever category was most recently processed through the gate** — or, if no category has passed yet at this grid point, leftover values from a previous k-level or column (or genuinely uninitialized values on first use). + +**Why this breaks your swap symmetry:** suppose at some (i,k), category A has healthy ice and category B is in the degenerate `nitot == nsmall` state. If A has the lower index, B inherits A's `f1pr*` values. After swapping the destination assignments, B now has the lower index — and inherits values from category 2, or from a previous level, instead. The contamination is different in the two runs, so the process rates differ by more than roundoff. The contaminated rates are proportional to `nitot = 1e-8`, so each individual instance is tiny — but a tiny asymmetric perturbation is all it takes. + +The same `ERM` gate (`nitot > nsmall`) appears in sedimentation (lines 5393, 5487, 5740), but there the fall speeds are explicitly zeroed each substep (`V_qit(:) = 0.`), so no staleness occurs. The final-diagnostics loop (line 6272) uses `≥ nsmall` — inconsistent with the strict `>` in the main loop, incidentally. + +**Fix suggestions:** +- Make the gates consistent: either change line 2871 (and the sedimentation gates) to `nitot(i,k,iice) .ge. nsmall`, or make every downstream process condition require exactly the same predicate as `qitot_notsmall_1` (e.g., set a per-category logical `log_lookupFresh(iice)` inside the gate and require it in every block that consumes `f1pr*`). +- Defensively reset all `f1pr*` scalars (and `Eii_fact(iice)`, see 2.2) at the top of each `iice_loop1` iteration. A cheap way to *prove* this mechanism is active: initialize them to signaling NaNs with FP trapping enabled — the trap will fire at the first stale consumption. + +### 2.2 `Eii_fact` and `tmp1` initialization gaps + +`Eii_fact` (dimension `nCat`) is set **only** inside `qitot_notsmall_1` (lines 3065–3079) and is never given a default. Any consumption outside the gate (self-collection at 3288, and ice-ice collection if you ever re-enable it) uses a stale value from a previous k-level or an undefined one on first touch. + +Inside its computation there is a second stale-scalar hazard (lines 3065–3068): + +```fortran +if (qirim(i,k,iice)>0.) then + if ((qitot(i,k,iice)-qiliq(i,k,iice))>0.) then + tmp1 = qirim(i,k,iice)/(qitot(i,k,iice)-qiliq(i,k,iice)) + endif + if (tmp1.lt.0.6) then ... +``` + +If `qirim > 0` while `qitot − qiliq ≤ 0` (inconsistent but reachable state), `tmp1` retains whatever the previous category or process left in it. `tmp1` is a heavily reused scratch variable, so the inherited value is arbitrary and ordering-dependent. + +### 2.3 Things checked and found clean (for your configuration) + +Ice–ice collection and its tendency application are both properly gated by `log_iceice_interaction` (lines 3188, 4706). Merging is off under `cat_init_new` (line 6074). All six initiation processes (contact/immersion freezing, rain immersion, rime splintering, deposition nucleation, homogeneous cloud and rain freezing) have `catdest_*` assignments for nCat = 2, 3, 4, and none falls back to `icecat_destination` or a hardcoded index when `cat_init_new = .true.`. The `merge_opt == -1` / `qrcol_opt == 2` special cases are restricted to `nCat == 2` and don't fire at nCat = 4. `impose_max_total_Ni` — which scales all categories by a ratio involving `sum(nitot)` — is commented out at all three call sites. Each initiation process writes to its own rate array (`qcheti`, `qrheti`, `qinuc`, `qrmul`, …), so no destination-overwrite conflicts exist. Sedimentation is fully independent per category. `diam_ice` is zeroed at line 2501 and again before homogeneous freezing (5932), so its staleness only causes a category's HM size check to fail deterministically, which is symmetric. + +--- + +## 3. Inherent order-of-operations sites (unavoidable with current structure) + +These all combine identical physical values in category-index order. Floating-point addition is not associative, so a content swap of categories 3 and 4 changes the rounding wherever both hold nonzero values. Each occurrence seeds an O(1 ulp) relative perturbation into a prognostic field. + +**Sequential updates of shared prognostic fields inside category loops.** The largest contributor is `iice_loop3` (lines 4657–4771), where `qc`, `nc`, `qr`, `nr`, `qv`, and `th` are updated once per category, in loop order: `((qc − s₁·dt) − s₂·dt) − s₃·dt − s₄·dt` ≠ the same with s₃ and s₄ interchanged. The same pattern occurs in the initial clipping loop (2641–2683, `qv`/`th` incremented per category), the liquid-fraction clipping loop (4797), the small-value clipping loop (4832), and the final-diagnostics loop (6428). + +**Explicit reductions over categories.** `sum(nitot(i,k,:))` inside deposition nucleation (lines 4047, 4050) — this one directly modulates `N_nuc`/`Q_nuc`, i.e., the very processes you swapped. The saturation-adjustment and conservation limiters at lines 4431, 4447–4448, 4459–4464, 4490–4491, 4518–4521, 4600–4601 (`sum(qidep)`, `sum(qccol)`, `sum(qisub)`, etc.), where the resulting `ratio` rescales every category's rates. The accumulations `epsi_tot = epsi_tot + epsi(iice)` (line 3417) and `epsiw_tot` (3422), which feed `xx` and `aaa` (3783, 3824) and therefore condensation/deposition for everything at that grid point. The Hallett–Mossop accumulation `qrmul(iice_dest) = qrmul(iice_dest) + dum2` over source categories (3739–3740). `compute_SCPF(Qc + sum(Qitot,dim=2), …)` (2718, 5069, 5921) if SCPF is active. + +Notably, the code already contains one fix for exactly this issue — DTD's comment at lines 4477–4481 ("replaced sum(qisub) with tmp2 to avoid repeated summation (and potential order-dependent results)"). That fix addressed a *worse* variant (re-summing a partially-modified array), but the ordinary permuted-content sensitivity remains everywhere `sum()` is used. + +**Host-model couplings outside this file.** Per-scalar advection is identical regardless of which tracer slot holds a species, but anything in the host that sums hydrometeors in array order can also seed differences: total-condensate loading in the pressure/buoyancy terms, and the wrapper's `diag_effi_ave` (lines 1195–1204, `dum1+dum2+dum3+dum4`) if it feeds radiation. + +--- + +## 4. How to determine which class you're seeing, and what to do + +**Diagnose the seed.** At the first divergent time step, difference the two runs' full state. If the maximum relative difference is ~1e-7 (single-precision ulp) and confined to a few grid points where both swapped species coexist, the seed is Section 3 roundoff. If you see a jump much larger than that, or differences localized where one category sits at `nitot == nsmall`, it's the Section 2.1 bug. Writing per-timestep, per-field checksums and bisecting to the first divergent (i,j,k) is cheap and definitive. + +**Trap the stale-value bug directly.** Compile with FP trapping (`-ffpe-trap=invalid` / `-fpe0`) after initializing `f1pr01…f1pr38`, `Eii_fact`, and `tmp1` to signaling NaNs at the top of each `iice_loop1` iteration. Any trap is proof the bug path executes in your runs. Independently, changing the line-2871 gate to `.ge. nsmall` and re-running the swap test tells you how much of the divergence that path explains. + +**Test the roundoff hypothesis.** Build the model in double precision (or promote just the microphysics reals). If divergence onset is delayed dramatically (roundoff seeds shrink from ~1e-7 to ~1e-16 relative), the driver is Section 3. If the timing barely changes, keep hunting for a logic bug. + +**If you want true permutation invariance** (bit-identical results under destination swaps), the reductions must be made independent of which slot holds which value. Practical options, in increasing rigor: (a) accumulate all category reductions and shared-field tendency sums in double precision and round once — not formally invariant, but usually pushes differences below single-precision representability for a long time; (b) sum categories in a *value-sorted* order (a sum over ascending values is invariant to slot permutation; ties are harmless because equal values commute); (c) restructure so per-category tendencies are stored in arrays and applied to shared fields in a single fused expression rather than incrementally per category — this fixes `iice_loop3` and the clipping loops, which are the biggest contributors. Note that even one surviving order-sensitive reduction is enough to eventually diverge. + +--- + +## 5. Summary of most likely culprits, ranked + +**(1)** Order-of-operations roundoff in category reductions and sequential shared-field updates (Section 3) — mathematically guaranteed to break bit-identity once swapped species coexist anywhere; fully consistent with your observed timeline. **(2)** The `nitot == nsmall` stale-`f1pr*`/`Eii_fact` gating bug (Section 2.1) — a genuine, fixable defect producing ordering-dependent physics, though its rate perturbations are individually tiny. **(3)** The `tmp1`/`Eii_fact` initialization gaps (2.2) — same family, rarer trigger. **(4)** Host-side order-sensitive sums (total condensate, `diag_effi_ave` → radiation) — worth checking once the in-scheme sources are controlled. + +The realistic expectation: fixing (2) and (3) is worthwhile and may change the divergence onset, but exact invariance under the swap will additionally require (1)-class restructuring or the double-precision accumulation strategy. The double-precision A/B test in Section 4 is the fastest way to confirm this before investing in refactoring. diff --git a/p3_smallvalue_gating_notes.md b/p3_smallvalue_gating_notes.md new file mode 100644 index 0000000..fb618ce --- /dev/null +++ b/p3_smallvalue_gating_notes.md @@ -0,0 +1,486 @@ +# P3 small-value gating: grid-point noise investigation + +Running record of the 2026-08-01 session. Companion to `NOTES.md` (which covers +the separate category-swap / bit-reproducibility work). Read this before +touching any `qsmall` / `nsmall` test, floor, or gate in `src/module_mp_p3.F`. + +**Status:** all changes are uncommitted, syntax-checked, and exercised in short +(1500 s, 200-step) runs of the 2 km ptype-54 case. Nothing is committed. + +--- + +## 1. The problem + +Grid-point ("checkerboard") noise in ptype-54 storm simulations: isolated +spikes in pressure perturbation and theta, holes in the predicted moments, and +isolated bright pixels in diagnosed reflectivity — mostly aloft around the +edges of the ice field, but not only there. Not seen with the NSSL scheme in +the same model setup. + +## 2. The central insight + +Nearly every symptom traced to one structural pattern: + +> **The host delivers a hydrometeor species with mass but no number, and P3 +> responds by manufacturing the missing number rather than declining to act.** + +The manufactured number is always `nsmall = 1e-8 #/kg`, which for any real +mass implies an absurd mean particle size. Downstream, the lookup-table index +clamp (`dum1 = min(dum1, real(isize))`) silently absorbs the result, so the +failure is *laundered into a legal table index* and never reported. + +Three independent confirmations of the same shape: + +| species | how the broken state arrives | what P3 did about it | +|---|---|---| +| ice | host advection delivers `qitot > 0`, `nitot < 0` | `where(nitot<0) nitot=0`, then entry clip floors to `nsmall` | +| rain | same, `qr > 0`, `nr <= 0` | entry clip floors `nr` to `nsmall` | +| cloud | same, `qc > 0`, `nc = 0` | entry clip floors `nc` to `nsmall` | + +Measured: `PREQN` fired ~47,000 times/run for ice (100% with **negative** +`nitot` at the pack, before P3's own clamp zeroes it). `PREQR` fired ~49,000 +times for rain, a third of them with genuinely negative `nr`. + +**The root cause is upstream of P3, in the host's transport of number +concentration.** It is not fixed. Everything done this session changes how P3 +*responds* to it. + +## 3. `qsmall` / `nsmall` — the logic that matters + +Current values (`module_mp_p3.F`): + +``` +qsmall = 1.e-12 ! raised from P3's original 1.e-14 by ERM +nsmall = 1.e-8 ! raised from 1.e-16 by ERM +ntiny = nsmall ! comment suggests intent was nsmall*1e-8, i.e. smaller +``` + +### 3.1 Two alternative protections, and why that matters + +A hazard (division by number, `log` of number, a lookup keyed on `q/n`) can be +protected in two different ways: + +1. **A floor** — `n = max(n, nsmall)` — makes the value safe but *invents + number*, producing an absurd size. +2. **A gate** — `if (q >= qsmall .and. n >= nsmall)` — declines to act. + +The original upstream P3 had only floors. ERM and DTD added gates over time, so +the current tree has **both** in most places. That redundancy is why the floors +can be removed: the gates already do the job. But it is *not* uniform, and the +exceptions are where every bug in this session lived. + +### 3.2 The invariant, and how it breaks + +With floors disabled, the intended invariant after the entry clip is: + +> either `(q = 0, n = 0)` or `(q >= qsmall .and. n >= nsmall)` + +Every downstream gate depends on it. **A floor sitting under a gate that tests +a *different* variable silently breaks it.** That is the single most important +thing to know before editing this code. + +Concrete instance (cost a NaN crash and most of an evening): +`if (log_maxnsmall) nr(i,k) = max(nr(i,k),ntiny)` inside `qitot_notsmall_1`, +whose gate tests **`qitot`/`nitot` only**. Sequence: + +1. `get_rain_dsd2` declines (`nr < nsmall`) → `cdistr = 0`, `lamr = 0`. +2. That line floors `nr` to exactly `nsmall`. +3. A later consumer gate tests `nr >= nsmall` → passes on a DSD that was declined. +4. `log(cdistr=0) + (-6*log(lamr=0))` = `-Inf + Inf` = NaN → invalid operation. + +**Rule: a floor on variable X must be gated by the same switch that controls +X's floors, no matter which block it sits in.** All 6 `nr` floors are now under +`log_nrfloor`; all 8 `nitot` floors and the `nc` floors under `log_nifloor`. + +### 3.3 `if/else` structure is load-bearing + +Several `if (q >= qsmall …)` tests have an **`else` that destroys the mass** +(returns it to vapour). Attaching an `n` condition to such a test does not make +the point inert — it *destroys* it. Both exit clips are like this. + +Correct pattern (used in both exit blocks now): + +```fortran +if (q >= qsmall) then ! else clears the category + if (log_Xfloor .or. n >= nsmall) then ! guards lookups/diagnostics only + … + endif +else + …clear… +endif +``` + +I got this wrong on the rain exit block first time round; Daniel caught it. + +### 3.4 Threshold edits that cancelled each other + +- `qsmall` was raised to `1e-12` while the secondary clip criteria still read + `q < 1.e-12 .and. sup < -0.1`. Since `qsmall == 1e-12` the second clause is a + **no-op** — the "only clip if subsaturated" safety valve is dead. +- `if (qitot >= qsmall .and. qitot < 1.e-12 …)` is an **empty set**. That + small-warm-ice-to-rain conversion never fires. Originates in ERM's file. +- `log_maxnsmall` gates the *wrong* floors: the ones it switches sit inside + gates already requiring `n >= nsmall` (and `ntiny == nsmall`), so they are + provable no-ops; the entry-clip floors that actually act are **not** switched + by it. Setting `log_maxnsmall = .false.` is therefore not a test of anything. + +## 4. Code changes (all uncommitted) + +`src/module_mp_p3.F` (+694 lines), `src/mp_driver.F`, `src/param.F`. +`src/input.F` has unrelated whitespace-only changes that predate this session. + +### 4.1 New namelist options (`&p3_params`) + +| option | default | purpose | +|---|---|---| +| `p3_limlog` | `.false.` | limiter-firing log → `p3_limlog_NNNN.out` | +| `p3_limlog_rat` | `0.9` | record conservation-limiter firings only below this ratio | +| `p3_dbg_i/j/k` | `0` | targeted point dump → `p3_dbgpt_NNNN.out` (`<=0` disables) | +| `p3_dbg_halo` | `1` | half-width of the dumped block | +| **`p3_nifloor`** | `.true.` | **TEMPORARY** — `.false.` disables all `nitot`/`nc` floors | +| **`p3_nrfloor`** | `.true.` | **TEMPORARY** — `.false.` disables all `nr` floors | + +Both floor switches use the `log_Xfloor .or. …` short-circuit form so `.true.` +reproduces original behaviour. **Verified bit-identical for `p3_nifloor`.** +`p3_nrfloor = .true.` was verified bit-identical *before* the final +restructuring of the ice exit block — **re-verify both after the next build.** + +### 4.2 `p3_nifloor = .false.` — 21 guarded sites + +Entry-clip `nc` and `nitot` floors; `nc` conditions on five cloud gates +(`Vt_qc`/`D_c`, the `t<=269.15` block, `1./lamc**bcn`, `qc_not_small_1`, +`diag_effc`); `qc_not_small_2` (homogeneous freezing); `nitot` conditions on +the `k_loop_fz` and `qi_not_small_merge` gates; the restructured exit ice +block; and 8 `log_maxnsmall` `nitot` floors. Search `TEMPORARY (log_nifloor)`. + +### 4.3 `p3_nrfloor = .false.` — 15 guarded sites + +Entry-clip `nr` floor; `get_rain_dsd2`'s internal guard; `nr` conditions on the +three ice-collects-rain blocks, the `t<=269.15` rain-freezing block, rain +evaporation (`epsr`), and the exit rain block's DSD/`ze_rain` sub-block; and +6 `log_maxnsmall` `nr` floors. + +### 4.4 Bug fixed in passing + +`mp_driver.F`: `IF (trim(qunit(lccn)) /= 'none')` evaluated `qunit(0)` whenever +`p3_ccn_on = 0` (which sets `lccn = 0`). Out-of-bounds read; in an optimised +build the branch would then read *and write* `q3d(i,j,k,0)` — a full 3-D slab +before the array. Now `lccn > 0 .and. trim(qunit(max(lccn,1))) /= 'none'` at +four sites. **Never A/B'd against an unpatched binary**, so it is unknown +whether it was firing in production runs. + +### 4.5 `get_rain_dsd2` — `mu_r` was unset on the else path + +Its `else` set `lamr`, `cdistr`, `logn0r` but **not** `mu_r` (unlike +`get_cloud_dsd2`, which sets `mu_c = 0`). Harmless while the else only fired on +`qr < qsmall`; widening the guard would have left `mu_r` stale. Now sets +`mu_r = 0.`. + +## 5. Instrumentation + +### 5.1 Limiter-firing log (`p3_limlog`) + +`event it i j k (full grid) iice ratio v1 v2 v3 v4`, one line per firing. +Read-only; `.false.` leaves every path bit-identical. Events: + +- **`PREQN` / `PREQR`** *(host-side, `mp_driver`)* — what the host hands P3. + `PREQN` is a **sign** test (ice mass with `nitot <= 0`); `PREQR` a **ratio** + test (rain mean-mass diameter > `preqr_dmax = 1 mm`, hardcoded parameter). + The distinction matters: `PREQN` stayed silent through the entire 50 dBZ + episode because that rain had *small* number, not *zero*. +- **`NFLRC` / `NFLRR` / `NFLRI`** — an entry-clip floor condition was met. + Logged *before* the floor, so they record the condition, not the action. +- **`NGATE`** — ice category rejected by the `nitot >= nsmall` gate. +- **`CLIPR`** — now provably dead; kept as a canary. +- **`MAXNI`** — `impose_max_Ni` clipped `nitot`. +- **`RLAMX` / `RLAMN`** — rain lambda limiter pinned the spectrum at max/min + mean diameter. `iice` column carries the call site (1 = k-loop, + 2 = sedimentation, **3 = final diagnostics, the one feeding `ze_rain`**). + Useful identity: **`ratio` = the reflectivity factor**, so + `ΔdBZ = 10·log10(ratio)`. +- **`CLOUD`/`RAIN`/`ICE`/`VAPOR`/`SATC0`/`SATCR`/`SATER`/`SATD0`/`SATDR`/`MELT`/`QILIQ`** + — conservation and saturation-adjustment limiters. + +### 5.2 Targeted point dump (`p3_dbg_*`) + +One line per timestep per point in a `(2·halo+1)³` block. Columns: `qc nc mu_c +lamc qr nr mu_r lamr ze_ice ze_rain dbz`, four `nr` and four `qr` checkpoints, +`dnr_ice ncautr nrslf nrevp`, `qcacc_raw qcacc_fin accbr rwrad xvr`, then per +ice category `qitot nitot qirim birim zitot diag_di`. + +The **checkpoints** are the most valuable part — `nr`/`qr` captured at entry, +post-ice-interaction, post-warm-phase and post-sedimentation, so a change can +be attributed to a phase rather than guessed at. They are what disproved both +the "sedimentation creates mass" and "transport delivered it" hypotheses for +the 50 dBZ case. + +`accbr` records which Cohard–Pinty accretion branch executed (0/2/3/4). + +## 6. Findings, with evidence + +### 6.1 Resolved: 19.8 dBZ blip (rain) + +Host delivered `qr ≈ 6e-8` with `nr <= 0`; entry clip floored `nr` to `1e-8`; +`get_rain_dsd2`'s lambda limiter pinned the spectrum at the 2 mm ceiling and +rebuilt `nr`; `ze ∝ qr²/nr` rendered it at 19.8 dBZ, ~33 dB above what the same +mass with intact number would give. **Fixed** by `p3_nrfloor = .false.` +(confirmed — the blip is gone). + +### 6.2 Open: ~50 dBZ feature (rain accretion runaway) — **SHELVED** + +At (38,38,12–13), `qr` jumped 5 orders in one step. Attribution via checkpoints: +not transport, not sedimentation, not ice melt — the **warm phase** added +`1.28e-4 kg/kg` of rain mass while adding **zero** rain number. + +Measured cause: `accbr = 4`, i.e. the Cohard–Pinty **small-drop** accretion +branch, selected because `rwrad = 49.0 µm` fell just under the 50 µm switch. +That branch scales as `xvr² ∝ 1/nr²`. With `nr = 0.32 #/kg` instead of a +physical ~1e4, the raw rate is inflated by ~1e9. `qcacc_raw = 1.43e-3` was +clamped 83.7× by the conservation limiter to `1.71e-5` — which still converted +**the entire cloud water content of the level in one 7.5 s step**, giving a +9.2 mm mean drop before the lambda limiter pinned it at 2 mm. + +Also observed: the branch **flips every timestep** (`accbr` = 2, 2, 0, 4, 3 +over it=196–200; `rwrad` = 69.5, 79.8, —, 49.0, 1817 µm), with raw rates +differing by 1.8e5 across the 50 µm switch. That threshold is itself a +per-point discontinuity between formulas with opposite `nr` sensitivity. + +**Note there is a fix already written and commented out** three lines below the +branch (`module_mp_p3.F`, search `qcacc = Min(qcacc, 0.10*qc(i,k)*odt )`): a +*timescale* bound rather than a mass bound. Enabling it would turn a one-step +total conversion into a ten-step drawdown. One-line experiment. + +Daniel's read after the final run: many remaining glitches still look like this +mechanism. + +### 6.3 Cross-version check (ORIG / ERM / current) + +The pathology is **not** specific to local edits. Compared against +`~/Projects/NCAR_P3/cm1r21.0_new_p3/src/module_mp_p3.F` (clean upstream) and +`~/Projects/cm1r21.0_Ted/src/module_mp_p3.F` (ERM's): + +- **ORIG** has no `nitot` floor and no `nitot` in any gate, so `nitot = 0` + reaches `find_lookupTable_indices_1a` and `alog10(qitot/0) = +Inf` is clamped + to the largest size bin — *the same wrong state*, reached by a different + route. ORIG is arguably worse: its exit gate is `qitot >= qsmall` only, so + `nitot = 0` propagates back to the host and the bad point is self-sustaining. +- **ERM** added the floors (to stop `alog10` of a negative producing NaN) and + raised `qsmall`/`nsmall`. The floors are a band-aid over the same input + problem. +- Daniel reports the **developers' latest version** shows similar behaviour. + +`inv_Drmax = 1/0.002` (2 mm) is the upstream default in all three, not a local +change. The commented-out "old value" is 0.8 mm; at the ceiling +`ze_rain ∝ qr·Drmax³`, so 2 mm renders a pinned point ~12 dB brighter. + +## 7. Wrong turns — read this before repeating them + +1. **Cited `NOTES.md` as evidence for a code claim.** The working tree had ~50 + uncommitted `nsmall`-guard removals; the note described a tree that no + longer existed. → **Always `git status -s` and read the diff first.** + (Saved as a memory note.) +2. **Verified "is this gate protected?" with an `awk` scan that broke across + nested loops**, producing false "UNGATED" results, then quoted them. Verify + suspicious hits by hand. +3. **Checked what each gate *protects* but never what its `else` *does*.** The + rain exit block's `else` clips `qr` to vapour, so adding an `nr` condition + to the `if` relocated the clipping rather than removing it — and I described + it as doing the opposite. Daniel caught it. Same defect nearly repeated on + the ice exit block. +4. **Missed division by `nc` itself** when checking the cloud path (searched + only `/lamc`), causing `qcacc = 0 × Inf = NaN`. The guard needed was on + `xvc = qc/(nc*1000)` at the `iparam=5` branch. +5. **Chased a phantom `lamc = NaN`.** `mu_c` is clamped to `[2,15]` in + `get_cloud_dsd2`'s then-branch and set to 0 in its else, so `mu_c = 0` with + `lamc = NaN` is *impossible* from that routine — which should have stopped + the hypothesis immediately. `lamc` is an **uninitialised automatic array** + that the point dump reads unconditionally; the NaN was almost certainly + stack garbage from a column that took `goto 333`. +6. **Built an unverified causal chain** (`epsr` → `xx` → cloud condensation) + on top of (5) and presented it as the explanation. It was wrong. +7. **Failed to revisit an invariant after deleting its precondition.** I argued + the floor at `qitot_notsmall_1` was harmless *because the entry clip + guaranteed* `nr < nsmall ⟹ qr = 0` — then removed that clip and never + rechecked. Daniel had flagged that exact line as suspicious. +8. **Removed observability while changing behaviour.** Adding `nr < nsmall` to + the entry-clip trigger moved those points to the other branch, silently + zeroing `NFLRR`, and I then quoted `NFLRR = 0` as if it meant "no orphaned + rain". + +Meta-lesson: **the failures were all in verification method, not in reading +individual lines.** Enumerate exhaustively, check both branches, and re-derive +any invariant whose precondition you have just changed. + +## 8. Known latent issues (not fixed) + +- **`mu_c`, `lamc`, `cdist`, `cdist1`, `nu` are never initialised at `p3_main` + entry.** Automatic locals, written only where `get_cloud_dsd2` is called, so + columns taking `goto 333` leave stack garbage that diagnostics will read. + Cost one wrong turn. `diag_di`, `ze_ice`, `ze_rain`, `diag_ze` *are* + initialised. +- **`nu` is `intent(out)` but only assigned when `iparam == 1`** on the + then-path, so it returns undefined for `iparam = 5`. Currently harmless (all + reads sit in `iparam` 1/2 branches) but a live trap. +- **`impose_max_Ni` clips `nitot` without touching `qitot` or `zitot`**, + leaving an inconsistent 3-moment triple on 100% of firings. `p3_nimax = -1` + disables it but is a workaround, not a fix. +- **`zitot` is destroyed at the entry conversion** when `nitot <= 0`: + `where(nitot>0) zitot = zitot**2/nitot elsewhere zitot = 0`. Because + `log_ModAdvZitot = .true.` the advected variable is `√(Z·N)`, so recovering + `Z` *requires* `N` — a corrupted `N` genuinely destroys two of three moments. + Reconstruction from `(q, z)` is **not possible**: with a 3-parameter gamma + and three prognosed moments, `(N₀, μ, λ)` are independent, so `(q, z)` leaves + a free parameter (Daniel's correction — an earlier suggestion of mine to + reconstruct `nitot` was wrong). +- **Dead code in the ice entry clip** — the redundant `sup` clause and the + empty-set branch (§3.4). +- **`qitot/nitot > qr/nr` at ~3636** is gated on `nitot` but not `nr`; closed + in practice by the `p3_nrfloor` invariant, but fragile. + +## 9. Next steps + +**Highest value first.** + +1. **Look for an ice analogue of the `1/nr²` accretion runaway.** Nobody has + checked whether any ice process rate has comparable inverse-`nitot` + sensitivity. Zero visibility currently. Daniel flagged this explicitly. +2. **Revisit `qcacc`** (§6.2). Cheapest experiment in the whole list: uncomment + the `Min(qcacc, 0.10*qc*odt)` timescale bound and rerun. +3. **Watch for mass accumulation.** With both switches `.false.`, number-less + ice *and* rain now keep their mass and are never cleared — neither exit clip + fires on them. `NGATE` and `NFLRR` are the counters; steady is fine, + monotonically climbing means mass piling up in inert points. Ice matters + more (p99 orphaned `qitot ≈ 3.9e-3` vs rain's `1.4e-7`). +4. **Re-verify bit-identity** of `p3_nifloor = .true.` and `p3_nrfloor = .true.` + after the exit-block restructuring. +5. **Initialise the DSD arrays** at `p3_main` entry (§8) — cheap, removes a + whole class of phantom diagnostics. +6. **Retire the temporary switches.** `p3_nifloor` and `p3_nrfloor` were + explicitly agreed as A/B-only. Once the behaviour is settled, fold the + winner in unconditionally and delete both, along with the ~36 guarded sites. + `p3_limlog` and `p3_dbg_*` follow the existing `p3_chksum`/`p3_chkpts` + tooling pattern and were **not** flagged temporary. +7. **The upstream number-transport problem** remains untouched. `PREQN` ~47,000 + and `PREQR` ~49,000 firings per run. Everything here is symptom management. + Daniel deprioritised this deliberately — noting it so nobody assumes it was + handled. + +## 10. Gotchas for a fresh session + +- **Index convention:** Daniel's analysis tooling is **0-based**; CM1 is + 1-based. His `(i,j,k)` = CM1's `(i+1, j+1, k+1)`. This cost a full + rebuild/rerun cycle. `p3_dbg_halo >= 1` makes the dump immune. +- **`diag_ze = -99`** in output means the column was skipped + (`goto 333`, no hydrometeors) — not a real reflectivity. +- **`-ffpe-trap=invalid` catches `log(negative)` and `Inf-Inf` but not + divide-by-zero.** Several hazards here are `x/0`, which needs + `-ffpe-trap=zero`. +- Syntax-check without disturbing the build: + `cpp -C -P -traditional -Wno-invalid-pp-token -ffreestanding -DMPI -DNETCDF -DNCFPLUS src/X.F > /tmp/X.f90` + then `gfortran -fsyntax-only -ffree-form -ffree-line-length-none /tmp/X.f90`. + `param.F`/`mp_driver.F` need `mpif90` and `-I src`. +- Test case: `~/Projects/NCAR_P3/simulations/CM1r21/2km_P3_tests/2km050399_WC_drag_pcmaxni_iparam5_P354`. + `ptype = 54`, `iparam = 5` (Cohard–Pinty), `p3_nimax = 2000.e3`, + `p3_ccn_on = 0`, `dtl = 7.5`, 1500 s = 200 steps. + +--- + +## 11. Changes on disk as of 2026-08-05 + +Everything in §1–§10 above was committed as `48092ba`. What follows is what sat +uncommitted in `src/module_mp_p3.F` at the start of the 2026-08-05 session +(Daniel's edits between sessions), plus the `p3_hm_opt` work done in it. + +### 11.1 Daniel's edits — the gating campaign generalised + +The gate/floor logic of §3 was pushed through the rest of the scheme. ~25 gates +that tested only `q >= qsmall` now also test the matching number: + +- **`nc >= nsmall` added to:** ice-collects-cloud (`qccol`), the two + `t > 273.15` cloud-collection blocks (`qccoll` liqFrac, `qcshd`), `epsc`, + the `qccon` condensation statement, cloud self-collection, and rain-collects- + cloud accretion. +- **`nitot >= nsmall` added to:** all four `t > 273.15` collection blocks, + `qitot_notsmall` **and** `qitotcatcoll_notsmall` in ice-ice collection, + `nislf`, both melting branches, wet growth, `epsi`, the liqFrac refreeze/shed + block, `ice_present` in the HM block, all four dep/sub blocks, the `iice_loop2` + rime-fraction and `mu_i` blocks, rime densification during melting, the + liqFrac `>0.99` clip sum, and the 3-moment group-1 block (§11.2). +- **`nr >= nsmall` added to:** the `qrcon` statement, rain-collects-cloud + accretion, and `qr_not_small_2` (homogeneous rain freezing below 233.15 K). + +**This is consistent with §3 and it is the right direction** — it moves the +scheme from "floor the number and run at an absurd size" to "decline to act". +Three things to be aware of: + +1. These conditions are **unconditional**, not wrapped in the + `(log_nifloor .or. …)` short-circuit that §4.2/§4.3 used. That is fine for + bit-identity only *because* the floors, when on, guarantee `n >= nsmall` + wherever `q >= qsmall`; with `p3_nifloor = .true.` they are no-ops. It does + mean the two switch families are no longer the single place to look — a + future retirement of the switches (§9.6) has to account for these too. +2. Checked against the §3.3 rule (what does the `else` do?): none of the new + gates sits on an `if` whose `else` destroys mass. The riskiest ones are all + plain "skip the process" — no `else` at all, or an `else` that zeroes a rate + (`epsc`, `epsi`). No mass is silently returned to vapour. +3. `rimevolume`/`rimefraction`/`liquidfraction` (skipped at `iice_loop2` when + the new `nitot` test fails) are whole-array-zeroed once per `p3_main` call + and indexed `(i,k,iice)`, so a skipped point reads 0, not stale data. Their + consumers are weighted by `qicol`, which is itself zero for a gated-out + category. Safe. + +### 11.2 3-moment group-1 block: `dumni` gate replaces the `dumni` floor + +`dumni` is now computed **above** the `if`, the gate reads +`dumqi >= qsmall .and. dumni >= nsmall`, and `dumni = max(dumni,nsmall)` is +commented out. This is exactly the §3.1 floor→gate substitution applied to the +dummy state. The block has no `else`, and the group-2 `zitot` additions below it +are unconditional, so a rejected point simply leaves `zitot` alone. Daniel's +in-line question (`! DTD: should we also gate on dumni > nsmall?`) is answered +by the code beneath it. No concerns. + +### 11.3 Hallett-Mossop source was flipped by commenting + +The cloud-riming splinter block had been uncommented and the rain-riming block +commented out — the reverse of `48092ba`. Two side effects of that particular +edit, both now gone (§11.4): + +- `qrmul_dp`/`nimul_dp` were left initialised and applied but never accumulated, + so the post-loop application added zero. +- The cloud path accumulated `qcmul(iice_dest)`/`nimul(iice_dest)` **inside** the + category loop in single precision — reintroducing precisely the fixed-slot-order + sum that the comment three lines above says was removed as a + category-relabeling roundoff seed. + +### 11.4 New: `p3_hm_opt` (this session) + +Rime splintering is now a namelist option instead of a comment-block choice. +`&p3_params`, plumbed like `p3_qrcol_opt` (declaration + `NAMELIST` + `MPI_BCAST` +in `param.F`, optional `p3_hm_opt` argument on all 15 `p3_init` call sites, +clamped to `[0,3]` in `p3_init`, module variable `hm_opt` in `module_mp_p3.F`). + +| `p3_hm_opt` | behaviour | +|---|---| +| 0 | off entirely — `calc_HM` is skipped regardless of `log_hmossopOn` | +| 1 | riming of **cloud** droplets only (`qccol → qcmul`) — **default** | +| 2 | riming of **rain** only (`qrcol → qrmul`) — original P3 / commit `48092ba` | +| 3 | both | + +`hm_opt` is decoded once per `p3_main` call into two locals, `hm_cloud` and +`hm_rain`, which appear both in `HM_conditions_met` (at least one enabled source +must be collecting) and on each splintering branch. + +Notes: + +- **The default is 1**, chosen to reproduce the working tree as found, not + commit `48092ba`. One line in `src/param.F` if that is the wrong call. +- `log_hmossopOn` is unchanged and still independent: for `nCat = 1` it is the + seasonal `t(i,kbot) < 278 K` proxy. `p3_hm_opt = 0` overrides it; nothing + overrides `log_hmossopOn = .false.`. +- **Both** paths now accumulate into double-precision `qcmul_dp`/`qrmul_dp`/ + `nimul_dp` and are applied to `iice_dest` once after the loop, restoring the + category-order invariance of §11.3. `qcmul_dp` is new. For `nCat = 1` this is + an exact no-op (single term, `dble`→`sngl` round-trips exactly); **for + `nCat > 1` with `p3_hm_opt = 1` it changes the last bits** relative to the + working tree as found. `p3_hm_opt = 2` should be bit-identical to `48092ba`. +- Builds clean (`cd src && make`). **Not yet run.** diff --git a/run/namelist.input b/run/namelist.input index 4f222da..90f148d 100644 --- a/run/namelist.input +++ b/run/namelist.input @@ -212,9 +212,9 @@ ! custom bubble settings for iinit=1 &bubble numbub = 0, - tbubrandpert = 0.0, - tbub = 1.0, 1.0, 3.0, - xradbub = 10000.0, 1.0e4, 1.0e4, + tbubrandpert = 0.0, + tbub = 1.0, 1.0, 3.0, + xradbub = 10000.0, 1.0e4, 1.0e4, yradbub = 10000.0, 1.0e4, 1.0e4, zradbub = 1400.0, 1500., 1500., xcbub = 17000.0, 17000, 5.0e4, @@ -226,7 +226,7 @@ &forcing iforce = 0, nwfor = 0, - iwforce = 0, + iwforce = 0, iwshap = -1, -1, -1, wfmeso = 3.0e-2, 2.0e-2, 4.0e-2 xwfrad = 6000.0, 6000., 2.5e3, @@ -443,3 +443,52 @@ cnoh = 4.e4, ! for single moment only / +! Used when ptype is one of the P3 options (50-54,56-63) + &p3_params + p3_cccn = 300.e6, + p3_nimax = 2000.e3, + p3_iparam = 3, + p3_ccn_on = 0, + p3_merge_opt = 1, + p3_qrcol_opt = 0, + p3_hm_opt = 1, ! Hallett-Mossop rime splintering: 0 = off, 1 = riming of cloud only, + ! 2 = riming of rain only (original P3), 3 = both + rssflg = 1, + sssflg = 1, + p3_cat_init_new = .true., + p3_chksum = .false., + p3_chkpts = .false., + qsum_invariant = .false., + log_nislf = .true., + log_iceice_interaction = .true., + p3_catdest_contact_n2 = 1, + p3_catdest_contact_n3 = 3, + p3_catdest_contact_n4 = 4, + p3_catdest_rainimm_n2 = 2, + p3_catdest_rainimm_n3 = 2, + p3_catdest_rainimm_n4 = 2, + p3_catdest_rimesplinter_n2 = 1, + p3_catdest_rimesplinter_n3 = 3, + p3_catdest_rimesplinter_n4 = 3, + p3_catdest_depnuc_n2 = 1, + p3_catdest_depnuc_n3 = 3, + p3_catdest_depnuc_n4 = 4, + p3_catdest_homocloud_n2 = 1, + p3_catdest_homocloud_n3 = 1, + p3_catdest_homocloud_n4 = 1, + p3_catdest_homorain_n2 = 2, + p3_catdest_homorain_n3 = 2, + p3_catdest_homorain_n4 = 2, + p3_catdest_contact_n5 = 4, + p3_catdest_contact_n6 = 4, + p3_catdest_rainimm_n5 = 2, + p3_catdest_rainimm_n6 = 2, + p3_catdest_rimesplinter_n5 = 3, + p3_catdest_rimesplinter_n6 = 3, + p3_catdest_depnuc_n5 = 5, + p3_catdest_depnuc_n6 = 5, + p3_catdest_homocloud_n5 = 1, + p3_catdest_homocloud_n6 = 1, + p3_catdest_homorain_n5 = 2, + p3_catdest_homorain_n6 = 6, + / diff --git a/src/Makefile b/src/Makefile index b65f4e6..f52e3d0 100644 --- a/src/Makefile +++ b/src/Makefile @@ -22,23 +22,23 @@ LINKOPTS = -lnetcdf -lnetcdff #----------------------------------------------------------------------------- # HARDWARE SECTION -#-- Choose the appropriate architecture, and uncomment all lines +#-- Choose the appropriate architecture, and uncomment all lines #-- in that section. See "README.compile" for more information. #----------------------------------------------------------------------------- -# single processor, Intel compiler +# single processor, Intel compiler # (eg, NCAR's yellowstone/caldera/cheyenne) #FC = ifort #OPTS = -O3 -xHost -ip -assume byterecl -fp-model precise -ftz -no-fma #CPP = cpp -C -P -traditional -Wno-invalid-pp-token -ffreestanding #----------------------------------------------------------------------------- -# multiple processors, distributed memory (MPI), Intel compiler +# multiple processors, distributed memory (MPI), Intel compiler # (eg, NCAR's yellowstone/cheyenne) #FC = mpif90 #OPTS = -O3 -xHost -ip -assume byterecl -fp-model precise -ftz -no-fma #CPP = cpp -C -P -traditional -Wno-invalid-pp-token -ffreestanding #DM = -DMPI #----------------------------------------------------------------------------- -# multiple processors, shared memory (OpenMP), Intel compiler +# multiple processors, shared memory (OpenMP), Intel compiler # (eg, NCAR's yellowstone/cheyenne) #FC = mpif90 #OPTS = -O3 -xHost -ip -assume byterecl -fp-model precise -ftz -no-fma -qopenmp @@ -76,15 +76,24 @@ LINKOPTS = -lnetcdf -lnetcdff #OMP = -DOPENMP #----------------------------------------------------------------------------- # single processor, GNU compiler -FC = gfortran -OPTS = -ffree-form -ffree-line-length-none -O2 -finline-functions -CPP = cpp -C -P -traditional -Wno-invalid-pp-token -ffreestanding +# FC = gfortran +# # OPTS = -ffree-form -ffree-line-length-none -O2 -finline-functions +# OPTS = -ffree-form -ffree-line-length-none -O0 -g -ffpe-trap=invalid -fcheck=bounds +# CPP = cpp -C -P -traditional -Wno-invalid-pp-token -ffreestanding #----------------------------------------------------------------------------- # multiple processors, distributed memory (MPI), GNU compiler FC = mpif90 OPTS = -ffree-form -ffree-line-length-none -O2 -finline-functions CPP = cpp -C -P -traditional -Wno-invalid-pp-token -ffreestanding DM = -DMPI +# multiple processors, distributed memory (MPI), GNU compiler, double precision +# DTD TODO: this doesn't seem to work on my Macbook at least. Run stalls somewhere before starting +# the main time loop. +# FC = mpif90 +# OPTS = -ffree-form -ffree-line-length-none -O2 -finline-functions -fdefault-real-8 -fdefault-double-8 +# CPP = cpp -C -P -traditional -Wno-invalid-pp-token -ffreestanding +# DM = -DMPI +# DP = -DDP #----------------------------------------------------------------------------- # multiple processors, shared memory (OpenMP), GNU compiler #FC = gfortran @@ -254,7 +263,7 @@ hifrq.o: input.o constants.o cm1libs.o adv.o adv_routines.o bc.o ib_module.o wri ib_module.o: input.o constants.o bc.o comm.o init3d.o: constants.o input.o misclibs.o cm1libs.o bc.o comm.o module_mp_nssl_2mom.o poiss.o parcel.o ib_module.o turb.o init_physics.o: constants.o input.o sfclay.o sfclayrev.o slab.o radtrns3d.o irrad3d.o goddard.o module_ra_rrtmg_lw.o module_ra_rrtmg_sw.o module_sf_gfdl.o module_sf_mynn.o module_bl_mynn.o module_sf_myjsfc.o -init_surface.o: constants.o input.o oml.o +init_surface.o: constants.o input.o oml.o init_terrain.o: constants.o input.o bc.o comm.o adv_routines.o interp_routines.o: constants.o input.o irrad3d.o: radlib3d.o diff --git a/src/Makefile_bell b/src/Makefile_bell index 16fc54d..a7d5da4 100644 --- a/src/Makefile_bell +++ b/src/Makefile_bell @@ -82,9 +82,17 @@ LINKOPTS = -lnetcdf -lnetcdff #----------------------------------------------------------------------------- # multiple processors, distributed memory (MPI), GNU compiler FC = mpif90 -OPTS = -ffree-form -ffree-line-length-none -O2 -finline-functions -march=znver2 +OPTS = -ffree-form -ffree-line-length-none -O2 -finline-functions CPP = cpp -C -P -traditional -Wno-invalid-pp-token -ffreestanding DM = -DMPI +# multiple processors, distributed memory (MPI), GNU compiler, double precision +# DTD TODO: this doesn't seem to work on my Macbook at least. Run stalls somewhere before starting +# the main time loop. +# FC = mpif90 +# OPTS = -ffree-form -ffree-line-length-none -O2 -finline-functions -fdefault-real-8 -fdefault-double-8 +# CPP = cpp -C -P -traditional -Wno-invalid-pp-token -ffreestanding +# DM = -DMPI +# DP = -DDP #----------------------------------------------------------------------------- # multiple processors, shared memory (OpenMP), GNU compiler #FC = gfortran diff --git a/src/cm1.F b/src/cm1.F index 19b2578..c793b88 100644 --- a/src/cm1.F +++ b/src/cm1.F @@ -7,7 +7,7 @@ program cm1 ! 20 April 2022 ! https://www2.mmm.ucar.edu/people/bryan/cm1/ ! -! (c)2022 - University Corporation for Atmospheric Research +! (c)2022 - University Corporation for Atmospheric Research ! !----------------------------------------------------------------------------- ! @@ -99,7 +99,7 @@ program cm1 real, dimension(:,:,:), allocatable :: dum1,dum2,dum3,dum4,dum5,dum6,dum7,dum8,dum9 real, dimension(:,:), allocatable :: zs,gz,rgz,gzu,rgzu,gzv,rgzv,dzdx,dzdy real, dimension(:,:,:), allocatable :: gx,gxu,gy,gyv - real, dimension(:,:,:), allocatable :: rain,sws,svs,sps,srs,sgs,sus,shs + real, dimension(:,:,:), allocatable :: rain,hail,sws,svs,sps,srs,sgs,sus,shs real, dimension(:,:), allocatable :: tsk,znt,rznt,zntmp,ust,ustbase,stau,tst,qst,z0t,z0q,thflux,qvflux, & !Qin add ustbase for WC cd,ch,cq,u1,u1base,v1,v1base,s1,s1base,t1,xland,psfc,tlh,f2d,psmth,prate,ustt,ut,vt,st,cm0 !Qin add u1base,v1base,s1base for WC real, dimension(:,:), allocatable :: radbcw,radbce @@ -269,7 +269,7 @@ program cm1 #ifdef MPI integer :: reqs,rc,ii,jj,id,itmp1,itmp2,jtmp1,jtmp2 integer, dimension(MPI_STATUS_SIZE) :: status - real :: mp_total,minvalue,temx,temy,temni,temnj ! Changed "minval" to "minvalue" here because it was overriding + real :: mp_total,minvalue,temx,temy,temni,temnj ! Changed "minval" to "minvalue" here because it was overriding ! the built-in function "minval" and causing an "Unclassifiable statement" error double precision :: tstart,tend integer, dimension(:), allocatable :: isum,jsum @@ -391,7 +391,7 @@ program cm1 cm1rversion = 21.0 !---------------------------------------------------------------------- -! For arbitrary 3d output array: +! For arbitrary 3d output array: ! ! nout3d is the total number of output variables. ! @@ -399,14 +399,14 @@ program cm1 ! fill in the out3d(i,j,k,1) and out3d(i,j,k,2) etc arrays with the ! information you wish to write out.) ! -! No other changes are necessary: output file will contain the +! No other changes are necessary: output file will contain the ! variables "out1", "out2", "out3", ... etc. ! nout3d = 3 nout3d = 19 !---------------------------------------------------------------------- -! For arbitrary 2d output array: +! For arbitrary 2d output array: ! ! nout2d is the total number of output variables. ! @@ -414,7 +414,7 @@ program cm1 ! fill in the out2d(i,j,1) and out3d(i,j,2) etc arrays with the ! information you wish to write out.) ! -! No other changes are necessary: output file will contain the +! No other changes are necessary: output file will contain the ! variables "out2d1", "out2d2", "out2d3", ... etc. nout2d = 2 @@ -1484,6 +1484,8 @@ program cm1 #endif allocate( rain(ib:ie,jb:je,nrain) ) rain = 0.0 + allocate( hail(ib:ie,jb:je,nrain) ) + hail = 0.0 allocate( sws(ib:ie,jb:je,nrain) ) sws = 0.0 allocate( svs(ib:ie,jb:je,nrain) ) @@ -2386,7 +2388,7 @@ program cm1 zh,mh,rmh,zf,mf,rmf,rho0s,pi0s,prs0s, & pi0,prs0,rho0,thv0,th0,rth0,qv0, & u0,v0,qc0,qi0,rr0,rf0,rrf0, & - rain,sws,svs,sps,srs,sgs,sus,shs, & + rain,hail,sws,svs,sps,srs,sgs,sus,shs, & thflux,qvflux,cd,ch,cq,f2d, & dum1,dum2,dum3,dum4,divx,rho,prs, & rru,ua,u3d,uten,uten1,rrv,va,v3d,vten,vten1, & @@ -2689,7 +2691,7 @@ program cm1 if(dowr) write(outfile,*) ' restart_read time = ',time_misc if(dowr) write(outfile,*) ! In case user wants to change values on a restart: - IF( restart_reset_frqtim )THEN + IF( restart_reset_frqtim )THEN if( statfrq.gt.1.0e-6 ) stattim = mtime + statfrq if( tapfrq.gt.1.0e-6 ) taptim = mtime + tapfrq if( rstfrq.gt.1.0e-6 ) rsttim = mtime + rstfrq @@ -2905,7 +2907,7 @@ program cm1 call read_lsnudge(lsnudge_u,lsnudge_v,lsnudge_th,lsnudge_qv,sngl(mtime),zh) - ! 190407: moved this from lsnudge_module + ! 190407: moved this from lsnudge_module !!! lsnudge_tau = var1 ! time scale (seconds) for damping !!! lsnudge_start = var2 ! time (seconds) to begin large-scale nudging !!! lsnudge_end = var3 ! time (seconds) to end large-scale nudging @@ -2994,7 +2996,7 @@ program cm1 adtlast = dbldt - ! adaptive dt if starting CM1 for first time + ! adaptive dt if starting CM1 for first time ! (ie, not a restart) call calccflquick(dt,uh,vh,mh,u3d,v3d,w3d,reqc) @@ -3383,14 +3385,14 @@ program cm1 call pdefq( 0.0,asq(1),ruh,rvh,rmh,rho,q3d(ib,jb,kb,1)) else call mp_driver(nstep,dt,qbudget,asq,bsq,xh,ruh,xf,ruf,yh,rvh,yf,rvf, & - mh,rmh,c1,c2,zh,mf,rmf,zf,rain,prate,pi0,th0,rho0,prs0,qv0, & + mh,rmh,c1,c2,zh,mf,rmf,zf,rain,hail,prate,pi0,th0,rho0,prs0,qv0, & rho,prs,dum1,dum2,dum3,dum4,dum5,dum6,dum7,dum8, & w3d,ppi,pp3d,ppten,sten,tha,th3d,thten,qa,q3d,qten, & p3a,p3o,dum2d1,dum2d2,dum2d3,dum2d4,dum2d5, & effc,effi,effs,effr,effg,effis, & tdiag,qdiag,out2d,out3d, & dowriteout,dorad,dotdwrite,doazimwrite,dorestart, & - getdbz,getvt,dotbud,doqbud) + getdbz,getvt,dotbud,doqbud,qunit) endif ENDIF @@ -3407,7 +3409,7 @@ program cm1 pi0,rho0,prs0,thv0,th0,rth0,qv0,qc0, & qi0,rr0,rf0,rrf0, & zs,gz,rgz,gzu,rgzu,gzv,rgzv,dzdx,dzdy, & - rain,sws,svs,sps,srs,sgs,sus,shs, & + rain,hail,sws,svs,sps,srs,sgs,sus,shs, & dum1,dum2,dum3,dum4,dum5,dum6,dum7,dum8, & divx,rho,rr,rf,prs, & u0,rru,ua,u3d,uten,uten1, & @@ -3912,7 +3914,7 @@ program cm1 xh,xf,uf,yh,yf,vf,xfref,yfref, & rds,sigma,rdsf,sigmaf,zh,zf,mf,gx,gy,wprof, & pi0,prs0,rho0,rr0,rf0,rrf0,th0,qv0,u0,v0,thv0,rth0,qc0,qi0, & - zs,rgzu,rgzv,rain,sws,svs,sps,srs,sgs,sus,shs,thflux,qvflux,psfc, & + zs,rgzu,rgzv,rain,hail,sws,svs,sps,srs,sgs,sus,shs,thflux,qvflux,psfc, & rxh,arh1,arh2,uh,ruh,rxf,arf1,arf2,vh,rvh,mh,rmh,rmf,rr,rf, & gz,rgz,gzu,gzv,gxu,gyv,dzdx,dzdy,c1,c2, & cd,ch,cq,tlh,f2d,psmth,prate,ustt,cm0, & diff --git a/src/init3d.F b/src/init3d.F index c5fe20b..a79141b 100644 --- a/src/init3d.F +++ b/src/init3d.F @@ -62,7 +62,7 @@ subroutine init3d(xh,rxh,uh,ruh,xf,rxf,uf,ruf,yh,vh,rvh,yf,vf,rvf, & zh,mh,rmh,zf,mf,rmf,rho0s,pi0s,prs0s, & pi0,prs0,rho0,thv0,th0,rth0,qv0, & u0,v0,qc0,qi0,rr0,rf0,rrf0, & - rain,sws,svs,sps,srs,sgs,sus,shs, & + rain,hail,sws,svs,sps,srs,sgs,sus,shs, & thflux,qvflux,cd,ch,cq,f2d, & dum1,dum2,dum3,dum4,divx,rho,prs, & rru,ua,u3d,uten,uten1,rrv,va,v3d,vten,vten1, & @@ -101,7 +101,7 @@ subroutine init3d(xh,rxh,uh,ruh,xf,rxf,uf,ruf,yh,vh,rvh,yf,vf,rvf, & real, dimension(ib:ie,jb:je) :: rho0s,pi0s,prs0s real, dimension(ib:ie,jb:je,kb:ke) :: pi0,prs0,rho0,thv0,th0,rth0,qv0 real, dimension(ib:ie,jb:je,kb:ke) :: qc0,qi0,rr0,rf0,rrf0 - real, dimension(ib:ie,jb:je,nrain) :: rain,sws,svs,sps,srs,sgs,sus,shs + real, dimension(ib:ie,jb:je,nrain) :: rain,hail,sws,svs,sps,srs,sgs,sus,shs real, dimension(ib:ie,jb:je) :: thflux,qvflux,cd,ch,cq,f2d real, dimension(ib:ie,jb:je,kb:ke) :: dum1,dum2,dum3,dum4 real, dimension(ib:ie,jb:je,kb:ke) :: divx,rho,prs @@ -185,6 +185,7 @@ subroutine init3d(xh,rxh,uh,ruh,xf,rxf,uf,ruf,yh,vh,rvh,yf,vf,rvf, & do i=ib,ie ! these are all positive-definite, so set initial value to zero: rain(i,j,n)=0.0 + hail(i,j,n)=0.0 sws(i,j,n)=0.0 srs(i,j,n)=0.0 sgs(i,j,n)=0.0 diff --git a/src/input.F b/src/input.F index 40890d0..34818ad 100644 --- a/src/input.F +++ b/src/input.F @@ -29,6 +29,17 @@ MODULE input integer ierr + ! Category-swap bit-identity test (see NOTES.md): when .true., the + ! order-sensitive sums of the moist scalars (q3d slots) that feed the + ! prognostic dynamics (buoyancy/loading and moist thermodynamic terms in + ! solve1/solve2, moisture sums in turb) are replaced by permutation- + ! invariant sorted sums (function sortsumq below), so the result does not + ! depend on which scalar slot holds which value. Set via qsum_invariant + ! in the &p3_params namelist (read/broadcast in param.F). Diagnostic-only + ! sums (statpack, writeout, domaindiag, azimavg, parcel, pdcomp) are NOT + ! modified. + logical :: qsum_invariant = .false. + !----------------------------------- logical terrain_flag,procfiles,dowr, & @@ -53,7 +64,7 @@ MODULE input !----------------------------------------------------------------------- integer :: nodex=0,nodey=0 - integer nx,ny,nz,ppnode,timeformat,timestats,outunits, & + integer :: nx,ny,nz,ppnode,timeformat,timestats,outunits, & ni,nj,nk,nkp1,ngxy,ngz, & ib,ie,jb,je,kb,ke, & ibm,iem,jbm,jem,kbm,kem, & @@ -115,6 +126,7 @@ MODULE input output_format,output_filetype,output_interp, & restart_format,restart_filetype, & output_rain,output_sws,output_svs,output_sps,output_srs, & + output_hail=1, & output_sgs,output_sus,output_shs,output_coldpool,output_zs, & output_psfc, & output_basestate,output_sfcflx,output_sfcparams,output_sfcdiags,& @@ -307,7 +319,7 @@ MODULE input xradbub,yradbub,zradbub namelist /param9/ & output_format,output_filetype, & - output_interp, & + output_interp,output_hail, & output_rain,output_sws,output_svs,output_sps,output_srs, & output_sgs,output_sus,output_shs,output_coldpool, & output_sfcflx,output_sfcparams,output_sfcdiags, & @@ -410,4 +422,42 @@ end function mytime !ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc + pure real function sortsumq(v) + implicit none + + real, intent(in), dimension(:) :: v + + ! Permutation-invariant sum of moist-scalar values at one grid point: + ! the values are summed in ascending sorted order, so the result does + ! not depend on which scalar slot holds which value (equal values + ! commute, so ties are harmless). Used for the category-swap + ! bit-identity test when qsum_invariant = .true. (see NOTES.md). + ! Insertion sort: slot counts are small (<= a few per phase). + + real, dimension(size(v)) :: w + real :: tmp + integer :: i,j + + w = v + do i=2,size(v) + tmp = w(i) + j = i-1 + do + if( j.lt.1 )exit + if( w(j).le.tmp )exit + w(j+1) = w(j) + j = j-1 + enddo + w(j+1) = tmp + enddo + + sortsumq = 0.0 + do i=1,size(v) + sortsumq = sortsumq + w(i) + enddo + + end function sortsumq + + !ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc + END MODULE input diff --git a/src/module_mp_nssl_2mom.F b/src/module_mp_nssl_2mom.F index 5e52d07..b0166f5 100644 --- a/src/module_mp_nssl_2mom.F +++ b/src/module_mp_nssl_2mom.F @@ -1,15 +1,11 @@ !COMMAS/1:MODEL_LAYER:PHYSICS -! prepocessed on "Jun 9 2024" at "15:06:19" - - - - +! prepocessed on "Jul 3 2026" at "14:37:53" !--------------------------------------------------------------------- -! IMPORTANT: Best results are attained using the 5th-order WENO (Weighted Essentially Non-Oscillatory) advection option (4) for scalars: +! IMPORTANT (WRF ONLY): Best results are attained using the 5th-order WENO (Weighted Essentially Non-Oscillatory) advection option (4) for scalars: ! moist_adv_opt = 4, ! scalar_adv_opt = 4, (can also use option 3, which is WENO without the positive definite filter) ! The WENO-5 scheme provides a 5th-order (horizontal and vertical) adaptive weighting of components that @@ -23,7 +19,8 @@ ! ! WENO references: Jiang and Shu, 1996, J. Comp. Phys. v. 126, 202-223; Shu 2003, Int. J. Comp. Fluid Dyn. v. 17 107-118; ! -!! This module provides a 1/2/3-moment bulk microphysics scheme based on a combination of + +!> This module provides a 1/2/3-moment bulk microphysics scheme based on a combination of !! Straka and Mansell (2005, JAM) and Zeigler (1985, JAS) and modified/upgraded in !! in Mansell, Zeigler, and Bruning (2010, JAS). Two-moment adaptive sedimentation !! follows Mansell (2010, JAS), using parameter infall = 4. @@ -70,8 +67,22 @@ ! Note: Some parameters below apply to unreleased features. ! ! + !--------------------------------------------------------------------- -! Apr. 2023 +! Feb. 2025 +! - More accurate saturation mixing ratio calculation (iqvsopt=1) +! - Changed default droplet renucleation to irenuc=5, which allows extra nucleation at high supersaturation +! - Default explicit rain breakup for 3-moment (irainbreak=2) +! - Imposed reflectivity conservation in graupel->hail conversion (ihlcnh=3) and Bigg +! freezing (both 2- and 3-moment) +! - Option (nsplinter=1001) for ice crystal production by drop freezing/shattering (Sullivan et al. 2018) +! - Option (incwet = 1) to treat wet growth only for D > Dwet rather than all or nothing; results in +! slightly greater hail production due to maintaining dry growth at D < Dwet +! - Improved logic for sedimentation +! - Separated flushing of small masses into its own subroutine (smallvalues) +! - Some syntax fixes for issues with old versions of gfortran +!--------------------------------------------------------------------- +! Apr. 2023 (WRF-4.6) ! - Update to 3-moment for rain, graupel, and hail ! - Change default graupel/hail fall speeds to icdx/icdxhl=6 (Milbrandt & Morrison 2013) ! and also set default ehw0=0.9 and ehlw0=0.9 to compensate for lower fall speeds. @@ -172,15 +183,26 @@ + + + MODULE module_mp_nssl_2mom IMPLICIT NONE public nssl_2mom_driver public nssl_2mom_init + + public nssl_qtodbz + public nssl_column_dbz + + private gamma_sp,gamxinf,GAML02, GAML02d300, GAML02d500, fqvs, fqis private gamma_dp, gamxinfdp, gamma_dpr private delbk, delabk private gammadp + private galpha, dgalpha + private zraten,zrateq,zrateqn + logical, private :: cleardiag = .false. PRIVATE @@ -192,10 +214,13 @@ MODULE module_mp_nssl_2mom #endif LOGICAL, PRIVATE:: is_aerosol_aware = .false. + logical, private :: turn_on_cin = .false. +! #if defined(1) && !defined(COMMAS) integer, private :: myrankcm1 = 0 +! #endif integer, private :: eqtset = 1 ! Flag for use with cm1 to use alternate equation set (changes latent heating rates) ! value of > 2 invokes the equivalent version of eqtset=2 that applies updates to both theta and Pi. double precision, parameter, public :: zscale = 1.0d0 ! 1.000e-10 @@ -216,7 +241,13 @@ MODULE module_mp_nssl_2mom integer :: iusewetgraupel = 1 ! =1 to turn on use of QHW for graupel reflectivity (only for ZVDM -- mixedphase) ! =2 turn on for graupel density less than 300. only integer :: iusewethail = 0 ! =1 to turn on use of QHW for graupel reflectivity (only for ZVDM -- mixedphase) + integer :: iusewetsnow = 0 ! =1 to turn on diagnosed bright band; =2 'old' snow reflectivity (dry), =3 'old' snow dbz + brightband + + integer,public :: icorrecthaildbz = 1 ! =1 to adjust hail number conc. from gr->hl conversion to keep correct Z + integer,public :: icorrectfddbz = 1 ! =1 to adjust graupel/FD number conc. from rain freezing to keep correct Z + real ,public :: zxmincorr = 1.e-15 ! minimum Z to run correction to C + real ,public :: cxmincorr = 1.e-3 ! minimum C to run correction to C ! microphysics real, public :: rho_qr = 1000., cnor = 8.0e5 ! cnor is set in namelist!! rain params @@ -236,8 +267,11 @@ MODULE module_mp_nssl_2mom real , private :: cwdiap = 20.0e-6 ! threshold diameter of cloud drops (Ferrier 1994 autoconversion) real , private :: cwdisp = 0.15 ! assume droplet dispersion parameter (can be 0.3 for maritime) real , public :: ccn = 0.6e+09 ! set in namelist!! Central plains CCN value + real , public :: ccn_co = 0.05e+09 ! set in namelist!! Central plains CCN value + real , public :: ccn_nu = 1.6e+09 ! set in namelist!! Central plains CCN value real , public :: ccnuf = 0 ! set in namelist!! Central plains CCN value real , public :: qccn, qccnuf ! ccn "mixing ratio" + real , public :: qccnco, qccnnu ! ccn "mixing ratio" for coarse and nu modes real , private :: old_qccn = -1.0 integer, private :: iauttim = 1 ! 10-ice rain delay flag real , private :: auttim = 300. ! 10-ice rain delay time @@ -259,6 +293,7 @@ MODULE module_mp_nssl_2mom logical :: decayufccn = .false. integer :: i_uf_or_ccn = 0 ! 0 = ship adds UF; 1 = treat UF as regular ccn (add to qccn) + ! sedimentation flags ! itfall -> 0 = 1st order fallout (other options removed) ! iscfall, infall -> fallout options for charge and number concentration, respectively @@ -266,21 +301,27 @@ MODULE module_mp_nssl_2mom integer, private :: itfall = 0 integer, private :: iscfall = 1 integer, public :: irfall = -1 - integer, public :: isfall = 2 ! default limit with method II (more restrictive) + integer, public :: iifall = 0 + integer, public :: isfall = 4 ! default limit with method II (more restrictive) + logical, public :: do_accurate_sedimentation = .false. ! if true, recalculate fall speeds on sub time steps; (more expensive) + ! if false, reuse fall speeds on multiple steps (can have a noticeable speedup) ! Mainly is an issue for small dz near the surface. + integer, public :: interval_sedi_vt = 1 ! interval for recalculating Vt in sedimentation subloop (only when do_accurate_sedimentation = .true.) + integer, public :: infall = 4 ! 0 -> uses number-wgt for N; NO correction applied (results in excessive size sorting) ! 1 -> uses mass-weighted fallspeed for N ALWAYS ! 2 -> uses number-wgt for N and mass-weighted correction for N (Method II in Mansell, 2010 JAS) ! 3 -> uses number-wgt for N and Z-weighted correction for N (Method I in Mansell, 2010 JAS) ! 4 -> Hybrid of 2 and 3: Uses minimum N from each method (z-wgt and m-wgt corrections) (Method I+II in Mansell, 2010 JAS) - ! 5 -> uses number-wgt for N and uses average of N-wgt and q-wgt instead of Max. integer :: imydiagalpha = 0 ! apply MY diagnostic shape parameter for fall speeds (1=for fall speed only; 2=also for microphysics rates) real, public :: rainfallfac = 1.0 ! factor to adjust rain fall speed (single moment only) + real, public :: icefallfac = 1.0 ! factor to adjust ice fall speed real, public :: snowfallfac = 1.0 ! factor to adjust snow fall speed + real, public :: graupelfallfac = 1.0 ! factor to adjust graupel fall speed real, public :: hailfallfac = 1.0 ! factor to adjust hail fall speed integer, public :: icefallopt = 3 ! 1= default, 2 = Ferrier ice fall speed; 3 = adjusted Ferrier (slightly high Vt) @@ -337,17 +378,24 @@ MODULE module_mp_nssl_2mom integer, public :: idiagnosecnu = 0 ! =1 to diagnose cnu based on Chandrakar et al. 2016 data; =2 for Geoffroy et al. (2010, ACP) integer, private :: iccwflg = 1 ! sets max size of first droplets in parcel to 4 micron radius (in two-moment liquid) ! (first nucleation is done with a KW sat. adj. step) - integer, private :: issfilt = 0 ! flag to turn on filtering of supersaturation field + integer, private :: issfilt = 0 ! flag to turn on filtering of supersaturation field (obsolete) + integer, private :: isscheck = 0 ! flag to check max condensation from droplet nucleation (experimental -- do not use!) + real , private :: dcritcheck = 2.*3.17e-6 ! diameter of newly nucleated droplets (isscheck = 1) integer, public :: icnuclimit = 0 ! limit droplet nucleation based on Konwar et al. (2012) and Chandrakar et al. (2016) + integer, public :: icondlimit = 0 ! Check if condensation exceeds sat adj. (1=on, 0 = off unless dt>dtcond) + real , private :: dtcond = 10. ! timestep above which icondlimit is enabled + integer, public :: irenuc = 7 ! =1 to always allow renucleation of droplets within the cloud (do no use, obsolete) + ! =2 renucleation following Twomey/Cohard&Pinty + ! =5 Similar to 7 but can produce extra activated nuclei from the 'smaller' CCN at higher SS ! =7 New renucleation that requires prediction of the number of activated nuclei ! i.e., not only at cloud base integer, private :: irenuc3d = 0 ! =1 to include horizontal gradient in renucleation of droplets within the cloud - real :: renucfrac = 0.0 ! = 0 : cnuc = cwccn + real , private :: renucfrac = 0.0 ! = 0 : cnuc = cwccn ! = 1 : cnuc = actual available CCN ! otherwise cnuc = cwccn*(1. - renufrac) + ccnc(1:ngscnt)*renucfrac - real :: ssf2kmax = 10. ! max value for ssf**cck in irenuc=4 or 5 + real , private :: ssf2kmax = 10. ! max value for ssf**cck in irenuc=4 or 5 real , private :: cck = 0.6 ! exponent in Twomey expression real , private :: ciintmx = 1.0e6 ! limit on ice concentration from primary nucleation @@ -363,7 +411,9 @@ MODULE module_mp_nssl_2mom integer, public :: itype1 = 0, itype2 = 2 ! controls Hallett-Mossop process integer, private :: in_freeze_rain_first = 0 ! =1 use IN to freezed rain drops (if none, then freeze droplets) integer, public :: icenucopt = 1 ! =1 Meyers/Ferrier primary ice nucleation; =2 Thompson/Cooper, =3 Phillips (Meyers/Demott), =4 DeMott (2010) - real, public :: naer = 1.0e6 ! background large aerosol conc. for DeMott + integer, public :: inactopt = 2 ! 1=old IN activation using cmassin; 2=activate IN by depleting droplets + real, public :: naer = 1.0e6 ! background large aerosol conc. for DeMott (per standard m^3) + real, public :: naerdust = 1.0e6 ! background mineral dust for DeMott 2015 (per standard m^3) integer, private :: icfn = 2 ! contact freezing: 0 = off; 1 = hack (ok for single moment); 2 = full Cotton/Meyers version integer, private :: ihrn = 0 ! Hobbs-Rangno ice multiplication (Ferrier, 1994; use in 10-ice only) integer, public :: ibfc = 1 ! Flag to use Bigg freezing on droplets (0 = off (uses alternate freezing), 1 = on) @@ -401,9 +451,13 @@ MODULE module_mp_nssl_2mom integer, private :: ierw = 1 ! for single-moment rain (LFO/Z) integer, public :: iehr0c = 0 ! 0 -> no collection for T > 0C; 1 -> turn on collection/shedding for T > 0C integer, public :: iehlr0c = 0 ! 0 -> no collection for T > 0C; 1 -> turn on collection/shedding for T > 0C + + real , public :: eiw0 = 0.5 ! constant or max assumed ice-crystal-droplet collection efficiency + real , public :: esw0 = 0.5 ! constant or max assumed snow-droplet collection efficiency real , public :: ehw0 = 0.9 ! 0.5 ! constant or max assumed graupel-droplet collection efficiency real , private :: erw0 = 1.0 ! constant assumed rain-droplet collection efficiency real , public :: ehlw0 = 0.9 ! 0.75 ! constant or max assumed hail-droplet collection efficiency + real , public :: efw0 = 0.5 ! constant or max assumed graupel-droplet collection efficiency real :: ehr0 = 1.0 ! constant or max assumed graupel-rain collection efficiency real :: efr0 = 1.0 ! constant or max assumed graupel-rain collection efficiency @@ -441,8 +495,10 @@ MODULE module_mp_nssl_2mom ! 4 = as 3 but sets min factor of 0.1 and goes to full value at 0.5% SSI real , private :: ess0 = 0.5, ess1 = 0.05 ! snow aggregation coefficients: ess0*exp(ess1*min(temcg(mgs),0.0)) ! set ess1 = 0 to get a constant value of ess0 - real , public :: esstem1 = -25. ! lower temperature where snow aggregation turns on - real , public :: esstem2 = -20. ! higher temperature for linear ramp of ess from zero at esstem1 to formula value at esstem2 + + real , public :: esstem1 = -15. ! lower temperature where snow aggregation turns on + real , public :: esstem2 = -10. ! higher temperature for linear ramp of ess from zero at esstem1 to formula value at esstem2 + real , public :: essrmax = 0.02 ! maximum snow radius (meters) for csacs real , public :: essfrac1 = 0.5 ! snow mass fraction 1 for aggregation roll-off real , public :: essfrac2 = 0.75 ! snow mass fraction 2 for aggregation roll-off @@ -458,7 +514,7 @@ MODULE module_mp_nssl_2mom real , private :: rz ! reflectivity conservation factor for graupel/rain ! now calculated in icezvd_dr.F from alphah and rnu ! currently only used for graupel melting to rain - real , private :: rzhl ! reflectivity conservation factor for hail/rain + real , private :: rzhl, rzhlh ! reflectivity conservation factor for hail/rain, hail/graupel ! now calculated in icezvd_dr.F from alphahl and rnu real , private :: rzs ! reflectivity conservation factor for snow(imusnow=3) with rain (imurain=1) @@ -483,18 +539,22 @@ MODULE module_mp_nssl_2mom integer, private :: ished2cld = 0 ! 1: Send shed liquid (from wet growth) to cloud droplets integer, public :: ihmlt = 2 ! 1=old melting with vmlt; 2=new melting using mean volume diam of graupel/hail - integer, public :: imltshddmr = 2 ! 0 (default)=mean diameter of drops produced during melting+shedding as before (using mean diameter of graupel/hail + integer, public :: imltshddmr = 1 ! Options: + ! 0=mean diameter of drops produced during melting+shedding as before (using mean diameter of graupel/hail ! and max mean diameter of rain) - ! 1=new method where mean diameter of rain during melting is adjusted linearly downward + ! 1 (default) =new method where mean diameter of rain during melting is adjusted linearly downward ! toward 3 mm for large (> sheddiam) graupel and hail, to take into account shedding of ! smaller drops. sheddiam0 controls the size of graupel/hail above which the assumed ! mean diameter of rain is set to 3 mm ! Only valid for ihmlt = 2 for ZVD(H) but also applies to ZVD(H)M - ! 2 = method that sets the resulting rain size ( vshdgs ) according to the mass-weighted diameter of the ice + ! 2 = method that sets the resulting rain size ( vshdgs ) according to the max-mass diameter + ! of the ice; tends to cause smaller rain drops in forward flank real :: mltdiam1 = 9.0e-3, mltdiam2 = 16.0e-3, mltdiam3 = 19.0e-3, mltdiam4 = 200.0e-3, mltdiam05 = 4.5e-3 integer, public :: nsplinter = 0 ! number of ice splinters per freezing drop, if negative, then per resulting graupel particle + ! Set nslpinter >= 1000 to turn on Lawson 2015 splintering option + ! nslpinter = 1001 (NSSL) applies temperature-based factor from Sullivan et al. 2018 real, private :: lawson_splinter_fac = 2.5e-11 ! constant in Lawson et al. (2015, JAS) for ice particle production from freezing drops integer, private :: isnwfrac = 0 ! 0= no snow fragmentation; 1 = turn on snow fragmentation (Schuur, 2000) @@ -504,8 +564,13 @@ MODULE module_mp_nssl_2mom real, public :: qhacidn = -1. integer, private :: iraintypes = 0 + integer, private :: nraintypes = 3 ! number of rain source types + integer, parameter :: maxraintypes = 5 ! number of rain source types logical, private :: mixedphase = .false. ! .false.=off, true=on to include mixed phase graupel integer, private :: imixedphase = 0 + logical, private :: slowfreeze = .false. ! .false.=off, true=on to partially freeze rain at higher temp + real, private :: rainfreeztemplow = -25.0, rainfreeztemphigh = -10.0 ! temperature (low) at which rain freezes instantly + real, private :: rainfreezefrac0 = 0.15 ! starting rain freezing fraction for T > rainfreeztemphigh logical, private :: qsdenmod = .false. ! true = modify snow density by linear interpolation of snow and rain density logical, private :: qhdenmod = .false. ! true = modify graupel density by linear interpolation of graupel and rain density logical, private :: qsvtmod = .false. ! true = modify snow fall speed by linear interpolation of snow and rain vt @@ -513,6 +578,8 @@ MODULE module_mp_nssl_2mom real :: sheddiamlg = 10.0e-03 ! diameter of hail to use fwmlarge real :: sheddiam0 = 20.0e-03 ! diameter of hail at which all water is shed + real :: fwmhtmptem = -15. ! temperature at which fwmhtmp fully switches to liquid water only being on large particles + integer :: ifwmhtmptemopt = 1 ! option to use fwmhtmptem (1) or dwet (2) for max liquid at T < 0. integer :: ifwmhopt = 2 ! option for calculating maximum liquid fraction when fwmh and/or fwmhl is set to -1 ! 1 = maximum based on size of maximum mass diameter ! 2 = integrate over spectrum for maximum liquid (experimental) @@ -530,8 +597,8 @@ MODULE module_mp_nssl_2mom logical :: rescale_high_alpha = .false. ! whether to rescale number. conc. when alpha = alphamax (3-moment only) logical :: rescale_low_alpha = .true. ! whether to rescale Z (graupel/hail) when alpha = alphamin (3-moment only) logical :: rescale_low_alphar = .true. ! whether to rescale Z for rain when alpha = alphamin (3-moment only) - logical :: rescale_low_alphah = .true. ! whether to rescale Z for rain when alpha = alphamin (3-moment only) - logical :: rescale_low_alphahl = .true. ! whether to rescale Z for rain when alpha = alphamin (3-moment only) + logical :: rescale_low_alphah = .false. ! whether to rescale Z for graupel/FD when alpha = alphamin (3-moment only) + logical :: rescale_low_alphahl = .false. ! whether to rescale Z for hail when alpha = alphamin (3-moment only) real, parameter :: alpharmax = 8. ! limited for rwvent calculation @@ -550,6 +617,8 @@ MODULE module_mp_nssl_2mom real , public :: dwtempmin = 242. ! lowest temperature to allow wet growth conversion to hail real , public :: dwehwmin = 0. ! Minimum ehw to use to find wet growth diameter (if > ehw0, then wet growth diam becomes smaller) real , public :: dg0thresh = 0.15 ! graupel wet growth diameter above which we say do not bother + real , private :: wetgrthtoffset = -1. ! maximum temperature (Celcius) for wet growth (shedding) + real , private :: hailcnvtoffset = -2. ! maximum temperature (Celcius) for hail conversion integer :: ifddenfac = 0 ! = 1 to use density threshold to count FD as GR when converting to HL real :: fddenthresh = 500. ! if ifddenfac > 0, then hail from FD with lower density are considered to come from graupel integer :: icvhl2h = 0 ! allow conversion of hail back to graupel when hail density gets close to minimum allowed @@ -564,13 +633,18 @@ MODULE module_mp_nssl_2mom integer, public :: iferwisventr = 2 ! =1 for Ferrier rwvent, =2 for Wisner rwvent (imurain=1) integer, public :: izwisventr = 2 ! =1 for old Ziegler rwvent, =2 for Wisner-style rwvent (imurain=3) integer :: iresetmoments = 0 ! if >0, then set all moments to zero when one of them is zero (3-moment only) - integer, public :: imaxdiaopt = 3 - ! = 1 use mean diameter for breakup - ! = 2 use maximum mass diameter for breakup - ! = 3 use mass-weighted diameter for breakup - integer :: irainbreak = 0 ! 1 = on; Active rain breakup (use for 3-moment rain) + integer, public :: imaxdiaopt = -1 + ! = 1 use mean diameter for rain breakup (default for 3-moment) + ! = 2 use maximum mass diameter for rain breakup + ! = 3 use mass-weighted diameter for rain breakup (default for 2-moment) + integer :: irainbreak = -1 ! -1 : auto sets off for 2-moment and on (=2) for 3-moment + ! 0 = off + ! 1 = on (no diameter dependence) (recommend using option 2) + ! 2 = (recommended) as for 1, but apply factor of 1-ec0 to turn off a smaller diameter (ec0 is rain self-coll factor) + ! 10 = as for 1, but sets ec0=1 for rain self-collection (i.e., no passive breakup); set higher rainbreakfac for this option + ! 11 = breakup for DSD tail only; uses draintail etc. integer :: ibincracr = 0 - real :: rainbreakfac = 1.0e6 ! 1.e6 for irainbreak=2 (reduce double counting); 2.0e6 for lower hand fit for irainbreak=10; 2.542e6 for 'best' fit + real :: rainbreakfac = 2.5e6 ! 1.e6 for irainbreak=2 (reduce double counting); 2.0e6 for lower hand fit for irainbreak=10; 2.542e6 for 'best' fit real :: draintail = 10.e-3 ! starting size for rain breakup (irainbreak = 11) real :: drsmall = 1.e-3 ! size of small drops from breakup (irainbreak = 11) real :: qrbrthresh1 = 0.1e-3 ! lower threshold rain content (kg/m^3) for large drop breakup (irainbreak=11) @@ -671,6 +745,7 @@ MODULE module_mp_nssl_2mom integer, private :: lccnaco = 0 integer, private :: lccnanu = 0 integer, private :: lcina = 0 + integer, private :: lcinda = 0 integer, private :: lcin = 0 integer, private :: lnc = 9 integer, private :: lnr = 10 @@ -795,10 +870,14 @@ MODULE module_mp_nssl_2mom integer :: ichge = 3 integer :: ichgw = 2 real :: charging_border = 4000. ! width of no-charging zone from boundary + real, private :: delqnw = -1.0e-10!-1.0e-12 ! real, private :: delqxw = 1.0e-10! 1.0e-12 ! real :: tindmn = 233, tindmx = 298.0 ! min and max temperatures where inductive charging is allowed + integer, private :: imorrgdnglimit = 0 ! flag to impose limit on graupel slope parameter + real, private :: morrdnglimit = 2000.E-6 + ! ! gamma function lookup table ! @@ -819,7 +898,7 @@ MODULE module_mp_nssl_2mom real :: ciacrratio(0:nqiacrratio,ialpstart:nqiacralpha) real :: qiacrratio(0:nqiacrratio,ialpstart:nqiacralpha) real :: ziacrratio(0:nqiacrratio,ialpstart:nqiacralpha) - double precision :: gamxinflu(0:nqiacrratio,ialpstart:nqiacralpha,12,2) ! last index for graupel (1) or hail (2) + double precision :: gamxinflu(0:nqiacrratio,ialpstart:nqiacralpha,13,2) ! last index for graupel (1) or hail (2) ! real :: ciacrratio(0:nqiacrratio,0:nqiacralpha) ! real :: qiacrratio(0:nqiacrratio,0:nqiacralpha) ! real :: ziacrratio(0:nqiacrratio,0:nqiacralpha) @@ -842,6 +921,8 @@ MODULE module_mp_nssl_2mom integer lvol(lc:lqmx) integer lz(lc:lqmx) integer lliq(li:lqmx) + integer lrain(maxraintypes) + integer linfall(lc:lqmx) integer denscale(lc:lqmx) ! flag for density scaling (mixing ratio conversion) integer ido(lc:lqmx) @@ -880,10 +961,12 @@ MODULE module_mp_nssl_2mom ! new values for cs and ds real, parameter :: cs = 12.42 ! snow terminal velocity power law coefficient real, parameter :: ds = 0.42 ! snow terminal velocity power law coefficient + real, parameter :: cp608 = 0.608 ! constant used in conversion of T to Tv real, parameter :: gr = 9.8 + real, parameter :: pi = 3.141592653589793 real, parameter :: piinv = 1./pi real, parameter :: pid4 = pi/4.0 @@ -896,11 +979,11 @@ MODULE module_mp_nssl_2mom real xvfmn, xvfmx ! min, max frozen drop volumes real xvgmn, xvgmx ! min, max graupel volumes real xvhmn, xvhmn0, xvhmx, xvhmx0 ! min, max hail volumes - real xvhlmn, xvhlmx ! min, max lg hail volumes + real xvhlmn, xvhlmx, xvhlmx0 ! min, max lg hail volumes - real, parameter :: dhlmn = 0.3e-3, dhlmx = 40.e-3 + real, parameter :: dhlmn = 0.3e-3 real, parameter :: dhmn0 = 0.3e-3 - real, public :: dhmn = dhmn0, dhmx = -1. + real, public :: dhmn = dhmn0, dhmx = -1., dhlmx = -1. ! 40.e-3 real, parameter :: cwradn = 2.0e-6, xcradmn = cwradn ! minimum radius real, parameter :: cwradx = 60.e-6, xcradmx = cwradx ! maximum radius @@ -922,8 +1005,10 @@ MODULE module_mp_nssl_2mom parameter( xvsmn=0.523599*(0.01e-3)**3, xvsmx=0.523599*(10.e-3)**3 ) !( was 4.1887e-9 ) ! mks parameter( xvfmn=0.523599*(0.1e-3)**3, xvfmx=0.523599*(10.e-3)**3 ) ! mks xvfmx = (pi/6)*(10mm)**3 parameter( xvgmn=0.523599*(0.1e-3)**3, xvgmx=0.523599*(10.e-3)**3 ) ! mks xvfmx = (pi/6)*(10mm)**3 + parameter( xvhmn0=0.523599*(0.3e-3)**3, xvhmx0=0.523599*(20.e-3)**3 ) ! mks xvfmx = (pi/6)*(10mm)**3 - parameter( xvhlmn=0.523599*(dhlmn)**3, xvhlmx=0.523599*(dhlmx)**3 ) ! mks xvfmx = (pi/6)*(10mm)**3 + parameter( xvhlmn=0.523599*(dhlmn)**3, xvhlmx0=0.523599*(40.e-3)**3 ) ! mks xvfmx = (pi/6)*(10mm)**3 + ! ! electrical permitivity of air C / (N m**2) - check the units @@ -952,6 +1037,7 @@ MODULE module_mp_nssl_2mom real, parameter :: esbolton = 6.112e2 real, parameter :: tfrh = 233.15 + real, parameter :: tfr = 273.15 real, parameter :: cp = 1004.0, rd = 287.04 @@ -963,7 +1049,9 @@ MODULE module_mp_nssl_2mom real, parameter :: tfrcbw = tfr - cbw real, parameter :: tfrcbi = tfr - cbi real, parameter :: rovcp = rd/cp + real :: rdorv = 0.622 + real, parameter :: poo = 1.0e+05 real, parameter :: advisc0 = 1.832e-05 ! reference dynamic viscosity (SMT; see Beard & Pruppacher 71) real, parameter :: advisc1 = 1.718e-05 ! dynamic viscosity constant used in thermal conductivity calc @@ -981,8 +1069,11 @@ MODULE module_mp_nssl_2mom real :: cckm,ccne,ccnefac,cnexp,CCNE0 + integer :: na = 9 + integer :: nxtra = 1 + real gf4p5, gf4ds, gf4br real gsnow1, gsnow53, gsnow73 real gfcinu1, gfcinu1p47, gfcinu2p47 @@ -1001,22 +1092,60 @@ MODULE module_mp_nssl_2mom logical, parameter :: do_satadj_for_wrfchem = .true. - integer, parameter :: ac_opt = 0 ! option flag for alternate aerosol (for NUWRF only) + integer, private :: lcn_nu = 0 ! 27 ! need to check no conflict with other variables + integer, private :: lcn_ac = 0 ! 28 + integer, private :: lcn_co = 0 ! 29 + integer, private :: lcinp = 0 ! 30 + integer, public :: ac_opt = 0 ! option flag for: (1 and 2 currently for NUWRF only) + ! 0 : normal NSSL CCN physics + ! 1 : accumulation mode CN following Fridland et al. (2012, 2017), + ! where CCN number is sum of unactivated CCN and droplet concentrations + ! 2 : As for 1 but have three modes (but does not partition activated CCN) + ! 11: As for 1 but track activated CCN as a separate category (CN category advects only) + ! 22: As for 11 but 3 modes, each with its own activation tracer + real, public :: ac_wthresh = 10.0 ! for W < ac_wthresh, use max of sswater and diagnosed SS; otherwise use sswater logical, private :: nuaccoinp = .false. +! T.Iguchi Y2021 Update +! logical :: ac_only = .true. ! flag for considering ac_mode of CN only, or all nu,ac,co modes (still under construction) + + logical, public :: arg_para = .true. ! flag for Abdul-Razzak_and_Ghan parameterization works similarly to flag_qndrop, and neglects irenuc, ccna(mgs), and cnuc(mgs) + real, public :: nu_pmr = 7.5 * 1.e-3 * 1.e-6 ! aerosol radius (meter); these parameter values follow Cheng et al. (2007QJ) + real, public :: nu_pgw = 0.53 ! Unlike original Abdul-Razzak_and_Ghan, this value is used without log (Cheng et al. 2007QJ) + real, public :: nu_kappa = 0.07 ! ammonium sulfate as CCN (Petters and Kreidenweis, 2007ACP) + real, public :: ac_pmr = 3.8 * 1.e-2 * 1.e-6 ! aerosol radius (meter) + real, public :: ac_pgw = 0.69 + real, public :: ac_kappa = 0.61 ! ammonium sulfate as CCN (Petters and Kreidenweis, 2007ACP) + real, public :: co_pmr = 0.51 * 1.e-6 ! aerosol radius (meter) + real, public :: co_pgw = 0.77 + real, public :: co_kappa = 0.61 ! ammonium sulfate as CCN (Petters and Kreidenweis, 2007ACP) + + real, parameter :: cn_minlimit = 1.e3 ! 1.e3 m-3 = 0.001 cm-3 + + logical :: dm15_para = .false. ! flag for DeMott et al. (2015) parameterization for heterogenous freezing, regardless of "ibfc" + + ! Note to users: Many of these options are for development and not guaranteed to perform well. ! Some may not be functional depending on the version of the code. ! Some may be useful for ensemble physics diversity. Feel free to contact Ted Mansell if you have questions ! in that regard. NAMELIST /nssl_mp_params/ & +! nuwrf 3-mode params + ac_opt,arg_para, & + ac_kappa, ac_pmr, ac_pgw, & + nu_kappa, nu_pmr, nu_pgw, & + co_kappa, co_pmr, co_pgw, & + ccn_co, ccn_nu, & +! --- ndebug, ncdebug,& iusewetgraupel, & iusewethail, & iusewetsnow, & + icorrecthaildbz, icorrectfddbz, zxmincorr, cxmincorr, & idbzci, & vtmaxsed, & itfall,iscfall, & - infall,irfall,isfall, & + infall,irfall,isfall,iifall, & rssflg, & sssflg, & hssflg, & @@ -1025,15 +1154,15 @@ MODULE module_mp_nssl_2mom irimdenopt,rimdenvwgt, & rimc1, rimc2, rimc3, rimc4, & idiagnosecnu, & - icnuclimit, & - irenuc, & + icnuclimit,icondlimit, & + irenuc, ccn, & restoreccn, ccntimeconst, cck, & decayufccn, ufccntimeconst, & switchccn, old_cccn, & ciintmx, & itype1, itype2, & - icenucopt, in_freeze_rain_first, & - naer, & + icenucopt, inactopt, in_freeze_rain_first, & + naer,naerdust, & icfn, & ibfc, iacr, icracr, & icracrthresh, & @@ -1088,6 +1217,7 @@ MODULE module_mp_nssl_2mom ehimax, & ehsmax, & ecollmx, & + eiw0, esw0, & ehw0, ehlw0, & ehr0, ehlr0, & erw0, & @@ -1097,7 +1227,7 @@ MODULE module_mp_nssl_2mom iqcinit, & ssmxinit, & xvdmx, & - dhmn, dhmx, & + dhmn, dhmx, dhlmx, & fwms,fwmh,fwmhl, & ifwmhopt, & ihxw2rain, & @@ -1113,7 +1243,8 @@ MODULE module_mp_nssl_2mom rescale_low_alphah, & rescale_low_alphahl, & rescale_high_alpha, & - ihlcnh, hldia1,iusedw, dwehwmin, dwmin, dwmax, dwtempmin, dg0thresh, & + ihlcnh, hldia1,iusedw, dwehwmin, dwmin, dwmax, dwtempmin, dg0thresh, incwet, & + wetgrthtoffset, hailcnvtoffset, & icvhl2h, hldnmn,hdnmn, & hlcnhdia, hlcnhqmin, & isedonly, & @@ -1146,6 +1277,7 @@ MODULE module_mp_nssl_2mom delta_alphamlr, & iqvsopt, & maxsupersat, & + do_accurate_sedimentation, interval_sedi_vt ! ##################################################################### ! ##################################################################### @@ -1156,12 +1288,15 @@ MODULE module_mp_nssl_2mom ! ##################################################################### + + REAL FUNCTION fqvs(t) implicit none real :: t fqvs = exp(caw*(t-273.15)/(t-cbw)) END FUNCTION fqvs + REAL FUNCTION fqis(t) implicit none real :: t @@ -1175,11 +1310,18 @@ END FUNCTION fqis + + + + ! ##################################################################### ! ##################################################################### + SUBROUTINE nssl_2mom_init( & + & ipctmp, mixphase,ihvol,idoniconlytmp,eqtset_tmp, index_ccna, index_cina, outfile, & - & namelist_filename, & + + & namelist_filename, internal_nml, & & nssl_graupelfallfac, & & nssl_hailfallfac, & & nssl_ehw0, & @@ -1194,10 +1336,17 @@ SUBROUTINE nssl_2mom_init( & & nssl_alphahl, & & nssl_alphar, & & nssl_density_on, nssl_hail_on, nssl_ccn_on, nssl_icecrystals_on, ccn_is_ccna, & + & nssl_cina_on, & + & nssl_cinda_on, & + & nssl_ccn_opt, & + & nssl_icenucopt, & + & infileunit, & + & compute_dualpol, & & myrank, mpiroot & ) + implicit none real, intent(in), optional :: & @@ -1212,33 +1361,51 @@ SUBROUTINE nssl_2mom_init( & & nssl_alphahl, & & nssl_alphar integer, intent(in), optional :: & - & nssl_icdx, & + & nssl_icdx, & & nssl_icdxhl, myrank, mpiroot, & - & nssl_ufccn - logical, intent(in), optional :: nssl_density_on, nssl_hail_on, nssl_ccn_on, nssl_icecrystals_on + & nssl_ufccn, & + & nssl_ccn_opt + integer, optional, intent(in) :: compute_dualpol, nssl_icenucopt + logical, intent(in), optional :: nssl_density_on, nssl_ccn_on, nssl_hail_on, nssl_icecrystals_on, & + nssl_cina_on,nssl_cinda_on integer, intent(inout), optional :: ccn_is_ccna integer, intent(in),optional :: infileunit + integer,parameter::strsize=512 - character(len=strsize), intent(in), optional :: namelist_filename - character(len=strsize) :: namelist_inputfile + + character(len=*), intent(in), optional :: internal_nml(:) + character(len=*), intent(in), optional :: namelist_filename + character(len=strsize) :: namelist_inputfile ! local string + logical :: read_internal = .false. + logical :: file_exist = .false. + logical :: is_initialized = .false. + integer, optional, intent(in) :: eqtset_tmp integer, optional, intent(in) :: index_ccna, index_cina, outfile + + + integer, intent(in) :: ipctmp,mixphase integer, optional, intent(in) :: ihvol logical, optional, intent(in) :: idoniconlytmp + + integer :: igvol_local = 1 logical :: wrote_namelist = .false. + logical :: wrf_dm_on_monitor + integer :: hail_on = -1, density_on = -1, icecrystals_on = 1 integer :: ccn_on = -1 + integer :: compute_dualpol_local = 0 - double precision :: arg + double precision :: arg,cwch real :: temq integer :: igam integer :: i,il,j,l @@ -1247,17 +1414,25 @@ SUBROUTINE nssl_2mom_init( & real :: bxh1,bxhl1 real :: alp,ratio - double precision :: x,y,y2,y7 - logical :: turn_on_ccna, turn_on_cina + double precision :: x,y,y2,y3,y7 + logical :: turn_on_ccna, turn_on_cina, turn_on_cinda integer :: iufccn = 0 integer :: istat real :: alpjj, alpii, xnuii, xnujj integer :: ii, jj - + + ! DTD: I don't think this is supposed to be here (preprocessing issue for CM1?) + ! nssl_params(11) is ipelec, so redo indices if it is not zero (inner grid) + ! IF ( is_initialized .and. nssl_params(11) == 0 ) RETURN + is_initialized = .true. + + + turn_on_ccna = .false. turn_on_cina = .false. + turn_on_cinda = .false. ! IF ( present( igvol ) ) THEN ! igvol_local = igvol @@ -1289,10 +1464,15 @@ SUBROUTINE nssl_2mom_init( & ENDIF ENDIF + IF ( present( compute_dualpol ) ) THEN + compute_dualpol_local = compute_dualpol + ENDIF + ! ! set some global values from namelist input ! + ! open(unit=20,file='namelist.input',form='formatted',status='old', & ! access='sequential') ! read(20,nml=micro_params) @@ -1308,6 +1488,7 @@ SUBROUTINE nssl_2mom_init( & + IF ( present(nssl_graupelfallfac) ) graupelfallfac = nssl_graupelfallfac IF ( present(nssl_hailfallfac) ) hailfallfac = nssl_hailfallfac IF ( present(nssl_ehw0) ) THEN @@ -1334,70 +1515,112 @@ SUBROUTINE nssl_2mom_init( & ENDIF + ipconc = ipctmp - IF ( ipconc < 5 ) THEN - ihlcnh = 0 - ENDIF IF ( ihlcnh <= 0 ) THEN - IF ( ipconc == 5 ) THEN + IF ( ipconc < 5 ) THEN + ihlcnh = 0 + ELSEIF ( ipconc == 5 ) THEN + ihlcnh = 3 + ELSEIF ( ipconc >= 6 ) THEN ihlcnh = 3 ENDIF ENDIF - ! turn on active rain breakup by default for 3-moment rain since it has no implicit breakup from sedimentation - IF ( irainbreak == 0 .and. ipconc >= 6 ) THEN - irainbreak = 2 + IF ( imaxdiaopt <= 0 ) THEN + IF ( ipconc < 5 ) THEN + imaxdiaopt = 3 + ELSEIF ( ipconc == 5 ) THEN + imaxdiaopt = 3 + ELSEIF ( ipconc >= 6 ) THEN + imaxdiaopt = 1 + ENDIF ENDIF - - namelist_inputfile = 'namelist.input' ! default for WRF/1 - IF ( present( namelist_filename ) ) THEN + + + + +#ifdef INTERNAL_FILE_NML + read_internal = .true. + read (internal_nml, nml = nssl_mp_params, iostat=istat) +#endif + + namelist_inputfile = 'namelist.input' ! default for WRF/cm1 + IF ( present( namelist_filename ) ) THEN ! filename is passed in namelist_inputfile = namelist_filename ELSE ENDIF - open(15,file=namelist_inputfile,status='old',form='formatted',action='read') + + open(15,file=trim(namelist_inputfile),status='old',form='formatted',action='read') rewind(15) read(15,NML=nssl_mp_params,iostat=istat) close(15) - IF ( istat /= 0 ) THEN -#ifdef WRF_ELEC - IF ( wrf_dm_on_monitor() ) THEN - write(0,*) 'NSSL_2MOM_INIT: NSSL_MP_PARAMS namelist: not found or bad token' + + + + ! turn on active rain breakup by default for 3-moment rain since it has no implicit breakup from sedimentation + ! Check this after namelist read so that user can set irainbreak=0 to turn off + IF ( irainbreak == -1 ) THEN + IF ( ipconc >= 6 ) THEN + irainbreak = 2 + ELSE + irainbreak = 0 ENDIF -#else - ! write(0,*) 'NSSL_2MOM_INIT: PROBLEM WITH NSSL_MP_PARAMS namelist: not found or bad token' -#endif ENDIF - IF ( istat /= 0 ) THEN - IF ( present(myrank) ) THEN - IF ( myrank == 0 ) write(0,*) 'READ_NAMELIST: PROBLEM WITH NSSL_MP_PARAMS namelist: not found or bad token' + + IF ( icorrecthaildbz == -1 ) THEN + IF ( ipconc >= 6 ) THEN + icorrecthaildbz = 0 + ELSE + icorrecthaildbz = 1 ENDIF - ELSE - IF ( present(myrank) ) THEN - IF ( myrank == 0 ) write(0,*) 'Read nssl_mp_params' + ENDIF + + IF ( icorrectfddbz == -1 ) THEN + IF ( ipconc >= 6 ) THEN + icorrectfddbz = 0 + ELSE + icorrectfddbz = 1 ENDIF ENDIF -! IF ( present( outfile ) ) THEN -! IF ( outfile >= 0 ) THEN -! write(outfile,NML=nssl_mp_params) -! ENDIF -! ENDIF - IF ( present(myrank) ) THEN - myrankcm1 = myrank - IF ( myrank == 0 ) THEN + + IF ( present( nssl_icenucopt ) ) THEN + icenucopt = nssl_icenucopt + ENDIF + + + + IF ( present ( myrank ) .and. present ( mpiroot ) ) THEN + myrankcm1 = myrank + IF ( myrank == mpiroot ) THEN + IF ( istat /= 0 ) THEN + write(0,*) 'NSSL_2MOM_INIT: PROBLEM WITH NSSL_MP_PARAMS namelist: not found or bad token' + ENDIF + +! write(0,*) 'iusewetsnow = ',iusewetsnow + + inquire(file='namelist.output', exist=file_exist) ! check for WRF standard namelist output + IF ( file_exist ) THEN + open(15,file='namelist.output',status='old',action='readwrite', position='append',form='formatted') + ELSE open(15,file='nssl_mp_params.out',status='unknown',form='formatted') - write(15,NML=nssl_mp_params) - close(15) - ENDIF - ENDIF + ENDIF + write(15,NML=nssl_mp_params) + close(15) + ENDIF ! rank=0 + ENDIF + + + @@ -1413,6 +1636,9 @@ SUBROUTINE nssl_2mom_init( & IF ( present( nssl_ccn_on ) ) THEN IF ( nssl_ccn_on ) THEN ccn_on = 1 + IF ( present( nssl_ccn_opt ) ) THEN + IF ( nssl_ccn_opt > 10 ) ac_opt = 22 + ENDIF ELSE ccn_on = 0 irenuc = 2 @@ -1423,8 +1649,11 @@ SUBROUTINE nssl_2mom_init( & turn_on_ccna = .true. IF ( present( nssl_ccn_on ) ) THEN IF ( .not. nssl_ccn_on ) THEN - write(0,*) 'NSSL_MP Error: Must have nssl_ccn_on=1 for irenuc >= 5!' + + write(0,*) 'NSSL_MP Error: Must have nssl_ccn_on=1/true for irenuc >= 5!' + STOP + ENDIF ENDIF ENDIF @@ -1441,6 +1670,13 @@ SUBROUTINE nssl_2mom_init( & cwccn = ccn + IF ( present( nssl_cina_on ) ) THEN + turn_on_cina = nssl_cina_on + ENDIF + IF ( present( nssl_cinda_on ) ) THEN + turn_on_cinda = nssl_cinda_on + ENDIF + lhab = 8 lhl = 8 IF ( icespheres >= 1 ) THEN @@ -1484,6 +1720,7 @@ SUBROUTINE nssl_2mom_init( & ENDIF + ! write(0,*) 'wrf_init: lhab,lhl,hail_on,density_on = ',lhab,lhl,hail_on,density_on ! IF ( ipelec > 0 ) idonic = .true. @@ -1506,6 +1743,8 @@ SUBROUTINE nssl_2mom_init( & tabqis(l) = exp(cai*(temq-273.15)/(temq-cbi)) dtabqis(l) = ((-cai*(-273.15 + temq))/(temq - cbi)**2 + & & cai/(temq - cbi))*tabqis(l) + + end do bx(lr) = 0.85 @@ -1557,8 +1796,8 @@ SUBROUTINE nssl_2mom_init( & gmoi(igam) = gamma_dp(arg) end do - ! build lookup table to compute the number and mass fractions of rain drops - ! (imurain=1) greater than a given diameter. Used for qiacr and ciacr + ! build lookup table to compute the number and mass fractions of particles + ! (mu=1) greater than a given diameter. Used for qiacr and ciacr ! Uses incomplete gamma functions ! The terms with bxh or bxhl will be off if the actual bxh or bxhl is different from the base value (icdx=6 option) @@ -1570,6 +1809,7 @@ SUBROUTINE nssl_2mom_init( & alp = float(j)*dqiacralpha y = gamma_dpr(1.+alp) y2 = gamma_dpr(2.+alp) + y3 = gamma_dpr(real(3.+alp)) DO i = 0,nqiacrratio ratio = float(i)*dqiacrratio x = gamxinfdp( 1.+alp, ratio ) @@ -1586,6 +1826,7 @@ SUBROUTINE nssl_2mom_init( & gamxinflu(i,j,10,1)= gamxinfdp( 4.0+alp, ratio )/y gamxinflu(i,j,12,1) = gamxinfdp( 2.0+alp, ratio )/y2 + gamxinflu(i,j,13,1) = gamxinfdp( 3.0+alp, ratio )/y3 ! hail (.,.,.,2) gamxinflu(i,j,1,2) = gamxinflu(i,j,1,1) @@ -1595,6 +1836,8 @@ SUBROUTINE nssl_2mom_init( & gamxinflu(i,j,6,2) = (gamma_dpr(5.5+alp+0.5*bxhl1) - gamxinfdp( 5.5+alp+0.5*bxhl1, ratio ))/y gamxinflu(i,j,9,2) = gamxinflu(i,j,9,1) gamxinflu(i,j,10,2)= gamxinflu(i,j,10,1) + gamxinflu(i,j,12,2) = gamxinflu(i,j,12,1) + gamxinflu(i,j,13,2) = gamxinflu(i,j,13,1) IF ( alp > 1.1 ) THEN ! gamxinflu(i,j,7,1) = gamxinfdp( alp - 1., ratio )/y @@ -1664,16 +1907,24 @@ SUBROUTINE nssl_2mom_init( & lhw = 0 lhlw = 0 + denscale(:) = 0 + ! lccn = 9 IF ( ipconc == 0 ) THEN IF ( hail_on == 1 ) THEN ! turn on graupel density for 1-moment scheme - lvh = 9 - ltmp = 9 - denscale(lvh) = 1 + IF ( density_on >= 1 ) THEN ! turn on graupel density for 1-moment scheme + lvh = 9 + ltmp = 9 + denscale(lvh) = 1 + ELSE + ltmp = lhab + lvh = 0 + lvhl = 0 + ENDIF ELSE ! no hail, 'LFO' scheme ltmp = lhab lhl = 0 @@ -1720,6 +1971,7 @@ SUBROUTINE nssl_2mom_init( & ! ltmp = lhlw ENDIF ELSEIF ( ipconc >= 6 ) THEN + ltmp = lhab IF ( iufccn > 0 ) THEN ltmp = ltmp+1 @@ -1754,19 +2006,23 @@ SUBROUTINE nssl_2mom_init( & IF ( ipconc == 6 ) THEN ltmp = ltmp + 1 lzh = ltmp + denscale(lzh) = 1 ELSEIF ( ipconc == 7 ) THEN ltmp = ltmp + 1 lzh = ltmp ltmp = ltmp + 1 lzr = ltmp + denscale(lzh:lzr) = 1 ELSEIF ( ipconc == 8 ) THEN ltmp = ltmp + 1 lzh = ltmp ltmp = ltmp + 1 lzr = ltmp + denscale(lzh:lzr) = 1 IF ( lhl > 1 ) THEN ltmp = ltmp + 1 lzhl = ltmp + denscale(lzhl) = 1 ENDIF ! write(0,*) 'ipcon,lzr = ',ipconc,lzr,lzh,lzhl ENDIF @@ -1783,13 +2039,18 @@ SUBROUTINE nssl_2mom_init( & ENDIF ! ltmp = lhlw ENDIF + ELSE + write(0,*) 'nssl_2mom_init: Invalid value of ipctmp' STOP + ENDIF + + ! write(0,*) 'wrf_init: lh,lhl,lzh,lzhl = ',lh,lhl,lzh,lzhl ! write(0,*) 'wrf_init: ipconc = ',ipconc ! write(0,*) 'wrf_init: irenuc, turn_on_ccna = ',irenuc, turn_on_ccna @@ -1799,12 +2060,28 @@ SUBROUTINE nssl_2mom_init( & denscale(ltmp) = 1 ENDIF + IF ( turn_on_cina ) THEN + IF ( icenucopt == 5 ) THEN + ! error + ENDIF ltmp = ltmp + 1 lcina = ltmp denscale(ltmp) = 1 ENDIF + IF ( turn_on_cinda ) THEN + IF ( turn_on_cina ) THEN + ! assume option 6 + icenucopt = 6 + ELSE + icenucopt = 5 + ENDIF + ltmp = ltmp + 1 + lcinda = ltmp + denscale(ltmp) = 1 + ENDIF + IF ( turn_on_cin .or. is_aerosol_aware ) THEN ltmp = ltmp + 1 lcin = ltmp @@ -1812,7 +2089,8 @@ SUBROUTINE nssl_2mom_init( & !debug write(0,*) 'Setting lcin to ',lcin ENDIF na = ltmp - + + ln(:) = 0 ln(lc) = lnc ln(lr) = lnr ln(li) = lni @@ -1820,6 +2098,7 @@ SUBROUTINE nssl_2mom_init( & ln(lh) = lnh IF ( lhl .gt. 1 ) ln(lhl) = lnhl + ipc(:) = 0 ipc(lc) = 2 ipc(lr) = 3 ipc(li) = 1 @@ -1866,7 +2145,7 @@ SUBROUTINE nssl_2mom_init( & lliq(lh) = lhw IF ( lhl .gt. 1 ) lliq(lhl) = lhlw IF ( mixedphase ) THEN -! write(0,*) 'lsw,lhw,lhlw = ',lsw,lhw,lhlw +! write(0,*) 'lsw,lhw,lhlw,ltmp = ',lsw,lhw,lhlw,ltmp ENDIF @@ -1924,10 +2203,10 @@ SUBROUTINE nssl_2mom_init( & ELSE ! rain is gamma of diameter rz = ((4. + alphah)*(5. + alphah)*(6. + alphah)*(1. + alphar)*(2. + alphar)*(3. + alphar))/ & - & ((1 + alphah)*(2 + alphah)*(3 + alphah)*(4. + alphar)*(5. + alphar)*(6. + alphar)) + & ((1. + alphah)*(2. + alphah)*(3. + alphah)*(4. + alphar)*(5. + alphar)*(6. + alphar)) rzhl = ((4. + alphahl)*(5. + alphahl)*(6. + alphahl)*(1. + alphar)*(2. + alphar)*(3. + alphar))/ & - & ((1 + alphahl)*(2 + alphahl)*(3 + alphahl)*(4. + alphar)*(5. + alphar)*(6. + alphar)) + & ((1. + alphahl)*(2. + alphahl)*(3. + alphahl)*(4. + alphar)*(5. + alphar)*(6. + alphar)) rzs = & @@ -1937,14 +2216,17 @@ SUBROUTINE nssl_2mom_init( & ENDIF + rzhlh = ((4. + alphahl)*(5. + alphahl)*(6. + alphahl)*(1. + alphah)*(2. + alphah)*(3. + alphah))/ & + & ((1. + alphahl)*(2. + alphahl)*(3. + alphahl)*(4. + alphah)*(5. + alphah)*(6. + alphah)) + IF ( ipconc <= 5 ) THEN - imltshddmr = Min(1, imltshddmr) +! imltshddmr = Min(1, imltshddmr) ibinhmlr = 0 ibinhlmlr = 0 ENDIF IF ( ipconc > 5 .and. (ibinhmlr == 0 .and. ibinhlmlr == 0 ) ) THEN - imltshddmr = Min(1, imltshddmr) +! imltshddmr = Min(1, imltshddmr) ENDIF ! write(0,*) 'rz,rzhl = ', rz,rzhl @@ -2022,11 +2304,23 @@ SUBROUTINE nssl_2mom_init( & ido(lh) = idohw IF ( lhl .gt. 1 ) ido(lhl) = idohl + linfall(:) = infall + linfall(lc) = 0 IF ( irfall .lt. 0 ) irfall = infall IF ( isfall .lt. 0 ) isfall = infall + IF ( iifall .lt. 0 ) iifall = infall IF ( lzr > 0 ) irfall = 0 + IF ( lzs > 0 ) isfall = 0 + IF ( lzh > 0 ) linfall(lh) = 0 + IF ( lzhl > 0 .and. lhl > 0 ) linfall(lhl) = 0 + IF ( lzr > 0 .and. lf > 0 ) linfall(lf) = 0 + linfall(lr) = irfall + linfall(ls) = isfall + linfall(li) = iifall qccn = ccn/rho00 + qccnco = ccn_co/rho00 + qccnnu = ccn_nu/rho00 qccnuf = ccnuf/rho00 IF ( old_cccn > 0.0 ) THEN old_qccn = old_cccn/rho00 @@ -2055,6 +2349,19 @@ SUBROUTINE nssl_2mom_init( & ELSE xvhmx = 0.523599*(dhmx)**3 ENDIF + + IF ( dhlmx <= 0.0 ) THEN + xvhlmx = xvhlmx0 + ELSE + xvhlmx = 0.523599*(dhlmx)**3 + ENDIF + + IF ( ipconc == 5 .and. imorrgdnglimit >= 1 ) THEN + ! convert morrdnglimit to xvhmx equivalent + cwch = ((3. + alphah)*(2. + alphah)*(1.0 + alphah))**(-1./3.) + xvhmx = pi/6.0*(morrdnglimit/cwch)**3 + dhmx = morrdnglimit/cwch + ENDIF IF ( qhdpvdn < 0. ) qhdpvdn = xdnmn(lh) IF ( qhacidn < 0. ) qhacidn = xdnmn(lh) @@ -2135,7 +2442,9 @@ SUBROUTINE nssl_2mom_init( & IF ( lh .gt. 1 .and. lnh .gt. 1 ) qxmin(lh ) = 1.0e-12 IF ( lhl.gt. 1 .and. lnhl.gt. 1 ) qxmin(lhl) = 1.0e-12 + qxmin_init(:) = 1.0e-8 ! threshold for considering single-moment initial condition mixing ratios + ! constants for droplet nucleation cckm = cck-1. @@ -2145,7 +2454,9 @@ SUBROUTINE nssl_2mom_init( & ! if k (cck) is changed! ccne = ccnefac*1.e6*(1.e-6*Abs(cwccn))**(2./(2.+cck)) ccne0 = ccnefac*1.e6*(1.e-6)**(2./(2.+cck)) + ! write(0,*) 'cwccn, cck, ccne = ',cwccn,cck,ccne,ccnefac,cnexp + IF ( cwccn .lt. 0.0 ) THEN cwccn = Abs(cwccn) ccwmx = 50.e9 ! cwccn @@ -2242,33 +2553,38 @@ SUBROUTINE nssl_2mom_init( & iexy(lhl,ls) = iehlsw ; iexy(lhl,li) = iehli ; iexy(lhl,lc) = iehlc ; iexy(lhl,lr) = iehlr ; ENDIF - + + ! IF ( icefallfac /= 1.0 ) write(0,*) 'icefallfac = ',icefallfac ! IF ( snowfallfac /= 1.0 ) write(0,*) 'snowfallfac = ',snowfallfac - RETURN END SUBROUTINE nssl_2mom_init ! ##################################################################### ! ##################################################################### + SUBROUTINE nssl_2mom_driver(qv, qc, qr, qi, qs, qh, qhl, ccw, crw, cci, csw, chw, chl, & - cn, vhw, vhl, cna, cni, f_cn, f_cna, f_cina, & + cn, vhw, vhl, cna, cni, cndi, f_cn, f_cna, f_cina, f_cinda, & f_qc, f_qr, f_qi, f_qs, f_qh, f_qhl, & - cnuf, f_cnuf, & + cn_nu, cn_co, cinp, f_cnnu, f_cnco, f_cinp, & + cna_co, cna_nu, f_cnaco, f_cnanu, & + cnuf, f_cnuf, cn_ac, f_cnac, & zrw, zhw, zhl, f_zrw, f_zhw, f_zhl, f_vhw, f_vhl, & qsw, qhw, qhlw, & - tt, th, pii, p, w, dn, dz, dtp, itimestep, & + tt, th, pii, p, w, dn, dz, dtp, itimestep, first_step, & is_theta_or_temp, & ntmul, ntcnt, lastloop, & - RAIN,nrain,prate, & + + RAIN,hail,nrain,prate, & tcond,tevac,tevar,train, & ruh,rvh,rmh,rr, & dx, dy, & ib3d,ie3d,jb3d,je3d,kb3d,ke3d, & nout3d,out3d, & axtra, dorad, & + SNOWNC, SNOWNCV, GRPLNC, GRPLNCV, & SR,HAILNC, HAILNCV, & hail_maxk1, hail_max2d, nwp_diagnostics, & @@ -2282,8 +2598,10 @@ SUBROUTINE nssl_2mom_driver(qv, qc, qr, qi, qs, qh, qhl, ccw, crw, cci, csw, chw rscghis_2d,rscghis_2dp,rscghis_2dn, & scr,scw,sci,scs,sch,schl,sctot, & elec_physics, & - induc,elecz,scion,sciona, & + induc,elecz,scion,sciona,f_scion,f_sciona, & noninduc,noninducp,noninducn, & + + ssat3d,ssati,nssl_ssat_output, & pcc2, pre2, depsubr, & mnucf2, melr2, ctr2, & rim1_2, rim2_2,rim3_2, & @@ -2297,12 +2615,16 @@ SUBROUTINE nssl_2mom_driver(qv, qc, qr, qi, qs, qh, qhl, ccw, crw, cci, csw, chw ! re_liquid, re_graupel, re_hail, re_icesnow, & ! vtcloud, vtrain, vtsnow, vtgraupel, vthail, & ipelectmp, & - diagflag,ke_diag, & + isedonly_in, & + diagflag,ke_diag,diag_dbz, & + refl_diagnostic,kdbz1km, & !LJR + nssl_progn, & ! wrf-chem ! 20130903 acd_mb_washout start wetscav_on, rainprod, evapprod, & ! wrf-chem ! 20130903 acd_mb_washout end cu_used, qrcuten, qscuten, qicuten, qccuten, & ! hm added + ids,ide, jds,jde, kds,kde, & ! domain dims ims,ime, jms,jme, kms,kme, & ! memory dims its,ite, jts,jte, kts,kte) ! tile dims @@ -2310,21 +2632,31 @@ SUBROUTINE nssl_2mom_driver(qv, qc, qr, qi, qs, qh, qhl, ccw, crw, cci, csw, chw + + + + + ! this line intentionally commented #ifdef MPI use mpi ! this line intentionally commented #endif + implicit none + !Subroutine arguments: + integer :: mytask = 0 integer, intent(in), optional :: & ids,ide, jds,jde, kds,kde + integer, intent(in):: & + ims,ime, jms,jme, kms,kme, & its,ite, jts,jte, kts,kte real, dimension(ims:ime, jms:jme, kms:kme), intent(inout):: & @@ -2337,7 +2669,12 @@ SUBROUTINE nssl_2mom_driver(qv, qc, qr, qi, qs, qh, qhl, ccw, crw, cci, csw, chw qi,qhl,ccw,crw,cci,csw,chw,chl,vhw,vhl integer, optional, intent(in) :: is_theta_or_temp logical, optional, intent(in) :: f_zrw, f_zhw, f_zhl, f_vhw, f_vhl ! not used yet - real, dimension(ims:ime, jms:jme, kms:kme), optional, intent(inout):: dbz, vzf, cn, cna, cni, cnuf + integer, optional, intent(in) :: nssl_ssat_output + real, dimension(ims:ime, jms:jme, kms:kme), optional, intent(inout):: dbz, vzf, cn, cna, cni, cndi, cnuf + + real, dimension(ims:ime, jms:jme, kms:kme), optional, intent(inout):: cn_nu, cn_ac, cn_co, cinp, cna_co, cna_nu + logical, optional, intent(in) :: f_cnnu, f_cnac, f_cnco, f_cinp, f_cnaco, f_cnanu + real, dimension(ims:ime, jms:jme), optional, intent(inout):: compdbz real, dimension(ims:ime, jms:jme), optional, intent(inout):: rscghis_2d, & ! 2D accumulation arrays for vertically-integrated charging rate rscghis_2dp, & ! 2D accumulation arrays for vertically-integrated charging rate (positive only) @@ -2349,11 +2686,14 @@ SUBROUTINE nssl_2mom_driver(qv, qc, qr, qi, qs, qh, qhl, ccw, crw, cci, csw, chw real, dimension(ims:ime, jms:jme, kms:kme), optional, intent(inout):: & induc,noninduc,noninducp,noninducn ! charging rates: inductive, noninductive (all, positive, negative to graupel) real, dimension(ims:ime, jms:jme, kms:kme), optional, intent(in) :: elecz ! elecsave = Ez - real, dimension(ims:ime, jms:jme, kms:kme,2),optional, intent(inout) :: scion + real, dimension(ims:ime, jms:jme, kms:kme, 2),optional, intent(inout) :: scion real, dimension(ims:ime, jms:jme, kms:kme), intent(in):: p,w,dz,dn + real, dimension(ims:ime, jms:jme, kms:kme), intent(inout):: pii + real, dimension(ims:ime, jms:jme, kms:kme), optional, intent(inout):: & + ssat3d, ssati, & pcc2, pre2, depsubr, & mnucf2, melr2, ctr2, & rim1_2, rim2_2,rim3_2, & @@ -2367,12 +2707,15 @@ SUBROUTINE nssl_2mom_driver(qv, qc, qr, qi, qs, qh, qhl, ccw, crw, cci, csw, chw ! re_liquid, re_graupel, re_hail, re_icesnow, & ! vtcloud, vtrain, vtsnow, vtgraupel, vthail + real, dimension(ims:ime, jms:jme, kms:kme), optional, intent(inout) :: axtra + + ! COMMAS vars integer, intent(in) :: nrain - real, dimension(ims:ime, jms:jme,nrain), intent(inout):: & - rain ! accumulated precip (NC) and rate (NCV) + real, dimension(ims:ime, jms:jme,nrain), intent(inout), optional :: & + rain, hail ! accumulated precip (NC) and rate (NCV) real, dimension(ims:ime, jms:jme), optional, INTENT(INOUT) :: prate real, dimension(ims:ime, jms:jme) :: & ! used as local temp array in 1/COMMAS RAINNC,RAINNCV ! accumulated precip (NC) and rate (NCV) @@ -2380,6 +2723,7 @@ SUBROUTINE nssl_2mom_driver(qv, qc, qr, qi, qs, qh, qhl, ccw, crw, cci, csw, chw SNOWNC,SNOWNCV,GRPLNC,GRPLNCV,SR,HAILNC,HAILNCV ! accumulated precip (NC) and rate (NCV) ! logical, parameter :: f_THPROC = .false. + ! extra vars for cm1 real*8, intent(inout) :: tcond,tevac,tevar,train REAL, DIMENSION(ims:ime, jms:jme, kms:kme), INTENT(IN):: rmh, rr @@ -2387,26 +2731,36 @@ SUBROUTINE nssl_2mom_driver(qv, qc, qr, qi, qs, qh, qhl, ccw, crw, cci, csw, chw real, intent(in), dimension(jms:jme) :: rvh logical, intent(in), optional :: dorad ! flag for radiation logical :: doradlocal + real*8, dimension(jte) :: bud1,bud2 + real, dimension(ims:ime, jms:jme), optional, intent(inout) :: hail_maxk1, hail_max2d integer, optional, intent(in) :: nwp_diagnostics + ! for cm1, set nproctot=44 (or as needed) to get domain total rates integer, parameter :: nproc = 1 double precision :: proctot(nproc),proctotmpi(nproc) + REAL, DIMENSION(ims:ime, jms:jme, kms:kme), optional, INTENT(INOUT):: re_cloud, re_ice, re_snow, & re_rain, re_graup, re_hail + REAL, DIMENSION(ims:ime, jms:jme, kms:kme), optional, INTENT(IN):: tkediss + REAL, DIMENSION(ims:ime, jms:jme), optional, INTENT(INOUT):: refl_diagnostic ! 1km-ish reflectivity + integer, DIMENSION(ims:ime, jms:jme), optional, INTENT(IN):: kdbz1km ! index of level just below 1km INTEGER, INTENT(IN), optional :: has_reqc, has_reqi, has_reqs, has_reqr, has_reqg, has_reqh real, dimension(ims:ime, jms:jme), intent(out), optional :: & rainncw2, rainnci2 ! liquid rain, ice, accumulation rates real, optional, intent(in) :: dx,dy real, intent(in) :: dtp integer, intent(in) :: itimestep !, ccntype + logical, optional, intent(in) :: first_step integer, intent(in), optional :: ntmul, ntcnt logical, optional, intent(in) :: lastloop - logical, optional, intent(in) :: diagflag, f_cna, f_cn, f_cina, f_cnuf + logical, optional, intent(in) :: diagflag, f_cna, f_cn, f_cina, f_cinda, f_cnuf, diag_dbz logical, optional, intent(in) :: f_qc, f_qr, f_qi, f_qs, f_qh, f_qhl - integer, optional, intent(in) :: ipelectmp, ke_diag + logical, optional, intent(in) :: f_scion,f_sciona + integer, optional, intent(in) :: ipelectmp, ke_diag, isedonly_in + LOGICAL, INTENT(IN), OPTIONAL :: nssl_progn ! flags for wrf-chem @@ -2418,8 +2772,10 @@ SUBROUTINE nssl_2mom_driver(qv, qc, qr, qi, qs, qh, qhl, ccw, crw, cci, csw, chw logical :: flag_ccn = .false. logical :: flag_qi = .true. logical :: has_reqr_local = .false., has_reqg_local = .false., has_reqh_local = .false. + logical :: flag logical :: nwp_diagflag = .false. + integer :: compute_dualpol_local = 0 real :: cinchange, t7max,testmax,wmax ! 20130903 acd_ck_washout start @@ -2436,18 +2792,22 @@ SUBROUTINE nssl_2mom_driver(qv, qc, qr, qi, qs, qh, qhl, ccw, crw, cci, csw, chw INTEGER, optional, intent(in) :: cu_used LOGICAL, optional, intent(in) :: wetscav_on + integer, intent(in) :: ib3d,ie3d,jb3d,je3d,kb3d,ke3d,nout3d real, intent(inout) , dimension(ib3d:ie3d,jb3d:je3d,kb3d:ke3d,nout3d) :: out3d + ! ! local variables ! real, dimension(its:ite, 1, kts:kte) :: elec2 ! ez = elecsave slab + ! real, dimension(its:ite, 1, kts:kte,2) :: scion2 ! 1=- , 2=+ real, dimension(its:ite, kts:kte) :: rainprod2d, evapprod2d,tke2d real, dimension(its:ite, 1, kts:kte, na) :: an, ancuten real, dimension(its:ite, 1, kts:kte, nxtra) :: axtra2d - real, dimension(its:ite, 1, kts:kte, 3) :: alpha2d - real, dimension(its:ite, 1, kts:kte) :: t0,t1,t2,t3,t4,t5,t6,t7,t8,t9 + real, dimension(its:ite, 1, kts:kte, 4) :: alpha2d + + real, dimension(its:ite, 1, kts:kte) :: t0,t1,t2,t3,t4,t5,t6,t7,t8,t9,t7d real, dimension(its:ite, 1, kts:kte) :: dn1,t00,t77,ssat,pn,wn,dz2d,dz2dinv,dbz2d,vzf2d real, dimension(its:ite, 1, na) :: xfall real, dimension(its:ite, 1) :: hailmax1d,hailmaxk1 @@ -2471,6 +2831,7 @@ SUBROUTINE nssl_2mom_driver(qv, qc, qr, qi, qs, qh, qhl, ccw, crw, cci, csw, chw real, parameter :: cnin2a = 12.96 real, parameter :: cnin2b = 0.639 + double precision :: cwmass1,cwmass2 double precision :: rwmass1,rwmass2 double precision :: icemass1,icemass2 @@ -2480,16 +2841,18 @@ SUBROUTINE nssl_2mom_driver(qv, qc, qr, qi, qs, qh, qhl, ccw, crw, cci, csw, chw double precision :: wvol5,wvol10 real :: tmp,dv,dv1,tmpchg real :: rdt + real :: temp1, c1 double precision :: dt1,dt2 double precision :: timesed,timesed1,timesed2,timesed3, timegs, timenucond, timedbz,zmaxsed double precision :: timevtcalc,timesetvt - logical :: f_cnatmp, f_cinatmp, f_cnacotmp, f_cnanutmp + logical :: f_cnatmp, f_cinatmp, f_cindatmp, f_cnacotmp, f_cnanutmp logical :: has_wetscav integer :: kediagloc integer :: iunit + integer :: isedonly_local real :: ycent, y, emissrate, emissrate0, emissrate1, z, fac, factot real :: fach(kts:kte) @@ -2498,16 +2861,21 @@ SUBROUTINE nssl_2mom_driver(qv, qc, qr, qi, qs, qh, qhl, ccw, crw, cci, csw, chw integer :: loopcnt, loopmax, outerloopcnt logical :: lastlooptmp + logical :: is_first_step ! for initializing Z moments when restarting from 2-moment + ! -#if defined(MPI) +#if defined(MPI) || defined( WRF_ELEC ) + INTEGER :: mpi_error_code = 1 #endif + ! ------------------------------------------------------------------- + rdt = 1.0/dtp IF ( debugdriver ) write(0,*) 'N2M: entering routine' @@ -2518,7 +2886,14 @@ SUBROUTINE nssl_2mom_driver(qv, qc, qr, qi, qs, qh, qhl, ccw, crw, cci, csw, chw flag_cnuf = .false. flag_ccn = .false. nwp_diagflag = .false. - + is_first_step = .false. + + IF ( present( first_step ) ) THEN + is_first_step = first_step + ELSEIF ( itimestep == 1 ) THEN + is_first_step = .true. + ENDIF + IF ( PRESENT ( nssl_progn ) ) flag_qndrop = nssl_progn IF ( present ( f_cnuf ) ) flag_cnuf = f_cnuf IF ( present ( nwp_diagnostics ) ) nwp_diagflag = ( nwp_diagnostics > 0 ) @@ -2541,6 +2916,7 @@ SUBROUTINE nssl_2mom_driver(qv, qc, qr, qi, qs, qh, qhl, ccw, crw, cci, csw, chw IF ( .not. flag_qi .and. ffrzs < 1.0 ) ffrzs = 1.0 + IF ( PRESENT ( has_reqr ) ) has_reqr_local = has_reqr > 0 IF ( PRESENT ( has_reqg ) ) has_reqg_local = has_reqg > 0 @@ -2574,6 +2950,12 @@ SUBROUTINE nssl_2mom_driver(qv, qc, qr, qi, qs, qh, qhl, ccw, crw, cci, csw, chw ELSE f_cinatmp = .false. ENDIF + + IF ( present( f_cinda ) ) THEN + f_cindatmp = f_cinda + ELSE + f_cindatmp = .false. + ENDIF IF ( present( vzf ) ) vzflag0 = 1 @@ -2582,6 +2964,13 @@ SUBROUTINE nssl_2mom_driver(qv, qc, qr, qi, qs, qh, qhl, ccw, crw, cci, csw, chw ELSE ipelec = 0 ENDIF + + IF ( present( isedonly_in ) ) THEN + isedonly_local = isedonly_in + ELSE + isedonly_local = 0 + ENDIF + ! IF ( present( dbz ) ) THEN ! DO jy = jts,jte ! DO kz = kts,kte @@ -2600,11 +2989,14 @@ SUBROUTINE nssl_2mom_driver(qv, qc, qr, qi, qs, qh, qhl, ccw, crw, cci, csw, chw dy1 = 1.0 ENDIF + makediag = .true. IF ( present( diagflag ) ) THEN makediag = diagflag .or. itimestep == 1 + IF ( diagflag ) cleardiag = .true. + ENDIF IF ( debugdriver ) write(0,*) 'N2M: makediag = ',makediag @@ -2622,9 +3014,12 @@ SUBROUTINE nssl_2mom_driver(qv, qc, qr, qi, qs, qh, qhl, ccw, crw, cci, csw, chw + + ! ENDIF ! itimestep == 1 + ! sedimentation settings infdo = 2 @@ -2635,13 +3030,14 @@ SUBROUTINE nssl_2mom_driver(qv, qc, qr, qi, qs, qh, qhl, ccw, crw, cci, csw, chw infdo = 0 ENDIF - IF ( infall .ge. 3 .or. ipconc .ge. 6 ) THEN + IF ( Any(linfall(:) .ge. 3 ) .or. ipconc .ge. 6 ) THEN infdo = 2 ENDIF - + IF (present( HAILNCV ) ) HAILNCV(its:ite,jts:jte) = 0. + tke2d(:,:) = 0.0 ! initialize if not used lnb = Max(lh,lhl)+1 ! lnc @@ -2669,43 +3065,58 @@ SUBROUTINE nssl_2mom_driver(qv, qc, qr, qi, qs, qh, qhl, ccw, crw, cci, csw, chw + IF ( debugdriver ) write(0,*) 'N2M: jy loop 1, lhl,na = ',lhl,na,present(qhl) ancuten(its:ite,1,kts:kte,:) = 0.0 thproclocal(:,:) = 0.0 + proctot(:) = 0 + + +#if (defined (OPENMP) ) !$OMP PARALLEL DO DEFAULT(SHARED) & -!$OMP PRIVATE(ix,jy,kz,xfall,axtra2d,an,t0,t1,t2,t3,t4,t5,t6,t7,t8,t9, & +!$OMP PRIVATE(ix,jy,kz,xfall,axtra2d,an,t0,t1,t2,t3,t4,t5,t6,t7,t8,t9,t7d, & !$OMP t00,t77,dbz2d,vzf2d,dn1,pn,wn,dz2d,dz2dinv,ltemq,ssival,dp1, & !$OMP elec2,thproclocal,t8s,t9s,il,n,ssat,loopcnt, & !$OMP qvapor,ssifac,ancuten,rainprod2d,evapprod2d,kediagloc,alpha2d, & + !$OMP hailmax1d,hailmaxk1) ! need to figure out how to treat thproc: with a critical section? +#endif DO jy = jts,jye ! write(0,*) 'N2M: load an, jy,lccn = ',jy,lccn,qccn - IF ( present( pcc2 ) .and. makediag ) THEN + + IF ( ( present( pcc2 ) .or. present( axtra ) ) .and. makediag ) THEN + axtra2d(its:ite,1,kts:kte,:) = 0.0 ENDIF - IF ( nwp_diagflag ) THEN + IF ( nwp_diagflag .or. compute_dualpol_local > 0 ) THEN alpha2d(its:ite,1,kts:kte,1) = alphar alpha2d(its:ite,1,kts:kte,2) = alphah alpha2d(its:ite,1,kts:kte,3) = alphahl + ENDIF + + ! for now, only using thproclocal for domain totals thproclocal(:,:) = 0.0 + ! copy from 3D array to 2D slab DO kz = kts,kte DO ix = its,ite + an(ix,1,kz,lt) = th(ix,jy,kz) + an(ix,1,kz,lv) = qv(ix,jy,kz) an(ix,1,kz,lc) = qc(ix,jy,kz) an(ix,1,kz,lr) = qr(ix,jy,kz) @@ -2719,7 +3130,9 @@ SUBROUTINE nssl_2mom_driver(qv, qc, qr, qi, qs, qh, qhl, ccw, crw, cci, csw, chw IF ( lhl > 1 ) an(ix,1,kz,lhl) = qhl(ix,jy,kz) IF ( lccn > 1 ) THEN IF ( is_aerosol_aware .and. flag_qnwfa ) THEN + ! + ELSEIF ( flag_ccn ) THEN IF ( lccna > 1 .and. .not. ( present( cna ) .and. f_cnatmp ) ) THEN an(ix,1,kz,lccna) = cn(ix,jy,kz) @@ -2732,14 +3145,19 @@ SUBROUTINE nssl_2mom_driver(qv, qc, qr, qi, qs, qh, qhl, ccw, crw, cci, csw, chw ENDIF ELSE IF ( lccna == 0 .and. ( .not. f_cnatmp ) ) THEN + an(ix,1,kz,lccn) = qccn - ccw(ix,jy,kz) + ELSE + an(ix,1,kz,lccn) = qccn + ENDIF ENDIF ENDIF + IF ( lccnuf > 0 .and. flag_cnuf ) THEN IF ( i_uf_or_ccn == 0 ) THEN ! UF are UF an(ix,1,kz,lccnuf) = Max(0.0, cnuf(ix,jy,kz) ) @@ -2750,16 +3168,24 @@ SUBROUTINE nssl_2mom_driver(qv, qc, qr, qi, qs, qh, qhl, ccw, crw, cci, csw, chw IF ( lccna > 1 ) THEN IF ( present( cna ) .and. f_cnatmp ) THEN - an(ix,1,kz,lccna) = cna(ix,jy,kz) + an(ix,1,kz,lccna) = Max(0.0, cna(ix,jy,kz) ) ENDIF ENDIF + IF ( lcina > 1 ) THEN IF ( present( cni ) .and. f_cinatmp ) THEN an(ix,1,kz,lcina) = cni(ix,jy,kz) ENDIF ENDIF + IF ( lcinda > 1 ) THEN + IF ( present( cndi ) .and. f_cindatmp ) THEN + ! icenucopt = 6 + an(ix,1,kz,lcinda) = cndi(ix,jy,kz) + ENDIF + ENDIF + IF ( ipconc >= 5 ) THEN an(ix,1,kz,lnc) = ccw(ix,jy,kz) IF ( constccw > 0.0 ) THEN @@ -2775,17 +3201,22 @@ SUBROUTINE nssl_2mom_driver(qv, qc, qr, qi, qs, qh, qhl, ccw, crw, cci, csw, chw an(ix,1,kz,lnh) = chw(ix,jy,kz) IF ( lhl > 1 ) an(ix,1,kz,lnhl) = chl(ix,jy,kz) ENDIF - IF ( lvh > 0 ) an(ix,1,kz,lvh) = vhw(ix,jy,kz) + IF ( lvh > 0 .and. present( vhw ) ) an(ix,1,kz,lvh) = vhw(ix,jy,kz) IF ( lvhl > 0 .and. present( vhl ) ) an(ix,1,kz,lvhl) = vhl(ix,jy,kz) + IF ( ipconc >= 6 ) THEN IF ( lzr > 0 ) an(ix,1,kz,lzr) = zrw(ix,jy,kz)*zscale IF ( lzh > 0 ) an(ix,1,kz,lzh) = zhw(ix,jy,kz)*zscale IF ( lzhl > 0 ) an(ix,1,kz,lzhl) = zhl(ix,jy,kz)*zscale ENDIF + + + + ENDDO ENDDO @@ -2793,8 +3224,10 @@ SUBROUTINE nssl_2mom_driver(qv, qc, qr, qi, qs, qh, qhl, ccw, crw, cci, csw, chw DO ix = its,ite + t0(ix,1,kz) = th(ix,jy,kz)*pii(ix,jy,kz) ! temperature (Kelvin) - t00(ix,1,kz) = 380.0/p(ix,jy,kz) + + t00(ix,1,kz) = 380.0/p(ix,jy,kz) ! 380 = 0.622*6.112*100 (0.622=rd/rw; 6.112 from formula fit; 100 to convert mb to Pa) t77(ix,1,kz) = pii(ix,jy,kz) dbz2d(ix,1,kz) = 0.0 vzf2d(ix,1,kz) = 0.0 @@ -2823,10 +3256,13 @@ SUBROUTINE nssl_2mom_driver(qv, qc, qr, qi, qs, qh, qhl, ccw, crw, cci, csw, chw t7(ix,1,kz) = 0.0 t8(ix,1,kz) = 0.0 t9(ix,1,kz) = 0.0 + t7d(ix,1,kz) = 0.0 pn(ix,1,kz) = p(ix,jy,kz) wn(ix,1,kz) = w(ix,jy,kz) + dn1(ix,1,kz) = dn(ix,jy,kz) + ! wmax = Max(wmax,wn(ix,1,kz)) dz2d(ix,1,kz) = dz(ix,jy,kz) dz2dinv(ix,1,kz) = 1./dz(ix,jy,kz) @@ -2849,6 +3285,7 @@ SUBROUTINE nssl_2mom_driver(qv, qc, qr, qi, qs, qh, qhl, ccw, crw, cci, csw, chw ssival = Min(t8s,max(an(ix,1,kz,lv),0.0))/t9s ! qv/qvi + if ( ssival .gt. 1.0 ) then ! IF ( icenucopt == 1 ) THEN @@ -2899,8 +3336,9 @@ SUBROUTINE nssl_2mom_driver(qv, qc, qr, qi, qs, qh, qhl, ccw, crw, cci, csw, chw end if - ELSEIF ( icenucopt == 4 ) THEN ! DeMott 2010 + ELSEIF ( icenucopt == 4 .or. icenucopt == 5 .or. icenucopt == 6 ) THEN + IF ( icenucopt == 4 .or. icenucopt == 6 ) THEN ! DeMott 2010 IF ( t0(ix,1,kz) < 268.16 .and. t0(ix,1,kz) > 223.15 .and. ssival > 1.001 ) THEN ! ! a = 0.0000594, b = 3.33, c = 0.0264, d = 0.0033, @@ -2909,7 +3347,9 @@ SUBROUTINE nssl_2mom_driver(qv, qc, qr, qi, qs, qh, qhl, ccw, crw, cci, csw, chw ! naer needs units of cm**-3, so mult by 1.e-6 ! dp1 = 1.e3*0.0000594*(273.16 - t0(ix,1,kz))**3.33 * (1.e-6*cin*dn(ix,1,kz))**(0.0264*(273.16 - t0(ix,1,kz)) + 0.0033) + tmp = 1.e-6*naer + dp1 = 1.e3*dn1(ix,1,kz)/rho00*0.0000594*(273.16 - t0(ix,1,kz))**3.33 * tmp**(0.0264*(273.16 - t0(ix,1,kz)) + 0.0033) t7(ix,1,kz) = Min(dp1, 1.0d30) @@ -2917,6 +3357,28 @@ SUBROUTINE nssl_2mom_driver(qv, qc, qr, qi, qs, qh, qhl, ccw, crw, cci, csw, chw ! t7(ix,1,kz) = 0.0 ENDIF + ELSEIF ( icenucopt == 5 .or. icenucopt == 6 ) THEN ! DeMott 2015 + + IF ( t0(ix,1,kz) < 268.16 .and. t0(ix,1,kz) > 223.15 .and. ssival > 1.001 ) THEN ! + + ! cf = 1, alpha=0, beta = 1.25, gamma = 0.46, delta = -11.6 + ! nint = cf * naer**(alpha*(-Tc) + beta) *exp(gamma*(-Tc) + delta) + ! nint = 1.0 * naer**( beta) *exp(gamma*(-Tc) + delta) + ! nint has units of per (standard) liter, so mult by 1.e3 and scale by dn/rho00 + ! naer needs units of cm**-3, so mult by 1.e-6 + + + tmp = 1.e-6*naerdust + + ! dp1 = 1.e3*0.0000594*(273.16 - t0(ix,jy,kz))**3.33 * (1.e-6*cin*dn(ix,jy,kz))**(0.0264*(273.16 - t0(ix,jy,kz)) + 0.0033) + dp1 = 1.e3*dn1(ix,1,kz)/rho00* (tmp)**(1.25)*exp( 0.46*(273.16 - t0(ix,1,kz)) - 11.6) + t7d(ix,1,kz) = Min(dp1, 1.0d30) + + ELSE + t7d(ix,1,kz) = 0.0 + ENDIF + ENDIF ! demott options + ENDIF ! icenucopt @@ -2937,6 +3399,7 @@ SUBROUTINE nssl_2mom_driver(qv, qc, qr, qi, qs, qh, qhl, ccw, crw, cci, csw, chw ! transform from number mixing ratios to number conc. + IF ( loopcnt == 1 ) THEN DO il = lnb,na IF ( denscale(il) == 1 ) THEN @@ -2949,6 +3412,7 @@ SUBROUTINE nssl_2mom_driver(qv, qc, qr, qi, qs, qh, qhl, ccw, crw, cci, csw, chw ENDDO ! il ENDIF + ! sedimentation xfall(:,:,:) = 0.0 @@ -2957,8 +3421,10 @@ SUBROUTINE nssl_2mom_driver(qv, qc, qr, qi, qs, qh, qhl, ccw, crw, cci, csw, chw ! IF ( .true. ) THEN -! for real cases when hydrometeor mixing ratios have been initialized without concentrations - IF ( itimestep == 1 .and. ipconc > 0 .and. loopcnt == 1 ) THEN + +! for real cases when hydrometeor mixing ratios have been initialized without concentrations (or without Z moments) + IF ( (itimestep == 1 .or. (is_first_step .and. ipconc > 5) ) .and. & + ipconc > 0 .and. loopcnt == 1 ) THEN call calcnfromq(nx,ny,nz,an,na,nor,nor,dn1) ENDIF @@ -2980,29 +3446,19 @@ SUBROUTINE nssl_2mom_driver(qv, qc, qr, qi, qs, qh, qhl, ccw, crw, cci, csw, chw call calcnfromcuten(nx,ny,nz,ancuten,an,na,nor,nor,dn1) - DO kz = kts,kte - DO ix = its,ite - - - IF ( ipconc >= 6 ) THEN -! IF ( lzr > 0 ) an(ix,1,kz,lzr) = an(ix,1,kz,lzr) + ancuten(ix,1,kz,lzr) - ENDIF - - ENDDO - ENDDO - ENDIF !} ENDIF !} - - + IF ( isedonly_local == 0 ) THEN + call sediment1d(dtp,nx,ny,nz,an,na,nor,nor,xfall,dn1,dz2d,dz2dinv, & & t0,t7,infdo,jy,its,jts & & ,timesed1,timesed2,timesed3,zmaxsed,timesetvt) + ! copy xfall to appropriate places... IF ( debugdriver ) write(0,*) 'N2M: end sediment, jy = ',jy @@ -3018,11 +3474,11 @@ SUBROUTINE nssl_2mom_driver(qv, qc, qr, qi, qs, qh, qhl, ccw, crw, cci, csw, chw & xfall(ix,1,lh)*1000./xdn0(lr) ) ENDIF IF ( present ( rainncw2 ) ) THEN ! rain only - rainncw2(ix,jy) = rainncw2(ix,jy) + dtp*dn1(ix,1,1)*xfall(ix,1,lr) + rainncw2(ix,jy) = rainncw2(ix,jy) + dtp*dn1(ix,1,1)*xfall(ix,1,lr) ENDIF IF ( present ( rainnci2 ) ) THEN ! ice only IF ( lhl > 1 ) THEN - rainnci2(ix,jy) =rainnci2(ix,jy) + dtp*dn1(ix,1,1)*(xfall(ix,1,ls)*1000./xdn0(lr) + & + rainnci2(ix,jy) = rainnci2(ix,jy) + dtp*dn1(ix,1,1)*(xfall(ix,1,ls)*1000./xdn0(lr) + & & xfall(ix,1,lh)*1000./xdn0(lr) + xfall(ix,1,lhl)*1000./xdn0(lr) ) ELSE rainnci2(ix,jy) = rainnci2(ix,jy) + dtp*dn1(ix,1,1)*(xfall(ix,1,ls)*1000./xdn0(lr) + & @@ -3031,15 +3487,37 @@ SUBROUTINE nssl_2mom_driver(qv, qc, qr, qi, qs, qh, qhl, ccw, crw, cci, csw, chw ENDIF IF ( present( SNOWNCV ) ) SNOWNCV(ix,jy) = SNOWNCV(ix,jy) + dtp*dn1(ix,1,1)*xfall(ix,1,ls)*1000./xdn0(lr) IF ( present( GRPLNCV ) ) THEN + IF ( lhw > 0 ) THEN + tmp = xfall(ix,1,lhw) ! subtract liquid fraction from ice accumulation + ELSE + tmp = 0.0 + ENDIF + IF ( lhl > 1 .and. .not. present( HAILNC) ) THEN ! if no separate hail accum, then add to graupel + IF ( lhlw > 0 ) tmp = tmp + xfall(ix,1,lhlw) + GRPLNCV(ix,jy) = GRPLNCV(ix,jy) + dtp*dn1(ix,1,1)*(xfall(ix,1,lh) + xfall(ix,1,lhl) - tmp) *1000./xdn0(lr) + ELSE + GRPLNCV(ix,jy) = GRPLNCV(ix,jy) + dtp*dn1(ix,1,1)*(xfall(ix,1,lh)-tmp)*1000./xdn0(lr) + ENDIF + ENDIF + + + IF ( present( hail ) ) THEN IF ( lhl > 1 .and. .not. present( HAILNC) ) THEN ! if no separate hail accum, then add to graupel - GRPLNCV(ix,jy) = GRPLNCV(ix,jy) + dtp*dn1(ix,1,1)*(xfall(ix,1,lh) + xfall(ix,1,lhl)) *1000./xdn0(lr) + tmp = dtp*dn1(ix,1,1)*(xfall(ix,1,lh) + xfall(ix,1,lhl)) *1000./xdn0(lr) ELSE - GRPLNCV(ix,jy) = GRPLNCV(ix,jy) + dtp*dn1(ix,1,1)*xfall(ix,1,lh)*1000./xdn0(lr) + tmp = dtp*dn1(ix,1,1)*xfall(ix,1,lh)*1000./xdn0(lr) ENDIF + do n = 1,nrain + hail(ix,jy,n) = hail(ix,jy,n) + 0.1*tmp + enddo ENDIF + + IF ( loopcnt == loopmax ) RAINNC(ix,jy) = RAINNC(ix,jy) + RAINNCV(ix,jy) - IF ( loopcnt == loopmax ) THEN + + + IF ( loopcnt == loopmax .and. present( rain ) ) THEN do n = 1,nrain RAIN(ix,jy,n) = RAIN(ix,jy,n) + 0.1*RAINNCV(ix,jy) enddo @@ -3053,16 +3531,18 @@ SUBROUTINE nssl_2mom_driver(qv, qc, qr, qi, qs, qh, qhl, ccw, crw, cci, csw, chw ! bud2(jy) = bud2(jy) - rr(ix,jy,kz)*PRE(kz)*ruh(ix)*rvh(jy)*rmh(ix,jy,kz)*tem1 ! enddo + IF ( present (SNOWNC) .and. present (SNOWNCV) .and. loopcnt == loopmax ) THEN SNOWNC(ix,jy) = SNOWNC(ix,jy) + SNOWNCV(ix,jy) ENDIF IF ( lhl > 1 ) THEN -!#ifdef 1 -! IF ( .true. ) THEN -!#else IF ( present( HAILNC ) ) THEN -!#endif - HAILNCV(ix,jy) = dtp*dn1(ix,1,1)*xfall(ix,1,lhl)*1000./xdn0(lr) + IF ( lhlw > 0 ) THEN + tmp = xfall(ix,1,lhlw) ! subtract liquid fraction from ice accumulation + ELSE + tmp = 0.0 + ENDIF + HAILNCV(ix,jy) = dtp*dn1(ix,1,1)*(xfall(ix,1,lhl)-tmp)*1000./xdn0(lr) IF ( loopcnt == loopmax ) HAILNC(ix,jy) = HAILNC(ix,jy) + HAILNCV(ix,jy) ! ELSEIF ( present( GRPLNCV ) ) THEN ! if no separate hail accum, then add to graupel ! GRPLNCV(ix,jy) = GRPLNCV(ix,jy) + dtp*dn1(ix,1,1)*xfall(ix,1,lhl)*1000./xdn0(lr) @@ -3071,10 +3551,14 @@ SUBROUTINE nssl_2mom_driver(qv, qc, qr, qi, qs, qh, qhl, ccw, crw, cci, csw, chw IF ( present( GRPLNCV ) .and. loopcnt == loopmax ) THEN GRPLNC(ix,jy) = GRPLNC(ix,jy) + GRPLNCV(ix,jy) ENDIF + ENDDO + ENDIF ! isedonly_local + ! ENDIF ! .false. + IF ( isedonly /= 1 ) THEN ! call nssl_2mom_gs: main gather-scatter routine to calculate microphysics @@ -3082,11 +3566,12 @@ SUBROUTINE nssl_2mom_driver(qv, qc, qr, qi, qs, qh, qhl, ccw, crw, cci, csw, chw ! IF ( isedonly /= 2 ) THEN + call nssl_2mom_gs & & (nx,ny,nz,na,jy & & ,nor,nor & & ,dtp,dz2d & - & ,t0,t1,t2,t3,t4,t5,t6,t7,t8,t9 & + & ,t0,t1,t2,t3,t4,t5,t6,t7,t8,t9,t7d & & ,an,dn1,t77 & & ,pn,wn,0 & & ,t00,t77, & @@ -3098,6 +3583,7 @@ SUBROUTINE nssl_2mom_driver(qv, qc, qr, qi, qs, qh, qhl, ccw, crw, cci, csw, chw & thproclocal,nproc,dx1,dy1,ngs, & & timevtcalc,axtra2d, makediag & & ,has_wetscav, rainprod2d, evapprod2d, alpha2d & + & ,elec2,its,ids,ide,jds,jde & & ) @@ -3105,6 +3591,10 @@ SUBROUTINE nssl_2mom_driver(qv, qc, qr, qi, qs, qh, qhl, ccw, crw, cci, csw, chw + + + + ENDIF ! isedonly /= 1 ! droplet nucleation/condensation/evaporation @@ -3117,9 +3607,20 @@ SUBROUTINE nssl_2mom_driver(qv, qc, qr, qi, qs, qh, qhl, ccw, crw, cci, csw, chw & ,an,dn1,t77 & & ,pn,wn & & ,ngs & + & ,axtra2d, makediag & & ,ssat,t00,t77,flag_qndrop) +! Clean up tiny values of mixing ratio and final checks on max/min sizes + CALL smallvalues & + & (nx,ny,nz,na,jy & + & ,nor,nor,dtp,nx & + & ,t0 & + & ,an,dn1,wn & + & ,t77,flag_qndrop) + + + ENDIF @@ -3127,32 +3628,76 @@ SUBROUTINE nssl_2mom_driver(qv, qc, qr, qi, qs, qh, qhl, ccw, crw, cci, csw, chw + ENDDO ! loopcnt=1,loopmax + IF ( present( pcc2 ) .and. makediag ) THEN DO kz = kts,kte DO ix = its,ite + ! example of using the 'axtra2d' array to get rates out of the microphysics routine for output. ! Search for 'axtra' to find example code below ! pcc2(ix,jy,kz) = axtra2d(ix,1,kz,1) + ENDDO ENDDO ENDIF + IF ( ( present( ssat3d ) .and. present( nssl_ssat_output ) ) .and. makediag ) THEN + DO kz = kts,kte + DO ix = its,ite + + ! updated temperature and qv + temp1 = t0(ix,1,kz) ! an(ix,1,kz,lt)*t77(ix,1,kz) + ltemq = Int( (temp1-163.15)/fqsat+1.5 ) + ltemq = Min( nqsat, Max(1,ltemq) ) + + IF ( present( ssat3d ) .and. nssl_ssat_output >= 1 ) THEN + +! c1 = t00(ix,1,kz)*tabqvs(ltemq) + IF ( iqvsopt == 0 ) THEN + c1 = (380.0/pn(ix,1,kz))*tabqvs(ltemq) + ELSEIF ( iqvsopt == 1 ) THEN + c1 = rdorv*esbolton*tabqvs(ltemq)/(pn(ix,1,kz) - esbolton*tabqvs(ltemq)) + ENDIF + + IF ( c1 > 0. ) THEN + ssat3d(ix,jy,kz) = 100.*(an(ix,1,kz,lv)/c1 - 1.0) ! from "new" values + ENDIF + + ENDIF + + IF ( present( ssati ) .and. nssl_ssat_output >= 2 ) THEN + t9s = (380.0/pn(ix,1,kz))*tabqis(ltemq) !saturation mixing ratio wrt ice + ssati(ix,jy,kz) = 100.*(an(ix,1,kz,lv)/t9s - 1.0) ! Min(t8s,max(an(ix,1,kz,lv),0.0))/t9s ! qv/qvi + ENDIF + + ENDDO + ENDDO + ENDIF + + + + ! compute diagnostic S-band reflectivity if needed IF ( present( dbz ) .and. makediag .and. lastlooptmp ) THEN ! calc dbz IF ( .true. ) THEN + IF ( present(ke_diag) ) THEN kediagloc = ke_diag ELSE kediagloc = nz ENDIF call radardd02(nx,ny,nz,nor,na,an,t0, & + & dbz2d,dn1,nz,cnoh,rho_qh,ipconc,kediagloc, 0) + ENDIF ! .false. + DO kz = kts,kediagloc ! kte DO ix = its,ite @@ -3169,20 +3714,44 @@ SUBROUTINE nssl_2mom_driver(qv, qc, qr, qi, qs, qh, qhl, ccw, crw, cci, csw, chw IF ( present( compdbz ) ) THEN compdbz(ix,jy) = Max( compdbz(ix,jy), dbz2d(ix,1,kz) ) ENDIF + IF ( present( refl_diagnostic ) .and. present( diag_dbz ) .and. present( kdbz1km ) ) THEN + IF (diag_dbz) then + refl_diagnostic(ix,jy) = dbz2d(ix,1,kdbz1km(ix,jy)) + ! print*, "after refl_diagnostic" + ENDIF + ENDIF ENDDO ENDDO ENDIF + IF ( present( refl_diagnostic ) .and. present( diag_dbz ) .and. present( kdbz1km ) ) THEN + IF (diag_dbz .and. .not. makediag ) then + ! compute diagnostics S-band refelctivity at chosen levels at every time step + !print*, "computing 1 level reflectivity" + call radardd02(nx,ny,nz,nor,na,an,t0, & + & dbz2d,dn1,nz,cnoh,rho_qh,ipconc,kediagloc, 0, & + & zdbz_start=Minval(kdbz1km(its:ite,jy)), zdbz_end=Maxval(kdbz1km(its:ite,jy)) ) + + do ix = its, ite + refl_diagnostic(ix,jy) = dbz2d(ix,1,kdbz1km(ix,jy) ) + enddo + + ENDIF + ENDIF + + ! Following Greg Thompson, calculation for effective radii. Used by RRTMG LW/SW schemes if enabled in module_physics_init.F + IF ( present( dorad ) ) THEN doradlocal = dorad ELSE doradlocal = .true. ENDIF IF ( doradlocal ) THEN + IF ( present( has_reqc ).and. present( has_reqi ) .and. present( has_reqs ) .and. & present( re_cloud ).and. present( re_ice ) .and. present( re_snow ) .and. & lastlooptmp) THEN @@ -3249,9 +3818,13 @@ SUBROUTINE nssl_2mom_driver(qv, qc, qr, qi, qs, qh, qhl, ccw, crw, cci, csw, chw ENDIF ENDIF + ENDIF ! dorad + + + IF ( present( hail_maxk1 ) .and. present( hail_max2d ) .and. nwp_diagflag ) THEN DO ix = its,ite hailmax1d(ix,1) = hail_max2d(ix,jy) @@ -3268,6 +3841,7 @@ SUBROUTINE nssl_2mom_driver(qv, qc, qr, qi, qs, qh, qhl, ccw, crw, cci, csw, chw ! ENDIF ENDIF + ! transform concentrations back to mixing ratios DO il = lnb,na IF ( denscale(il) == 1 ) THEN @@ -3278,6 +3852,7 @@ SUBROUTINE nssl_2mom_driver(qv, qc, qr, qi, qs, qh, qhl, ccw, crw, cci, csw, chw ENDDO ENDIF ENDDO ! il + ! copy 2D slabs back to 3D @@ -3285,11 +3860,15 @@ SUBROUTINE nssl_2mom_driver(qv, qc, qr, qi, qs, qh, qhl, ccw, crw, cci, csw, chw DO kz = kts,kte DO ix = its,ite + th(ix,jy,kz) = an(ix,1,kz,lt) + + IF ( eqtset > 2 ) THEN pii(ix,jy,kz) = t77(ix,1,kz) ENDIF + qv(ix,jy,kz) = an(ix,1,kz,lv) qc(ix,jy,kz) = an(ix,1,kz,lc) qr(ix,jy,kz) = an(ix,1,kz,lr) @@ -3299,7 +3878,9 @@ SUBROUTINE nssl_2mom_driver(qv, qc, qr, qi, qs, qh, qhl, ccw, crw, cci, csw, chw IF ( lhl > 1 ) qhl(ix,jy,kz) = an(ix,1,kz,lhl) IF ( lccn > 1 .and. is_aerosol_aware .and. flag_qnwfa ) THEN + ! not used here + ELSEIF ( flag_ccn .and. lccn > 1 .and. .not. flag_qndrop) THEN IF ( lccna > 1 .and. .not. ( present( cna ) .and. f_cnatmp ) ) THEN cn(ix,jy,kz) = Max(0.0, an(ix,1,kz,lccna) ) @@ -3313,11 +3894,17 @@ SUBROUTINE nssl_2mom_driver(qv, qc, qr, qi, qs, qh, qhl, ccw, crw, cci, csw, chw ENDIF ENDIF + IF ( lcina > 1 ) THEN IF ( present( cni ) .and. f_cinatmp ) THEN cni(ix,jy,kz) = Max(0.0, an(ix,1,kz,lcina) ) ENDIF ENDIF + IF ( lcinda > 1 ) THEN + IF ( present( cndi ) .and. f_cindatmp ) THEN + cndi(ix,jy,kz) = Max(0.0, an(ix,1,kz,lcinda) ) + ENDIF + ENDIF IF ( lccnuf > 0 .and. flag_cnuf ) THEN IF ( i_uf_or_ccn > 0 ) THEN ! UF are ccn and lccnuf is zero, so put cnuf into lccnuf to do decay @@ -3334,6 +3921,7 @@ SUBROUTINE nssl_2mom_driver(qv, qc, qr, qi, qs, qh, qhl, ccw, crw, cci, csw, chw + IF ( ipconc >= 5 ) THEN ccw(ix,jy,kz) = an(ix,1,kz,lnc) @@ -3344,6 +3932,7 @@ SUBROUTINE nssl_2mom_driver(qv, qc, qr, qi, qs, qh, qhl, ccw, crw, cci, csw, chw IF ( lhl > 1 ) chl(ix,jy,kz) = an(ix,1,kz,lnhl) ENDIF + IF ( ipconc >= 6 ) THEN IF ( lzr > 0 ) zrw(ix,jy,kz) = an(ix,1,kz,lzr) *zscaleinv IF ( lzh > 0 ) zhw(ix,jy,kz) = an(ix,1,kz,lzh) *zscaleinv @@ -3352,7 +3941,10 @@ SUBROUTINE nssl_2mom_driver(qv, qc, qr, qi, qs, qh, qhl, ccw, crw, cci, csw, chw - IF ( lvh > 0 ) vhw(ix,jy,kz) = an(ix,1,kz,lvh) + + + + IF ( lvh > 0 .and. present( vhw ) ) vhw(ix,jy,kz) = an(ix,1,kz,lvh) IF ( lvhl > 0 .and. present( vhl ) ) vhl(ix,jy,kz) = an(ix,1,kz,lvhl) #if ( WRF_CHEM == 1 ) @@ -3380,20 +3972,28 @@ SUBROUTINE nssl_2mom_driver(qv, qc, qr, qi, qs, qh, qhl, ccw, crw, cci, csw, chw !$OMP END CRITICAL ENDIF + ENDDO ! jy + DO jy = jts,jte DO ix = its,ite train = train + RAINNCV(ix,jy)*ruh(ix)*rvh(jy)*dx*dy ENDDO ENDDO + + + + + + 11 format('processes: ',100(1x,1pe12.5)) IF ( nproc > 1 ) THEN #ifdef MPI @@ -3408,12 +4008,15 @@ SUBROUTINE nssl_2mom_driver(qv, qc, qr, qi, qs, qh, qhl, ccw, crw, cci, csw, chw ENDIF + RETURN END SUBROUTINE nssl_2mom_driver + ! ##################################################################### ! ##################################################################### + REAL FUNCTION GAMMA_SP(xx) implicit none @@ -3432,7 +4035,9 @@ REAL FUNCTION GAMMA_SP(xx) IF ( xx <= 0.0 ) THEN write(0,*) 'Argument to gamma must be > 0!! xx = ',xx + STOP + ENDIF x = xx @@ -3451,6 +4056,7 @@ END FUNCTION GAMMA_SP ! ##################################################################### + DOUBLE PRECISION FUNCTION GAMMA_DPR(x) ! dp gamma with real input implicit none @@ -3469,6 +4075,7 @@ end FUNCTION GAMMA_DPR ! ##################################################################### + real function GAMXINF(A1,X1) ! =================================================== @@ -3496,7 +4103,9 @@ real function GAMXINF(A1,X1) XAM=-X+A*DLOG(X) IF (XAM.GT.700.0.OR.A.GT.170.0) THEN WRITE(*,*)'a and/or x too large' + STOP + ENDIF IF (X.EQ.0.0) THEN GIN=0.0 @@ -3528,6 +4137,7 @@ END function GAMXINF ! ##################################################################### + double precision function GAMXINFDP(A1,X1) ! =================================================== @@ -3557,7 +4167,9 @@ double precision function GAMXINFDP(A1,X1) XAM=-X+A*DLOG(X) IF (XAM.GT.700.0.OR.A.GT.170.0) THEN WRITE(*,*)'a and/or x too large' + STOP + ENDIF IF (X.EQ.0.0) THEN GIN=0.0 @@ -3590,6 +4202,7 @@ END function GAMXINFDP ! ##################################################################### + real function gaminterp(ratio, alp, luindex, ilh) implicit none @@ -3640,6 +4253,7 @@ END FUNCTION gaminterp ! It is used for qiacr with the gamma of volume to calculate what ! fraction of drops exceed a certain size (this version is for 40 micron drops) ! ********************************************************** + real FUNCTION GAML02(x) implicit none integer ig, i, ii, n, np @@ -3682,6 +4296,7 @@ END FUNCTION GAML02 ! It is used for qiacr with the gamma of volume to calculate what ! fraction of drops exceed a certain size (this version is for 300 micron drops) (see zieglerstuff.nb) ! ********************************************************** + real FUNCTION GAML02d300(x) implicit none integer ig, i, ii, n, np @@ -3728,6 +4343,7 @@ END FUNCTION GAML02d300 ! It is used for qiacr with the gamma of volume to calculate what ! fraction of drops exceed a certain size (this version is for 500 micron drops) (see zieglerstuff.nb) ! ********************************************************** + real FUNCTION GAML02d500(x) implicit none integer ig, i, ii, n, np @@ -3798,6 +4414,7 @@ END function BETA ! ##################################################################### ! ##################################################################### + DOUBLE PRECISION FUNCTION GAMMA_DP(xx) implicit none @@ -3829,6 +4446,7 @@ DOUBLE PRECISION FUNCTION GAMMA_DP(xx) END function gamma_dp ! ##################################################################### + SUBROUTINE GAMMADP(X,GA) ! ! ================================================== @@ -3846,6 +4464,19 @@ SUBROUTINE GAMMADP(X,GA) integer :: k,m1,m double precision :: G(26) + + DATA G/1.0D0,0.5772156649015329D0, & + & -0.6558780715202538D0, -0.420026350340952D-1, & + & 0.1665386113822915D0,-.421977345555443D-1, & + & -.96219715278770D-2, .72189432466630D-2, & + & -.11651675918591D-2, -.2152416741149D-3, & + & .1280502823882D-3, -.201348547807D-4, & + & -.12504934821D-5, .11330272320D-5, & + & -.2056338417D-6, .61160950D-8, & + & .50020075D-8, -.11812746D-8, & + & .1043427D-9, .77823D-11, & + & -.36968D-11, .51D-12, & + & -.206D-13, -.54D-14, .14D-14, .1D-15/ IF (X.EQ.INT(X)) THEN IF (X.GT.0.0D0) THEN @@ -3869,18 +4500,6 @@ SUBROUTINE GAMMADP(X,GA) ELSE Z=X ENDIF - DATA G/1.0D0,0.5772156649015329D0, & - & -0.6558780715202538D0, -0.420026350340952D-1, & - & 0.1665386113822915D0,-.421977345555443D-1, & - & -.96219715278770D-2, .72189432466630D-2, & - & -.11651675918591D-2, -.2152416741149D-3, & - & .1280502823882D-3, -.201348547807D-4, & - & -.12504934821D-5, .11330272320D-5, & - & -.2056338417D-6, .61160950D-8, & - & .50020075D-8, -.11812746D-8, & - & .1043427D-9, .77823D-11, & - & -.36968D-11, .51D-12, & - & -.206D-13, -.54D-14, .14D-14, .1D-15/ GR=G(26) DO K=25,1,-1 GR=GR*Z+G(K) @@ -3900,6 +4519,7 @@ END SUBROUTINE GAMMADP ! ! ! ##################################################################### + Function delbk(bb,nu,mu,k) ! ! Purpose: Caluculates collection coefficients following Siefert (2006) @@ -3955,6 +4575,7 @@ END Function delbk ! ! ##################################################################### ! Equation (91) in Seifert and Beheng (2006) ("a" collecting "b") + Function delabk(ba,bb,nua,nub,mua,mub,k) implicit none @@ -3973,7 +4594,9 @@ Function delabk(ba,bb,nua,nub,mua,mub,k) del = tmp - dgam*i IF ( i+1 > ngm0 ) THEN write(0,*) 'delabk: i+1 > ngm0!!!!',i,ngm0,nua,mua,tmp + STOP + ENDIF g1pnua = gmoi(i) + (gmoi(i+1) - gmoi(i))*del*dgami ! write(91,*) 'delabk: g1pnua,gamma = ',g1pnua,Gamma_sp((1. + nua)/mua) @@ -4014,11 +4637,14 @@ Function delabk(ba,bb,nua,nub,mua,mub,k) END Function delabk + + ! ##################################################################### ! ! ! ##################################################################### + REAL FUNCTION cnudiag(ccw) ! function to diagnose cloud drop DSD shape parameter (cnu) based on Chandrakar et al. 2016 (PNAS) data @@ -4071,6 +4697,8 @@ REAL FUNCTION cnudiag(ccw) RETURN END FUNCTION cnudiag + + ! ##################################################################### ! ! ##################################################################### @@ -4089,9 +4717,11 @@ end subroutine cld_cpu ! !-------------------------------------------------------------------------- ! + ! ####################################################################### ! HAILMAXD - calculated maximum expected hail size ! ####################################################################### + subroutine hailmaxd(dtp,nx,ny,nz,an,na,nor,norz,alpha2d,dn, & & hailmax1d,hailmaxk1,jslab ) ! @@ -4320,6 +4950,7 @@ subroutine hailmaxd(dtp,nx,ny,nz,an,na,nor,norz,alpha2d,dn, & END SUBROUTINE HAILMAXD ! ####################################################################### ! ####################################################################### + subroutine sediment1d(dtp,nx,ny,nz,an,na,nor,norz,xfall,dn,dz3d,dz3dinv, & & t0,t7,infdo,jslab,its,jts, & & timesed1,timesed2,timesed3,zmaxsed,timesetvt) ! used for timing @@ -4332,6 +4963,7 @@ subroutine sediment1d(dtp,nx,ny,nz,an,na,nor,norz,xfall,dn,dz3d,dz3dinv, & ! implicit none + integer nx,ny,nz,nor,norz,ngt,jgs,na,ia integer id ! =1 use density, =0 no density integer :: its,jts ! SW point of local tile @@ -4443,10 +5075,12 @@ subroutine sediment1d(dtp,nx,ny,nz,an,na,nor,norz,xfall,dn,dz3d,dz3dinv, & jgs = jy + ! ! zero the precip flux arrays (2d) ! + xvt(:,:,:,:) = 0.0 if ( ndebug .gt. 0 ) write(0,*) 'dbg = 3a' @@ -4486,6 +5120,7 @@ subroutine sediment1d(dtp,nx,ny,nz,an,na,nor,norz,xfall,dn,dz3d,dz3dinv, & + if (ndebug .gt. 0 ) write(0,*) 'dbg = 3a2' ! loop over columns @@ -4493,6 +5128,7 @@ subroutine sediment1d(dtp,nx,ny,nz,an,na,nor,norz,xfall,dn,dz3d,dz3dinv, & dummy = 0.d0 + call ziegfall1d(nx,ny,nz,nor,norz,na,dtp,jgs,ix, & & xvt, rhovtzx, & @@ -4503,9 +5139,11 @@ subroutine sediment1d(dtp,nx,ny,nz,an,na,nor,norz,xfall,dn,dz3d,dz3dinv, & & rho0,temcg,temg,rhovt,cwnc,cinc,fadvisc,cwdia,cipmas,cnina,cimas, & & cnostmp, & & infdo,0 & + & ) + ! loop over each species and do sedimentation for all moments DO il = lc,lhab IF ( ido(il) == 0 ) CYCLE @@ -4516,6 +5154,7 @@ subroutine sediment1d(dtp,nx,ny,nz,an,na,nor,norz,xfall,dn,dz3d,dz3dinv, & ! phi = 0 + vtmax = 0.0 do kz = kzb,kze @@ -4540,6 +5179,7 @@ subroutine sediment1d(dtp,nx,ny,nz,an,na,nor,norz,xfall,dn,dz3d,dz3dinv, & ! ENDIF ENDDO + IF ( vtmax == 0.0 ) CYCLE @@ -4566,6 +5206,7 @@ subroutine sediment1d(dtp,nx,ny,nz,an,na,nor,norz,xfall,dn,dz3d,dz3dinv, & dtfrac = dtptmp/dtp + DO n = 1,ndfall IF ( do_accurate_sedimentation .and. n .ge. 2 .and. ( n == interval_sedi_vt*(n/interval_sedi_vt) ) ) THEN @@ -4575,6 +5216,7 @@ subroutine sediment1d(dtp,nx,ny,nz,an,na,nor,norz,xfall,dn,dz3d,dz3dinv, & dummy = 0.d0 + xvt(kzb:kze,ix,1:3,il) = 0.0 ! reset to zero because routine will only compute points with q > qmin call ziegfall1d(nx,ny,nz,nor,norz,na,dtp,jgs,ix, & @@ -4598,15 +5240,14 @@ subroutine sediment1d(dtp,nx,ny,nz,an,na,nor,norz,xfall,dn,dz3d,dz3dinv, & + ENDIF ! (n .ge. 2) - IF ( il >= lr .and. ( infall .eq. 3 .or. infall .eq. 4 ) .and. ln(il) > 0 ) THEN - IF ( (il .eq. lr .and. irfall .eq. infall .and. lzr < 1) .or. & - (il .ge. lh .and. lz(il) .lt. 1 ) .or. (il == ls .and. isfall == infall ) ) THEN + + IF ( il >= lr .and. ( linfall(il) .eq. 3 .or. linfall(il) .eq. 4 ) .and. ln(il) > 0 ) THEN call calczgr1d(nx,ny,nz,nor,na,an,ixe,kze, & & z,db1,jgs,ipconc, dnu(il), il, ln(il), qxmin(il), xvmn(il), xvmx(il), lvol(il), xdn0(il), ix ) - ENDIF ENDIF if (ndebug .gt. 0 ) write(0,*) 'dbg = 1b' @@ -4617,6 +5258,7 @@ subroutine sediment1d(dtp,nx,ny,nz,an,na,nor,norz,xfall,dn,dz3d,dz3dinv, & & an,db1,il,1,xfall,dtz1,ix) + if (ndebug .gt. 0 ) write(0,*) 'dbg = 3c' ! volume @@ -4628,6 +5270,7 @@ subroutine sediment1d(dtp,nx,ny,nz,an,na,nor,norz,xfall,dn,dz3d,dz3dinv, & ENDIF ENDIF + ! reflectivity IF ( ipconc .ge. 6 ) THEN @@ -4637,40 +5280,32 @@ subroutine sediment1d(dtp,nx,ny,nz,an,na,nor,norz,xfall,dn,dz3d,dz3dinv, & ENDIF ENDIF + if (ndebug .gt. 0 ) write(0,*) 'dbg = 3d' IF ( ipconc .gt. 0 ) THEN !{ IF ( ipconc .ge. ipc(il) ) THEN - IF ( ( infall .ge. 2 .or. (infall .eq. 0 .and. il .lt. lh) ) .and. lz(il) .lt. 1) THEN !{ + IF ( ( linfall(il) .ge. 2 ) .and. lz(il) .lt. 1) THEN !{ ! ! load number conc. into tmpn to do fallout by mass-weighted mean fall speed ! to put a lower bound on number conc. ! - IF ( ( infall .eq. 3 .or. infall .eq. 4 ) .and. ( (il == ls .and. isfall .eq. infall ) & - & .or. il .eq. lh .or. il .eq. lhl .or. il == lf .or. & - & ( il .eq. lr .and. irfall .eq. infall) ) ) THEN - - ! set up for method I+II + IF ( linfall(il) == 3 .or. linfall(il) == 4 ) THEN + ! set up for method I or I+II DO kz = kzb,kze -! DO ix = ixb,ixe tmpn2(ix,jy,kz) = z(ix,kz,il) -! ENDDO ENDDO DO kz = kzb,kze -! DO ix = ixb,ixe tmpn(ix,jy,kz) = an(ix,jy,kz,ln(il)) -! ENDDO ENDDO ELSE ! set up for method II only DO kz = kzb,kze -! DO ix = ixb,ixe tmpn(ix,jy,kz) = an(ix,jy,kz,ln(il)) -! ENDDO ENDDO ENDIF @@ -4681,17 +5316,14 @@ subroutine sediment1d(dtp,nx,ny,nz,an,na,nor,norz,xfall,dn,dz3d,dz3dinv, & if (ndebug .gt. 0 ) write(0,*) 'dbg = 3f' in = 2 - IF ( infall .eq. 1 ) in = 1 + IF ( linfall(il) .eq. 1 ) in = 1 call fallout1d(nx,ny,nz,nor,na,dtptmp,dtfrac,jgs,xvt(1,1,in,il), & & an,db1,ln(il),0,xfall,dtz1,ix) - IF ( lz(il) .lt. 1 ) THEN ! if not 3-moment, run one of the correction schemes - IF ( (infall .ge. 2 .or. infall .eq. 3) .and. .not. (infall .eq. 0 .and. il .ge. lh) & - & .and. ( il .eq. lr .or. (il .ge. li .and. il .le. lhab) )) THEN -! : .or. il .eq. lhl )) THEN - + IF ( lz(il) .lt. 1 ) THEN ! { if not 3-moment, run one of the correction schemes + IF ( linfall(il) >= 2 ) THEN xfall0(:,jgs) = 0.0 IF ( ( infall .eq. 3 .or. infall .eq. 4 ) .and. & @@ -4706,42 +5338,38 @@ subroutine sediment1d(dtp,nx,ny,nz,an,na,nor,norz,xfall,dn,dz3d,dz3dinv, & & tmpn,db1,1,0,xfall0,dtz1,ix) ENDIF - IF ( ( infall .eq. 3 .or. infall .eq. 4 ) .and. ( (il .eq. lr .and. irfall .eq. infall) & - & .or. il .ge. lh .or. (il == ls .and. isfall .eq. infall ) ) ) THEN -! "Method I" - dbz correction - + IF ( linfall(il) == 3 .or. linfall(il) == 4 ) THEN + ! "Method I" - dbz correction + ! Uses input tmpn2 (temp. Z-moment) to determine if new N and q values in an(:,:,:,ln(il)) + ! cause an increase in reflectivity moment. If so, either use N from mass-wgt Vt (tmpn) to replace + ! new N (infall=3; I) or use smaller N from tmpn or calculated from q and temporary Z (infall=4; I+II) + ! Uses 'z' array to check if new reflectivity is greater than pre-sedimentation reflectivity call calcnfromz1d(nx,ny,nz,nor,na,an,tmpn2,ixe,kze, & & z,db1,jgs,ipconc, dnu(il), il, ln(il), qxmin(il), xvmn(il), xvmx(il),tmpn, & & lvol(il), xdn0(il), infall, ix) - ELSEIF ( infall .eq. 5 .and. il .ge. lh .or. ( il == lr .and. irfall == 5 ) ) THEN + ELSEIF ( linfall(il) .eq. 5 .and. il .ge. lh .or. ( il == lr .and. irfall == 5 ) ) THEN DO kz = kzb,kze -! DO ix = ixb,ixe an(ix,jgs,kz,ln(il)) = Max( an(ix,jgs,kz,ln(il)), 0.5* ( an(ix,jgs,kz,ln(il)) + tmpn(ix,jy,kz) )) - -! ENDDO ENDDO ELSEIF ( .not. (il .eq. lr .and. irfall .eq. 0) .and. .not. (il .eq. ls .and. isfall .eq. 0) ) THEN ! "Method II" M-wgt N-fallout correction DO kz = kzb,kze -! DO ix = ixb,ixe - an(ix,jgs,kz,ln(il)) = Max( an(ix,jgs,kz,ln(il)), tmpn(ix,jy,kz) ) - -! ENDDO ENDDO - ENDIF - ENDIF ! lz(il) .lt. 1 + ENDIF !} + ENDIF - ENDIF - ENDIF + ENDIF !} lz(il) .lt. 1 + ENDIF ! ipconc > ipc - ENDIF !} + ENDIF !} (ipconc > 0) + ENDDO ! n=1,ndfall @@ -4750,6 +5378,7 @@ subroutine sediment1d(dtp,nx,ny,nz,an,na,nor,norz,xfall,dn,dz3d,dz3dinv, & ENDDO ! ix + deallocate( db1,dtz1,dz2dinv,db1inv,rhovtzx ) deallocate( xfall0, xvt, tmpn ) deallocate( tmpn2, z) @@ -4788,6 +5417,7 @@ END SUBROUTINE SEDIMENT1D ! !-------------------------------------------------------------------------- ! + subroutine fallout1d(nx,ny,nz,nor,na,dtp,dtfrac,jgs,vt, & & a,db1,ia,id,xfall,dtz1,ixcol) ! @@ -4898,6 +5528,7 @@ END SUBROUTINE FALLOUT1D ! ############################################################################## ! ############################################################################## + subroutine calczgr1d(nx,ny,nz,nor,na,a,ixe,kze, & & z,db,jgs,ipconc, alpha, l,ln, qmin, xvmn,xvmx, lvol, rho_qx, ixcol) @@ -4924,7 +5555,7 @@ subroutine calczgr1d(nx,ny,nz,nor,na,a,ixe,kze, & integer ix,jy,kz - real vr,qr,nrx,rd,xv,g1,zx,chw,xdn,ynu + real vr,qr,nrx,rd,xv,g1,zx,chw,xdn,ynu,xvbarmax jy = jgs @@ -4957,11 +5588,23 @@ subroutine calczgr1d(nx,ny,nz,nor,na,a,ixe,kze, & xv = db(ix,kz)*a(ix,jy,kz,l)/(xdn*a(ix,jy,kz,ln)) chw = a(ix,jy,kz,ln) - IF ( xv .lt. xvmn .or. xv .gt. xvmx ) THEN - xv = Min( xvmx, Max( xvmn,xv ) ) + IF ( imaxdiaopt == 1 .or. l /= lr ) THEN + xvbarmax = xvmx + ELSEIF ( imaxdiaopt == 2 ) THEN ! test against maximum mass diameter + xvbarmax = xvmx /((3. + alpha)**3/((3. + alpha)*(2. + alpha)*(1. + alpha))) + ELSEIF ( imaxdiaopt == 3 ) THEN ! test against mass-weighted diameter + xvbarmax = xvmx /((4. + alpha)**3/((3. + alpha)*(2. + alpha)*(1. + alpha))) + ELSE + xvbarmax = xvmx + ENDIF + + IF ( xv .lt. xvmn .or. xv .gt. xvbarmax ) THEN + xv = Min( xvbarmax, Max( xvmn,xv ) ) chw = db(ix,kz)*a(ix,jy,kz,l)/(xv*xdn) + a(ix,jy,kz,ln) = chw ENDIF + g1 = (6.0 + alpha)*(5.0 + alpha)*(4.0 + alpha)/ & & ((3.0 + alpha)*(2.0 + alpha)*(1.0 + alpha)) zx = g1*db(ix,kz)**2*(a(ix,jy,kz,l))*a(ix,jy,kz,l)/chw @@ -5020,6 +5663,7 @@ END subroutine calczgr1d ! Calculation is in a slab (constant jgs) ! + subroutine calcnfromz1d(nx,ny,nz,nor,na,a,t0,ixe,kze, & & z0,db,jgs,ipconc, alpha, l,ln, qmin, xvmn,xvmx,t1, & & lvol, rho_qx, infall, ixcol) @@ -5053,14 +5697,8 @@ subroutine calcnfromz1d(nx,ny,nz,nor,na,a,t0,ixe,kze, & double precision vr,qr,nrx,rd,g1,zx,chw,z,znew,zt,zxt real xv,xdn integer :: ndbz, nmwgt, nnwgt, nwlessthanz - - ndbz = 0 - nmwgt = 0 - nnwgt = 0 - nwlessthanz = 0 - - + jy = jgs ix = ixcol @@ -5101,42 +5739,19 @@ subroutine calcnfromz1d(nx,ny,nz,nor,na,a,t0,ixe,kze, & IF ( (z .gt. t0(ix,jy,kz) .and. z .gt. 0.0 .and. & - & t0(ix,jy,kz) .gt. z0(ix,kz,l) )) THEN !{ + & t0(ix,jy,kz) .gt. 0.0 )) THEN !{ ! (( +! & t0(ix,jy,kz) .gt. z0(ix,kz,l) )) THEN zx = t0(ix,jy,kz)/((6./(pi*1000.))**2) - + ! nrx is number diagnosed from sedimented Z nrx = g1*db(ix,kz)**2*( a(ix,jy,kz,l))*a(ix,jy,kz,l)/zx IF ( infall .eq. 3 ) THEN - IF ( nrx .gt. a(ix,jy,kz,ln) ) THEN - ndbz = ndbz + 1 - IF ( t1(ix,jy,kz) .lt. ndbz ) nwlessthanz = nwlessthanz + 1 - ELSE - nnwgt = nnwgt + 1 - ENDIF a(ix,jy,kz,ln) = Max( real(nrx), a(ix,jy,kz,ln) ) - ELSE - IF ( nrx .gt. a(ix,jy,kz,ln) .and. t1(ix,jy,kz) .gt. a(ix,jy,kz,ln) ) THEN - IF ( nrx .lt. t1(ix,jy,kz) ) THEN - ndbz = ndbz + 1 - ELSE - nmwgt = nmwgt + 1 - IF ( t1(ix,jy,kz) .lt. ndbz ) nwlessthanz = nwlessthanz + 1 - ENDIF - ELSE - nnwgt = nnwgt + 1 - ENDIF - + ELSE ! infall = 4 a(ix,jy,kz,ln) = Max(Min( real(nrx), t1(ix,jy,kz) ), a(ix,jy,kz,ln) ) ENDIF ELSE ! } { - IF ( t1(ix,jy,kz) .gt. 0 .and. a(ix,jy,kz,ln) .gt. 0 ) THEN - IF ( t1(ix,jy,kz) .gt. a(ix,jy,kz,ln) ) THEN - nmwgt = nmwgt + 1 - ELSE - nnwgt = nnwgt + 1 - ENDIF - ENDIF a(ix,jy,kz,ln) = Max(t1(ix,jy,kz), a(ix,jy,kz,ln) ) nrx = a(ix,jy,kz,ln) @@ -5146,13 +5761,7 @@ subroutine calcnfromz1d(nx,ny,nz,nor,na,a,t0,ixe,kze, & ! } ELSE ! { - IF ( t1(ix,jy,kz) .gt. 0 .and. a(ix,jy,kz,ln) .gt. 0 ) THEN - IF ( t1(ix,jy,kz) .gt. a(ix,jy,kz,ln) ) THEN - nmwgt = nmwgt + 1 - ELSE - nnwgt = nnwgt + 1 - ENDIF - ENDIF + ENDIF! } ENDDO @@ -5203,6 +5812,7 @@ subroutine calcnfromz1d(nx,ny,nz,nor,na,a,t0,ixe,kze, & END subroutine calcnfromz1d + ! ############################################################################## ! ############################################################################## ! @@ -5213,10 +5823,11 @@ END subroutine calcnfromz1d ! ! 10.27.2015: Added hail calculation ! + subroutine calcnfromq(nx,ny,nz,an,na,nor,norz,dn, & & qcw,qci,qsw,qrw,qhw,qhl, & & ccw,cci,csw,crw,chw,chl, & - & cccn,cccna, vhw,vhl,qv,spechum, invertccn_flag, cwmasin ) + & cccn,cccna, vhw,vhl,qv,spechum, invertccn_flag, cwmasin, sizecheck_flag ) @@ -5231,13 +5842,12 @@ subroutine calcnfromq(nx,ny,nz,an,na,nor,norz,dn, & real, optional, dimension(nx,nz), intent(inout) :: qcw,qci,qsw,qrw,qhw,qhl, & ccw,cci,csw,crw,chw,chl, & cccn,cccna,vhw,vhl,qv, spechum - logical, optional, intent(in) :: invertccn_flag + logical, optional, intent(in) :: invertccn_flag, sizecheck_flag real, optional :: cwmasin integer ixe,kze real alpha real qmin - real xvmn,xvmx integer ipconc integer lvol ! index for volume integer infall @@ -5257,10 +5867,10 @@ subroutine calcnfromq(nx,ny,nz,an,na,nor,norz,dn, & real, parameter :: xgms=xdnh*0.523599*(300.e-6)**3 ! mks (300 micron diam sphere approx) real, parameter :: cwmas09 = 1000.*0.523599*(2.*9.e-6)**3 ! mass of 9-micron radius droplet - real xv,xdn,cwmasinv + real xv,xvmax,xdn,cwmasinv,hwdn integer :: ndbz, nmwgt, nnwgt, nwlessthanz double precision :: mixconv, mixconvqv, qsmax,qsmax2,qsmax3,qsmax4 - logical :: invertccn_local + logical :: invertccn_local, sizecheck_flag_local ! ------------------------------------------------------------------ @@ -5269,7 +5879,13 @@ subroutine calcnfromq(nx,ny,nz,an,na,nor,norz,dn, & ELSE invertccn_local = .false. ENDIF - + + IF ( present( sizecheck_flag ) ) THEN + sizecheck_flag_local = sizecheck_flag + ELSE + sizecheck_flag_local = .false. + ENDIF + IF ( present( cwmasin ) ) THEN cwmasinv = 1.0/cwmasin ELSE @@ -5399,9 +6015,24 @@ subroutine calcnfromq(nx,ny,nz,an,na,nor,norz,dn, & an(ix,jy,kz,lv) = an(ix,jy,kz,lv) + an(ix,jy,kz,lr) an(ix,jy,kz,lnr) = 0.0 an(ix,jy,kz,lr) = 0.0 + ELSEIF ( sizecheck_flag_local ) THEN + ! check size + xv = dn(ix,kz)*an(ix,jy,kz,lr)/(rho_qr*an(ix,jy,kz,lnr)) + IF ( imaxdiaopt == 3 .and. lzr <= 0 ) THEN + xvmax = xvmx(lr)/((4. + alphar)**3/((3. + alphar)*(2. + alphar)*(1. + alphar))) + ELSE + xvmax = xvmx(lr) + ENDIF + IF ( xvmn(lr) > xv ) THEN + an(ix,jy,kz,lnr) = dn(ix,kz)*an(ix,jy,kz,lr)/(rho_qr*xvmn(lr)) + ELSEIF ( xv > xvmax ) THEN + an(ix,jy,kz,lnr) = dn(ix,kz)*an(ix,jy,kz,lr)/(rho_qr*xvmax) + ENDIF + ENDIF ENDIF + IF ( lzr > 1 ) THEN ! set reflectivity moment IF ( an(ix,jy,kz,lr) > qxmin_init(lr) .and. an(ix,jy,kz,lzr) < zxmin .and. & an(ix,jy,kz,lnr) > cxmin ) THEN @@ -5411,6 +6042,7 @@ subroutine calcnfromq(nx,ny,nz,an,na,nor,norz,dn, & ENDIF ENDIF + ! snow IF ( lns > 1 ) THEN IF ( an(ix,jy,kz,lns) <= 0.1*cxmin .and. an(ix,jy,kz,ls) > qxmin_init(ls) ) THEN @@ -5438,9 +6070,14 @@ subroutine calcnfromq(nx,ny,nz,an,na,nor,norz,dn, & IF ( lnh > 1 ) THEN IF ( an(ix,jy,kz,lnh) <= 0.1*cxmin .and. an(ix,jy,kz,lh) > qxmin_init(lh) ) THEN + xdn = xdnh IF ( lvh > 1 ) THEN IF ( an(ix,jy,kz,lvh) <= 0.0 ) THEN an(ix,jy,kz,lvh) = an(ix,jy,kz,lh)/xdnh + ELSE + ! check density limits + xdn = Max(xdnmn(lh), Min(xdnmx(lh), dn(ix,kz)*an(ix,jy,kz,lh)/an(ix,jy,kz,lvh) ) ) + an(ix,jy,kz,lvh) = an(ix,jy,kz,lh)/xdn ENDIF ENDIF @@ -5469,10 +6106,34 @@ subroutine calcnfromq(nx,ny,nz,an,na,nor,norz,dn, & an(ix,jy,kz,lv) = an(ix,jy,kz,lv) + an(ix,jy,kz,lh) an(ix,jy,kz,lh) = 0.0 - + ELSEIF ( sizecheck_flag_local ) THEN + ! check size limits + xdn = xdnh + IF ( lvh > 1 ) THEN + IF ( an(ix,jy,kz,lvh) <= 0.0 ) THEN + an(ix,jy,kz,lvh) = an(ix,jy,kz,lh)/xdnh + ELSE + ! check density limits + xdn = Max(xdnmn(lh), Min(xdnmx(lh), dn(ix,kz)*an(ix,jy,kz,lh)/an(ix,jy,kz,lvh) ) ) + an(ix,jy,kz,lvh) = an(ix,jy,kz,lh)/xdn + ENDIF + ENDIF + + ! check volume + xv = dn(ix,kz)*an(ix,jy,kz,lh)/(xdn*an(ix,jy,kz,lnh)) +! IF ( lzh <= 0 ) THEN +! xv = xv/((4. + alphah)**3/((3. + alphah)*(2. + alphah)*(1. + alphah))) +! ENDIF + IF ( xvmn(lh) > xv ) THEN + an(ix,jy,kz,lnh) = dn(ix,kz)*an(ix,jy,kz,lh)/(rho_qr*xvmn(lh)) + ELSEIF ( xv > xvmx(lh) ) THEN + an(ix,jy,kz,lnh) = dn(ix,kz)*an(ix,jy,kz,lh)/(rho_qr*xvmx(lh)) + ENDIF + ENDIF ENDIF + IF ( lzh > 1 ) THEN ! set reflectivity moment IF ( an(ix,jy,kz,lh) > qxmin_init(lh) .and. an(ix,jy,kz,lzh) < zxmin .and. & an(ix,jy,kz,lnh) > cxmin ) THEN @@ -5482,6 +6143,7 @@ subroutine calcnfromq(nx,ny,nz,an,na,nor,norz,dn, & ENDIF ENDIF + ! hail IF ( lnhl > 1 .and. lhl > 1 ) THEN @@ -5508,9 +6170,33 @@ subroutine calcnfromq(nx,ny,nz,an,na,nor,norz,dn, & an(ix,jy,kz,lv) = an(ix,jy,kz,lv) + an(ix,jy,kz,lhl) an(ix,jy,kz,lhl) = 0.0 + ELSEIF ( sizecheck_flag_local ) THEN + ! check size limits + xdn = xdnhl + IF ( lvh > 1 ) THEN + IF ( an(ix,jy,kz,lvhl) <= 0.0 ) THEN + an(ix,jy,kz,lvhl) = an(ix,jy,kz,lhl)/xdnhl + ELSE + ! check density limits + xdn = Max(xdnmn(lhl), Min(xdnmx(lhl), dn(ix,kz)*an(ix,jy,kz,lhl)/an(ix,jy,kz,lvhl) ) ) + an(ix,jy,kz,lvhl) = an(ix,jy,kz,lhl)/xdn + ENDIF + ENDIF + + ! check volume + xv = dn(ix,kz)*an(ix,jy,kz,lhl)/(xdn*an(ix,jy,kz,lnhl)) +! IF ( lzhl <= 0 ) THEN +! xv = xv/((4. + alphahl)**3/((3. + alphahl)*(2. + alphahl)*(1. + alphahl))) +! ENDIF + IF ( xvmn(lhl) > xv ) THEN + an(ix,jy,kz,lnhl) = dn(ix,kz)*an(ix,jy,kz,lhl)/(rho_qr*xvmn(lhl)) + ELSEIF ( xv > xvmx(lhl) ) THEN + an(ix,jy,kz,lnhl) = dn(ix,kz)*an(ix,jy,kz,lhl)/(rho_qr*xvmx(lhl)) + ENDIF ENDIF ENDIF + IF ( lzhl > 1 ) THEN ! set reflectivity moment IF ( an(ix,jy,kz,lhl) > qxmin_init(lhl) .and. an(ix,jy,kz,lzhl) < zxmin .and. & an(ix,jy,kz,lnhl) > cxmin ) THEN @@ -5519,6 +6205,7 @@ subroutine calcnfromq(nx,ny,nz,an,na,nor,norz,dn, & an(ix,jy,kz,lzhl) = 36.*g1hl*dn(ix,kz)**2*q**2/(pi**2*xdnhl**2*nrx) ! *dninv ENDIF ENDIF + ! ENDIF @@ -5584,6 +6271,7 @@ END subroutine calcnfromq ! ! 10.27.2015: Added hail calculation ! + subroutine calcnfromcuten(nx,ny,nz,an,anold,na,nor,norz,dn) @@ -5599,7 +6287,6 @@ subroutine calcnfromcuten(nx,ny,nz,an,anold,na,nor,norz,dn) integer ixe,kze real alpha real qmin - real xvmn,xvmx integer ipconc integer lvol ! index for volume integer infall @@ -5687,9 +6374,11 @@ subroutine calcnfromcuten(nx,ny,nz,an,anold,na,nor,norz,dn) anold(ix,jy,kz,lnr) = anold(ix,jy,kz,lnr) + an(ix,jy,kz,lr)/xmass ENDIF + IF ( lzr > 1 ) THEN ! set reflectivity moment an(ix,jy,kz,lzr) = 36.*g1r*dn(ix,kz)**2*q**2/(pi**2*xdnr**2*nrx) ! *dninv ENDIF + ENDIF ENDIF @@ -5740,9 +6429,11 @@ subroutine calcnfromcuten(nx,ny,nz,an,anold,na,nor,norz,dn) ! ! an(ix,jy,kz,lnh) = nrx ! *dninv ! convert to number mixing ratio ! + ! IF ( lzh > 1 ) THEN ! set reflectivity moment ! an(ix,jy,kz,lzh) = 36.*g1h*dn(ix,kz)**2*q**2/(pi**2*xdnh**2*nrx) ! *dninv ! ENDIF + ! ENDIF ! ENDIF ! @@ -5766,9 +6457,11 @@ subroutine calcnfromcuten(nx,ny,nz,an,anold,na,nor,norz,dn) ! ! an(ix,jy,kz,lnhl) = nrx ! *dninv ! convert to number mixing ratio ! + ! IF ( lzhl > 1 ) THEN ! set reflectivity moment ! an(ix,jy,kz,lzhl) = 36.*g1hl*dn(ix,kz)**2*q**2/(pi**2*xdnhl**2*nrx) ! *dninv ! ENDIF + ! ENDIF ! ENDIF @@ -5782,6 +6475,7 @@ END subroutine calcnfromcuten ! ##################################################################### ! ##################################################################### + SUBROUTINE calc_eff_radius & & (nx,ny,nz,na,jyslab & & ,nor,norz & @@ -5854,6 +6548,9 @@ SUBROUTINE calc_eff_radius & double precision :: numh, numhl,denomh,denomhl logical :: flag_t4, flag_t5, flag_t6 + + real, parameter :: qmin = 1.e-8 + real, parameter :: volmin = 1.e-30 ! ------------------------------------------------------------------------------- @@ -5968,7 +6665,7 @@ SUBROUTINE calc_eff_radius & ENDIF IF ( present( t4 ) .and.( ( present(qrw) .and. present(crw) ) .or. flag_t4 ) ) THEN - IF ( qx(mgs,lr) > Max(1.e-8,qxmin(lr)) .and. cx(mgs,lr) > cxmin ) THEN + IF ( qx(mgs,lr) > Max(qmin,qxmin(lr)) .and. cx(mgs,lr) > cxmin ) THEN IF ( imurain == 1 ) THEN ! gamma-diameter ! Lambda for rain lam_r = factor_r *((xdn0(lr)*cx(mgs,lr))/(qx(mgs,lr)*rho0(mgs)))**(1./3.) @@ -5987,11 +6684,11 @@ SUBROUTINE calc_eff_radius & IF ( lhl < 1 .or. flag_t6 ) THEN ! graupel only - IF ( qx(mgs,lh) > Max(1.e-8,qxmin(lh)) ) THEN + IF ( qx(mgs,lh) > Max(qmin,qxmin(lh)) ) THEN ! Lambda for graupel hwdn = xdn0(lh) IF ( lvh > 1 ) THEN ! variable density - IF ( an(ix,jy,kz,lvh) > 1.e-30 ) THEN + IF ( an(ix,jy,kz,lvh) > volmin ) THEN hwdn = rho0(mgs)*qx(mgs,lh)/an(ix,jy,kz,lvh) ENDIF ENDIF @@ -6002,11 +6699,11 @@ SUBROUTINE calc_eff_radius & ELSE ! have hail, too, but do not have t6 array - IF ( qx(mgs,lh) > Max(1.e-8,qxmin(lh)) .and. qx(mgs,lhl) < Max(1.e-8,qxmin(lhl)) ) THEN + IF ( qx(mgs,lh) > Max(qmin,qxmin(lh)) .and. qx(mgs,lhl) < Max(qmin,qxmin(lhl)) ) THEN ! Lambda for graupel hwdn = xdn0(lh) IF ( lvh > 1 ) THEN ! variable density - IF ( an(ix,jy,kz,lvh) > 1.e-30 ) THEN + IF ( an(ix,jy,kz,lvh) > volmin ) THEN hwdn = rho0(mgs)*qx(mgs,lh)/an(ix,jy,kz,lvh) ENDIF ENDIF @@ -6014,11 +6711,11 @@ SUBROUTINE calc_eff_radius & lam_h = factor_h *((hwdn*cx(mgs,lh))/(qx(mgs,lh)*rho0(mgs)))**(1./3.) t5(ix,jy,kz) = 0.5*(alphah+3.)/lam_h - ELSEIF ( qx(mgs,lh) < Max(1.e-8,qxmin(lh)) .and. qx(mgs,lhl) > Max(1.e-8,qxmin(lhl)) ) THEN + ELSEIF ( qx(mgs,lh) < Max(qmin,qxmin(lh)) .and. qx(mgs,lhl) > Max(qmin,qxmin(lhl)) ) THEN ! Lambda for hail hldn = xdn0(lhl) IF ( lvhl > 1 ) THEN ! variable density - IF ( an(ix,jy,kz,lvhl) > 1.e-30 ) THEN + IF ( an(ix,jy,kz,lvhl) > volmin ) THEN hldn = rho0(mgs)*qx(mgs,lhl)/an(ix,jy,kz,lvhl) ENDIF ENDIF @@ -6026,19 +6723,19 @@ SUBROUTINE calc_eff_radius & lam_hl = factor_hl *((hldn*cx(mgs,lhl))/(qx(mgs,lhl)*rho0(mgs)))**(1./3.) t5(ix,jy,kz) = 0.5*(alphahl+3.)/lam_hl - ELSEIF ( qx(mgs,lh) > Max(1.e-8,qxmin(lh)) .and. qx(mgs,lhl) > Max(1.e-8,qxmin(lhl)) ) THEN + ELSEIF ( qx(mgs,lh) > Max(qmin,qxmin(lh)) .and. qx(mgs,lhl) > Max(qmin,qxmin(lhl)) ) THEN ! r_eff graupel and hail combined hldn = xdn0(lhl) IF ( lvhl > 1 ) THEN ! variable density - IF ( an(ix,jy,kz,lvhl) > 1.e-30 ) THEN + IF ( an(ix,jy,kz,lvhl) > volmin ) THEN hldn = rho0(mgs)*qx(mgs,lhl)/an(ix,jy,kz,lvhl) ENDIF ENDIF hwdn = xdn0(lh) IF ( lvh > 1 ) THEN ! variable density - IF ( an(ix,jy,kz,lvh) > 1.e-30 ) THEN + IF ( an(ix,jy,kz,lvh) > volmin ) THEN hwdn = rho0(mgs)*qx(mgs,lh)/an(ix,jy,kz,lvh) ENDIF ENDIF @@ -6063,11 +6760,11 @@ SUBROUTINE calc_eff_radius & IF ( present(t6) .and. flag_t6 .and. lhl > 1 ) THEN - IF ( qx(mgs,lhl) > Max(1.e-8,qxmin(lhl)) ) THEN + IF ( qx(mgs,lhl) > Max(qmin,qxmin(lhl)) ) THEN ! Lambda for hail hldn = xdn0(lhl) IF ( lvhl > 1 ) THEN ! variable density - IF ( an(ix,jy,kz,lvhl) > 1.e-30 ) THEN + IF ( an(ix,jy,kz,lvhl) > volmin ) THEN hldn = rho0(mgs)*qx(mgs,lhl)/an(ix,jy,kz,lvhl) ENDIF ENDIF @@ -6087,14 +6784,17 @@ SUBROUTINE calc_eff_radius & END SUBROUTINE calc_eff_radius + ! ##################################################################### ! ##################################################################### + SUBROUTINE QVEXCESS(ngs,mgs,qwvp0,qv0,qcw1,pres,thetap0,theta0, & & qvex,pi0,tabqvs,nqsat,fqsat,cbw,fcqv1,felvcp,ss1,pk,ngscnt) !##################################################################### ! Purpose: find the amount of vapor that can be condensed to liquid +! No ice here !##################################################################### implicit none @@ -6170,6 +6870,7 @@ SUBROUTINE QVEXCESS(ngs,mgs,qwvp0,qv0,qcw1,pres,thetap0,theta0, & qvs(mgs) = pqs(mgs)*tabqvs(ltemq) ELSEIF ( iqvsopt == 1 ) THEN qvs(mgs) = rdorv*esbolton*tabqvs(ltemq)/(pres(mgs) - esbolton*tabqvs(ltemq)) + ENDIF qss(mgs) = (0.01*ss1 + 1.0)*qvs(mgs) @@ -6235,6 +6936,7 @@ SUBROUTINE QVEXCESS(ngs,mgs,qwvp0,qv0,qcw1,pres,thetap0,theta0, & qvs(mgs) = pqs(mgs)*tabqvs(ltemq) ELSEIF ( iqvsopt == 1 ) THEN qvs(mgs) = rdorv*esbolton*tabqvs(ltemq)/(pres(mgs) - esbolton*tabqvs(ltemq)) + ENDIF qcw(mgs) = max( 0.0, qcw(mgs) ) qwv(mgs) = max( 0.0, qvap(mgs)) @@ -6259,6 +6961,7 @@ END SUBROUTINE QVEXCESS ! ! ############################################################################## ! + SUBROUTINE setvtz(ngscnt,qx,qxmin,qxw,cx,rho0,rhovt,xdia,cno,cnostmp, & & xmas,vtxbar,xdn,xvmn0,xvmx0,xv,cdx,cdxgs, & & ipconc1,ndebug1,ngs,nz,igs,kgs,fadvisc, & @@ -7107,6 +7810,7 @@ SUBROUTINE setvtz(ngscnt,qx,qxmin,qxw,cx,rho0,rhovt,xdia,cno,cnostmp, & if ( qx(mgs,ls) .gt. qxmin(ls) ) then IF ( ipconc .ge. 4 ) THEN if ( mixedphase .and. qsvtmod ) then + else IF ( isnowfall == 1 ) THEN ! original (Zrnic et al. 1993) @@ -7280,6 +7984,7 @@ SUBROUTINE setvtz(ngscnt,qx,qxmin,qxw,cx,rho0,rhovt,xdia,cno,cnostmp, & vtxbar(mgs,lh,1) = (330.*gf4br/6.0)*(xdia(mgs,lh,1)**br)*rhovt(mgs) ENDIF + end if end do if ( ndebug1 .gt. 0 ) write(0,*) 'SETVTZ: Set hail vt' @@ -7374,6 +8079,7 @@ SUBROUTINE setvtz(ngscnt,qx,qxmin,qxw,cx,rho0,rhovt,xdia,cno,cnostmp, & ENDIF + end if end do if ( ndebug1 .gt. 0 ) write(0,*) 'SETVTZ: Set hail vt' @@ -7526,8 +8232,8 @@ SUBROUTINE setvtz(ngscnt,qx,qxmin,qxw,cx,rho0,rhovt,xdia,cno,cnostmp, & & (aax*(xdia(mgs,il,1) )**bbx * & & x)/y ! & Gamma(7.0 + alpha(mgs,il) + bbx)/Gamma(7. + alpha(mgs,il)) - IF ( .not. (vtxbar(mgs,il,1) > -1. .and. vtxbar(mgs,il,1) < 200. ) .or. & - .not. (vtxbar(mgs,il,3) > -1. .and. vtxbar(mgs,il,3) < 200. ) ) THEN + IF ( .not. (vtxbar(mgs,il,1) > -1. .and. vtxbar(mgs,il,1) < 250. ) .or. & + .not. (vtxbar(mgs,il,3) > -1. .and. vtxbar(mgs,il,3) < 250. ) ) THEN write(0,*) 'Setvtz: problem with vtxbar1/3: ',il,vtxbar(mgs,il,1),vtxbar(mgs,il,3),aax,bbx,x,y write(0,*) 'q, number, diam1,3(mm) = ', qx(mgs,il),cx(mgs,il),1000.*xdia(mgs,il,1),1000.*xdia(mgs,il,3) ! call commasmpi_abort() @@ -7557,6 +8263,7 @@ SUBROUTINE setvtz(ngscnt,qx,qxmin,qxw,cx,rho0,rhovt,xdia,cno,cnostmp, & ! & Gamma_sp(1.0 + dnu(il) + 0.6)/Gamma_sp(1. + dnu(il)) ENDIF ! } + ! IF ( infdo .ge. 2 ) THEN ! Z-weighted ! vtxbar(mgs,il,3) = rhovt(mgs)* & ! & (ax(il)*(1.0/xdia(mgs,il,1) )**(- bx(il))* & @@ -7643,6 +8350,7 @@ END SUBROUTINE setvtz ! subroutine to calculate fall speeds of hydrometeors ! + subroutine ziegfall1d(nx,ny,nz,nor,norz,na,dtp,jgs,ixcol, & & xvt, rhovtzx, & & an,dn,ipconc0,t0,t7,cwmasn,cwmasx, & @@ -7667,6 +8375,7 @@ subroutine ziegfall1d(nx,ny,nz,nor,norz,na,dtp,jgs,ixcol, & ! implicit none + integer ng1 parameter(ng1 = 1) @@ -7763,7 +8472,7 @@ subroutine ziegfall1d(nx,ny,nz,nor,norz,na,dtp,jgs,ixcol, & logical ldoliq - real chw, qr, z, rd, alp, z1, g1, vr, nrx, tmp + real chw, qr, z, rd, alp, z1, g1, vr, nrx, tmp, tmpc, tmpz real vtmax real xvbarmax @@ -7796,6 +8505,7 @@ subroutine ziegfall1d(nx,ny,nz,nor,norz,na,dtp,jgs,ixcol, & ! constants ! + ldoliq = .false. IF ( ls .gt. 1 ) THEN DO il = ls,lhab @@ -7855,13 +8565,12 @@ subroutine ziegfall1d(nx,ny,nz,nor,norz,na,dtp,jgs,ixcol, & ngscnt = 0 - do kz = nzmpb,nz + do kz = 1,nz do ix = ixcol,ixcol flag = .false. - DO il = l1,l2 - flag = flag .or. ( an(ix,jy,kz,il) .gt. qxmin(il) ) + flag = flag .or. ( an(ix,jy,kz,il) > 0.0 ) ENDDO if ( flag ) then @@ -7870,7 +8579,7 @@ subroutine ziegfall1d(nx,ny,nz,nor,norz,na,dtp,jgs,ixcol, & ngscnt = ngscnt + 1 igs(ngscnt) = ix kgs(ngscnt) = kz - if ( ngscnt .eq. ngs ) goto 1100 + if ( ngscnt .eq. nz ) goto 1100 end if end do !!ix nxmpb = 1 @@ -7886,6 +8595,7 @@ subroutine ziegfall1d(nx,ny,nz,nor,norz,na,dtp,jgs,ixcol, & ! + ! ! Reconstruct various quantities ! @@ -7896,11 +8606,11 @@ subroutine ziegfall1d(nx,ny,nz,nor,norz,na,dtp,jgs,ixcol, & temg(mgs) = t0(igs(mgs),jy,kgs(mgs)) temcg(mgs) = temg(mgs) - tfr - + ! end do ! -! only need fadvisc for +! only need fadvisc for droplets IF ( lc .gt. 1 .and. (ildo == 0 .or. ildo == lc ) ) then do mgs = 1,ngscnt fadvisc(mgs) = advisc0*(416.16/(temg(mgs)+120.0))* & @@ -7949,58 +8659,52 @@ subroutine ziegfall1d(nx,ny,nz,nor,norz,na,dtp,jgs,ixcol, & cx(mgs,li) = Max(an(igs(mgs),jy,kgs(mgs),lni), 0.0) end do end if + if ( ipconc .ge. 2 .and. lc .gt. 1 .and. (ildo == 0 .or. ildo == lc ) ) then do mgs = 1,ngscnt cx(mgs,lc) = Max(an(igs(mgs),jy,kgs(mgs),lnc), 0.0) -! cx(mgs,lc) = Min( ccwmx, cx(mgs,lc) ) end do end if + if ( ipconc .ge. 3 .and. lr .gt. 1 .and. (ildo == 0 .or. ildo == lr ) ) then do mgs = 1,ngscnt cx(mgs,lr) = Max(an(igs(mgs),jy,kgs(mgs),lnr), 0.0) -! IF ( qx(mgs,lr) .le. qxmin(lr) ) THEN -! ELSE -! cx(mgs,lr) = Max( 0.0, cx(mgs,lr) ) -! ENDIF end do end if + if ( ipconc .ge. 4 .and. ls .gt. 1 .and. (ildo == 0 .or. ildo == ls ) ) then do mgs = 1,ngscnt cx(mgs,ls) = Max(an(igs(mgs),jy,kgs(mgs),lns), 0.0) -! IF ( qx(mgs,ls) .le. qxmin(ls) ) THEN -! ELSE -! cx(mgs,ls) = Max( 0.0, cx(mgs,ls) ) -! ENDIF end do end if if ( ipconc .ge. 5 .and. lh .gt. 1 .and. (ildo == 0 .or. ildo == lh ) ) then do mgs = 1,ngscnt - cx(mgs,lh) = Max(an(igs(mgs),jy,kgs(mgs),lnh), 0.0) -! IF ( qx(mgs,lh) .le. qxmin(lh) ) THEN -! ELSE -! cx(mgs,lh) = Max( 0.0, cx(mgs,lh) ) -! ENDIF - end do ENDIF if ( ipconc .ge. 5 .and. lhl .gt. 1 .and. (ildo == 0 .or. ildo == lhl ) ) then do mgs = 1,ngscnt - cx(mgs,lhl) = Max(an(igs(mgs),jy,kgs(mgs),lnhl), 0.0) -! IF ( qx(mgs,lhl) .le. qxmin(lhl) ) THEN -! cx(mgs,lhl) = 0.0 -! ELSEIF ( cx(mgs,lhl) .eq. 0.0 .and. qx(mgs,lhl) .lt. 3.0*qxmin(lhl) ) THEN -! qx(mgs,lhl) = 0.0 -! ELSE -! cx(mgs,lhl) = Max( 0.0, cx(mgs,lhl) ) -! ENDIF - end do end if - + + ! Vaporize tiny values + DO il = l1,l2 + IF ( lz(il) < 1 .and. ln(il) > 1 ) THEN + do mgs = 1,ngscnt + IF ( cx(mgs,il) <= cxmin .or. qx(mgs,il) < qxmin(il) ) THEN + cx(mgs,il) = 0.0 + an(igs(mgs),jgs,kgs(mgs),lv) = an(igs(mgs),jgs,kgs(mgs),lv) + an(igs(mgs),jgs,kgs(mgs),il) + qx(mgs,il) = 0.0 + an(igs(mgs),jgs,kgs(mgs),il) = qx(mgs,il) + an(igs(mgs),jgs,kgs(mgs),ln(il)) = cx(mgs,il) + ENDIF + end do + ENDIF + ENDDO + do mgs = 1,ngscnt xdn(mgs,lc) = xdn0(lc) xdn(mgs,lr) = xdn0(lr) @@ -8078,6 +8782,7 @@ subroutine ziegfall1d(nx,ny,nz,nor,norz,na,dtp,jgs,ixcol, & ENDIF + ! ! Set 6th moments ! @@ -8100,10 +8805,13 @@ subroutine ziegfall1d(nx,ny,nz,nor,norz,na,dtp,jgs,ixcol, & ENDDO ENDIF + + + ! Find shape parameter rain @@ -8358,7 +9066,7 @@ subroutine ziegfall1d(nx,ny,nz,nor,norz,na,dtp,jgs,ixcol, & ! ENDIF ENDIF - IF ( zx(mgs,il) > 0.0 .and. cx(mgs,il) <= 0.0 ) THEN + IF ( zx(mgs,il) > zxmin .and. cx(mgs,il) <= cxmin ) THEN ! have mass and reflectivity but no concentration, so set concentration, using default alpha g1 = (6.0 + alpha(mgs,il))*(5.0 + alpha(mgs,il))*(4.0 + alpha(mgs,il))/ & & ((3.0 + alpha(mgs,il))*(2.0 + alpha(mgs,il))*(1.0 + alpha(mgs,il))) @@ -8367,6 +9075,18 @@ subroutine ziegfall1d(nx,ny,nz,nor,norz,na,dtp,jgs,ixcol, & cx(mgs,il) = g1*dn(igs(mgs),jy,kgs(mgs))**2*(6*qr)**2/(z*(pi*xdn(mgs,il))**2) an(igs(mgs),jgs,kgs(mgs),ln(il)) = cx(mgs,il) + IF ( cx(mgs,il) < cxmin ) THEN + ! if resulting concentration is too small, then zero out + cx(mgs,il) = 0.0 + zx(mgs,il) = 0.0 + an(igs(mgs),jgs,kgs(mgs),lv) = an(igs(mgs),jgs,kgs(mgs),lv) + an(igs(mgs),jgs,kgs(mgs),il) + + qx(mgs,il) = 0.0 + an(igs(mgs),jgs,kgs(mgs),il) = qx(mgs,il) + an(igs(mgs),jgs,kgs(mgs),ln(il)) = cx(mgs,il) + an(igs(mgs),jgs,kgs(mgs),lz(il)) = zx(mgs,il) + ENDIF + ELSEIF ( zx(mgs,il) <= zxmin .and. cx(mgs,il) > cxmin ) THEN ! have mass and concentration but no reflectivity, so set reflectivity, using default alpha g1 = (6.0 + alpha(mgs,il))*(5.0 + alpha(mgs,il))*(4.0 + alpha(mgs,il))/ & @@ -8428,7 +9148,7 @@ subroutine ziegfall1d(nx,ny,nz,nor,norz,na,dtp,jgs,ixcol, & ! check for artificial breakup (graupel/hail larger than allowed max size) - IF ( imaxdiaopt == 1 ) THEN + IF ( imaxdiaopt == 1 .or. il /= lr ) THEN xvbarmax = xvmx(il) ELSEIF ( imaxdiaopt == 2 ) THEN ! test against maximum mass diameter xvbarmax = xvmx(il) /((3. + alpha(mgs,il))**3/((3. + alpha(mgs,il))*(2. + alpha(mgs,il))*(1. + alpha(mgs,il)))) @@ -8444,7 +9164,16 @@ subroutine ziegfall1d(nx,ny,nz,nor,norz,na,dtp,jgs,ixcol, & IF ( tmp < cx(mgs,il) ) THEN ! breakup g1 = 36.*(6.0 + alpha(mgs,il))*(5.0 + alpha(mgs,il))*(4.0 + alpha(mgs,il))/ & & ((3.0 + alpha(mgs,il))*(2.0 + alpha(mgs,il))*(1.0 + alpha(mgs,il))*pi**2) - zx(mgs,il) = zx(mgs,il) + g1*(rho0(mgs)/xdn(mgs,il))**2*( (qx(mgs,il)/tmp)**2 * (tmp-cx(mgs,il)) ) + ! check if incoming zx is consistent + ! Z from incoming cx, qx, and alpha + tmpz = g1/(pi/6.*xdn(mgs,il))**2 * ((rho0(mgs)*qx(mgs,il))**2)/tmp + IF ( tmpz > zx(mgs,il) ) THEN + ! find cx that gives zx + tmpc = g1/(pi/6.*xdn(mgs,il))**2 * ((rho0(mgs)*qx(mgs,il))**2)/zx(mgs,il) + cx(mgs,il) = Max(cx(mgs,il), tmpc) + ENDIF + zx(mgs,il) = g1/(pi/6.*xdn(mgs,il))**2 * ((rho0(mgs)*qx(mgs,il))**2)/cx(mgs,il) +! zx(mgs,il) = zx(mgs,il) + g1*(rho0(mgs)/xdn(mgs,il))**2*( (qx(mgs,il)/tmp)**2 * (tmp-cx(mgs,il)) ) an(igs(mgs),jgs,kgs(mgs),lz(il)) = zx(mgs,il) chw = cx(mgs,il) @@ -8510,11 +9239,14 @@ subroutine ziegfall1d(nx,ny,nz,nor,norz,na,dtp,jgs,ixcol, & + + ! ! Set density ! if (ndebugzf .gt. 0 ) write(0,*) 'ZIEGFALL: call setvtz' ! + call setvtz(ngscnt,qx,qxmin,qxw,cx,rho0,rhovt,xdia,cno,cnostmp, & & xmas,vtxbar,xdn,xvmn,xvmx,xv,cdx,cdxgs, & @@ -8525,6 +9257,7 @@ subroutine ziegfall1d(nx,ny,nz,nor,norz,na,dtp,jgs,ixcol, & + ! ! put fall speeds into the x-z arrays ! @@ -8538,6 +9271,7 @@ subroutine ziegfall1d(nx,ny,nz,nor,norz,na,dtp,jgs,ixcol, & & ( vtxbar(mgs,il,1) .gt. vtxbar(mgs,il,3) .and. vtxbar(mgs,il,3) > 0.0) ) THEN + ! IF ( qx(mgs,il) > 1.e-4 .and. & ! & .not. ( il == lr .and. 1.e3*xdia(mgs,il,3) > 5.0 ) ) THEN ! write(0,*) 'infdo,mgs = ',infdo,lzr,mgs @@ -8551,6 +9285,7 @@ subroutine ziegfall1d(nx,ny,nz,nor,norz,na,dtp,jgs,ixcol, & ! write(0,*) 'alpha = ',alpha(mgs,il) ! ENDIF ! ENDIF + vtxbar(mgs,il,1) = Max( vtxbar(mgs,il,1), vtxbar(mgs,il,2) ) vtxbar(mgs,il,3) = Max( vtxbar(mgs,il,3), vtxbar(mgs,il,1) ) @@ -8561,6 +9296,7 @@ subroutine ziegfall1d(nx,ny,nz,nor,norz,na,dtp,jgs,ixcol, & IF ( vtxbar(mgs,il,1) .gt. vtmax .or. vtxbar(mgs,il,2) .gt. vtmax .or. & & vtxbar(mgs,il,3) .gt. vtmax ) THEN + ! IF ( ndebugzf >= 0 .and. 1.e3*qx(mgs,il) > 0.1 ) THEN ! write(0,*) 'infdo = ',infdo ! write(0,*) 'Problem with vtxbar for il at i,j,k = ',il,igs(mgs),jy,kgs(mgs) @@ -8573,6 +9309,7 @@ subroutine ziegfall1d(nx,ny,nz,nor,norz,na,dtp,jgs,ixcol, & ! write(0,*) 'alpha = ',alpha(mgs,il) ! ENDIF ! ENDIF + vtxbar(mgs,il,1) = Min(vtmax,vtxbar(mgs,il,1) ) vtxbar(mgs,il,2) = Min(vtmax,vtxbar(mgs,il,2) ) vtxbar(mgs,il,3) = Min(vtmax,vtxbar(mgs,il,3) ) @@ -8595,6 +9332,7 @@ subroutine ziegfall1d(nx,ny,nz,nor,norz,na,dtp,jgs,ixcol, & ENDDO + if (ndebugzf .gt. 0 ) write(0,*) 'ZIEGFALL: COPIED FALL SPEEDS' @@ -8625,6 +9363,7 @@ subroutine ziegfall1d(nx,ny,nz,nor,norz,na,dtp,jgs,ixcol, & if (ndebugzf .gt. 0 ) write(0,*) "ZIEGFALL: EXITING SUBROUTINE" + RETURN END subroutine ziegfall1d @@ -8632,12 +9371,260 @@ END subroutine ziegfall1d ! ##################################################################### + +!----------------------------------------------------------------------- +! +! ################################################################## +! ###### ###### +! ###### REAL FUNCTION NSSL_QTODBZ ###### +! ###### ###### +! ################################################################## +! +! Computes effective radar-reflectivity factor corresponding to the model +! hydrometeor variables. +! +! +! Units are MKS, and for most accurate results, make sure that the +! number concentrations and densities of rain, snow and hail are the +! same as the model used in producing the fields. +! +! To be fully consistent with the microphysics, hail/graupel particle +! conditions (wet or dry) would need to be passed to this routine. This +! is because hail/graupel can be wet at temperatures colder than freezing. +! Instead, here we assume that all particles are dry at T<0. (M. Gilmore) +! +!-------------------------------------------------------------------------- +! +! Code obtained from Lou Wicker, 30 August 2004 +! Modified by David Dowell, 7 September 2004, after input from Matt Gilmore +! +! +! 2005.07.18: (erm) Added option for Ferrier (1994) version of dBZ +! calculation, which uses equivalent melted diameter. +! Here it is assumed that all ice particles are dry, which +! may not be realistic in that regard. +! +! Also added dBZ calculation for 10-ice and 2-moment +! +!-------------------------------------------------------------------------- +! +!----------------------------------------------------------------------- + REAL FUNCTION nssl_qtodbz( & + qc, qr, qi, qs, qh, qhl, ccw, crw, cci, csw, chw, chl, & + vhw, vhl, zrw, zhw, zhl, pb, tb ) + + implicit none + +!---- Passed Variables + + integer nc + real :: qc, qr, qi, qs, qh, qhl, ccw, crw, cci, csw, chw, chl, & + vhw, vhl, zrw, zhw, zhl + real pb, tb + real cno(3:50) + ! real cnoh, cnos, cnor, rho_qh, rho_qs, rho_qr + real :: mindbz = 0 + integer :: ipconc +!--- Local Variables + +! integer lv,lc,lr,li,lir,ls +! integer lgl,lgm,lgh,lf,lh +! integer lip,lhl,lhab + + + + logical ice10 + +! integer iuseferrier ! set = 1 to use alternate dBZ based on Ferrier 1994 + ! NOTE that snow is treated as always dry. Might want to + ! change that.... +! integer idbzci ! set = 1 to include dBZ contribution of cloud ice + ! in 3ice (Heymsfield JAS, 1977). Used for 10-ice by default +! parameter ( iuseferrier = 1, idbzci = 0 ) + + integer nx,ny,nz,nor, k, kediagloc + parameter ( nx = 1, ny = 1, nz = 1, nor = 0) + real z1d(1,4), gz(1), den, temp + real :: an(-nor+1:nx+nor,-nor+1:ny+nor,-nor+1:nz+nor,na) + real :: dn(-nor+1:nx+nor,-nor+1:ny+nor,-nor+1:nz+nor) + real :: temk(-nor+1:nx+nor,-nor+1:ny+nor,-nor+1:nz+nor) + real :: dbz(-nor+1:nx+nor,-nor+1:ny+nor,-nor+1:nz+nor) + +!----------------------------------------------------------------------- + + + den = 1.0e5*pb**2.509/(287.04*tb) + temp = tb*pb + + +! IF ( microp(1:5) .eq. 'ICE10' .or. microp(1:1) .eq. 'Z' .or. microp .eq. 'WARMZIEG' ) THEN +! CALL setmicro(cnoh,rho_qh,cnor,rho_qr,cnos,rho_qs) + + z1d(:,:) = 1.0 + gz(1) = 1.0 + an(:,:,:,:) = 0.0 + dn(:,:,:) = den + temk = temp + +! DO k = 1,2*lqmx + an(1,1,1,lc) = qc + an(1,1,1,lr) = qr + an(1,1,1,li) = qi + an(1,1,1,ls) = qs + an(1,1,1,lh) = qh + IF ( lhl > 1 ) an(1,1,1,lhl) = qhl + an(1,1,1,lnc) = den*ccw + an(1,1,1,lnr) = den*crw + an(1,1,1,lni) = den*cci + an(1,1,1,lns) = den*csw + an(1,1,1,lnh) = den*chw + IF ( lnhl > 1 ) an(1,1,1,lnhl) = den*chl + IF ( lvh > 1 ) an(1,1,1,lvh) = den*vhw + IF ( lvhl > 1 ) an(1,1,1,lvhl) = den*vhl + IF ( lzr > 1 ) an(1,1,1,lzr) = den*zrw + IF ( lzh > 1 ) an(1,1,1,lzh) = den*zhw + IF ( lzhl > 1 ) an(1,1,1,lzhl) = den*zhl +! ENDDO + + call calcnfromq(nx,ny,nz,an,na,nor,nor,dn) + +! write(*,*) 'qtodbz: den,temp = ',den,temp + +! assume ipconc = 0 for now.... +! assume print unit=6 + kediagloc = 1 + call radardd02(nx,ny,nz,nor,na,an,temk, & + & dbz,dn,1,cnoh,rho_qh,ipconc,kediagloc,0, zdbz_start=1,zdbz_end=1) +! call radardd02(nx,ny,nz,nor,na,an,temk, +! dbz,dn, 1, cnoh,rho_qh,ipconc, 6, microp, 0, 0, vzf) + +! IF ( dbz .gt. 1.0 ) write(*,*) 'qtodbz: dbz = ', dbz + nssl_qtodbz = Max( dbz(1,1,1), mindbz ) + + RETURN + + + + RETURN + END FUNCTION nssl_qtodbz + +! ###################################################################### +! +! nssl_column_dbz: column-level reflectivity (dBZ) +! Processes an entire column at once for efficiency, avoiding +! per-level overhead of nssl_qtodbz. +! +! ###################################################################### + + subroutine nssl_column_dbz(nz_in, & + qc, qr, qi, qs, qh, qhl, & + ccw, crw, cci, csw, chw, chl, & + vhw, vhl, zrw, zhw, zhl, & + pb, tb, rho_air, dbzout, no_dbz ) + +! ############################################################################## + implicit none + +!---- Passed Variables + + integer, intent(in) :: nz_in + real, dimension(nz_in), intent(inout) :: qc, qr, qi, qs, qh, qhl + real, dimension(nz_in), intent(inout) :: ccw, crw, cci, csw, chw, chl + real, dimension(nz_in), intent(inout) :: vhw, vhl, zrw, zhw, zhl + real, dimension(nz_in), intent(in) :: pb, tb, rho_air + real, dimension(nz_in), intent(out), optional :: dbzout + logical, optional :: no_dbz ! if true, then skip reflectivity + +!--- Local Variables + + integer, parameter :: nx = 1, ny = 1, nor = 0 + integer :: k, kediagloc + real :: cnoh, rho_qh + real :: an(1,1,nz_in,na) + real :: dn(1,1,nz_in+1) + real :: temk(1,1,nz_in) + real :: dbz(1,1,nz_in) + real :: xv, xmas, cx + logical :: no_dbz_local + +!----------------------------------------------------------------------- + + no_dbz_local = .false. + IF ( present( no_dbz ) ) THEN + no_dbz_local = no_dbz + ENDIF + an(:,:,:,:) = 0.0 + do k = 1, nz_in + dn(1,1,k) = rho_air(k) ! 1.0e5*pb(k)**2.509/(287.04*tb(k)) + temk(1,1,k) = tb(k)*pb(k) + + an(1,1,k,lc) = qc(k) + an(1,1,k,lr) = qr(k) + an(1,1,k,li) = qi(k) + an(1,1,k,ls) = qs(k) + an(1,1,k,lh) = qh(k) + IF ( lhl > 1 ) an(1,1,k,lhl) = qhl(k) + an(1,1,k,lnc) = rho_air(k)*ccw(k) + an(1,1,k,lnr) = rho_air(k)*crw(k) + an(1,1,k,lni) = rho_air(k)*cci(k) + an(1,1,k,lns) = rho_air(k)*csw(k) + an(1,1,k,lnh) = rho_air(k)*chw(k) + IF ( lnhl > 1 ) an(1,1,k,lnhl) = rho_air(k)*chl(k) + IF ( lvh > 1 ) an(1,1,k,lvh) = rho_air(k)*vhw(k) + IF ( lvhl > 1 ) an(1,1,k,lvhl) = rho_air(k)*vhl(k) + IF ( lzr > 1 ) an(1,1,k,lzr) = rho_air(k)*zrw(k) + IF ( lzh > 1 ) an(1,1,k,lzh) = rho_air(k)*zhw(k) + IF ( lzhl > 1 ) an(1,1,k,lzhl) = rho_air(k)*zhl(k) + enddo + dn(1,1,nz_in+1) = dn(1,1,nz_in) + + call calcnfromq(nx,ny,nz_in,an,na,nor,nor,dn,sizecheck_flag=.true.) + + IF ( present( dbzout ) .and. .not. no_dbz_local ) THEN + kediagloc = nz_in + call radardd02(nx,ny,nz_in,nor,na,an,temk, & + & dbz,dn,1,cnoh,rho_qh,ipconc,kediagloc,0, & + & zdbz_start=1,zdbz_end=nz_in) + + do k = 1, nz_in + dbzout(k) = dbz(1,1,k) + enddo + ENDIF + + do k = 1, nz_in +! dn(1,1,k) = rho_air(k) ! 1.0e5*pb(k)**2.509/(287.04*tb(k)) +! temk(1,1,k) = tb(k)*pb(k) +! + qc(k) = an(1,1,k,lc) + qr(k) = an(1,1,k,lr) + qi(k) = an(1,1,k,li) + qs(k) = an(1,1,k,ls) + qh(k) = an(1,1,k,lh) + IF ( lhl > 1 ) qhl(k) = an(1,1,k,lhl) + crw(k) = an(1,1,k,lnr)/rho_air(k) + ccw(k) = an(1,1,k,lnc)/rho_air(k) + cci(k) = an(1,1,k,lni)/rho_air(k) + csw(k) = an(1,1,k,lns)/rho_air(k) + chw(k) = an(1,1,k,lnh)/rho_air(k) + IF ( lnhl > 1 ) chl(k) = an(1,1,k,lnhl)/rho_air(k) + IF ( lvh > 1 ) vhw(k) = an(1,1,k,lvh)/rho_air(k) + IF ( lvhl > 1 ) vhl(k) = an(1,1,k,lvhl)/rho_air(k) + IF ( lzr > 1 ) zrw(k) = an(1,1,k,lzr)/rho_air(k) + IF ( lzh > 1 ) zhw(k) = an(1,1,k,lzh)/rho_air(k) + IF ( lzhl > 1 ) zhl(k) = an(1,1,k,lzhl)/rho_air(k) + enddo + + END subroutine nssl_column_dbz + + ! ##################################################################### ! ##################################################################### ! ############################################################################## + subroutine radardd02(nx,ny,nz,nor,na,an,temk, & - & dbz,db,nzdbz,cnoh0t,hwdn1t,ipconc,ke_diag, iunit) + & dbz,db,nzdbz,cnoh0t,hwdn1t,ipconc,ke_diag, iunit, & + & vzflag0, vzf, zdbz_start, zdbz_end) ! ! 11.13.2005: Changed values of indices for reordering of lip ! @@ -8686,6 +9673,7 @@ subroutine radardd02(nx,ny,nz,nor,na,an,temk, & character(LEN=15), parameter :: microp = 'ZVD' integer nx,ny,nz,nor,na,ngt integer nzdbz ! how many levels actually to process + integer, intent(in), optional :: zdbz_start,zdbz_end ! start and end levels actually to process integer ng1,n10 integer iunit @@ -8702,12 +9690,18 @@ subroutine radardd02(nx,ny,nz,nor,na,an,temk, & integer imapz,mzdist integer vzflag +! #ifdef USEVZF + integer, optional, intent(in) :: vzflag0 +! #endif integer, parameter :: norz = 3 real an(-nor+ng1:nx+nor,-nor+ng1:ny+nor,-nor+ng1:nz+nor,na) real db(-nor+ng1:nx+nor,-nor+ng1:ny+nor,-nor+ng1:nz+nor) ! air density ! real gt(-nor+ng1:nx+nor,-nor+ng1:ny+nor,-nor+ng1:nz+nor,ngt) real temk(-nor+ng1:nx+nor,-nor+ng1:ny+nor,-nor+ng1:nz+nor) ! air temperature (kelvin) real dbz(-nor+ng1:nx+nor,-nor+ng1:ny+nor,-nor+ng1:nz+nor) ! reflectivity +! #ifdef USEVZF + real, optional, intent(out) :: vzf(-nor+ng1:nx+nor,-nor+ng1:ny+nor,-nor+ng1:nz+nor) ! power-weighted fall velocity +! #endif real gz(-nor+1:nz+nor) ! ,z1d(-nor+1:nz+nor,4) ! real g,rgas,eta,inveta @@ -8731,8 +9725,10 @@ subroutine radardd02(nx,ny,nz,nor,na,an,temk, & double precision :: xcnoh, xcnos, dadh, dads, zhdryc, zsdryc, zhwetc,zswetc double precision :: dadr real dbzmax,dbzmin + parameter ( dbzmin = 0 ) + real cnow,cnoi,cnoip,cnoir,cnor,cnos real cnogl,cnogm,cnogh,cnof,cnoh,cnohl @@ -8769,6 +9765,7 @@ subroutine radardd02(nx,ny,nz,nor,na,an,temk, & real :: dnsnow real qh + real, parameter :: cwmasn = 5.23e-13 ! minimum mass, defined by radius of 5.0e-6 real, parameter :: cwmasx = 5.25e-10 ! maximum mass, defined by radius of 50.0e-6 real, parameter :: cwradn = 5.0e-6 ! minimum radius @@ -8779,11 +9776,24 @@ subroutine radardd02(nx,ny,nz,nor,na,an,temk, & real :: ksq real :: dtp + integer :: loop_start, loop_end ! ######################################################################### + if (.not. present(zdbz_start)) then + loop_start = 1 + else + loop_start = zdbz_start + endif + if (.not. present(zdbz_end)) then + loop_end = ke_diag + else + loop_end = zdbz_end + endif + vzflag = 0 + izieg = 0 ice10 = 0 ! g=9.806 ! g: gravity constant @@ -9057,7 +10067,8 @@ subroutine radardd02(nx,ny,nz,nor,na,an,temk, & DO jy=1,1 - DO kz = 1,ke_diag ! nz + + DO kz = loop_start, loop_end !1,ke_diag ! nz DO ix=1,nx dbz(ix,jy,kz) = 0.0 @@ -9082,8 +10093,10 @@ subroutine radardd02(nx,ny,nz,nor,na,an,temk, & IF ( ipconc .le. 2 ) THEN gtmp(ix,kz) = dadr*an(ix,jy,kz,lr)**(0.25) dtmp(ix,kz) = zrc*gtmp(ix,kz)**7 + ELSEIF ( lzr .gt. 1 ) THEN dtmp(ix,kz) = 1e18*an(ix,jy,kz,lzr) + ELSEIF ( an(ix,jy,kz,lnr) .gt. 1.e-3 ) THEN IF ( imurain == 3 ) THEN vr = db(ix,jy,kz)*an(ix,jy,kz,lr)/(1000.*an(ix,jy,kz,lnr)) @@ -9096,6 +10109,7 @@ subroutine radardd02(nx,ny,nz,nor,na,an,temk, & ENDIF ENDIF dtmpr = dtmp(ix,kz) + ENDIF !----------------------------------------------------------------------- @@ -9309,6 +10323,7 @@ subroutine radardd02(nx,ny,nz,nor,na,an,temk, & ENDIF !} ENDIF !} + ENDIF !} ENDIF @@ -9352,10 +10367,12 @@ subroutine radardd02(nx,ny,nz,nor,na,an,temk, & IF ( izieg .ge. 1 .and. ipconc .ge. 5 ) THEN ltest = .false. + IF ( lzh > 1 ) THEN IF ( an(ix,jy,kz,lzh) > 0.0 .and. an(ix,jy,kz,lh) > qhmin .and. & an(ix,jy,kz,lnh) >= cxmin ) ltest = .true. ENDIF + IF ( ltest .or. (an(ix,jy,kz,lh) .ge. qhmin .and. an(ix,jy,kz,lnh) .ge. cxmin )) THEN @@ -9401,9 +10418,11 @@ subroutine radardd02(nx,ny,nz,nor,na,an,temk, & ENDIF IF ( lzh .gt. 1 ) THEN + x = (0.224*qh + 0.776*qxw)/an(ix,jy,kz,lh) ! weighted average of dielectric const dtmph = 1.e18*x*an(ix,jy,kz,lzh)*(hwdn/rwdn)**2 dtmp(ix,kz) = dtmp(ix,kz) + dtmph + ELSE g1 = (6.0 + alphah)*(5.0 + alphah)*(4.0 + alphah)/((3.0 + alphah)*(2.0 + alphah)*(1.0 + alphah)) ! zx = g1*(db(ix,jy,kz)*an(ix,jy,kz,lh))**2/chw @@ -9448,6 +10467,7 @@ subroutine radardd02(nx,ny,nz,nor,na,an,temk, & ENDIF + ENDIF ! } ENDIF ! na .gt. 5 @@ -9476,11 +10496,13 @@ subroutine radardd02(nx,ny,nz,nor,na,an,temk, & IF ( ipconc .ge. 5 ) THEN ltest = .false. + IF ( lzhl > 1 ) THEN IF ( an(ix,jy,kz,lzhl) > 0.0 .and. an(ix,jy,kz,lhl) > qhlmin .and. & an(ix,jy,kz,lnhl) > 0.0 ) ltest = .true. ENDIF + IF ( ltest .or. ( an(ix,jy,kz,lhl) .ge. qhlmin .and. an(ix,jy,kz,lnhl) .gt. 0.) ) THEN !{ chl = an(ix,jy,kz,lnhl) IF ( chl .gt. 0.0 ) THEN !{ @@ -9503,9 +10525,11 @@ subroutine radardd02(nx,ny,nz,nor,na,an,temk, & ENDIF IF ( lzhl .gt. 1 ) THEN !{ + x = (0.224*an(ix,jy,kz,lhl) + 0.776*qxw)/an(ix,jy,kz,lhl) ! weighted average of dielectric const dtmphl = 1.e18*x*an(ix,jy,kz,lzhl)*(hldn/rwdn)**2 dtmp(ix,kz) = dtmp(ix,kz) + dtmphl + ELSE !} g1 = (6.0 + alphahl)*(5.0 + alphahl)*(4.0 + alphahl)/((3.0 + alphahl)*(2.0 + alphahl)*(1.0 + alphahl)) @@ -9553,12 +10577,14 @@ subroutine radardd02(nx,ny,nz,nor,na,an,temk, & ENDIF ! ipconc .ge. 5 + ENDIF ! izieg .ge. 1 .and. lhl .gt. 1 IF ( dtmp(ix,kz) .gt. 0.0 ) THEN dbz(ix,jy,kz) = Max(dbzmin, 10.0*Log10(dtmp(ix,kz)) ) + IF ( dbz(ix,jy,kz) .gt. dbzmax ) THEN dbzmax = Max(dbzmax,dbz(ix,jy,kz)) @@ -9615,7 +10641,9 @@ subroutine radardd02(nx,ny,nz,nor,na,an,temk, & write(0,*) 'gtmp = ',gtmp(ix,kz),dtmp(ix,kz) IF ( .not. (dbz(ix,jy,kz) .gt. -100 .and. dbz(ix,jy,kz) .lt. 200 ) ) THEN write(0,*) 'dbz out of bounds!' + ! STOP + ENDIF ENDIF @@ -9643,15 +10671,19 @@ subroutine radardd02(nx,ny,nz,nor,na,an,temk, & ENDIF + RETURN END subroutine radardd02 + ! ############################################################################## ! ############################################################################## + + ! ##################################################################### ! ##################################################################### ! @@ -9662,16 +10694,21 @@ END subroutine radardd02 SUBROUTINE NUCOND & & (nx,ny,nz,na,jyslab & & ,nor,norz,dtp,nxi & + & ,dz3d & + & ,t0,t9 & & ,an,dn,p2 & & ,pn,w & + & ,ngs & + & ,axtra,io_flag & & ,ssfilt,t00,t77,flag_qndrop & & ) + implicit none ! real :: cwmasn = 1000.*0.523599*(2.*2.e-6)**3 @@ -9715,12 +10752,16 @@ SUBROUTINE NUCOND & real pb(-norz+ng1:nz+norz) real pinit(-norz+ng1:nz+norz) + real dz3d(-nor+1:nx+nor,-nor+1:ny+nor,-norz+1:nz+norz) + ! local + + real axtra(-nor+ng1:nx+nor,-nor+ng1:ny+nor,-norz+ng1:nz+norz,nxtra) logical :: io_flag @@ -9734,6 +10775,7 @@ SUBROUTINE NUCOND & real, parameter :: cwmas20 = 1000.*0.523599*(2.*20.e-6)**3 ! mass of 20-micron radius droplet, for sat. adj. integer nxmpb,nzmpb,nxz integer mgs,ngs,numgs,inumgs + integer ngscnt,igs(ngs),kgs(ngs) integer kgsp(ngs),kgsm(ngs) integer nsvcnt @@ -9762,8 +10804,6 @@ SUBROUTINE NUCOND & ! =0 to use ad to calculate SS ! =1 to use an at end of main jy loop to calculate SS parameter (iba = 1) - integer ifilt ! =1 to filter ssat, =0 to set ssfilt=ssat - parameter ( ifilt = 0 ) real temp1,temp2 ! ,ssold real :: ssmax(ngs) ! maximum SS experienced by a parcel real ssmx @@ -9775,7 +10815,7 @@ SUBROUTINE NUCOND & real volb, t2s real, parameter :: aa1 = 9.44e15, aa2 = 5.78e3 ! a1 in Ziegler - real ec0, ex1, ft, rhoinv(ngs) + real rhoinv(ngs) real chw, g1, rd1 @@ -9797,8 +10837,9 @@ SUBROUTINE NUCOND & real dqvr, dqc, dqr, dqi, dqs real qv1m,qvs1m,ss1m,ssi1m,qis1m real cwmastmp - real dcloud,dcloud2 ! ,as, bs - real dcrit + real dcloud,dcloud2,dcloudmx ! ,as, bs + real dcrit,dcloudcheck,cnucmax + real cn(ngs), cnuf(ngs) real :: ccwmax @@ -9880,7 +10921,7 @@ SUBROUTINE NUCOND & integer, parameter :: iunit = 0 - real :: frac, hwdn, tmpg + real :: frac, hwdn, tmpg, xdia1, xdia3, cwch,xvol real :: cvm,cpm,rmm @@ -9892,6 +10933,24 @@ SUBROUTINE NUCOND & integer :: count +! Addtion T.Iguchi Y2021 Update + real, parameter :: mwwater = 0.01801528 ! Molecular weight of water (kg/mol) + real, parameter :: rhowater = 997.0 ! Density of liquid water (kg/m3) + real, parameter :: gasconst = 8.3144598 ! Gas constant (m2 kg s-2 K-1 mol-1) + real :: sswater ! unit change supersaturation from percentage to n/a + real :: sigvl, aact + + real :: alpha_ar, gamma_ar, G_ar, evs, zeta, smax + real :: f_ac, g_ac, eta_ac + real :: f_nu, g_nu, eta_nu + real :: f_co, g_co, eta_co + + real :: sm_nu, sm_ac, sm_co, ss_ac, ss_nu, ss_co + real :: uu_nu, uu_ac, uu_co + + real :: cn_ac, cn_co, cn_nu + + ! ------------------------------------------------------------------------------- itile = nxi jtile = ny @@ -9902,16 +10961,20 @@ SUBROUTINE NUCOND & nxend = nxi + 1 nyend = ny + 1 nzend = nz + kzbeg = 1 + nzbeg = 1 IF ( ac_opt > 0 ) ccnefactwo = (1.63e-3/(cck * beta(3./2., cck/2.)))**(1.0/(cck + 2.0)) f5 = 237.3 * 17.27 * 2.5e6 / cp ! combined constants for rain condensation (Soong and Ogura 73) + jy = 1 kstag = 0 pb(:) = 0.0 pinit(:) = 0.0 + IF ( ipconc <= 1 .or. isedonly == 2 ) GOTO 2200 @@ -9936,11 +10999,13 @@ SUBROUTINE NUCOND & c1 = t00(ix,jy,kz)*tabqvs(ltemq) ELSEIF ( iqvsopt == 1 ) THEN c1 = rdorv*esbolton*tabqvs(ltemq)/(pn(ix,jy,kz) + pb(kz) - esbolton*tabqvs(ltemq)) - ! qvs(mgs) = pqs(mgs)*tabqvs(ltemq) + ENDIF IF ( c1 > 0. ) THEN ssfilt(ix,jy,kz) = 100.*(an(ix,jy,kz,lv)/c1 - 1.0) ! from "new" values + ELSE + ssfilt(ix,jy,kz) = -100. ENDIF ENDDO @@ -9992,6 +11057,7 @@ SUBROUTINE NUCOND & qvs(1) = pqs(1)*tabqvs(ltemq) ELSEIF ( iqvsopt == 1 ) THEN qvs(1) = rdorv*esbolton*tabqvs(ltemq)/(pres(1) - esbolton*tabqvs(ltemq)) + ENDIF qis(1) = pqs(1)*tabqis(ltemq) @@ -10028,8 +11094,10 @@ SUBROUTINE NUCOND & qx(:,:) = 0.0 cx(:,:) = 0.0 + zx(:,:) = 0.0 + xv(:,:) = 0.0 xmas(:,:) = 0.0 @@ -10076,15 +11144,16 @@ SUBROUTINE NUCOND & qvs(mgs) = pqs(mgs)*tabqvs(ltemq) ELSEIF ( iqvsopt == 1 ) THEN qvs(mgs) = rdorv*esbolton*tabqvs(ltemq)/(pres(mgs) - esbolton*tabqvs(ltemq)) + ENDIF qis(mgs) = pqs(mgs)*tabqis(ltemq) ! qvap(mgs) = max( (qwvp(mgs) + qv0(mgs)), 0.0 ) IF ( iqvsopt == 0 ) THEN es(mgs) = 6.1078e2*tabqvs(ltemq) - ! qvs(mgs) = pqs(mgs)*tabqvs(ltemq) ELSEIF ( iqvsopt == 1 ) THEN es(mgs) = esbolton*tabqvs(ltemq) + ENDIF ! es(mgs) = 6.1078e2*tabqvs(ltemq) qss(mgs) = qvs(mgs) @@ -10159,7 +11228,37 @@ SUBROUTINE NUCOND & ccnc(mgs) = an(igs(mgs),jy,kgs(mgs),lccn) + an(igs(mgs),jy,kgs(mgs),lccnuf) ELSE ccnc(mgs) = an(igs(mgs),jy,kgs(mgs),lccn) + IF ( lccna > 1 ) THEN + cnuc(mgs) = ccnc(mgs) + ENDIF + ENDIF + IF ( lcn_nu > 1 ) THEN + ccnc_nu(mgs) = an(igs(mgs),jy,kgs(mgs),lcn_nu) + ENDIF + IF ( lcn_co > 1 ) THEN + ccnc_co(mgs) = an(igs(mgs),jy,kgs(mgs),lcn_co) + ENDIF + IF ( lccnaco > 1 ) THEN + ccnaco(mgs) = an(igs(mgs),jy,kgs(mgs),lccnaco) + ELSE + ccnaco(mgs) = 0.0 ENDIF + IF ( lccnanu > 1 ) THEN + ccnanu(mgs) = an(igs(mgs),jy,kgs(mgs),lccnanu) + ELSE + ccnanu(mgs) = 0.0 + ENDIF + ELSEIF ( lccn > 1 .and. ( ac_opt == 1 .or. ac_opt == 11 ) ) THEN + ccnc(mgs) = an(igs(mgs),jy,kgs(mgs),lccn) + ! ccnc(mgs) = ccnc_ac(mgs) + cnuc(mgs) = ccnc(mgs) + cwnccn(mgs) = cnuc(mgs) + ! write(0,*) 'ccnc_ac,mgs = ', ccnc_ac(mgs),mgs,igs(mgs),jy,kgs(mgs) + ELSEIF ( lccn > 1 .and. ( ac_opt == 2 .or. ac_opt == 22 ) ) THEN + ccnc_nu(mgs) = an(igs(mgs),jy,kgs(mgs),lcn_nu) + ccnc(mgs) = an(igs(mgs),jy,kgs(mgs),lccn) + ! ccnc(mgs) = ccnc_ac(mgs) + ccnc_co(mgs) = an(igs(mgs),jy,kgs(mgs),lcn_co) ELSE ccnc(mgs) = cwnccn(mgs) ENDIF @@ -10185,7 +11284,9 @@ SUBROUTINE NUCOND & ENDIF ELSE IF ( lccn > 1 ) THEN - ccna(mgs) = cwnccn(mgs) - ccnc(mgs) ! diagnose activated ccn as background value - remaining unactivated ccn + + ccna(mgs) = 0.0 ! WRF driver interface already has ccw subtracted from ccnc + ELSE ccna(mgs) = cx(mgs,lc) ! approximation of number of activated ccn ENDIF @@ -10202,9 +11303,13 @@ SUBROUTINE NUCOND & DO mgs = 1,ngscnt ! default value of renucfrac is 0.0 IF ( irenuc /= 6 ) THEN - cnuc(mgs) = Max(ccnc(mgs),cwnccn(mgs))*(1. - renucfrac) + ccnc(mgs)*renucfrac + IF ( irenuc == 2 ) THEN + cnuc(mgs) = Max(ccnc(mgs),cwnccn(mgs))*(1. - renucfrac) + ccnc(mgs)*renucfrac + ELSE + cnuc(mgs) = ccnc(mgs)*(1. - renucfrac) + ccnc(mgs)*renucfrac + ENDIF ELSE - cnuc(mgs) = Max(ccnc(mgs),cwnccn(mgs))*(1. - renucfrac) + Max(0.0,ccnc(mgs) - ccna(mgs))*renucfrac + cnuc(mgs) = ccnc(mgs)*(1. - renucfrac) + Max(0.0,ccnc(mgs) - ccna(mgs))*renucfrac ENDIF IF ( renucfrac >= 0.999 ) THEN IF ( temg(mgs) < 265. ) THEN @@ -10230,6 +11335,7 @@ SUBROUTINE NUCOND & ventrxn(:) = ventrn + ! Find shape parameter rain IF ( lzr > 1 .and. rcond == 2 ) THEN ! { RAIN SHAPE PARAM @@ -10241,21 +11347,42 @@ SUBROUTINE NUCOND & il = lr DO mgs = 1,ngscnt - IF ( zx(mgs,il) <= zxmin ) THEN - qx(mgs,lv) = qx(mgs,lv) + qx(mgs,il) + IF ( iresetmoments == 1 .or. iresetmoments == il .or. iresetmoments == -1 ) THEN + IF ( zx(mgs,il) <= zxmin ) THEN ! .and. qx(mgs,il) > 0.05e-3 ) THEN qx(mgs,il) = 0.0 cx(mgs,il) = 0.0 an(igs(mgs),jgs,kgs(mgs),lv) = an(igs(mgs),jgs,kgs(mgs),lv) + an(igs(mgs),jgs,kgs(mgs),il) an(igs(mgs),jgs,kgs(mgs),il) = qx(mgs,il) an(igs(mgs),jgs,kgs(mgs),ln(il)) = cx(mgs,il) - ELSEIF ( cx(mgs,il) <= 0.0 ) THEN - qx(mgs,lv) = qx(mgs,lv) + qx(mgs,il) + ELSEIF ( iresetmoments == -1 .and. qx(mgs,il) < qxmin(il) ) THEN + zx(mgs,il) = 0.0 + cx(mgs,il) = 0.0 + an(igs(mgs),jgs,kgs(mgs),lv) = an(igs(mgs),jgs,kgs(mgs),lv) + an(igs(mgs),jgs,kgs(mgs),il) + + qx(mgs,il) = 0.0 + an(igs(mgs),jgs,kgs(mgs),il) = qx(mgs,il) + an(igs(mgs),jgs,kgs(mgs),ln(il)) = cx(mgs,il) + an(igs(mgs),jgs,kgs(mgs),lz(il)) = zx(mgs,il) + + ELSEIF ( cx(mgs,il) <= cxmin .and. iresetmoments /= -1 ) THEN ! .and. qx(mgs,il) > 0.05e-3 ) THEN +!! write(91,*) 'cx=0; qx,zx = ',1000.*qx(mgs,il),1.e18*zx(mgs,il) zx(mgs,il) = 0.0 qx(mgs,il) = 0.0 an(igs(mgs),jgs,kgs(mgs),lv) = an(igs(mgs),jgs,kgs(mgs),lv) + an(igs(mgs),jgs,kgs(mgs),il) an(igs(mgs),jgs,kgs(mgs),il) = qx(mgs,il) an(igs(mgs),jgs,kgs(mgs),lz(il)) = zx(mgs,il) ENDIF + ENDIF + + IF ( zx(mgs,il) <= zxmin .and. cx(mgs,il) <= cxmin ) THEN + zx(mgs,il) = 0.0 + cx(mgs,il) = 0.0 + an(igs(mgs),jgs,kgs(mgs),lv) = an(igs(mgs),jgs,kgs(mgs),lv) + an(igs(mgs),jgs,kgs(mgs),il) + qx(mgs,il) = 0.0 + an(igs(mgs),jgs,kgs(mgs),il) = qx(mgs,il) + an(igs(mgs),jgs,kgs(mgs),ln(il)) = cx(mgs,il) + an(igs(mgs),jgs,kgs(mgs),lz(il)) = zx(mgs,il) + ENDIF IF ( qx(mgs,lr) .gt. qxmin(lr) ) THEN @@ -10462,6 +11589,7 @@ SUBROUTINE NUCOND & ENDIF ! } + ! write(0,*) 'NUCOND: Set ssf variables, ssmxinit =',ssmxinit ssmx = 0.0 DO mgs = 1,ngscnt @@ -10615,16 +11743,32 @@ SUBROUTINE NUCOND & QEVAP= Min( qx(mgs,lc), R1*(qss(mgs)-qvap(mgs)) ) - IF ( qx(mgs,lc) <= QEVAP ) THEN ! GO TO 63 + IF ( qx(mgs,lc) <= QEVAP ) THEN !{ GO TO 63 qwvp(mgs) = qwvp(mgs) + qx(mgs,lc) thetap(mgs) = thetap(mgs) - felvcp(mgs)*qx(mgs,lc)/(pi0(mgs)) + IF ( io_flag .and. nxtra > 1 ) THEN axtra(igs(mgs),jy,kgs(mgs),1) = -qx(mgs,lc)/dtp ENDIF + qx(mgs,lc) = 0. - IF ( restoreccn ) THEN - IF ( lccna > 1 ) THEN - ccna(mgs) = ccna(mgs) - restoreccnfrac*cx(mgs,lc) + IF ( restoreccn ) THEN !{ + IF ( lccna > 1 .and. .not. (ac_opt == 1 .or. ac_opt == 2) ) THEN + tmp = restoreccnfrac*cx(mgs,lc) + IF ( lccnaco > 1 .and. lccnanu > 1 ) THEN + ! restore CCN proportionally to each type, although coarse are presumably already lost to rain + tmp2 = ccna(mgs) + ccnaco(mgs) + ccnanu(mgs) + IF ( tmp2 > 0.0 ) THEN + ccna(mgs) = ccna(mgs) - tmp*ccna(mgs)/tmp2 + ccnaco(mgs) = ccnaco(mgs) - tmp*ccnaco(mgs)/tmp2 + ccnanu(mgs) = ccnanu(mgs) - tmp*ccnanu(mgs)/tmp2 + ENDIF + ELSE + ccna(mgs) = ccna(mgs) - tmp + ENDIF + ELSEIF ( ac_opt == 1 ) THEN + ! do not need to add back because ccnc = ccn_unactivated + ccw, so reducing ccw "restores" ccn_unactived + ! ccnc(mgs) = ccnc(mgs) + restoreccnfrac*cx(mgs,lc) ELSEIF ( irenuc <= 2 ) THEN IF ( .not. invertccn ) THEN ccnc(mgs) = Max( ccnc(mgs), Min( qccn*rho0(mgs), ccnc(mgs) + restoreccnfrac*cx(mgs,lc) ) ) @@ -10632,16 +11776,29 @@ SUBROUTINE NUCOND & ccnc(mgs) = ccnc(mgs) + restoreccnfrac*cx(mgs,lc) ENDIF ENDIF - ENDIF + ENDIF !} cx(mgs,lc) = 0. - ELSE + ELSE !} { qctmp = qx(mgs,lc) qwvp(mgs) = qwvp(mgs) + QEVAP qx(mgs,lc) = qx(mgs,lc) - QEVAP IF ( qx(mgs,lc) .le. 0. ) THEN IF ( restoreccn ) THEN - IF ( lccna > 1 ) THEN - ccna(mgs) = ccna(mgs) - restoreccnfrac*cx(mgs,lc) + IF ( lccna > 1 .and. .not. (ac_opt == 1 .or. ac_opt == 2)) THEN + tmp = restoreccnfrac*cx(mgs,lc) + IF ( lccnaco > 1 .and. lccnanu > 1 ) THEN + ! restore CCN proportionally to each type, although coarse are presumably already lost to rain + tmp2 = ccna(mgs) + ccnaco(mgs) + ccnanu(mgs) + IF ( tmp2 > 0.0 ) THEN + ccna(mgs) = ccna(mgs) - tmp*ccna(mgs)/tmp2 + ccnaco(mgs) = ccnaco(mgs) - tmp*ccnaco(mgs)/tmp2 + ccnanu(mgs) = ccnanu(mgs) - tmp*ccnanu(mgs)/tmp2 + ENDIF + ELSE + ccna(mgs) = ccna(mgs) - tmp + ENDIF + ELSEIF ( ac_opt == 1 ) THEN + ! ccnc(mgs) = ccnc(mgs) + restoreccnfrac*cx(mgs,lc) ELSEIF ( irenuc <= 2 ) THEN ! ccnc(mgs) = Max( ccnc(mgs), Min( qccn*rho0(mgs), ccnc(mgs) + cx(mgs,lc) ) ) ! ccnc(mgs) = ccnc(mgs) + cx(mgs,lc) @@ -10656,8 +11813,22 @@ SUBROUTINE NUCOND & ELSE tmp = 0.9*QEVAP*cx(mgs,lc)/qctmp ! let droplets get smaller but also remove some. A factor of 1.0 would maintain same size IF ( restoreccn ) THEN - IF ( lccna > 1 ) THEN - ccna(mgs) = ccna(mgs) - restoreccnfrac*tmp + IF ( lccna > 1 .and. .not. (ac_opt == 1 .or. ac_opt == 2) ) THEN + tmp = restoreccnfrac*tmp + IF ( lccnaco > 1 .and. lccnanu > 1 ) THEN + ! restore CCN proportionally to each type, although coarse are presumably already lost to rain + tmp2 = ccna(mgs) + ccnaco(mgs) + ccnanu(mgs) + IF ( tmp2 > 0.0 ) THEN + ccna(mgs) = ccna(mgs) - tmp*ccna(mgs)/tmp2 + ccnaco(mgs) = ccnaco(mgs) - tmp*ccnaco(mgs)/tmp2 + ccnanu(mgs) = ccnanu(mgs) - tmp*ccnanu(mgs)/tmp2 + ENDIF + ELSE + ccna(mgs) = ccna(mgs) - tmp + ENDIF + ! ccna(mgs) = ccna(mgs) - restoreccnfrac*tmp + ELSEIF ( ac_opt == 1 ) THEN + ! ccnc(mgs) = ccnc(mgs) + restoreccnfrac*tmp ELSEIF ( irenuc <= 2 ) THEN ! ccnc(mgs) = Max( ccnc(mgs), Min( qccn*rho0(mgs), ccnc(mgs) + tmp ) ) ! ccnc(mgs) = ccnc(mgs) + tmp @@ -10671,11 +11842,13 @@ SUBROUTINE NUCOND & cx(mgs,lc) = cx(mgs,lc) - tmp ENDIF thetap(mgs) = thetap(mgs) - felvcp(mgs)*QEVAP/(pi0(mgs)) + IF ( io_flag .and. nxtra > 1 ) THEN axtra(igs(mgs),jy,kgs(mgs),1) = -QEVAP/dtp ENDIF - ENDIF + + ENDIF !} GO TO 631 @@ -10799,7 +11972,11 @@ SUBROUTINE NUCOND & ltemq = Min( nqsat, Max(1,ltemq) ) ltemq1 = ltemq temp1 = temg(mgs) - p380 = 380.0/pres(mgs) + IF ( iqvsopt == 0 ) THEN + p380 = 380.0/pres(mgs) + ELSE + p380 = esbolton*rdorv/(pres(mgs) - es(mgs)) + ENDIF ! taus = Max( 0.05*dtp, Min(taus, 0.25*dtp ) ) ! nc = NInt(dtp/Min(1.0,0.5*taus)) @@ -10842,6 +12019,14 @@ SUBROUTINE NUCOND & dqs = 0.0 dqvii = 0.0 dqvis = 0.0 + + IF ( icondlimit == 1 .or. dtp > dtcond ) THEN + ssmx = 0.001 + + CALL QVEXCESS(ngs,mgs,qwvp,qv0,qx(1,lc),pres,thetap,theta0,dcloudmx, & + & pi0,tabqvs,nqsat,fqsat,cbw,fcqv1,felvcp,ssmx,pk,ngscnt) + ENDIF + RK2c: DO WHILE ( dt1 .lt. dtp ) nc = 0 @@ -10934,17 +12119,31 @@ SUBROUTINE NUCOND & ENDDO RK2c + IF ( icondlimit == 1 .or. dtp > dtcond ) THEN + IF ( dqc + dqr > 0.0 .and. dcloudmx > 0.0 .and. dqc + dqr > dcloudmx ) THEN + ! backstop for max condensation + ! write(0,*) 'dcl,dclmx = ',dqc+dqr,dcloudmx,ssmx,dqc,dqr + dcloudcheck = dqc+dqr + dqc = dqc*dcloudmx/dcloudcheck + dqr = dqr*dcloudmx/dcloudcheck + ! write(0,*) 'new dcl,dqc,dqr = ',dqc+dqr,dqc,dqr + ENDIF + ENDIF + dcloud = dqc ! qx(mgs,lv) - qv1 thetap(mgs) = thetap(mgs) + e1*(DCLOUD + dqr) + IF ( eqtset > 2 ) THEN pipert(mgs) = pipert(mgs) + felvpi(mgs)*(DCLOUD + dqr) ENDIF + IF ( io_flag .and. nxtra > 1 ) THEN axtra(igs(mgs),jy,kgs(mgs),1) = DCLOUD/dtp axtra(igs(mgs),jy,kgs(mgs),2) = axtra(igs(mgs),jy,kgs(mgs),2) + dqr/dtp ENDIF + qwvp(mgs) = qwvp(mgs) - (DCLOUD + dqr) qx(mgs,lc) = qx(mgs,lc) + DCLOUD qx(mgs,lr) = qx(mgs,lr) + dqr @@ -10952,6 +12151,7 @@ SUBROUTINE NUCOND & !! & dx*dy*dz3d(igs(mgs),jy,kgs(mgs)) + IF ( lzr > 1 .and. rcond == 2 .and. qx(mgs,lr) .gt. qxmin(lr) & & .and. cx(mgs,lr) .gt. 1.e-9 ) THEN tmp = qx(mgs,lr)/cx(mgs,lr) @@ -10965,15 +12165,16 @@ SUBROUTINE NUCOND & zx(mgs,lr) = zx(mgs,lr) + g1*(rho0(mgs)/(xdn(mgs,lr)))**2*( 2.*( tmp ) * dqr ) ENDIF + theta(mgs) = thetap(mgs) + theta0(mgs) temg(mgs) = theta(mgs)*f1 ltemq = (temg(mgs)-163.15)/fqsat+1.5 ltemq = Min( nqsat, Max(1,ltemq) ) - ! qvs(mgs) = pqs(mgs)*tabqvs(ltemq) IF ( iqvsopt == 0 ) THEN qvs(mgs) = pqs(mgs)*tabqvs(ltemq) ELSEIF ( iqvsopt == 1 ) THEN qvs(mgs) = rdorv*esbolton*tabqvs(ltemq)/(pres(mgs) - esbolton*tabqvs(ltemq)) + ENDIF ! es(mgs) = 6.1078e2*tabqvs(ltemq) @@ -11012,7 +12213,7 @@ SUBROUTINE NUCOND & ! IF ( ssf(mgs) > ssmx .and. ssf(mgs) < 20.0 ) THEN ! test -- fails ! IF ( ssf(mgs) > ssmx .and. ssf(mgs) < 20.0 .and. ccnc(mgs) > 0.1*cwnccn(mgs)) THEN ! test -- is OK IF ( ssf(mgs) > ssmx .and. ssf(mgs) < 20.0 .and. & - ( ccnc(mgs) > 0.05*cwnccn(mgs) .or. ( ac_opt > 0 .and. ccnc_ac(mgs) - cx(mgs,lc) > 0.0 ) ) ) THEN ! test + ( ccnc(mgs) > 0.05*cwnccn(mgs) .or. ( ac_opt > 0 .and. ccnc(mgs) - cx(mgs,lc) > 0.0 ) ) ) THEN ! test ! IF ( ssf(mgs) > ssmx ) THEN ! original condition CALL QVEXCESS(ngs,mgs,qwvp,qv0,qx(1,lc),pres,thetap,theta0,dcloud, & & pi0,tabqvs,nqsat,fqsat,cbw,fcqv1,felvcp,ssmx,pk,ngscnt) @@ -11027,9 +12228,11 @@ SUBROUTINE NUCOND & thetap(mgs) = thetap(mgs) + felvcp(mgs)*DCLOUD/(pi0(mgs)) qwvp(mgs) = qwvp(mgs) - DCLOUD qx(mgs,lc) = qx(mgs,lc) + DCLOUD + IF ( io_flag .and. nxtra > 1 ) THEN axtra(igs(mgs),jy,kgs(mgs),1) = DCLOUD/dtp ENDIF + theta(mgs) = thetap(mgs) + theta0(mgs) temg(mgs) = theta(mgs)*pk(mgs) !( pres(mgs) / poo ) ** cap ! temg(mgs) = theta2temp( theta(mgs), pres(mgs) ) @@ -11040,6 +12243,7 @@ SUBROUTINE NUCOND & qvs(mgs) = pqs(mgs)*tabqvs(ltemq) ELSEIF ( iqvsopt == 1 ) THEN qvs(mgs) = rdorv*esbolton*tabqvs(ltemq)/(pres(mgs) - esbolton*tabqvs(ltemq)) + ENDIF ! es(mgs) = 6.1078e2*tabqvs(ltemq) @@ -11053,11 +12257,11 @@ SUBROUTINE NUCOND & IF ( .not. flag_qndrop ) THEN ! { do not calculate number of droplets if using wrf-chem - IF ( ac_opt == 0 ) THEN + ! IF ( ac_opt == 0 ) THEN cnuctmp = cnuc(mgs) - ELSE - cnuctmp = ccnc_ac(mgs) - ENDIF + ! ELSE + ! cnuctmp = ccnc(mgs) + ! ENDIF ! IF ( ssmax(mgs) .lt. sscb .and. qx(mgs,lc) .gt. qxmin(lc)) THEN IF ( dcloud .gt. qxmin(lc) .and. wvel(mgs) > 0.0) THEN @@ -11090,7 +12294,7 @@ SUBROUTINE NUCOND & ! ccnc(mgs) = 0.0 ENDIF ELSE - cn(mgs) = Min( cn(mgs), ccnc_ac(mgs) ) + cn(mgs) = Min( cn(mgs), ccnc(mgs) ) ENDIF ! cx(mgs,lc) = cx(mgs,lc) + cn(mgs) IF ( irenuc <= 2 .and. lccna < 1 ) ccnc(mgs) = Max(0.0, ccnc(mgs) - cn(mgs)) @@ -11138,8 +12342,10 @@ SUBROUTINE NUCOND & if (ndebug .gt. 0) write(0,*) "ICEZVD_DR: Entered Ziegler Cloud Nucleation" !mpidebug DSSDZ=0. + r2dzm=0.50/dz3d(igs(mgs),jy,kgs(mgs)) + IF ( irenuc >= 0 .and. ac_opt == 0 .and. .not. flag_qndrop ) THEN ! turn off nucleation when flag_qndrop (using WRF-CHEM for activation) IF ( irenuc < 2 ) THEN !{ @@ -11228,6 +12434,7 @@ SUBROUTINE NUCOND & ENDIF IF ( icnuclimit > 0 ) THEN + tmp = ccnc(mgs) + cx(mgs,lc) IF ( tmp < 330.34e6 ) THEN ccwmax = 1.1173e6 * (1.e-6*tmp)**0.9504 @@ -11247,6 +12454,7 @@ SUBROUTINE NUCOND & IF ( lccna < 1 ) ccnc(mgs) = Max(0.0, ccnc(mgs) - cn(mgs)) + ELSEIF ( irenuc == 3 ) THEN !} { ! Phillips Donner Garner 2007 ! if (ndebug .gt. 0) write(0,*) 'ICEZVD_DR: Cloud reNucleation, wvel = ',wvel(mgs) @@ -11311,6 +12519,7 @@ SUBROUTINE NUCOND & qx(mgs,lc) = qx(mgs,lc) + DCLOUD thetap(mgs) = thetap(mgs) + felvcp(mgs)*DCLOUD/(pi0(mgs)) qwvp(mgs) = qwvp(mgs) - DCLOUD + ENDIF ! 6/13/2016: Phillips et al. appears not to decrement CCN, but only increments CCNa. ! This would allow an initially non-homogeneous (vertically, e.g.) initial value of CCN/rho_air @@ -11328,6 +12537,7 @@ SUBROUTINE NUCOND & CN(mgs) = Min( 0.9*cnuc(mgs), CCNE0*cnuc(mgs)**(2./(2.+cck))*Max(0.0,wvel(mgs))**cnexp )! *Min(1.0,1./dtp) ! 0.3465 ! IF ( cn(mgs) + ccna(mgs) > 0.71*cnuc ) THEN ! prevent this branch from activating more than 70% of CCN + CN(mgs) = Min( CN(mgs), Max(0.0, (0.7*cnuc(mgs) - ccna(mgs) )) ) ! CN(mgs) = Min( CN(mgs), Max(0.0, 0.71*ccnc(mgs) - ccna(mgs) ) ) @@ -11352,6 +12562,7 @@ SUBROUTINE NUCOND & ! CN(mgs) = cnuc(mgs)*Min(ssf(mgs),ssfcut)**cck ! + CN(mgs) = Min(0.01*cnuc(mgs), Max( 0.0, CN(mgs) - ccna(mgs) ) ) ! this was from ! cn(mgs) = 0.0 ENDIF @@ -11373,26 +12584,45 @@ SUBROUTINE NUCOND & qx(mgs,lc) = qx(mgs,lc) + DCLOUD thetap(mgs) = thetap(mgs) + felvcp(mgs)*DCLOUD/(pi0(mgs)) qwvp(mgs) = qwvp(mgs) - DCLOUD + ! ccnc(mgs) = Max(0.0, ccnc(mgs) - cn(mgs)) ENDIF + ELSEIF ( irenuc == 5 ) THEN !} { + IF ( isscheck > 0 ) THEN + ! test code; not working yet as intended + ss1 = qv1/qvs1 + ssmx = 100.*0.01 + qvex = 0.0 + + CALL QVEXCESS(ngs,mgs,qwvp,qv0,qx(1,lc),pres,thetap,theta0,qvex, & + & pi0,tabqvs,nqsat,fqsat,cbw,fcqv1,felvcp,ssmx,pk,ngscnt) + + ! dcritcheck = 2.*3.17e-6 + dcloudcheck = 1000.*dcritcheck**3*Pi/6. + cnucmax = rho0(mgs)*qvex/dcloudcheck + ENDIF ! modification of Phillips Donner Garner 2007 ! if (ndebug .gt. 0) write(0,*) 'ICEZVD_DR: Cloud reNucleation, wvel = ',wvel(mgs) ! CN(mgs) = Min( 0.91*cnuc(mgs), CCNE0*cnuc(mgs)**(2./(2.+cck))*Max(0.0,wvel(mgs))**cnexp )! *Min(1.0,1./dtp) ! 0.3465 CN(mgs) = Min( cnuc(mgs), CCNE0*cnuc(mgs)**(2./(2.+cck))*Max(0.0,wvel(mgs))**cnexp ) + IF ( isscheck > 0 ) THEN + cn(mgs) = Min( cn(mgs), cnucmax ) + ENDIF + IF ( ccna(mgs) >= cnuc(mgs) ) THEN ! apply limit after all "base" CCN have been depleted temp1 = (theta0(mgs)+thetap(mgs))*pk(mgs) ! t77(ix,jy,kz) ltemq = Int( (temp1-163.15)/fqsat+1.5 ) ltemq = Min( nqsat, Max(1,ltemq) ) - ! c1= pqs(mgs)*tabqvs(ltemq) IF ( iqvsopt == 0 ) THEN c1 = pqs(mgs)*tabqvs(ltemq) ELSEIF ( iqvsopt == 1 ) THEN c1 = rdorv*esbolton*tabqvs(ltemq)/(pres(mgs) - esbolton*tabqvs(ltemq)) + ENDIF IF ( c1 > 0. ) THEN ssf(mgs) = Max(0.0, 100.*((qv0(mgs) + qwvp(mgs))/c1 - 1.0) ) ! from "new" values @@ -11415,6 +12645,10 @@ SUBROUTINE NUCOND & ! nucleation ! CN(mgs) = Min(cn(mgs), ccnc(mgs)) ! cn(mgs) = Min(cn(mgs), 0.5*dqc/cwmasn) ! limit the nucleation mass to half of the condensation mass + IF ( isscheck > 0 ) THEN + cn(mgs) = Min( cn(mgs), cnucmax ) + + ELSE dcrit = 2.0*2.0e-6 dcloud = 1000.*dcrit**3*Pi/6. ! cn(mgs) = Min(cn(mgs), 0.5*dqc/dcloud) ! limit the nucleation mass to half of the condensation mass @@ -11422,17 +12656,22 @@ SUBROUTINE NUCOND & ! tmp is number of droplets at diameter dcrit tmp = Max(0.0, rho0(mgs)*qx(mgs,lc)/dcloud - cx(mgs,lc)) ! (cx(mgs,lc) + cn(mgs)) cn(mgs) = Min(tmp, cn(mgs) ) + ENDIF IF ( cn(mgs) > 0.0 ) THEN cx(mgs,lc) = cx(mgs,lc) + cn(mgs) - dcrit = 2.5e-7 - - dcloud = 1000.*dcrit**3*Pi/6.*cn(mgs) + IF ( isscheck > 0 ) THEN + dcrit = dcritcheck + ELSE + dcrit = 2.5e-7 + ENDIF + dcloud = 1000.*dcrit**3*Pi/6.*cn(mgs) qx(mgs,lc) = qx(mgs,lc) + DCLOUD thetap(mgs) = thetap(mgs) + felvcp(mgs)*DCLOUD/(pi0(mgs)) qwvp(mgs) = qwvp(mgs) - DCLOUD + ENDIF ! 6/13/2016: Phillips et al. appears not to decrement CCN, but only increments CCNa. ! This would allow an initially non-homogeneous (vertically, e.g.) initial value of CCN/rho_air @@ -11452,6 +12691,7 @@ SUBROUTINE NUCOND & CN(mgs) = Min( (frac+0.01)*cnuc(mgs), CCNE0*cnuc(mgs)**(2./(2.+cck))*Max(0.0,wvel(mgs))**cnexp )! *Min(1.0,1./dtp) ! 0.3465 ! IF ( cn(mgs) + ccna(mgs) > 0.71*cnuc ) THEN ! prevent this branch from activating more than 70% of CCN + CN(mgs) = Min( CN(mgs), Max(0.0, (frac*cnuc(mgs) - ccna(mgs) )) ) ! CN(mgs) = Min( CN(mgs), Max(0.0, 0.71*ccnc(mgs) - ccna(mgs) ) ) ! write(0,*) '1: k,cn = ',kgs(mgs),cn(mgs),ssf(mgs) @@ -11471,11 +12711,11 @@ SUBROUTINE NUCOND & ltemq = Min( nqsat, Max(1,ltemq) ) ! c1 = t00(igs(mgs),jy,kgs(mgs))*tabqvs(ltemq) - ! c1= pqs(mgs)*tabqvs(ltemq) IF ( iqvsopt == 0 ) THEN c1 = pqs(mgs)*tabqvs(ltemq) ELSEIF ( iqvsopt == 1 ) THEN c1 = rdorv*esbolton*tabqvs(ltemq)/(pres(mgs) - esbolton*tabqvs(ltemq)) + ENDIF ssf(mgs) = 0.0 @@ -11501,6 +12741,7 @@ SUBROUTINE NUCOND & ENDIF + ! CN(mgs) = Min( Min(0.1,ssf(mgs)-1.)*cnuc(mgs), Max( 0.0, CN(mgs) - ccna(mgs) ) ) ! this was from ! CN(mgs) = Min( Min(0.5*cx(mgs,lc), Min(0.1,ssf(mgs)/100.)*cnuc(mgs)), Max( 0.0, CN(mgs) - ccna(mgs) ) ) ! this was from @@ -11517,6 +12758,7 @@ SUBROUTINE NUCOND & IF ( icnuclimit > 0 ) THEN ! max droplet conc. based on Chandrakar et al. (2016) and Konwar et al. (2012) + tmp = ccnc(mgs) - ccna(mgs) + cx(mgs,lc) IF ( tmp < 330.34e6 ) THEN ccwmax = 1.1173e6 * (1.e-6*tmp)**0.9504 @@ -11549,6 +12791,7 @@ SUBROUTINE NUCOND & qx(mgs,lc) = qx(mgs,lc) + DCLOUD thetap(mgs) = thetap(mgs) + felvcp(mgs)*DCLOUD/(pi0(mgs)) qwvp(mgs) = qwvp(mgs) - DCLOUD + ! ccnc(mgs) = Max(0.0, ccnc(mgs) - cn(mgs)) ccncuf(mgs) = Max(0.0, ccncuf(mgs) - cnuf(mgs)) ENDIF @@ -11577,11 +12820,11 @@ SUBROUTINE NUCOND & ltemq = Min( nqsat, Max(1,ltemq) ) ! c1 = t00(igs(mgs),jy,kgs(mgs))*tabqvs(ltemq) - !c1= pqs(mgs)*tabqvs(ltemq) IF ( iqvsopt == 0 ) THEN c1 = pqs(mgs)*tabqvs(ltemq) ELSEIF ( iqvsopt == 1 ) THEN c1 = rdorv*esbolton*tabqvs(ltemq)/(pres(mgs) - esbolton*tabqvs(ltemq)) + ENDIF ssf(mgs) = 0.0 @@ -11612,13 +12855,23 @@ SUBROUTINE NUCOND & qx(mgs,lc) = qx(mgs,lc) + DCLOUD thetap(mgs) = thetap(mgs) + felvcp(mgs)*DCLOUD/(pi0(mgs)) qwvp(mgs) = qwvp(mgs) - DCLOUD + ! ccnc(mgs) = Max(0.0, ccnc(mgs) - cn(mgs)) ENDIF ELSEIF ( irenuc == 9 .or. irenuc == 10 ) THEN ! } { + write(0,*) 'irenuc=9 requires nuwrfmods=1' + + + + ELSEIF ( irenuc == 11 ) THEN ! } { + + + write(0,*) 'irenuc=11 requires nuwrfmods=1' + ENDIF ! } @@ -11628,6 +12881,7 @@ SUBROUTINE NUCOND & ENDIF ! irenuc >= 0 .and. .not. flag_qndrop + ! IF( cx(mgs,lc) .GT. 0. .AND. qx(mgs,lc) .LE. qxmin(lc)) cx(mgs,lc)=0. GO TO 631 !.... NUCLEATION ON CLOUD INFLOW BOUNDARY POINT @@ -11662,9 +12916,11 @@ SUBROUTINE NUCOND & IF ( qvex .gt. 0.0 ) THEN thetap(mgs) = thetap(mgs) + felvcp(mgs)*qvex/(pi0(mgs)) + IF ( io_flag .and. nxtra > 1 ) THEN axtra(igs(mgs),jy,kgs(mgs),1) = axtra(igs(mgs),jy,kgs(mgs),1) + qvex/dtp ENDIF + qwvp(mgs) = qwvp(mgs) - qvex qx(mgs,lc) = qx(mgs,lc) + qvex IF ( .not. flag_qndrop) THEN @@ -11786,12 +13042,14 @@ SUBROUTINE NUCOND & ! qx(mgs,lr) = an(igs(mgs),jy,kgs(mgs),lr) end if + IF ( lzr > 1 .and. rcond == 2 ) THEN an(igs(mgs),jy,kgs(mgs),lzr) = zx(mgs,lr) + & & min( an(igs(mgs),jy,kgs(mgs),lzr), 0.0 ) ENDIF + IF ( ipconc .ge. 2 ) THEN an(igs(mgs),jy,kgs(mgs),lnc) = Max(cx(mgs,lc) , 0.0) ! IF ( ac_opt > 10 .and. (cx(mgs,lc) > 0. .or. ccna(mgs) > 0. ) ) THEN @@ -11803,6 +13061,18 @@ SUBROUTINE NUCOND & IF ( lccn .gt. 1 .and. lccna .lt. 1 ) THEN an(igs(mgs),jy,kgs(mgs),lccn) = Max(0.0, ccnc(mgs) ) ENDIF + ELSEIF ( ac_opt == 1 .and. lccn > 1) THEN + an(igs(mgs),jy,kgs(mgs),lccn) = Max( 0.0, ccnc(mgs) ) ! cn are depleted for ac_opt=1 or 2 + ELSEIF ( ac_opt == 11 .and. lccna > 1) THEN + ! an(igs(mgs),jy,kgs(mgs),lccna) = Max( 0.0, ccna(mgs) ) ! done below + ELSEIF ( ac_opt == 2 .and. lccn > 1) THEN + an(igs(mgs),jy,kgs(mgs),lccn) = Max( 0.0, ccnc(mgs) ) + an(igs(mgs),jy,kgs(mgs),lcn_nu) = Max( 0.0, ccnc_nu(mgs) ) + an(igs(mgs),jy,kgs(mgs),lcn_co) = Max( 0.0, ccnc_co(mgs) ) + ELSEIF ( ac_opt == 22 .and. lccna > 1) THEN + ! an(igs(mgs),jy,kgs(mgs),lccna) = Max( 0.0, ccna(mgs) ) ! done below + an(igs(mgs),jy,kgs(mgs),lccnanu) = Max( 0.0, ccnanu(mgs) ) + an(igs(mgs),jy,kgs(mgs),lccnaco) = Max( 0.0, ccnaco(mgs) ) ENDIF IF ( lccnuf .gt. 1 .and. .not. ( lccna .gt. 1 .and. i_uf_or_ccn > 0 ) ) THEN an(igs(mgs),jy,kgs(mgs),lccnuf) = Max(0.0, ccncuf(mgs) ) @@ -11810,7 +13080,7 @@ SUBROUTINE NUCOND & IF ( lccna .gt. 1 ) THEN an(igs(mgs),jy,kgs(mgs),lccna) = Max(0.0, ccna(mgs) ) ENDIF - ENDIF + ENDIF ! ipconc >= 2 IF ( ipconc .ge. 3 .and. rcond == 2 ) THEN an(igs(mgs),jy,kgs(mgs),lnr) = Max(cx(mgs,lr) , 0.0) ENDIF @@ -11843,17 +13113,79 @@ SUBROUTINE NUCOND & ! end of gather scatter (for this jy slice) -!#ifdef COMMAS -! GOTO 9999 -!#endif +! Redistribute inappreciable cloud particles and charge +! +! Redistribution everywhere in the domain... +! +! moved to separate subroutine (below) +! + + + + 9999 RETURN + + END SUBROUTINE NUCOND + + +! ##################################################################### +! ##################################################################### +! Clean up tiny values of mixing ratio +! Redistribute inappreciable cloud particles and charge +! +! Redistribution everywhere in the domain... +! + subroutine smallvalues & + & (nx,ny,nz,na,jyslab & + & ,nor,norz,dtp,nxi & + & ,t0 & + & ,an,dn, w & + + & ,t77,flag_qndrop & + & ) + + + + implicit none + + integer :: nx,ny,nz,na,nxi + integer :: nor,norz, jyslab ! ,nht,ngt,igsr + real :: dtp ! time step + logical,intent(in) :: flag_qndrop + +! +! external temporary arrays +! + real t77(-nor+1:nx+nor,-nor+1:ny+nor,-norz+1:nz+norz) + real t0(-nor+1:nx+nor,-nor+1:ny+nor,-norz+1:nz+norz) + real an(-nor+1:nx+nor,-nor+1:ny+nor,-norz+1:nz+norz,na) + real dn(-nor+1:nx+nor,-nor+1:ny+nor,-norz+1:nz+norz) + real w(-nor+1:nx+nor,-nor+1:ny+nor,-norz+1:nz+norz) + + ! local + + + + logical zerocx(lc:lqmx) + + real :: frac, hwdn, tmpg, xdia1, xdia3, cwch,xvol + + integer ix,kz,i,n, km1 + integer :: il + integer :: jy, jgs + real :: chw, g1, z1, tmp, tmp2, fw, tmpmx, qr + ! Redistribute inappreciable cloud particles and charge ! ! Redistribution everywhere in the domain... ! - IF ( .true. ) THEN - + + jy = 1 + + frac = 1.0 ! 0.25 ! 1.0 ! 0.2 + + cwch = ((3. + alphah)*(2. + alphah)*(1.0 + alphah))**(-1./3.) ! ! alternate test version for ipconc .ge. 3 ! just vaporize stuff to prevent noise in the number concentrations @@ -11873,21 +13205,23 @@ SUBROUTINE NUCOND & ELSE IF ( il == lc ) THEN IF ( ln(il) > 1 ) THEN - zerocx(il) = ( an(ix,jy,kz,ln(il)) <= 0.0 ) .and. .not. flag_qndrop ! do not reset if progn=1 (WRF-CHEM) + zerocx(il) = ( an(ix,jy,kz,ln(il)) < cxmin ) .and. .not. flag_qndrop ! do not reset if progn=1 (WRF-CHEM) ENDIF ELSE - IF ( ln(il) > 1 ) zerocx(il) = ( an(ix,jy,kz,ln(il)) <= 0.0 ) + IF ( ln(il) > 1 ) zerocx(il) = ( an(ix,jy,kz,ln(il)) < cxmin ) ENDIF ENDIF ENDDO IF ( lhl .gt. 1 ) THEN + IF ( lzhl .gt. 1 ) THEN an(ix,jy,kz,lzhl) = Max(0.0, an(ix,jy,kz,lzhl) ) - IF ( an(ix,jy,kz,lhl) .ge. frac*qxmin(lhl) .and. rescale_low_alpha ) THEN ! check 6th moment + IF ( an(ix,jy,kz,lhl) .ge. frac*qxmin(lhl) .and. & + rescale_low_alpha .and. rescale_low_alphahl ) THEN ! check 6th moment IF ( an(ix,jy,kz,lnhl) .gt. 0.0 ) THEN @@ -11919,6 +13253,7 @@ SUBROUTINE NUCOND & ENDIF ENDIF !lzhl + if ( (an(ix,jy,kz,lhl) .lt. frac*qxmin(lhl)) .or. zerocx(lhl) ) then @@ -11947,6 +13282,7 @@ SUBROUTINE NUCOND & an(ix,jy,kz,lzhl) = 0.0 ENDIF + ELSE IF ( lvol(lhl) .gt. 1 ) THEN ! check density IF ( an(ix,jy,kz,lvhl) .gt. 0.0 ) THEN @@ -11994,6 +13330,28 @@ SUBROUTINE NUCOND & ENDIF + IF ( lvhl .gt. 1 ) THEN + IF ( an(ix,jy,kz,lvhl) .gt. 0.0 ) THEN + hwdn = dn(ix,jy,kz)*an(ix,jy,kz,lhl)/an(ix,jy,kz,lvhl) + ELSE + hwdn = xdn0(lhl) + ENDIF + hwdn = Max( xdnmn(lhl), hwdn ) + ELSE + hwdn = xdn0(lhl) + ENDIF + + IF ( ipconc >= 5 .and. an(ix,jy,kz,lhl) .gt. qxmin(lhl) ) THEN + qr = an(ix,jy,kz,lhl) + xvol = dn(ix,jy,kz)*an(ix,jy,kz,lhl)/(hwdn*an(ix,jy,kz,lnhl)) + chw = an(ix,jy,kz,lnhl) + + IF ( xvol .lt. xvmn(lhl) .or. xvol .gt. xvmx(lhl) ) THEN + xvol = Min( xvmx(lhl), Max( xvmn(lhl),xvol ) ) + chw = dn(ix,jy,kz)*an(ix,jy,kz,lhl)/(xvol*hwdn) + an(ix,jy,kz,lnhl) = chw + ENDIF + ENDIF ! CHECK INTERCEPT IF ( ipconc == 5 .and. an(ix,jy,kz,lhl) .gt. qxmin(lhl) .and. alphahl .le. 0.1 .and. lnhl .gt. 1 .and. lzhl == 0 ) THEN @@ -12004,9 +13362,9 @@ SUBROUTINE NUCOND & hwdn = xdn0(lhl) ENDIF tmp = (hwdn*an(ix,jy,kz,lnhl))/(dn(ix,jy,kz)*an(ix,jy,kz,lhl)) - tmpg = an(ix,jy,kz,lnhl)*(tmp*(3.14159))**(1./3.) + tmpg = an(ix,jy,kz,lnhl)*(tmp*pi)**(1./3.) IF ( tmpg .lt. cnohlmn ) THEN - tmp = ( (hwdn)/(dn(ix,jy,kz)*an(ix,jy,kz,lhl))*(3.14159))**(1./3.) + tmp = ( (hwdn)/(dn(ix,jy,kz)*an(ix,jy,kz,lhl))*pi)**(1./3.) an(ix,jy,kz,lnhl) = (cnohlmn/tmp)**(3./4.) ENDIF @@ -12019,11 +13377,14 @@ SUBROUTINE NUCOND & + + IF ( lzh .gt. 1 ) THEN an(ix,jy,kz,lzh) = Max(0.0, an(ix,jy,kz,lzh) ) - IF ( .false. .and. an(ix,jy,kz,lh) .ge. frac*qxmin(lh) .and. rescale_low_alpha ) THEN + IF ( .false. .and. an(ix,jy,kz,lh) .ge. frac*qxmin(lh) .and. & + rescale_low_alpha .and. rescale_low_alphah ) THEN IF ( an(ix,jy,kz,lnh) .gt. 0.0 ) THEN @@ -12056,6 +13417,7 @@ SUBROUTINE NUCOND & ENDIF + if ( (an(ix,jy,kz,lh) .lt. frac*qxmin(lh)) .or. zerocx(lh) ) then ! IF ( an(ix,jy,kz,lh) .gt. 0 ) THEN @@ -12083,6 +13445,7 @@ SUBROUTINE NUCOND & an(ix,jy,kz,lzh) = 0.0 ENDIF + ELSE IF ( lvol(lh) .gt. 1 ) THEN ! check density IF ( an(ix,jy,kz,lvh) .gt. 0.0 ) THEN @@ -12130,9 +13493,6 @@ SUBROUTINE NUCOND & ENDIF -! CHECK INTERCEPT - IF ( ipconc == 5 .and. an(ix,jy,kz,lh) .gt. qxmin(lh) .and. alphah .le. 0.1 .and. lnh .gt. 1 .and. lzh == 0 ) THEN - IF ( lvh .gt. 1 ) THEN IF ( an(ix,jy,kz,lvh) .gt. 0.0 ) THEN hwdn = dn(ix,jy,kz)*an(ix,jy,kz,lh)/an(ix,jy,kz,lvh) @@ -12143,16 +13503,46 @@ SUBROUTINE NUCOND & ELSE hwdn = xdn0(lh) ENDIF + + IF ( ipconc >= 5 .and. an(ix,jy,kz,lh) .gt. qxmin(lh) ) THEN + qr = an(ix,jy,kz,lh) + xvol = dn(ix,jy,kz)*an(ix,jy,kz,lh)/(hwdn*an(ix,jy,kz,lnh)) + chw = an(ix,jy,kz,lnh) + + IF ( xvol .lt. xvmn(lh) .or. xvol .gt. xvmx(lh) ) THEN + xvol = Min( xvmx(lh), Max( xvmn(lh),xvol ) ) + chw = dn(ix,jy,kz)*an(ix,jy,kz,lh)/(xvol*hwdn) + an(ix,jy,kz,lnh) = chw + ENDIF + ENDIF + +! CHECK INTERCEPT + IF ( ipconc == 5 .and. an(ix,jy,kz,lh) .gt. qxmin(lh) .and. alphah .le. 0.1 .and. lnh .gt. 1 .and. lzh == 0 ) THEN + tmp = (hwdn*an(ix,jy,kz,lnh))/(dn(ix,jy,kz)*an(ix,jy,kz,lh)) - tmpg = an(ix,jy,kz,lnh)*(tmp*(3.14159))**(1./3.) + tmpg = an(ix,jy,kz,lnh)*(tmp*pi)**(1./3.) IF ( tmpg .lt. cnohmn ) THEN ! tmpg = an(ix,jy,kz,lnh)*( (hwdn*an(ix,jy,kz,lnh))/(dn(ix,jy,kz)*an(ix,jy,kz,lh))*(3.14159))**(1./3.) ! tmpg = an(ix,jy,kz,lnh)**(4./3.)*( (hwdn)/(dn(ix,jy,kz)*an(ix,jy,kz,lh))*(3.14159))**(1./3.) - tmp = ( (hwdn)/(dn(ix,jy,kz)*an(ix,jy,kz,lh))*(3.14159))**(1./3.) + tmp = ( (hwdn)/(dn(ix,jy,kz)*an(ix,jy,kz,lh))*pi)**(1./3.) an(ix,jy,kz,lnh) = (cnohmn/tmp)**(3./4.) ENDIF ENDIF + + IF ( ipconc == 5 .and. imorrgdnglimit == 1 ) THEN + ! limit on characteristic diameter (i.e., 1/slope) + xdia3 = (xvol*6.*piinv)**(1./3.) + xdia1 = cwch*xdia3 + IF ( xdia1 > morrdnglimit ) THEN + xdia1 = morrdnglimit + xvol = pi/6.0*(xdia1/cwch)**3 + chw = dn(ix,jy,kz)*qr/(xvol*hwdn) + an(ix,jy,kz,lnh) = chw + xdia3 = (xvol*6.*piinv)**(1./3.) + ENDIF + + ENDIF end if @@ -12199,6 +13589,7 @@ SUBROUTINE NUCOND & ENDIF + ELSEIF ( lvol(ls) .gt. 1 ) THEN ! check density IF ( an(ix,jy,kz,lvs) .gt. 0.0 ) THEN tmp = dn(ix,jy,kz)*an(ix,jy,kz,ls)/an(ix,jy,kz,lvs) @@ -12214,10 +13605,12 @@ SUBROUTINE NUCOND & end if + IF ( lzr > 1 ) THEN an(ix,jy,kz,lzr) = Max(0.0, an(ix,jy,kz,lzr) ) ENDIF + if ( (an(ix,jy,kz,lr) .lt. frac*qxmin(lr)) .or. zerocx(lr) ) then an(ix,jy,kz,lv) = an(ix,jy,kz,lv) + an(ix,jy,kz,lr) an(ix,jy,kz,lr) = 0.0 @@ -12226,14 +13619,17 @@ SUBROUTINE NUCOND & an(ix,jy,kz,lnr) = 0.0 ENDIF + IF ( lzr > 1 ) THEN an(ix,jy,kz,lzr) = 0.0 ENDIF + + end if ! -! for qci +! for qi ! IF ( (an(ix,jy,kz,li) .le. frac*qxmin(li)) .or. zerocx(li) ) THEN an(ix,jy,kz,lv) = an(ix,jy,kz,lv) + an(ix,jy,kz,li) @@ -12241,36 +13637,24 @@ SUBROUTINE NUCOND & IF ( ipconc .ge. 1 ) THEN an(ix,jy,kz,lni) = 0.0 ENDIF - ENDIF -! -! for qis -! - IF ( lis > 1 ) THEN ! { - IF ( (an(ix,jy,kz,lis) .le. frac*qxmin(lis)) .or. zerocx(lis) & ! .or. an(ix,jy,kz,lni) .lt. 0.1 - & ) THEN ! { { - an(ix,jy,kz,lv) = an(ix,jy,kz,lv) + an(ix,jy,kz,lis) - an(ix,jy,kz,lis)= 0.0 - IF ( ipconc .ge. 1 ) THEN - an(ix,jy,kz,lnis) = 0.0 - ENDIF - - ELSEIF ( icespheres >= 2 ) THEN ! } { - km1 = Max(1, kz-1) - IF ( 0.5*( w(ix,jy,kz) + w(ix,jy,kz+1)) < -1.0 .or. & - & (icespheres == 3 .and. ( t0(ix,jy,kz) < 232.15 .or. an(ix,jy,kz,lc) < qxmin(lc) ) ) .or. & - & (icespheres == 5 .and. ( t0(ix,jy,kz) < 232.15 .or. & - & ( an(ix,jy,kz,lc) < qxmin(lc) .and. an(ix,jy,km1,lc) < qxmin(lc) )) ) .or. & - & (icespheres == 4 .and. ( t0(ix,jy,kz) < 235.15 )) ) THEN ! transfer to regular ice crystals in downdraft or at low temp - an(ix,jy,kz,li) = an(ix,jy,kz,li) + an(ix,jy,kz,lis) - an(ix,jy,kz,lni) = an(ix,jy,kz,lni) + an(ix,jy,kz,lnis) - an(ix,jy,kz,lis)= 0.0 - an(ix,jy,kz,lnis)= 0.0 - - ENDIF - - ENDIF ! } } - ENDIF ! } + IF ( restoreccn ) THEN + tmp = an(ix,jy,kz,li) + an(ix,jy,kz,ls) + an(ix,jy,kz,lc) + IF ( tmp < qxmin(li) ) THEN + IF ( lcina > 0 ) THEN + IF ( an(ix,jy,kz,lcina) > 0. .and. tmp < qxmin(li) ) THEN + an(ix,jy,kz,lcina) = an(ix,jy,kz,lcina)*Exp(-dtp/ccntimeconst) + ENDIF + ENDIF + IF ( lcinda > 0 ) THEN + IF ( an(ix,jy,kz,lcinda) > 0. .and. tmp < qxmin(li) ) THEN + an(ix,jy,kz,lcinda) = an(ix,jy,kz,lcinda)*Exp(-dtp/ccntimeconst) + ENDIF + ENDIF + ENDIF + ENDIF + ENDIF ! qi + ! ! for qcw @@ -12284,37 +13668,66 @@ SUBROUTINE NUCOND & IF ( irenuc < 5 .and. lccna <= 1 ) THEN IF ( ac_opt == 0 ) THEN an(ix,jy,kz,lccn) = an(ix,jy,kz,lccn) + Max(0.0,an(ix,jy,kz,lnc)) + ELSEIF ( lccn > 1 ) THEN + an(ix,jy,kz,lccn) = an(ix,jy,kz,lccn) + Max(0.0,an(ix,jy,kz,lnc)) ENDIF ELSEIF ( lccna > 1 ) THEN - an(ix,jy,kz,lccna) = Max( 0.0, an(ix,jy,kz,lccna) - Max(0.0,an(ix,jy,kz,lnc)) ) + tmp = Max(0.0,an(ix,jy,kz,lnc)) + IF ( lccnaco > 1 .and. lccnanu > 1 ) THEN + ! restore CCN proportionally to each type, although coarse are presumably already lost to rain + tmp2 = an(ix,jy,kz,lccna) + an(ix,jy,kz,lccnaco) + an(ix,jy,kz,lccnanu) + IF ( tmp2 > 0.0 .and. tmp > 0.0 ) THEN + an(ix,jy,kz,lccna) = Max( 0.0, an(ix,jy,kz,lccna) - tmp*an(ix,jy,kz,lccna)/tmp2 ) + an(ix,jy,kz,lccnaco) = Max( 0.0, an(ix,jy,kz,lccnaco) - tmp*an(ix,jy,kz,lccnaco)/tmp2 ) + an(ix,jy,kz,lccnanu) = Max( 0.0, an(ix,jy,kz,lccnanu) - tmp*an(ix,jy,kz,lccnanu)/tmp2 ) + ENDIF + ELSE + an(ix,jy,kz,lccna) = Max( 0.0, an(ix,jy,kz,lccna) - tmp ) + ENDIF ENDIF ENDIF an(ix,jy,kz,lnc) = 0.0 IF ( lccn > 1 ) an(ix,jy,kz,lccn) = Max( 0.0, an(ix,jy,kz,lccn) ) - IF ( lccna > 0 .and. ac_opt == 0 ) THEN ! apply exponential decay to activated CCN to restore to environmental value +! IF ( lccna > 0 .and. ac_opt == 0 ) THEN ! apply exponential decay to activated CCN to restore to environmental value + IF ( lccna > 0 .and. .not. (ac_opt == 1 .or. ac_opt == 2) ) THEN ! apply exponential decay to activated CCN to restore to environmental value IF ( restoreccn ) THEN tmp = an(ix,jy,kz,li) + an(ix,jy,kz,ls) - - IF ( an(ix,jy,kz,lccna) > 1. .and. tmp < qxmin(li) ) an(ix,jy,kz,lccna) = an(ix,jy,kz,lccna)*Exp(-dtp/ccntimeconst) + IF ( tmp < qxmin(li) ) THEN + IF ( an(ix,jy,kz,lccna) > 1. .and. tmp < qxmin(li) ) an(ix,jy,kz,lccna) = an(ix,jy,kz,lccna)*Exp(-dtp/ccntimeconst) + IF ( lccnaco > 1 ) an(ix,jy,kz,lccnaco) = an(ix,jy,kz,lccnaco)*Exp(-dtp/ccntimeconst) + IF ( lccnanu > 1 ) an(ix,jy,kz,lccnanu) = an(ix,jy,kz,lccnanu)*Exp(-dtp/ccntimeconst) + ENDIF ENDIF - ELSEIF ( lccn > 1 .and. restoreccn .and. ac_opt == 0 ) THEN + ELSEIF ( lccn > 1 .and. restoreccn .and. ac_opt <= 2 ) THEN ! in this case, we are treating the ccn field as ccna tmp = an(ix,jy,kz,li) + an(ix,jy,kz,ls) ! IF ( ny == 2 .and. ix == nx/2 ) THEN ! write(0,*) 'restore: k, qccn,exp = ',kz,qccn,dn(ix,jy,kz)*qccn,Exp(-dtp/ccntimeconst) ! write(0,*) 'ccn1,ccn2 = ',an(ix,jy,kz,lccn),dn(ix,jy,kz)*qccn - Max(0.0 , dn(ix,jy,kz)*qccn - an(ix,jy,kz,lccn))*Exp(-dtp/ccntimeconst) ! ENDIF - IF ( an(ix,jy,kz,lccn) > 1. .and. tmp < qxmin(li) .and. ( an(ix,jy,kz,lccn) < dn(ix,jy,kz)*qccn .or. .not. invertccn ) ) THEN + IF ( tmp < qxmin(li) ) THEN + IF ( an(ix,jy,kz,lccn) > 1. .and. & + ( an(ix,jy,kz,lccn) < dn(ix,jy,kz)*qccn .or. .not. invertccn ) ) THEN ! an(ix,jy,kz,lccn) = & ! an(ix,jy,kz,lccn) + Max(0.0 , dn(ix,jy,kz)*qccn - an(ix,jy,kz,lccn))*(1.0 - Exp(-dtp/ccntimeconst)) ! Equivalent form after expanding last term: - an(ix,jy,kz,lccn) = & - dn(ix,jy,kz)*qccn - Max(0.0 , dn(ix,jy,kz)*qccn - an(ix,jy,kz,lccn))*Exp(-dtp/ccntimeconst) + tmp = an(ix,jy,kz,lccn) + an(ix,jy,kz,lccn) = Max( tmp, & + dn(ix,jy,kz)*qccn - Max(0.0 , dn(ix,jy,kz)*qccn - an(ix,jy,kz,lccn))*Exp(-dtp/ccntimeconst) ) + ! write(0,*) 'restore: ',ix,kz, tmp, an(ix,jy,kz,lccn),an(ix,jy,kz,lccn)-tmp ENDIF + IF ( ac_opt == 2 .and. lcn_co > 1 .and. lcn_nu > 1 ) THEN + an(ix,jy,kz,lcn_co) = & + dn(ix,jy,kz)*qccnco - Max(0.0 , dn(ix,jy,kz)*qccnco - an(ix,jy,kz,lcn_co))*Exp(-dtp/ccntimeconst) + an(ix,jy,kz,lcn_nu) = & + dn(ix,jy,kz)*qccnnu - Max(0.0 , dn(ix,jy,kz)*qccnnu - an(ix,jy,kz,lcn_nu))*Exp(-dtp/ccntimeconst) + ENDIF + ENDIF ! tmp < qxmin ENDIF + ENDIF ENDIF @@ -12323,20 +13736,13 @@ SUBROUTINE NUCOND & ! end do end do - ENDIF ! true/false - IF ( ndebug .ge. 1 ) write(6,*) 'END OF ICEZVD_DR' -! -! - - - 9999 RETURN - - END SUBROUTINE NUCOND + end subroutine smallvalues + + + -! ##################################################################### -! ##################################################################### @@ -12351,7 +13757,7 @@ subroutine nssl_2mom_gs & & (nx,ny,nz,na,jyslab & & ,nor,norz & & ,dtp,gz & - & ,t0,t1,t2,t3,t4,t5,t6,t7,t8,t9 & + & ,t0,t1,t2,t3,t4,t5,t6,t7,t8,t9,t7d & & ,an,dn,p2 & & ,pn,w,iunit & & ,t00,t77, & @@ -12360,13 +13766,17 @@ subroutine nssl_2mom_gs & ! & ln,ipc,lvol,lz,lliq, & & cdx, & & xdn0,tmp3d,tkediss & + & ,thproc,numproc,dx1,dy1,ngs & & ,timevtcalc,axtra,io_flag & & , has_wetscav,rainprod2d, evapprod2d, alpha2d & + & ,elec,its,ids,ide,jds,jde & & ) + + ! !-------------------------------------------------------------------------- ! @@ -12436,6 +13846,7 @@ subroutine nssl_2mom_gs & logical, intent(in) :: io_flag + integer itile,jtile,ktile integer ixbeg,jybeg integer ixend,jyend,kzend,kzbeg @@ -12449,12 +13860,17 @@ subroutine nssl_2mom_gs & real rainprod2d(-nor+1:nx+nor,-norz+ng1:nz+norz) real evapprod2d(-nor+1:nx+nor,-norz+ng1:nz+norz) + - real :: alpha2d(-nor+1:nx+nor,-norz+ng1:nz+norz,3) - real, parameter :: tfrdry = 243.15 + real :: alpha2d(-nor+1:nx+nor,-norz+ng1:nz+norz,4) + + + real, parameter :: tfrdry = 243.15 + logical lrescalelow(lc:lhab) + real tkediss(-nor+1:nx+nor,-norz+ng1:nz+norz) real axtra(-nor+ng1:nx+nor,-nor+ng1:ny+nor,-norz+ng1:nz+norz,nxtra) @@ -12485,12 +13901,15 @@ subroutine nssl_2mom_gs & logical, parameter :: gammacheck = .false. integer :: luindex double precision :: tmpgam + logical, parameter :: usegamxinfcnu = .false. logical, parameter :: usegamxinf = .false. logical, parameter :: usegamxinf2 = .false. logical, parameter :: usegamxinf3 = .false. + ! real rar ! rime accretion rate as calculated from qxacw + ! a few vars for time-split fallout real vtmax integer n,ndfall @@ -12502,7 +13921,9 @@ subroutine nssl_2mom_gs & real pb(-norz+ng1:nz+norz) real pinit(-norz+ng1:nz+norz) + real gz(-nor+ng1:nx+nor,-nor+ng1:ny+nor,-norz+ng1:nz+norz) ! dz + real qimax,xni0,roqi0 @@ -12522,7 +13943,7 @@ subroutine nssl_2mom_gs & integer i,j,k,i1 integer kzb,kze real slope1, slope2 - real x1, x2, x3 + real x1, x2, x3, y1 real eps,eps2 parameter (eps=1.e-20,eps2=1.e-5) ! @@ -12583,6 +14004,7 @@ subroutine nssl_2mom_gs & real t7(-nor+ng1:nx+nor,-nor+ng1:ny+nor,-norz+ng1:nz+norz) real t8(-nor+ng1:nx+nor,-nor+ng1:ny+nor,-norz+ng1:nz+norz) real t9(-nor+ng1:nx+nor,-nor+ng1:ny+nor,-norz+ng1:nz+norz) + real t7d(-nor+ng1:nx+nor,-nor+ng1:ny+nor,-norz+ng1:nz+norz) real p2(-nor+1:nx+nor,-nor+1:ny+nor,-norz+ng1:nz+norz) ! perturbation Pi real pn(-nor+1:nx+nor,-nor+1:ny+nor,-norz+ng1:nz+norz) @@ -12597,6 +14019,7 @@ subroutine nssl_2mom_gs & ! integer nxmpb,nzmpb,nxz integer jgs,mgs,ngs,numgs + integer, parameter :: ngsz = 500 integer ntt parameter (ntt=300) @@ -12623,7 +14046,8 @@ subroutine nssl_2mom_gs & ! - real ccnc(ngs),ccin(ngs),cina(ngs),ccna(ngs) + real ccnc(ngs),ccin(ngs),cina(ngs),ccna(ngs),cinda(ngs) + real cwnccn(ngs) real sscb ! 'cloud base' SS threshold parameter ( sscb = 2.0 ) @@ -12633,8 +14057,6 @@ subroutine nssl_2mom_gs & ! =0 to use ad to calculate SS ! =1 to use an at end of main jy loop to calculate SS parameter (iba = 1) - integer ifilt ! =1 to filter ssat, =0 to set ssfilt=ssat - parameter ( ifilt = 0 ) real temp1,temp2 ! ,ssold real :: mwat, mice, dice, mwshed, fwmax, fw, mwcrit, massfactor, tmpdiam real, parameter :: shedalp = 3. ! set 3 for maximum mass diameter (same as area-weighted diameter), 4 for mass-weighted diameter @@ -12657,12 +14079,13 @@ subroutine nssl_2mom_gs & real, parameter :: mfrag = 1.0e-10 ! assumed ice fragment mass for collisional splintering (Schuur & Rutledge 00b) double precision cautn(ngs), rh(ngs), nh(ngs) real ex1, ft, rhoinv(ngs) - double precision ec0(ngs) + real :: ec0(ngs) - real ac1,bc, taus, c1,d1,e1,f1,p380,tmp,tmp1,tmp2,tmp3,tmp4,tmp5,tmp6,temp3 ! , sstdy, super - real :: flim + real ac1,bc, c1,d1,e1,f1,p380,tmp,tmp1,tmp2,tmp3,tmp4,tmp5,tmp6,temp3 ! , sstdy, super + real :: flim, xmass real dw,dwr double precision :: tmpz, tmpzmlt + real :: tmpc real ratio, delx, dely real dbigg,volt real chgtmp,fac,mixedphasefac @@ -12752,6 +14175,7 @@ subroutine nssl_2mom_gs & real gf73rds, gf83rds real gamice73fac, gamsnow73fac real gf43rds, gf53rds + real aradcw,bradcw,cradcw,dradcw,cwrad,rwrad,rwradmn parameter ( rwradmn = 50.e-6 ) real dh0 @@ -12815,6 +14239,7 @@ subroutine nssl_2mom_gs & real :: qxmxd(ngs,lv:lhab) real :: scx(ngs,lc:lhab) real :: xv(ngs,lc:lhab) + real :: vtxbar(ngs,lc:lhab,3) real :: xmas(ngs,lc:lhab) real :: xdn(ngs,lc:lhab) @@ -12829,11 +14254,13 @@ subroutine nssl_2mom_gs & real :: alpha(ngs,lc:lhab) real :: dab0lh(ngs,lc:lhab,lc:lhab) real :: dab1lh(ngs,lc:lhab,lc:lhab) + real :: zx(ngs,lr:lhab) real :: zxmxd(ngs,lr:lhab) + real :: g1x(ngs,lr:lhab) - + real :: g1xmax,g1xmin real :: qsimxdep(ngs) ! max sublimation of qi+qs+qis real :: qsimxsub(ngs) ! max depositionof qi+qs+qis logical,parameter :: DoSublimationFix = .true. @@ -12856,9 +14283,10 @@ subroutine nssl_2mom_gs & real :: qhgt10mm ! mass greater than 10mm real :: qhgt20mm ! mass greater than 20mm real :: fwmhtmp - real, parameter :: fwmhtmptem = -15. ! temperature at which fwmhtmp fully switches to liquid water only being on large particles +! real, parameter :: fwmhtmptem = -15. ! temperature at which fwmhtmp fully switches to liquid water only being on large particles real, parameter :: d1t = (6.0 * 0.268e-3/(917.* pi))**(1./3.) ! d1t is the diameter of the ice sphere with the mass (0.268e-3 kg) of an 8mm spherical drop real, parameter :: srasheym = 0.1389 ! slope fraction from Rasmussen and Heymsfield + real :: dtmp ! real swvent(ngs),hwvent(ngs),rwvent(ngs),hlvent(ngs),hwventy(ngs),hlventy(ngs),rwventz(ngs) real hxventtmp @@ -12904,12 +14332,16 @@ subroutine nssl_2mom_gs & real qvimxd(ngs) real qimxd(ngs),qismxd(ngs),qcmxd(ngs),qrmxd(ngs),qsmxd(ngs),qhmxd(ngs),qhlmxd(ngs) real cimxd(ngs),ccmxd(ngs),crmxd(ngs),csmxd(ngs),chmxd(ngs) + real cionpmxd(ngs),cionnmxd(ngs) real clionpmxd(ngs),clionnmxd(ngs) + + real elec(-nor+ng1:nx+nor,-nor+ng1:ny+nor,-norz+ng1:nz+norz) ! Ez (elecsave) + ! ! ! Hallett-Mossop arrays @@ -12925,11 +14357,12 @@ subroutine nssl_2mom_gs & ! real :: chlcnh(ngs), vhlcnh(ngs), vhlcnhl(ngs) real :: chlcnhhl(ngs) ! number of new hail particles (may be different from number of lost graupel) - real cracif(ngs), ciacrf(ngs) + real ciacrf(ngs) ! cracif(ngs), real cracr(ngs) ! - real ciint(ngs), crfrz(ngs), crfrzf(ngs), crfrzs(ngs) + real ciint(ngs), crfrz(ngs), crfrzf(ngs), crfrzs(ngs), cidint(ngs) + real ciintd(ngs), qiintd(ngs) ! IN activation by droplet freezing real cicint(ngs) real cipint(ngs) real ciacw(ngs), cwacii(ngs) @@ -12956,6 +14389,7 @@ subroutine nssl_2mom_gs & real chlshr(ngs), chlshrr(ngs) + real chdpv(ngs),chsbv(ngs) real chmlr(ngs),chcev(ngs) real chmlrr(ngs) @@ -12975,16 +14409,21 @@ subroutine nssl_2mom_gs & ! ! real qrcnw(ngs), qwcnr(ngs) + real zrcnw(ngs),zracr(ngs),zracw(ngs),zrcev(ngs) + real qracw(ngs) ! qwacr(ngs), real qiacw(ngs) !, qwaci(ngs) + real qsacw(ngs) ! ,qwacs(ngs), real qhacw(ngs) ! qwach(ngs), real :: qhlacw(ngs), qxacwtmp, qxacrtmp, qxacitmp, qxacstmp ! + real :: cxacstmp,cxacitmp real vhacw(ngs), vsacw(ngs), vhlacw(ngs), vhlacr(ngs) + real qfcev(ngs) real qfmul1(ngs),cfmul1(ngs) ! @@ -13009,6 +14448,7 @@ subroutine nssl_2mom_gs & ! real qsaci(ngs) real qsacis(ngs) + real csacis(ngs) real qhaci(ngs) real qhacs(ngs) @@ -13017,6 +14457,7 @@ subroutine nssl_2mom_gs & real :: chacis0(ngs) real :: csaci0(ngs) ! collision rate only + real :: csacis0(ngs) ! collision rate only real :: chaci0(ngs) ! collision rate only real :: chacs0(ngs) ! collision rate only real :: chlaci0(ngs) @@ -13039,7 +14480,7 @@ subroutine nssl_2mom_gs & ! ! conversions ! - real qrfrz(ngs) ! , qirirhr(ngs) + real qrfrz(ngs), qrfrzfrac(ngs) ! , qirirhr(ngs) real zrfrz(ngs), zrfrzf(ngs), zrfrzs(ngs) real ziacrf(ngs), zhcnsh(ngs), zhcnih(ngs) real zhacw(ngs), zhacs(ngs), zhaci(ngs) @@ -13077,16 +14518,18 @@ subroutine nssl_2mom_gs & real qhcns(ngs), chcns(ngs), chcnsh(ngs), vhcns(ngs) real qscnh(ngs), cscnh(ngs), vscnh(ngs) real qhcni(ngs), chcni(ngs), chcnih(ngs), vhcni(ngs) - real qiint(ngs),qipipnt(ngs),qicicnt(ngs) - real cninm(ngs),cnina(ngs),cninp(ngs),wvel(ngs),wvelkm1(ngs) + real qiint(ngs),qipipnt(ngs),qicicnt(ngs),qidint(ngs),qiintv(ngs) + real cninm(ngs),cnina(ngs),cninp(ngs),wvel(ngs),wvelkm1(ngs),cninda(ngs) real tke(ngs) real uvel(ngs),vvel(ngs) ! real qidpv(ngs),qisbv(ngs) ! qicnv(ngs),qievv(ngs), + real qimlr(ngs),qidsv(ngs),qisdsv(ngs),qidsvp(ngs) ! ,qicev(ngs) real qismlr(ngs) ! + ! real :: qhldpv(ngs), qhlsbv(ngs) ! qhlcnv(ngs),qhlevv(ngs), real :: qhlmlr(ngs), qhldsv(ngs), qhlmlrsave(ngs) @@ -13167,7 +14610,7 @@ subroutine nssl_2mom_gs & real ehxw(ngs),ehlw(ngs),egmw(ngs),ehw(ngs) real err(ngs),esr(ngs),eglr(ngs),eghr(ngs),efr(ngs) real ehxr(ngs),ehlr(ngs),egmr(ngs) - real eri(ngs),esi(ngs),egli(ngs),eghi(ngs),efi(ngs),efis(ngs) + real eri(ngs),esi(ngs),esis(ngs),egli(ngs),eghi(ngs),efi(ngs),efis(ngs) real ehxi(ngs),ehli(ngs),egmi(ngs),ehi(ngs),ehis(ngs),ehlis(ngs) real ers(ngs),ess(ngs),egls(ngs),eghs(ngs),efs(ngs),ehs(ngs),ehsfac(ngs) real ehscnv(ngs) @@ -13176,7 +14619,7 @@ subroutine nssl_2mom_gs & real ehsclsn(ngs),ehiclsn(ngs),ehisclsn(ngs) real efsclsn(ngs),eficlsn(ngs),efisclsn(ngs) real ehlsclsn(ngs),ehliclsn(ngs),ehlisclsn(ngs) - real esiclsn(ngs) + real esiclsn(ngs),esisclsn(ngs) real :: ehs_collsn = 0.5, ehi_collsn = 1.0 real :: efs_collsn = 0.5, efi_collsn = 1.0 @@ -13233,6 +14676,7 @@ subroutine nssl_2mom_gs & real pqlwlghi(ngs),pqlwlghli(ngs) real pqlwlghd(ngs),pqlwlghld(ngs) + @@ -13411,6 +14855,7 @@ subroutine nssl_2mom_gs & integer :: infdo real tau, ewtmp + integer cntnic_noliq real q_noliqmn, q_noliqmx @@ -13420,8 +14865,10 @@ subroutine nssl_2mom_gs & ! arrays for temporary bin space + real :: xden,xmlt,cmlt,cmlttot,fventm,fventh,am,ah,felfinv,dmwdt + real :: qhmlrtmp,qhmlrtmp2, chmlrtmp, chmlrtmpd1inf, chlmlrtmp, zhlmlrtmp, zhlmlrrtmp, qvs0,tmpcmlt real :: term1,term2,term3,term4 @@ -13433,15 +14880,20 @@ subroutine nssl_2mom_gs & real, parameter :: c1hl=3.7, c2hl=0.3, c3hl=9.0, c4hl=6.5, c5hl=1.0, c6hl=6.5 ! Hail + ! inline functions for Newton method - real :: galpha, dgalpha + real :: a_in logical, parameter :: newton = .false. - galpha(a_in) = ((4. + a_in)*(5. + a_in)*(6. + a_in))/((1. + a_in)*(2. + a_in)*(3. + a_in)) - dgalpha(a_in) = (876. + 1260.*a_in + 621.*a_in**2 + 126.*a_in**3 + 9.*a_in**4)/ & - & (36. + 132.*a_in + 193.*a_in**2 + 144.*a_in**3 + 58.*a_in**4 + 12.*a_in**5 + a_in**6) + + + +! galpha(a_in) = ((4. + a_in)*(5. + a_in)*(6. + a_in))/((1. + a_in)*(2. + a_in)*(3. + a_in)) +! dgalpha(a_in) = (876. + 1260.*a_in + 621.*a_in**2 + 126.*a_in**3 + 9.*a_in**4)/ & +! & (36. + 132.*a_in + 193.*a_in**2 + 144.*a_in**3 + 58.*a_in**4 + 12.*a_in**5 + a_in**6) + ! ! #################################################################### ! @@ -13453,6 +14905,7 @@ subroutine nssl_2mom_gs & ! + pb(:) = 0.0 pinit(:) = 0.0 itile = nx @@ -13471,6 +14924,8 @@ subroutine nssl_2mom_gs & jstag = 0 kstag = 1 + + lrescalelow(:) = rescale_low_alpha lrescalelow(lr) = rescale_low_alphar .and. rescale_low_alpha lrescalelow(lh) = rescale_low_alphah .and. rescale_low_alpha @@ -13478,6 +14933,7 @@ subroutine nssl_2mom_gs & IF ( lhl > 1 ) lrescalelow(lhl) = rescale_low_alphahl .and. rescale_low_alpha + ! ! slope intercepts ! @@ -13500,7 +14956,9 @@ subroutine nssl_2mom_gs & ENDDO + ffrzh = 1 + ! DO il = lc,lhab ! write(iunit,*) 'delqnxa(',il,') = ',delqnxa(il) ! ENDDO @@ -13664,10 +15122,12 @@ subroutine nssl_2mom_gs & mltdiam(ndiam+4) = mltdiam4 !200.0e-3 ENDIF + kzb = 1 kze = ktile ! if (kzend .eq. nzend) kze = kzend-kzbeg+1-kstag + ! ! cw constants in mks units ! @@ -13704,6 +15164,7 @@ subroutine nssl_2mom_gs & iend = 0 + ! timetd1 = etime(tarray) ! timetd1 = tarray(1) @@ -13768,6 +15229,7 @@ subroutine nssl_2mom_gs & qvs(1) = pqs(1)*tabqvs(ltemq) ELSEIF ( iqvsopt == 1 ) THEN qvs(1) = rdorv*esbolton*tabqvs(ltemq)/(pres(1) - esbolton*tabqvs(ltemq)) + ENDIF IF ( iqis0 == 1 .or. temg(1) <= tfr+0.5 ) THEN @@ -13789,6 +15251,7 @@ subroutine nssl_2mom_gs & ENDIF + if ( an(ix,jy,kz,lv) .gt. qss(1) .or. & & an(ix,jy,kz,lc) .gt. qxmin(lc) .or. & @@ -13810,10 +15273,12 @@ subroutine nssl_2mom_gs & if ( ndebug .gt. 0 ) write(0,*) 'ICEZVD_GS: dbg = 5, ngscnt = ',ngscnt + ! write(0,*) 'allocating qc' xv(:,:) = 0.0 + xmas(:,:) = 0.0 vtxbar(:,:,:) = 0.0 xdia(:,:,:) = 0.0 @@ -13829,11 +15294,15 @@ subroutine nssl_2mom_gs & ! ! define temporaries for state variables to be used in calculations ! + if ( ndebug .gt. 0 ) write(0,*) 'ICEZVD_GS: dbg = def temps' + do mgs = 1,ngscnt + kgsm(mgs) = max(kgs(mgs)-1,1) kgsp(mgs) = min(kgs(mgs)+1,nz-1) kgsm2(mgs) = Max(kgs(mgs)-2,1) + theta0(mgs) = an(igs(mgs),jy,kgs(mgs),lt) thetap(mgs) = an(igs(mgs),jy,kgs(mgs),lt) - theta0(mgs) theta(mgs) = an(igs(mgs),jy,kgs(mgs),lt) @@ -13860,6 +15329,7 @@ subroutine nssl_2mom_gs & qvs(mgs) = pqs(mgs)*tabqvs(ltemq) ELSEIF ( iqvsopt == 1 ) THEN qvs(mgs) = rdorv*esbolton*tabqvs(ltemq)/(pres(mgs) - esbolton*tabqvs(ltemq)) + ENDIF IF ( iqis0 == 1 .or. temg(mgs) <= tfr+0.5 ) THEN @@ -13878,6 +15348,9 @@ subroutine nssl_2mom_gs & if ( temg(mgs) .lt. tfr ) then il5(mgs) = 1 end if + + qrfrzfrac(mgs) = 1.0 + enddo !mgs IF ( ipconc < 1 .and. lwsm6 ) THEN @@ -13909,13 +15382,17 @@ subroutine nssl_2mom_gs & + + ! ! set concentrations ! ! ssmax = 0.0 + if ( ndebug .gt. 0 .and. my_rank>=0 ) write(0,*) 'ICEZVD_GS: dbg = 5b' + if ( ipconc .ge. 1 ) then do mgs = 1,ngscnt @@ -13924,11 +15401,19 @@ subroutine nssl_2mom_gs & cx(mgs,li) = 0.0 ENDIF + IF ( lcina .gt. 1 ) THEN cina(mgs) = an(igs(mgs),jy,kgs(mgs),lcina) ELSE cina(mgs) = cx(mgs,li) ENDIF + + IF ( lcinda .gt. 1 ) THEN + cinda(mgs) = an(igs(mgs),jy,kgs(mgs),lcinda) + ELSE + cinda(mgs) = cx(mgs,li) + ENDIF + IF ( lcin > 1 ) THEN ccin(mgs) = an(igs(mgs),jy,kgs(mgs),lcin) ENDIF @@ -13949,6 +15434,7 @@ subroutine nssl_2mom_gs & ELSE ccnc(mgs) = 0.0 ENDIF + IF ( lccna .gt. 1 ) THEN ccna(mgs) = an(igs(mgs),jy,kgs(mgs),lccna) ELSE @@ -13994,6 +15480,7 @@ subroutine nssl_2mom_gs & end do end if if ( ipconc .ge. 5 ) then + do mgs = 1,ngscnt cx(mgs,lh) = Max(an(igs(mgs),jy,kgs(mgs),lnh), 0.0) @@ -14015,12 +15502,14 @@ subroutine nssl_2mom_gs & ENDIF + end do end if if ( lhl .gt. 1 .and. ipconc .ge. 5 ) then + do mgs = 1,ngscnt cx(mgs,lhl) = Max(an(igs(mgs),jy,kgs(mgs),lnhl), 0.0) @@ -14042,6 +15531,7 @@ subroutine nssl_2mom_gs & ENDIF + end do end if @@ -14076,6 +15566,9 @@ subroutine nssl_2mom_gs & + + + ! ! 6th moments ! @@ -14092,8 +15585,16 @@ subroutine nssl_2mom_gs & ENDIF + + IF ( ipconc .ge. 6 ) THEN + tmp = alphamax - 1.0 + g1xmax = (6.0 + tmp)*(5.0 + tmp)*(4.0 + tmp)/ & + & ((3.0 + tmp)*(2.0 + tmp)*(1.0 + tmp)) + g1xmin = (6.0 + alphamin)*(5.0 + alphamin)*(4.0 + alphamin)/ & + & ((3.0 + alphamin)*(2.0 + alphamin)*(1.0 + alphamin)) + IF ( lz(lr) .lt. 1 ) THEN g1x(:,lr) = (6.0 + alphar)*(5.0 + alphar)*(4.0 + alphar)/ & & ((3.0 + alphar)*(2.0 + alphar)*(1.0 + alphar)) @@ -14118,7 +15619,22 @@ subroutine nssl_2mom_gs & ENDIF + + IF ( ipconc == 5 ) THEN + ! set up factors for ihlcnh=3 conversion + g1x(:,lr) = (6.0 + alphar)*(5.0 + alphar)*(4.0 + alphar)/ & + & ((3.0 + alphar)*(2.0 + alphar)*(1.0 + alphar)) + g1x(:,lh) = (6.0 + alphah)*(5.0 + alphah)*(4.0 + alphah)/ & + & ((3.0 + alphah)*(2.0 + alphah)*(1.0 + alphah)) + IF ( lhl > 0 ) THEN + g1x(:,lhl) = (6.0 + alphahl)*(5.0 + alphahl)*(4.0 + alphahl)/ & + & ((3.0 + alphahl)*(2.0 + alphahl)*(1.0 + alphahl)) + ENDIF + ENDIF + + scx(:,:) = 0.0 + ! ! set shape parameters ! @@ -14131,6 +15647,7 @@ subroutine nssl_2mom_gs & alpha(:,li) = xnu(li) alpha(:,lc) = xnu(lc) + IF ( idiagnosecnu > 0 ) THEN DO mgs = 1,ngscnt IF ( cx(mgs,lc) > cxmin ) THEN @@ -14143,6 +15660,7 @@ subroutine nssl_2mom_gs & ENDDO ENDIF + IF ( imusnow == 1 ) THEN alpha(:,ls) = alphas ELSEIF ( imusnow == 3 ) THEN @@ -14173,6 +15691,7 @@ subroutine nssl_2mom_gs & da1lr(:) = da1(lr) da0lc(:) = da0(lc) da1lc(:) = da1(lc) + IF ( idiagnosecnu > 0 ) THEN DO mgs = 1,ngscnt IF ( cx(mgs,lc) > cxmin ) THEN @@ -14183,19 +15702,28 @@ subroutine nssl_2mom_gs & ENDIF + if ( ndebug .gt. 0 .and. my_rank>=0 ) write(0,*) my_rank, 'ICEZVD_GS: dbg = set rz' + IF ( lzh < 1 .or. lzhl < 1 ) THEN - rzxhlh(:) = rzhl/rz + IF ( icorrecthaildbz == 0 ) THEN + rzxhlh(:) = rzhlh + ELSE + rzxhlh(:) = 1.0 ! correction already accounts for difference in shape param + ENDIF ELSEIF ( lzh > 1 .and. lzhl > 1 ) THEN rzxhlh(:) = 1. ENDIF + IF ( lzr > 1 ) THEN rzxh(:) = 1. rzxhl(:) = 1. + ELSE rzxh(:) = rz rzxhl(:) = rzhl + ENDIF IF ( imurain == 1 .and. imusnow == 3 .and. lzr < 1 ) THEN @@ -14218,6 +15746,7 @@ subroutine nssl_2mom_gs & ! ! set factors ! + do mgs = 1,ngscnt ! ssi(mgs) = qx(mgs,lv)/qis(mgs) @@ -14252,7 +15781,7 @@ subroutine nssl_2mom_gs & tmp = qx(mgs,li)+qx(mgs,ls)+qx(mgs,lh) IF ( lhl > 1 ) tmp = tmp + qx(mgs,lhl) - IF ( lf > 1 ) tmp = tmp + qx(mgs,lf) + cvm = cv+cvv*qx(mgs,lv)+cpl*(qx(mgs,lc)+qx(mgs,lr)) & +cpigb*(tmp) @@ -14345,6 +15874,7 @@ subroutine nssl_2mom_gs & do mgs = 1,ngscnt xdn(mgs,li) = xdn0(li) + xdn(mgs,lc) = xdn0(lc) xdn(mgs,lr) = xdn0(lr) xdn(mgs,ls) = xdn0(ls) @@ -14358,6 +15888,7 @@ subroutine nssl_2mom_gs & IF ( lvol(lh) .gt. 1 ) THEN IF ( vx(mgs,lh) .gt. 0.0 .and. qx(mgs,lh) .gt. qxmin(lh) ) THEN IF ( mixedphase ) THEN + ELSE dnmx = xdnmx(lh) ENDIF @@ -14372,6 +15903,7 @@ subroutine nssl_2mom_gs & ENDIF + IF ( lhl .gt. 1 ) THEN xdn(mgs,lhl) = xdn0(lhl) @@ -14381,6 +15913,7 @@ subroutine nssl_2mom_gs & IF ( vx(mgs,lhl) .gt. 0.0 .and. qx(mgs,lhl) .gt. qxmin(lhl) ) THEN IF ( mixedphase .and. lhlw > 1 ) THEN + ELSE dnmx = xdnmx(lhl) ENDIF @@ -14536,6 +16069,7 @@ subroutine nssl_2mom_gs & massfacmlr = (3.0 + alphamlr)**3/((3.+alphamlr)*(2.+alphamlr)*(1. + alphamlr) ) ENDIF + ! Find shape parameter rain g1shr = 1.0 @@ -14878,7 +16412,7 @@ subroutine nssl_2mom_gs & cx(mgs,il) = rho0(mgs)*qx(mgs,il)/(xmas(mgs,il)) ENDIF - IF ( zx(mgs,il) > 0.0 .and. cx(mgs,il) <= 0.0 ) THEN + IF ( zx(mgs,il) > zxmin .and. cx(mgs,il) <= cxmin ) THEN ! have mass and reflectivity but no concentration, so set concentration, using default alpha g1 = (6.0 + alpha(mgs,il))*(5.0 + alpha(mgs,il))*(4.0 + alpha(mgs,il))/ & & ((3.0 + alpha(mgs,il))*(2.0 + alpha(mgs,il))*(1.0 + alpha(mgs,il))) @@ -14886,6 +16420,17 @@ subroutine nssl_2mom_gs & qr = qx(mgs,il) ! cx(mgs,il) = g1*dn(igs(mgs),jy,kgs(mgs))**2*(qr)*qr/z cx(mgs,il) = g1*dn(igs(mgs),jy,kgs(mgs))**2*(6.*qr)**2/(z*(pi*xdn(mgs,il))**2) + IF ( cx(mgs,il) < cxmin ) THEN + ! if resulting concentration is too small, then zero out + cx(mgs,il) = 0.0 + zx(mgs,il) = 0.0 + an(igs(mgs),jgs,kgs(mgs),lv) = an(igs(mgs),jgs,kgs(mgs),lv) + an(igs(mgs),jgs,kgs(mgs),il) + + qx(mgs,il) = 0.0 + an(igs(mgs),jgs,kgs(mgs),il) = qx(mgs,il) + an(igs(mgs),jgs,kgs(mgs),ln(il)) = cx(mgs,il) + an(igs(mgs),jgs,kgs(mgs),lz(il)) = zx(mgs,il) + ENDIF ELSEIF ( zx(mgs,il) <= zxmin .and. cx(mgs,il) > cxmin ) THEN ! have mass and concentration but no reflectivity, so set reflectivity, using default alpha @@ -14900,6 +16445,18 @@ subroutine nssl_2mom_gs & zx(mgs,il) = Max(zxmin*1.1, g1*dn(igs(mgs),jy,kgs(mgs))**2*(6*qr)**2/(chw*(pi*xdn(mgs,il))**2) ) an(igs(mgs),jgs,kgs(mgs),lz(il)) = zx(mgs,il) + IF ( zx(mgs,il) <= zxmin ) THEN + ! if resulting reflectivity is still too small, then zero out + cx(mgs,il) = 0.0 + zx(mgs,il) = 0.0 + an(igs(mgs),jgs,kgs(mgs),lv) = an(igs(mgs),jgs,kgs(mgs),lv) + an(igs(mgs),jgs,kgs(mgs),il) + + qx(mgs,il) = 0.0 + an(igs(mgs),jgs,kgs(mgs),il) = qx(mgs,il) + an(igs(mgs),jgs,kgs(mgs),ln(il)) = cx(mgs,il) + an(igs(mgs),jgs,kgs(mgs),lz(il)) = zx(mgs,il) + ENDIF + ELSEIF ( zx(mgs,il) <= zxmin .and. cx(mgs,il) <= 0.0 ) THEN ! How did this happen? ! set values according to dBZ of -10, or Z = 0.1 @@ -14956,7 +16513,7 @@ subroutine nssl_2mom_gs & ! check for artificial breakup (graupel/hail larger than allowed max size) - IF ( imaxdiaopt == 1 ) THEN + IF ( imaxdiaopt == 1 .or. il /= lr ) THEN xvbarmax = xvmx(il) ELSEIF ( imaxdiaopt == 2 ) THEN ! test against maximum mass diameter xvbarmax = xvmx(il) /((3. + alpha(mgs,il))**3/((3. + alpha(mgs,il))*(2. + alpha(mgs,il))*(1. + alpha(mgs,il)))) @@ -14983,12 +16540,21 @@ subroutine nssl_2mom_gs & IF ( tmp < cx(mgs,il) ) THEN ! artificial breakup has happened, so need to adjust reflectivity and find new shape parameter g1 = 36.*(6.0 + alpha(mgs,il))*(5.0 + alpha(mgs,il))*(4.0 + alpha(mgs,il))/ & & ((3.0 + alpha(mgs,il))*(2.0 + alpha(mgs,il))*(1.0 + alpha(mgs,il))*pi**2) - zx(mgs,il) = zx(mgs,il) + g1*(rho0(mgs)/xdn(mgs,il))**2*( (qx(mgs,il)/tmp)**2 * (tmp-cx(mgs,il)) ) +! zx(mgs,il) = zx(mgs,il) + g1*(rho0(mgs)/xdn(mgs,il))**2*( (qx(mgs,il)/tmp)**2 * (tmp-cx(mgs,il)) ) + ! check if incoming zx is consistent + ! Z from incoming cx, qx, and alpha + tmpz = g1/(pi/6.*xdn(mgs,il))**2 * ((rho0(mgs)*qx(mgs,il))**2)/tmp + IF ( tmpz > zx(mgs,il) ) THEN + tmpc = g1/(pi/6.*xdn(mgs,il))**2 * ((rho0(mgs)*qx(mgs,il))**2)/zx(mgs,il) + cx(mgs,il) = Max(cx(mgs,il), tmpc) + ! find cx that gives zx + ENDIF + zx(mgs,il) = g1/(pi/6.*xdn(mgs,il))**2 * ((rho0(mgs)*qx(mgs,il))**2)/cx(mgs,il) an(igs(mgs),jgs,kgs(mgs),lz(il)) = zx(mgs,il) - chw = cx(mgs,il) - qr = qx(mgs,il) - z = zx(mgs,il) + qr = qx(mgs,il) + chw = cx(mgs,il) + z = zx(mgs,il) rdi = z*(pi/6.*xdn(mgs,il))**2*chw/((rho0(mgs)*qr)**2) alp = (6.0+alpha(mgs,il))*(5.0+alpha(mgs,il))*(4.0+alpha(mgs,il))/ & @@ -15043,7 +16609,7 @@ subroutine nssl_2mom_gs & an(igs(mgs),jy,kgs(mgs),ln(il)) = chw ELSE - ! Usual resetting of reflectivity moment to force consisntency between Q, N, Z, and alpha when alpha = alphamin + ! Usual resetting of reflectivity moment to force consistency between Q, N, Z, and alpha when alpha = alphamin z1 = g1*dn(igs(mgs),jy,kgs(mgs))**2*(qr)*qr/chw z = z1*(6./(pi*xdn(mgs,il)))**2 zx(mgs,il) = z @@ -15102,12 +16668,12 @@ subroutine nssl_2mom_gs & gf1palp(mgs) = y IF ( iferwisventr == 2 ) THEN +! ventrn = Gamma(alphar + 2.5 + br/2.)/Gamma(alphar + 1.) ! adapted from Wisner et al. 1972 tmp = alpha(mgs,lr) + 2.5 + br/2. i = Int(dgami*(tmp)) del = tmp - dgam*i x = gmoi(i) + (gmoi(i+1) - gmoi(i))*del*dgami -! ventrx(mgs) = Gamma_sp(alpha(mgs,lr) + 1.5 + br/6.)/Gamma_sp(alpha(mgs,lr) + 1.) ventrxn(mgs) = x/y @@ -15218,6 +16784,7 @@ subroutine nssl_2mom_gs & rzxhlh(mgs) = rzxhl(mgs)/(((4. + alpha(mgs,il))*(5. + alpha(mgs,il))*(6. + alpha(mgs,il))*(1. + xnu(lr)))/ & & ((1. + alpha(mgs,il))*(2. + alpha(mgs,il))*(3. + alpha(mgs,il))*(2. + xnu(lr)))) ENDIF + ELSEIF ( il .eq. lhl ) THEN da0lhl(mgs) = delbk(bb(il), xnutmp, xmu(il), 0) IF ( lzr > 1 ) THEN @@ -15247,6 +16814,7 @@ subroutine nssl_2mom_gs & ! CALL cld_cpu('Z-MOMENT-1') + ! ! set some values for ice nucleation ! @@ -15255,12 +16823,16 @@ subroutine nssl_2mom_gs & ! wvel(mgs) = (0.5)*(w(igs(mgs),jgs,kp1) & ! & +w(igs(mgs),jgs,kgs(mgs))) + wvelkm1(mgs) = (0.5)*(w(igs(mgs),jgs,kgs(mgs)) & & +w(igs(mgs),jgs,kgsm(mgs))) cninm(mgs) = t7(igs(mgs),jgs,kgsm(mgs)) cnina(mgs) = t7(igs(mgs),jgs,kgs(mgs)) cninp(mgs) = t7(igs(mgs),jgs,kgsp(mgs)) + IF ( icenucopt == 5 .or. icenucopt == 6 ) THEN + cninda(mgs) = t7d(igs(mgs),jgs,kgs(mgs)) + ENDIF end do ! @@ -15277,9 +16849,12 @@ subroutine nssl_2mom_gs & ! & itype1a,itype2a,temcg,infdo,alpha) + infdo = 1 IF ( rimdenvwgt > 0 ) infdo = 1 + + call setvtz(ngscnt,qx,qxmin,qxw,cx,rho0,rhovt,xdia,cno,cnostmp, & & xmas,vtxbar,xdn,xvmn,xvmx,xv,cdx,cdxgs, & & ipconc,ndebug,ngs,nz,igs,kgs,fadvisc, & @@ -15288,6 +16863,8 @@ subroutine nssl_2mom_gs & ! & itype1,itype2,temcg,infdo,alpha,0,axh,bxh,axhl,bxhl) ! ,cdh,cdhl) + + IF ( lwsm6 .and. ipconc == 0 ) THEN tmp = Max(qxmin(lh), qxmin(ls)) DO mgs = 1,ngscnt @@ -15301,6 +16878,7 @@ subroutine nssl_2mom_gs & ENDIF + ! ! Set number concentrations (need xdia from setvt) ! @@ -15345,6 +16923,7 @@ subroutine nssl_2mom_gs & end if IF ( ipconc .ge. 2 ) THEN + DO mgs = 1,ngscnt rb(mgs) = 0.5*xdia(mgs,lc,1)*(1./(1.+alpha(mgs,lc)))**(1./6.) @@ -15364,6 +16943,7 @@ subroutine nssl_2mom_gs & ENDDO ENDIF + ! ! ! @@ -15371,6 +16951,7 @@ subroutine nssl_2mom_gs & ! maximum depletion tendency by any one source ! ! + if( ndebug .ge. 0 ) THEN !mpi! write(0,*) 'Set depletion max/min1' endif @@ -15387,6 +16968,7 @@ subroutine nssl_2mom_gs & qrmxd(mgs) = frac*qx(mgs,lr)*dtpinv qsmxd(mgs) = frac*qx(mgs,ls)*dtpinv qhmxd(mgs) = frac*qx(mgs,lh)*dtpinv + IF ( lhl > 1 ) qhlmxd(mgs) = frac*qx(mgs,lhl)*dtpinv end do ! @@ -15439,6 +17021,7 @@ subroutine nssl_2mom_gs & + IF ( ipconc >= 6 ) THEN frac = 0.4d0 zxmxd(:,:) = 0.0 @@ -15454,6 +17037,8 @@ subroutine nssl_2mom_gs & + + ! default factors between mean volume and maximum mass volume maxmassfac(lc) = ( (2. + 3.*(1. + xnu(lc)) )**3/( 3.*(1. + xnu(lc)) ) ) maxmassfac(li) = ( (2. + 3.*(1. + xnu(li)) )**3/( 3.*(1. + xnu(li)) ) ) @@ -15482,6 +17067,7 @@ subroutine nssl_2mom_gs & + DO mgs = 1,ngscnt DO il = lh,lhab ! graupel and hail only (and frozen drops) @@ -15515,6 +17101,7 @@ subroutine nssl_2mom_gs & ! if (ndebug .gt. 0 ) write(0,*) 'ICEZVD_GS: Set collection efficiencies' ! + do mgs = 1,ngscnt ! ! @@ -15555,6 +17142,7 @@ subroutine nssl_2mom_gs & ! eiw(mgs) = 0.0 eii(mgs) = 0.0 + ehsclsn(mgs) = 0.0 ehiclsn(mgs) = 0.0 ehlsclsn(mgs) = 0.0 @@ -15612,6 +17200,7 @@ subroutine nssl_2mom_gs & ENDIF + IF ( lhl .gt. 1 ) THEN ! hail is turned on ihlr(mgs) = 1 IF ( qx(mgs,lhl) .gt. qxmin(lhl) ) THEN @@ -15652,11 +17241,12 @@ subroutine nssl_2mom_gs & if (xdia(mgs,lc,1).gt.ewi_dcmin .and. xdia(mgs,li,1).gt.ewi_dimin) then ! erm 5/10/2007 test following change: ! if (xdia(mgs,lc,1).gt.12.0e-06 .and. xdia(mgs,li,1).gt.50.0e-06) then - eiw(mgs) = 0.5 + eiw(mgs) = eiw0 end if if ( temg(mgs) .ge. 273.15 ) eiw(mgs) = 0.0 end if + ! ! ! @@ -15793,9 +17383,17 @@ subroutine nssl_2mom_gs & IF ( ssi(mgs) <= 1.0 ) THEN fac = 0.1 ehsfac(mgs) = 0.1 - ELSEIF ( ssi(mgs) <= 1.005 ) THEN - fac = Max(0.1, fac*(ssi(mgs) - 1.0)/0.005) - ehsfac(mgs) = Max(0.1, (ssi(mgs) - 1.0)/0.005) + ELSEIF ( ssi(mgs) <= 1.005 ) THEN ! ssi in range of 1.0 to 1.005 + fac = 0.1 + (ssi(mgs) - 1.0)*(fac - 0.1)/(1.005 - 1.0) ! Max(0.1, fac*(ssi(mgs) - 1.0)/0.005) + ehsfac(mgs) = fac ! Max(0.1, (ssi(mgs) - 1.0)/0.005) + ENDIF + ELSEIF ( iessopt == 5 ) THEN ! factor based on ice supersat; very roughly based on Hosler et al. 1957 (J. Met.) + IF ( ssi(mgs) < 0.90 ) THEN + fac = 0.1 + ehsfac(mgs) = 0.1 + ELSEIF ( ssi(mgs) < 1.0 ) THEN ! ssi in range of 0.9 to 1.0 + fac = 0.1 + (ssi(mgs) - 0.9)*(fac - 0.1)/(1.0 - 0.9) + ehsfac(mgs) = fac ! Max(0.1, 0.1*(1.0 - ssi(mgs))/0.1) ENDIF ENDIF @@ -15827,6 +17425,8 @@ subroutine nssl_2mom_gs & ! ENDIF if ( temg(mgs) .gt. 273.15 ) esi(mgs) = 0.0 end if + + ! ! ! @@ -15946,6 +17546,7 @@ subroutine nssl_2mom_gs & end if ENDIF + ! ! @@ -16080,6 +17681,7 @@ subroutine nssl_2mom_gs & + ! ! ! @@ -16152,7 +17754,9 @@ subroutine nssl_2mom_gs & ! do mgs = 1,ngscnt qraci(mgs) = 0.0 + qracif(mgs) = 0.0 craci(mgs) = 0.0 +! cracif(mgs) = 0.0 qracs(mgs) = 0.0 IF ( eri(mgs) .gt. 0.0 .and. iacr .ge. 1 .and. xdia(mgs,lr,3) .gt. 2.*rwradmn ) THEN IF ( ipconc .ge. 3 ) THEN @@ -16321,6 +17925,7 @@ subroutine nssl_2mom_gs & ENDIF end do ! + ! ! do mgs = 1,ngscnt @@ -16361,6 +17966,7 @@ subroutine nssl_2mom_gs & ! ! + if (ndebug .gt. 0 ) write(0,*) 'Collection: graupel collects xxxxx' ! do mgs = 1,ngscnt @@ -16372,7 +17978,9 @@ subroutine nssl_2mom_gs & zhacw(mgs) = 0.0 IF ( .false. ) THEN + vtmax = (gz(igs(mgs),jgs,kgs(mgs))*dtpinv) + vtxbar(mgs,lh,1) = Min( vtmax, vtxbar(mgs,lh,1)) vtxbar(mgs,lh,2) = Min( vtmax, vtxbar(mgs,lh,2)) vtxbar(mgs,lh,3) = Min( vtmax, vtxbar(mgs,lh,3)) @@ -16525,8 +18133,7 @@ subroutine nssl_2mom_gs & end do - qhacis(:) = 0.0 - qhacis0(:) = 0.0 + ! ! do mgs = 1,ngscnt @@ -16679,7 +18286,9 @@ subroutine nssl_2mom_gs & vhlacw(mgs) = 0.0 vhlsoak(mgs) = 0.0 IF ( lhl > 1 .and. .true.) THEN + vtmax = (gz(igs(mgs),jgs,kgs(mgs))*dtpinv) + vtxbar(mgs,lhl,1) = Min( vtmax, vtxbar(mgs,lhl,1)) vtxbar(mgs,lhl,2) = Min( vtmax, vtxbar(mgs,lhl,2)) vtxbar(mgs,lhl,3) = Min( vtmax, vtxbar(mgs,lhl,3)) @@ -16780,6 +18389,7 @@ subroutine nssl_2mom_gs & qhlacis(:) = 0.0 qhlacis0(:) = 0.0 + qhlacs(:) = 0.0 qhlacs0(:) = 0.0 IF ( lhl .gt. 1 ) THEN @@ -16877,6 +18487,7 @@ subroutine nssl_2mom_gs & end do + ! ! if (ndebug .gt. 0 ) write(0,*) 'Collection: cloud ice collects xxxx8' @@ -16901,7 +18512,7 @@ subroutine nssl_2mom_gs & ni = ni + cx(mgs,li)*Exp(- (40.e-6/xdia(mgs,li,1))**3 ) ENDIF IF ( imurain == 1 ) THEN ! gamma of diameter - IF ( iacrsize /= 4 ) THEN + IF ( iacrsize /= 4 ) THEN IF ( iacrsize .eq. 1 ) THEN ratio = 500.e-6/xdia(mgs,lr,1) ELSEIF ( iacrsize .eq. 2 ) THEN @@ -16910,6 +18521,9 @@ subroutine nssl_2mom_gs & ratio = 40.e-6/xdia(mgs,lr,1) ELSEIF ( iacrsize .eq. 5 ) THEN ratio = 150.e-6/xdia(mgs,lr,1) + ELSEIF ( iacrsize .eq. 6 ) THEN + ratio = 60.e-6/xdia(mgs,lr,1) + ni = cx(mgs,li) ENDIF i = Min(nqiacrratio,Int(ratio*dqiacrratioinv)) j = Int(Max(0.0,Min(15.,alpha(mgs,lr)))*dqiacralphainv) @@ -16935,10 +18549,10 @@ subroutine nssl_2mom_gs & qr = (tmp1 + dely*dqiacralphainv*(tmp2 - tmp1))*qx(mgs,lr) - ELSE ! iacrsize == 4 : use all - nr = cx(mgs,lr) - qr = qx(mgs,lr) - ENDIF + ELSE ! iacrsize == 4 : use all + nr = cx(mgs,lr) + qr = qx(mgs,lr) + ENDIF vt = Sqrt((vtxbar(mgs,lr,1)-vtxbar(mgs,li,1))**2 + & & 0.04*vtxbar(mgs,lr,1)*vtxbar(mgs,li,1) ) @@ -16947,9 +18561,9 @@ subroutine nssl_2mom_gs & & ( da0(li)*xdia(mgs,li,3)**2 + & & dab1lh(mgs,li,lr)*xdia(mgs,lh,3)*xdia(mgs,li,3) + & & da1(lr)*xdia(mgs,lr,3)**2 ) - + qiacr(mgs) = Min( qrmxd(mgs), qiacr(mgs) ) - + ciacr(mgs) = 0.25*pi*eri(mgs)*ni*nr*vt* & & ( da0(li)*xdia(mgs,li,3)**2 + & @@ -17037,7 +18651,13 @@ subroutine nssl_2mom_gs & ! ave. diam of freezing drops in microns IF ( qiacr(mgs)*dtp > qxmin(lh) .and. ciacr(mgs) > 1.e-3 ) THEN tmpdiam = 1.e6*( 6.*qiacr(mgs)/(1000.*pi*ciacr(mgs) ) )**(1./3.) ! avg. diameter of newly frozen drops in microns - csplinter(mgs) = lawson_splinter_fac*tmpdiam**4*ciacr(mgs) + fac = 1.0 + IF ( nsplinter .eq. 1001 ) THEN + ! fac = 0.2/sqrt(2.0*pi*10.**2)*Exp(-0.5*((258.-temg(mgs))/10.)**2 ) ! temperature dependence from Sullivan et al. 2018 ACP + ! ELSE + fac = 0.2*Exp(-0.5*((258.-temg(mgs))/10.)**2 ) ! temperature dependence from Sullivan et al. 2018 ACP + ENDIF + csplinter(mgs) = fac*lawson_splinter_fac*tmpdiam**4*ciacr(mgs) ENDIF ELSEIF ( nsplinter .ge. 0 ) THEN csplinter(mgs) = nsplinter*ciacr(mgs) @@ -17103,12 +18723,13 @@ subroutine nssl_2mom_gs & if ( ipconc .ge. 2 .or. ipelec .ge. 9 ) then do mgs = 1,ngscnt ciacw(mgs) = 0.0 - IF ( eiw(mgs) .gt. 0.0 ) THEN + IF ( eiw(mgs) .gt. 0.0 .and. xmas(mgs,lc) > 0.0 ) THEN ciacw(mgs) = qiacw(mgs)*rho0(mgs)/xmas(mgs,lc) ciacw(mgs) = min(ciacw(mgs),ccmxd(mgs)) ENDIF end do + end if if (ndebug .gt. 0 ) write(0,*) 'ICEZVD_GS: conc 18' @@ -17117,6 +18738,7 @@ subroutine nssl_2mom_gs & tmp1 = 0.0 cracw(mgs) = 0.0 cracr(mgs) = 0.0 + zracr(mgs) = 0.0 ec0(mgs) = 1.e9 IF ( qx(mgs,lc) .gt. qxmin(lc) .and. qx(mgs,lr) .gt. qxmin(lr) & & .and. qracw(mgs) .gt. 0.0 ) THEN @@ -17130,7 +18752,7 @@ subroutine nssl_2mom_gs & & + 2.0*gf2*xdia(mgs,lc,1)*xdia(mgs,lr,1) & & + gf3*xdia(mgs,lr,2) ) ENDIF - ELSE ! IF ( ipconc .ge. 3 .and. + ELSE ! IF ( ipconc .ge. 3 .and. ) IF ( dmrauto <= 0 .or. rho0(mgs)*qx(mgs,lr) > 1.2*xl2p(mgs) ) THEN !{ IF ( 0.5*xdia(mgs,lr,3) .gt. rh(mgs) ) THEN ! { .or. cx(mgs,lr) .gt. nh(mgs) ! IF ( qx(mgs,lc) .gt. qxmin(lc) .and. qx(mgs,lr) .gt. qxmin(lr) ) THEN @@ -17167,18 +18789,19 @@ subroutine nssl_2mom_gs & ! check median volume diameter IF ( icracrthresh > 1 ) THEN IF ( imurain == 1 ) THEN - tmp = (3.67+alpha(mgs,lr))*xdia(mgs,lr,1) ! median volume diameter; units of mm (Ulbrich 1983, JCAM) + tmp = (3.67+alpha(mgs,lr))*xdia(mgs,lr,1) ! median volume diameter; units of m (Ulbrich 1983, JCAM) ELSE ! imurain == 3, tmp = (1.678+alpha(mgs,lr))**(1./3.)*xdia(mgs,lr,1) ! units of mm (using method of Ulbrich 1983. See ventillation_stuff.nb) ENDIF ELSE tmp = xdia(mgs,lr,3) - 0.1e-3 ENDIF + tmpdiam = tmp ! Using collection efficiency factor ec0 to simulate break-up that off-sets self-collection (Zieger 1985; Cohard & Pinty 2000) ! ec0 is 1 for rain diameter < 600 microns and then drop off toward zero until diameter of 2mm to represent passive breakup ! ec0 does not go negative here (i.e., does not follow other versions that create extra breakup at large rain diameter) - IF ( ( tmp .gt. 1.9e-3 .and. irainbreak /= 10 .and. irainbreak /= 20 ) .or. icracr <= 0 ) THEN + IF ( ( tmpdiam .gt. 1.9e-3 .and. irainbreak /= 10 .and. irainbreak /= 20 ) .or. icracr <= 0 ) THEN ec0(mgs) = 0.0 cracr(mgs) = 0.0 IF ( ibincracr == 3 ) THEN @@ -17188,12 +18811,15 @@ subroutine nssl_2mom_gs & ENDIF ELSE IF ( dmrauto <= 0 .or. rho0(mgs)*qx(mgs,lr) > 1.2*xl2p(mgs) ) THEN - IF ( xdia(mgs,lr,3) .lt. 6.1e-4 .or. irainbreak == 10 ) THEN + IF ( icracrthresh == 1 ) THEN + tmpdiam = xdia(mgs,lr,3) + ENDIF + + IF ( tmpdiam .lt. 6.1e-4 .or. irainbreak == 10 ) THEN ec0(mgs) = 1.0 ELSE - ec0(mgs) = Exp( -2500.0*(xdia(mgs,lr,3) - 6.0e-4) ) + ec0(mgs) = Exp( -2500.0*(tmpdiam - 6.0e-4) ) ENDIF - IF ( rwrad .ge. 50.e-6 ) THEN tmp1 = aa2*cx(mgs,lr)**2*xv(mgs,lr) @@ -17214,26 +18840,42 @@ subroutine nssl_2mom_gs & cracr(mgs) = tmp1 ENDIF ENDIF + ENDIF ! rwrad > 50 +! cracr(mgs) = Min(cracr(mgs),crmxd(mgs)) + ENDIF ! dmrauto <= 0 + ENDIF ! tmp > 1.9e-3 + + IF ( irainbreak == 100 ) THEN ! Morrison breakup + ec0(mgs) = 1.0 + IF ( xdia(mgs,lr,1) > 300.e-6 ) THEN + ec0(mgs) = 2. - Exp(2300.*(xdia(mgs,lr,1)-300.e-6)) + ENDIF + cracr(mgs) = 5.78*ec0(mgs)*cx(mgs,lr)*qx(mgs,lr) + ENDIF + + ENDIF ! ( qx(mgs,lr) .gt. qxmin(lr) ) - ENDIF ! dmrauto <= 0 - -! IF ( igs(mgs) == 15 ) write(6,*) 'cracr,k = ',kgs(mgs),cracr(mgs),qx(mgs,lr),cx(mgs,lr),ec0(mgs),rwrad -! cracr(mgs) = Min(cracr(mgs),crmxd(mgs)) - ENDIF - ENDIF - ENDIF ! active breakup option crbreak = 0.0 IF ( irainbreak == 1 .or. irainbreak == 10 ) THEN crbreak = Max( 0.0, rainbreakfac* (rho0(mgs)*qx(mgs,lr))**2 ) ! hand fit to lower range of wkqss output cracr(mgs) = cracr(mgs) - crbreak ! cracr is subtracted, so negative value for breakup - ELSEIF ( irainbreak == 2 .or. irainbreak == 20 ) THEN + ELSEIF ( irainbreak == 2 .or. irainbreak == 20 .or. irainbreak == 12 ) THEN ! irainbreak == 20 does not work as intended + IF ( irainbreak == 12 ) THEN + IF ( xdia(mgs,lr,1) > 300.e-6 ) THEN + crbreak = Max( 0.0, rainbreakfac*(rho0(mgs)*qx(mgs,lr))**2 ) ! hand fit to lower range of wkqss output + ELSE + crbreak = 0.0 + ENDIF + ELSE crbreak = Max( 0.0, rainbreakfac*(1. - ec0(mgs))*(rho0(mgs)*qx(mgs,lr))**2 ) ! hand fit to lower range of wkqss output + ENDIF ! crbreak = Max(0.0, -0.18 + 1.139e6 * (rho0(mgs)*qx(mgs,lr) + 0.00038106)**2) cracr(mgs) = cracr(mgs) - crbreak ! cracr is subtracted, so negative value for breakup + ELSEIF ( irainbreak == 11 .and. rho0(mgs)*qx(mgs,lr) > qrbrthresh1 .and. ipconc >= 5 ) THEN ! Ad hoc method to break up drops in the DSD tail (D > draintail) @@ -17265,6 +18907,7 @@ subroutine nssl_2mom_gs & ! ENDIF cracr(mgs) = cracr(mgs) - crbreak ! cracr is subtracted, so negative value for breakup + ! reflectivity -- not used yet: goes into zracr ! IF ( ipconc >= 6 .and. lzr > 1 ) THEN ! tmp3 = gaminterp(ratio,alpha(mgs,lr),11,1) @@ -17274,17 +18917,32 @@ subroutine nssl_2mom_gs & ! zxd1 = 0 ! ENDIF ! zrbreak = Max(0.0, zrbreak - crbreaksmall*drsmall**6) - ELSEIF ( irainbreak == 12 ) THEN - crbreak = Max( 0.0, 3.8098 * (rho0(mgs)*qx(mgs,lr))**1.9416 ) ! best fit to lower range of wkqss (collision only) output - cracr(mgs) = cracr(mgs) - crbreak ! cracr is subtracted, so negative value for breakup + +! ELSEIF ( irainbreak == 12 ) THEN +! crbreak = Max( 0.0, 3.8098 * (rho0(mgs)*qx(mgs,lr))**1.9416 ) ! best fit to lower range of wkqss (collision only) output +! cracr(mgs) = cracr(mgs) - crbreak ! cracr is subtracted, so negative value for breakup ENDIF ENDIF + IF ( lzr > 0 .and. cracr(mgs) /= 0.0 .and. cx(mgs,lr) > 0.0 ) THEN +! tmp = qx(mgs,lr)/cx(mgs,lr) +! zracr(mgs) = g1x(mgs,lr)*(6.*rho0(mgs)/(pi*1000.))**2*( tmp**2 * cracr(mgs) ) + ! rewrite because original can overestimate zracr if -cracr*dtp is on the order of cx (i.e., + ! large increase in the number of drops, which violates differential assumption + ! Pass -cracr because its meaning is backwards (neg. value ADDS number, positive value SUBTRACTS) + zracr(mgs) = zraten(dtpinv,dtp,g1x(mgs,lr),rho0(mgs),rho_qr,qx(mgs,lr),cx(mgs,lr),-cracr(mgs)) + +! zracr(mgs) = dtpinv*g1x(mgs,lr)*(6.*rho0(mgs)*qx(mgs,lr)/(pi*1000.))**2 & +! * ( cracr(mgs) )/((cx(mgs,lr) - dtp*cracr(mgs))*(cx(mgs,lr))) + ENDIF + ! cracw(mgs) = min(cracw(mgs),cxmxd(mgs,lc)) + end do end if + ! ! ! @@ -17362,6 +19020,7 @@ subroutine nssl_2mom_gs & end if + ! ! if (ndebug .gt. 0 ) write(0,*) 'ICEZVD_GS: conc 22nn' @@ -17469,6 +19128,7 @@ subroutine nssl_2mom_gs & end if + ! ! if (ndebug .gt. 0 ) write(0,*) 'ICEZVD_GS: conc 22jj' @@ -17508,7 +19168,9 @@ subroutine nssl_2mom_gs & if (ndebug .gt. 0 ) write(0,*) 'conc 26a' DO mgs = 1,ngscnt + zrcnw(mgs) = 0.0 + qrcnw(mgs) = 0.0 crcnw(mgs) = 0.0 cautn(mgs) = 0.0 @@ -17536,6 +19198,7 @@ subroutine nssl_2mom_gs & t2s = 3.72/(1.e6*(rb(mgs)-7.500d-6)*rho0(mgs)*qx(mgs,lc)) qrcnw(mgs) = Max( 0.0d0, xl2p(mgs)/(t2s*rho0(mgs)) ) + crcnw(mgs) = Max( 0.0d0, Min(3.5e9*xl2p(mgs)/t2s,0.5*cautn(mgs)) ) IF ( dmrauto == 0 ) THEN @@ -17558,7 +19221,8 @@ subroutine nssl_2mom_gs & tmp = crcnw(mgs) tmp2 = qrcnw(mgs)*cx(mgs,lr)/qx(mgs,lr) ! try mass*diameter-weighted average of old and new Dmr (using full qc mass) - crcnw(mgs) = (tmp*xdia(mgs,lc,3)*qx(mgs,lc)+tmp2*xdia(mgs,lr,3)*qx(mgs,lr))/(xdia(mgs,lc,3)*qx(mgs,lc)+xdia(mgs,lr,3)*qx(mgs,lr)) + crcnw(mgs) = (tmp*xdia(mgs,lc,3)*qx(mgs,lc)+tmp2*xdia(mgs,lr,3)*qx(mgs,lr))/ & + (xdia(mgs,lc,3)*qx(mgs,lc)+xdia(mgs,lr,3)*qx(mgs,lr)) ELSEIF ( ( dmropt == 7 ) .and. qx(mgs,lr) > qxmin(lr) ) THEN tmp = crcnw(mgs) tmp2 = qrcnw(mgs)*cx(mgs,lr)/qx(mgs,lr) @@ -17568,7 +19232,8 @@ subroutine nssl_2mom_gs & tmp = crcnw(mgs) tmp2 = qrcnw(mgs)*cx(mgs,lr)/qx(mgs,lr) ! try sqrt(diameter)-weighted average of old and new Dmr - crcnw(mgs) = (tmp*sqrt(xdia(mgs,lc,3))+tmp2*sqrt(xdia(mgs,lr,3)))/(sqrt(xdia(mgs,lc,3))+sqrt(xdia(mgs,lr,3))) + crcnw(mgs) = (tmp*sqrt(xdia(mgs,lc,3))+tmp2*sqrt(xdia(mgs,lr,3)))/ & + (sqrt(xdia(mgs,lc,3))+sqrt(xdia(mgs,lr,3))) ENDIF ELSEIF ( dmrauto == 1 .and. cx(mgs,lr) > cxmin) THEN IF ( qx(mgs,lr) > qxmin(lr) ) THEN @@ -17587,7 +19252,6 @@ subroutine nssl_2mom_gs & IF ( crcnw(mgs) < 1.e-30 ) qrcnw(mgs) = 0.0 -! IF ( igs(mgs) == 15 ) write(6,*) 'crcnw,k = ',kgs(mgs),crcnw(mgs),qx(mgs,lc),cx(mgs,lc),cautn(mgs),xv(mgs,lc) IF ( ipconc >= 6 ) THEN IF ( lzr > 1 .and. qrcnw(mgs) > 0.0 ) THEN @@ -17630,6 +19294,7 @@ subroutine nssl_2mom_gs & ! z = 36.*(alpha(mgs,lr)+2.0)*nrx*vr**2/((alpha(mgs,lr)+1.0)*pi**2) ENDIF ENDIF ! ipconc >= 6 + ! IF ( crcnw(mgs) .gt. cautn(mgs) .and. crcnw(mgs) .gt. 1.0 ) ! : THEN ! write(0,*) 'crcnw,cautn ',crcnw(mgs)/cautn(mgs), @@ -17798,6 +19463,7 @@ subroutine nssl_2mom_gs & ! volt is given in cm**3, so convert to m**3 dbigg = (6./pi* volt )**(1./3.) + ! perhaps should also test that W > V_t_dbigg, i.e., that drops the size of dbigg are being lifted and cooled. IF ( dbigg < 8.e-3 ) THEN !{ only bother if freezing diameter is reasonable @@ -17839,16 +19505,81 @@ subroutine nssl_2mom_gs & ELSE !{ - - IF ( ipconc >= 6 .and. lzr > 1 ) THEN + + + IF ( (ipconc >= 5 .or. lzr > 1) ) THEN !{ + + cxd1 = crfrz(mgs)*dtp + qxd1 = qrfrz(mgs)*dtp + ! interpolate along x, i.e., ratio; tmp1 = ziacrratio(i,j) + delx*dqiacrratioinv*(ziacrratio(ip1,j) - ziacrratio(i,j)) tmp2 = ziacrratio(i,jp1) + delx*dqiacrratioinv*(ziacrratio(ip1,jp1) - ziacrratio(i,jp1)) ! interpolate along alpha; - zrfrz(mgs) = (tmp1 + dely*dqiacralphainv*(tmp2 - tmp1))*zx(mgs,lr)*dtpinv - ENDIF + IF ( ipconc >= 6 .and. lzr > 1 ) THEN + + zxd1 = (tmp1 + dely*dqiacralphainv*(tmp2 - tmp1))*zx(mgs,lr) + ! Do the correction for alphamax + zrfrz(mgs) = zxd1*dtpinv + ! tmp4 is the Z from the converted particles assuming shape of alphamax + IF ( icorrectfddbz >= 1 .and. zxd1 > zxmincorr .and. cxd1 > cxmincorr ) THEN + IF ( icorrectfddbz == 1 ) THEN !{ + ! tmp3 is cx that is consistent with increased q and Z + ! g1x(mgs,lhl) = (pi*xdn(mgs,lhl))**2*zx(mgs,lhl)*cx(mgs,lhl)/((6.*rho0(mgs)*qx(mgs,lhl))**2) + il = lh + IF ( lf > 0 ) il = lf + tmp3 = g1x(mgs,il)*(rho0(mgs)*(qx(mgs,il)+qxd1))**2/((pi*xdn(mgs,il)/6.0)**2*(zx(mgs,il)+zxd1) ) + crfrzf(mgs) = dtpinv*Max(0.0, tmp3 - cx(mgs,il) ) + + ELSEIF ( icorrectfddbz > 1 ) THEN ! old version (not robust) + tmp3 = g1xmax*(rho0(mgs)*qxd1)**2/((pi*rhofrz/6.0)**2) + tmp4 = tmp3/cxd1 + IF ( tmp4 > zxd1 ) THEN ! calculate new graupel/fd number to match zxd1 + ! increase cxd1 to make z,q,c rates consistent + ! cxd1 = g1xmax*(rho0(mgs)*qxd1)**2/(zxd1*(pi*xdn(mgs,lh)/6.0)**2) + cxd1 = tmp3/zxd1 + crfrzf(mgs) = dtpinv*cxd1 + ENDIF + ENDIF !} + ENDIF + + ELSE + IF ( icorrectfddbz >= 1 ) THEN + tmp5 = g1x(mgs,lr)*(rho0(mgs)*qx(mgs,lr))**2/((pi*xdn(mgs,lr)/6.)**2*cx(mgs,lr)) + zxd1 = (tmp1 + dely*dqiacralphainv*(tmp2 - tmp1))*tmp5 ! reflectivity transfer from rain + IF ( icorrectfddbz == 1 ) THEN + IF ( zxd1 > zxmincorr .and. cxd1 > cxmincorr ) THEN + ! tmp3 is cx that is consistent with increased q and Z + ! g1x(mgs,lhl) = (pi*xdn(mgs,lhl))**2*zx(mgs,lhl)*cx(mgs,lhl)/((6.*rho0(mgs)*qx(mgs,lhl))**2) + il = lh + IF ( lf > 0 ) il = lf + IF ( cx(mgs,il) > cxmin ) THEN + ! graupel/fd reflectivity + tmp = g1x(mgs,il)*(rho0(mgs)*qx(mgs,il))**2/((pi*xdn(mgs,il)/6.)**2*cx(mgs,il)) + ELSE + tmp = 0. + ENDIF + tmp3 = g1x(mgs,il)*(rho0(mgs)*(qx(mgs,il)+qxd1))**2/((pi*xdn(mgs,il)/6.0)**2*(tmp+zxd1) ) + crfrzf(mgs) = dtpinv*Max(0.0, tmp3 - cx(mgs,il) ) + ENDIF + ELSEIF ( icorrectfddbz > 1 ) THEN ! old version + ! tmp5 is rain reflectivity moment + ! tmp4 is the reflectivity of the newly-converted graupel particles (use g1x(lh) for loss term) + ! which we want to match zxd1 to prevent spurious increase in total reflectivity + IF ( zxd1 > zxmincorr .and. cxd1 > cxmincorr ) THEN + tmp3 = g1x(mgs,lr)*(rho0(mgs)*qxd1)**2/((pi*xdn(mgs,lr)/6.0)**2) + tmp4 = tmp3/cxd1 + IF ( tmp4 > zxd1 ) THEN ! calculate new FD number to match zxd1 + crfrzf(mgs) = tmp3/zxd1*dtpinv + ENDIF + ENDIF + ENDIF ! t/f + ENDIF + ENDIF + ENDIF !} + IF ( ibiggsmallrain > 0 .and. xv(mgs,lr) < 2.*xvmn(lr) .and. ( ibiggsnow == 1 .or. ibiggsnow == 3 ) ) THEN ! IF ( ibiggsmallrain > 0 .and. xv(mgs,lr) < xvbiggsnow .and. ( ibiggsnow == 1 .or. ibiggsnow == 3 ) ) THEN @@ -17858,10 +19589,12 @@ subroutine nssl_2mom_gs & crfrzs(mgs) = crfrz(mgs) qrfrzs(mgs) = qrfrz(mgs) + IF ( ipconc >= 6 .and. lzr > 1 ) THEN zrfrzs(mgs) = zrfrz(mgs) zrfrzf(mgs) = 0. ENDIF + ELSEIF ( dbigg < Max( biggsnowdiam, Max(dfrz,dhmn)) .and. ( ibiggsnow == 1 .or. ibiggsnow == 3 ) ) THEN ! { convert some to snow or ice crystals ! temporarily store qrfrz and crfrz in snow terms and caclulate new crfrzf, qrfrzf, and zrfrzf. Leave crfrz etc. alone! @@ -17873,10 +19606,26 @@ subroutine nssl_2mom_gs & crfrzf(mgs) = 0.0 qrfrzf(mgs) = 0.0 + IF (ipconc >= 6 .and. lzr > 1 ) THEN zrfrzs(mgs) = zrfrz(mgs) zrfrzf(mgs) = 0. ENDIF + + ELSEIF ( .false. ) THEN ! test code similar to capture freezing + + frach = 1.0 + IF ( crfrz(mgs) > qxmin(lh) ) THEN + xvfrz = rho0(mgs)*qrfrz(mgs)/(crfrz(mgs)*900.) ! mean volume of frozen drops; 900. for frozen drop density + frach = 0.5 *(1. + Tanh(0.2e12 *( xvfrz - 1.15*xvbiggsnow))) + + qrfrzs(mgs) = (1.-frach)*qrfrz(mgs) + crfrzs(mgs) = (1.-frach)*crfrz(mgs) ! *rzxh(mgs) + + ENDIF + qrfrzs(mgs) = frach*qrfrz(mgs) + crfrzs(mgs) = frach*crfrz(mgs) + ELSE !{ ! recalculate using dhmn for ratio @@ -17886,7 +19635,7 @@ subroutine nssl_2mom_gs & ! j = Int(Max(0.0,Min(15.,alpha(mgs,lr)))*dqiacralphainv) ! j = Int(Max(alphamin,Min(alphamax,alpha(mgs,lr)))*dqiacralphainv) IF ( alp0flag ) THEN - j = Int(Max(0.0,Min(15.,alpha(mgs,lr)))*dqiacralphainv) + j = Int(Max(0.0,Min(alphamax,alpha(mgs,lr)))*dqiacralphainv) ELSE j = Int(Max(minalphalu,Min(maxalphalu,alpha(mgs,lr)))*dqiacralphainv) ENDIF @@ -17916,6 +19665,7 @@ subroutine nssl_2mom_gs & crfrzs(mgs) = crfrzs(mgs) - crfrzf(mgs) qrfrzs(mgs) = qrfrzs(mgs) - qrfrzf(mgs) + IF ( ipconc >= 6 .and. lzr > 1 ) THEN zrfrzs(mgs) = zrfrz(mgs) ! interpolate along x, i.e., ratio; @@ -17928,27 +19678,108 @@ subroutine nssl_2mom_gs & zrfrzs(mgs) = zrfrzs(mgs) - zrfrzf(mgs) zrfrzf(mgs) = (1000./900.)**2*zrfrzf(mgs) ENDIF - ENDIF ! } - ELSE - crfrzs(mgs) = 0.0 - qrfrzs(mgs) = 0.0 - zrfrzs(mgs) = 0.0 - ENDIF ! } + + + IF ( ( ipconc >= 5 .or. lzr > 1 ) ) THEN !{ + + cxd1 = crfrzf(mgs)*dtp + qxd1 = qrfrzf(mgs)*dtp + + ! interpolate along x, i.e., ratio; + tmp1 = ziacrratio(i,j) + delx*dqiacrratioinv*(ziacrratio(ip1,j) - ziacrratio(i,j)) + tmp2 = ziacrratio(i,jp1) + delx*dqiacrratioinv*(ziacrratio(ip1,jp1) - ziacrratio(i,jp1)) - ENDIF !} + ! interpolate along alpha; - IF ( (qrfrz(mgs))*dtp > qx(mgs,lr) ) THEN - fac = ( qrfrz(mgs) )*dtp/qx(mgs,lr) - qrfrz(mgs) = fac*qrfrz(mgs) + IF ( ipconc >= 6 .and. lzr > 1 ) THEN !{ + + zxd1 = (tmp1 + dely*dqiacralphainv*(tmp2 - tmp1))*zx(mgs,lr) + ! Do the correction for alphamax + zrfrz(mgs) = zxd1*dtpinv + ! tmp4 is the Z from the converted particles assuming shape of alphamax + IF ( icorrectfddbz >= 1 .and. zxd1 > zxmincorr .and. cxd1 > cxmincorr ) THEN + IF ( icorrectfddbz == 1 ) THEN + ! tmp3 is cx that is consistent with increased q and Z + ! g1x(mgs,lhl) = (pi*xdn(mgs,lhl))**2*zx(mgs,lhl)*cx(mgs,lhl)/((6.*rho0(mgs)*qx(mgs,lhl))**2) + il = lh + IF ( lf > 0 ) il = lf + tmp3 = g1x(mgs,il)*(rho0(mgs)*(qx(mgs,il)+qxd1))**2/((pi*xdn(mgs,il)/6.0)**2*(zx(mgs,il)+zxd1) ) + crfrzf(mgs) = dtpinv*Max(0.0, tmp3 - cx(mgs,il) ) + + ELSE ! old version (not robust) + tmp3 = g1xmax*(rho0(mgs)*qxd1)**2/((pi*rhofrz/6.0)**2) + tmp4 = tmp3/cxd1 + IF ( tmp4 > zxd1 ) THEN ! calculate new graupel/fd number to match zxd1 + ! increase cxd1 to make z,q,c rates consistent + ! cxd1 = g1xmax*(rho0(mgs)*qxd1)**2/(zxd1*(pi*xdn(mgs,lh)/6.0)**2) + cxd1 = tmp3/zxd1 + crfrzf(mgs) = dtpinv*cxd1 + ENDIF + ENDIF ! t/f + ENDIF + + ELSE ! }{ + IF ( icorrectfddbz >= 1 ) THEN + tmp5 = g1x(mgs,lr)*(rho0(mgs)*qx(mgs,lr))**2/((pi*xdn(mgs,lr)/6.)**2*cx(mgs,lr)) + zxd1 = (tmp1 + dely*dqiacralphainv*(tmp2 - tmp1))*tmp5 ! reflectivity transfer from rain + IF ( icorrectfddbz == 1 ) THEN + IF ( zxd1 > zxmincorr .and. cxd1 > cxmincorr ) THEN + ! tmp3 is cx that is consistent with increased q and Z + ! g1x(mgs,lhl) = (pi*xdn(mgs,lhl))**2*zx(mgs,lhl)*cx(mgs,lhl)/((6.*rho0(mgs)*qx(mgs,lhl))**2) + il = lh + IF ( lf > 0 ) il = lf + IF ( cx(mgs,il) > cxmin ) THEN + ! graupel/fd reflectivity + tmp = g1x(mgs,il)*(rho0(mgs)*qx(mgs,il))**2/((pi*xdn(mgs,il)/6.)**2*cx(mgs,il)) + ELSE + tmp = 0. + ENDIF + tmp3 = g1x(mgs,il)*(rho0(mgs)*(qx(mgs,il)+qxd1))**2/((pi*xdn(mgs,il)/6.0)**2*(tmp+zxd1) ) + crfrzf(mgs) = dtpinv*Max(0.0, tmp3 - cx(mgs,il) ) + ENDIF + ELSEIF ( icorrectfddbz > 1 ) THEN ! old version + ! tmp5 is rain reflectivity moment + tmp5 = g1x(mgs,lr)*(rho0(mgs)*qx(mgs,lr))**2/((pi*xdn(mgs,lr)/6.)**2*cx(mgs,lr)) + zxd1 = (tmp1 + dely*dqiacralphainv*(tmp2 - tmp1))*tmp5 + IF ( zxd1 > zxmincorr .and. cxd1 > cxmincorr ) THEN + ! tmp4 is the reflectivity of the newly-converted graupel particles (use g1x(lh) for loss term) + ! which we want to match zxd1 to prevent spurious increase in total reflectivity + tmp3 = g1x(mgs,lh)*(rho0(mgs)*qxd1)**2/((pi*xdn(mgs,lr)/6.0)**2) + tmp4 = tmp3/cxd1 + IF ( tmp4 > zxd1 ) THEN ! calculate new FD number to match zxd1 + crfrzf(mgs) = tmp3/zxd1*dtpinv + ENDIF + ENDIF + ENDIF + ENDIF + ENDIF !} + ENDIF !} + + ENDIF ! } + ELSE + crfrzs(mgs) = 0.0 + qrfrzs(mgs) = 0.0 + + zrfrzs(mgs) = 0.0 + + ENDIF ! } + + ENDIF !} + + IF ( (qrfrz(mgs))*dtp > qx(mgs,lr) ) THEN + fac = ( qrfrz(mgs) )*dtp/qx(mgs,lr) + qrfrz(mgs) = fac*qrfrz(mgs) qrfrzs(mgs) = fac*qrfrzs(mgs) qrfrzf(mgs) = fac*qrfrzf(mgs) crfrz(mgs) = fac*crfrz(mgs) crfrzs(mgs) = fac*crfrzs(mgs) crfrzf(mgs) = fac*crfrzf(mgs) + IF ( ipconc >= 6 .and. lzr > 1 ) THEN zrfrz(mgs) = fac*zrfrz(mgs) zrfrzf(mgs) = fac*zrfrzf(mgs) ENDIF + ENDIF ENDIF !} @@ -18072,7 +19903,13 @@ subroutine nssl_2mom_gs & tmp = 0 IF ( qrfrz(mgs)*dtp > qxmin(lh) .and. crfrz(mgs) > 1.e-3 ) THEN tmpdiam = 1.e6*( 6.*qrfrz(mgs)/(1000.*pi*crfrz(mgs) ))**(1./3.) ! avg. diameter of newly frozen drops in microns - tmp = lawson_splinter_fac*tmpdiam**4*crfrz(mgs) + fac = 1.0 + IF ( nsplinter .eq. 1001 ) THEN + ! fac = 0.2/sqrt(2.0*pi*10.**2)*Exp(-0.5*((258.-temg(mgs))/10.)**2 ) ! temperature dependence from Sullivan et al. 2018 ACP + ! ELSE + fac = 0.2*Exp(-0.5*((258.-temg(mgs))/10.)**2 ) ! temperature dependence from Sullivan et al. 2018 ACP + ENDIF + tmp = fac*lawson_splinter_fac*tmpdiam**4*crfrz(mgs) ENDIF ELSEIF ( nsplinter .gt. 0 ) THEN tmp = nsplinter*crfrz(mgs) @@ -18111,6 +19948,7 @@ subroutine nssl_2mom_gs & do mgs = 1,ngscnt qwfrz(mgs) = 0.0 cwfrz(mgs) = 0.0 + qwfrzc(mgs) = 0.0 cwfrzc(mgs) = 0.0 qwfrzp(mgs) = 0.0 @@ -18139,6 +19977,7 @@ subroutine nssl_2mom_gs & !!! cwfrz(mgs) = Min(cwfrz(mgs),ccmxd(mgs)) qwfrz(mgs) = cwfrz(mgs)*xdn0(lc)*rhoinv(mgs)*(volt + xv(mgs,lc)) + ELSE ratio = (1. + alpha(mgs,lc))*volt/xv(mgs,lc) @@ -18170,6 +20009,7 @@ subroutine nssl_2mom_gs & ENDIF + ENDIF ENDIF if ( temg(mgs) .gt. 268.15 ) then @@ -18179,16 +20019,18 @@ subroutine nssl_2mom_gs & end if ENDIF ! - if ( xplate(mgs) .eq. 1 ) then - qwfrzp(mgs) = qwfrz(mgs) - cwfrzp(mgs) = cwfrz(mgs) - end if + +! if ( xplate(mgs) .eq. 1 ) then + qwfrzp(mgs) = xplate(mgs)*qwfrz(mgs) + cwfrzp(mgs) = xplate(mgs)*cwfrz(mgs) +! end if ! - if ( xcolmn(mgs) .eq. 1 ) then - qwfrzc(mgs) = qwfrz(mgs) - cwfrzc(mgs) = cwfrz(mgs) - end if +! if ( xcolmn(mgs) .eq. 1 ) then + qwfrzc(mgs) = xcolmn(mgs)*qwfrz(mgs) + cwfrzc(mgs) = xcolmn(mgs)*cwfrz(mgs) +! end if + ! ! qwfrzp(mgs) = 0.0 ! qwfrzc(mgs) = qwfrz(mgs) @@ -18214,6 +20056,7 @@ subroutine nssl_2mom_gs & qwctfzc(mgs) = 0.0 cwctfzp(mgs) = 0.0 qwctfzp(mgs) = 0.0 + IF ( icfn .ge. 1 ) THEN IF ( temg(mgs) .lt. 271.15 .and. qx(mgs,lc) .gt. qxmin(lc)) THEN @@ -18273,20 +20116,22 @@ subroutine nssl_2mom_gs & ENDIF ! - if ( xplate(mgs) .eq. 1 ) then - qwctfzp(mgs) = qwctfz(mgs) - cwctfzp(mgs) = cwctfz(mgs) - end if + +! if ( xplate(mgs) .eq. 1 ) then + qwctfzp(mgs) = xplate(mgs)*qwctfz(mgs) + cwctfzp(mgs) = xplate(mgs)*cwctfz(mgs) +! end if ! - if ( xcolmn(mgs) .eq. 1 ) then - qwctfzc(mgs) = qwctfz(mgs) - cwctfzc(mgs) = cwctfz(mgs) - end if +! if ( xcolmn(mgs) .eq. 1 ) then + qwctfzc(mgs) = xcolmn(mgs)*qwctfz(mgs) + cwctfzc(mgs) = xcolmn(mgs)*cwctfz(mgs) +! end if ! IF ( cwctfz(mgs)*dtp > 0.5 .and. dtp*qwctfz(mgs) > qxmin(li) ) THEN ! write(91,*) 'cwctfz: ',cwctfz(mgs),qwctfz(mgs) ! ,cwctfzc(mgs),qwctfzc(mgs) ! ENDIF + ! ! qwctfzc(mgs) = qwctfz(mgs) ! qwctfzp(mgs) = 0.0 @@ -18302,8 +20147,6 @@ subroutine nssl_2mom_gs & ! Hobbs-Rangno ice enhancement (Ferrier, 1994) ! if (ndebug .gt. 0 ) write(0,*) 'conc 23a' - dthr = 300.0 - hrifac = (1.e-3)*((0.044)*(0.01**3)) do mgs = 1,ngscnt ciihr(mgs) = 0.0 qiihr(mgs) = 0.0 @@ -18311,9 +20154,15 @@ subroutine nssl_2mom_gs & qicichr(mgs) = 0.0 cipiphr(mgs) = 0.0 qipiphr(mgs) = 0.0 + ENDDO + + dthr = 300.0 + ! hrifac = (1.e-3)*((0.044)*(0.01**3)) + hrifac = cimas1 IF ( ihrn .ge. 1 ) THEN + do mgs = 1,ngscnt if ( qx(mgs,lc) .gt. qxmin(lc) ) then - if ( temg(mgs) .lt. 273.15 ) then + if ( temg(mgs) .lt. 265.15 ) then ! write(iunit,'(3(1x,i3),3(1x,1pe12.5))') ! : igs(mgs),jgs,kgs(mgs),cx(mgs,lc),rho0(mgs),qx(mgs,lc) ! write(iunit,'(1pe15.6)') @@ -18325,10 +20174,10 @@ subroutine nssl_2mom_gs & ! > ((1.e-3)*rho0(mgs)*qx(mgs,lc))/(cx(mgs,lc)*(1.e-6))) IF ( Log(cx(mgs,lc)*(1.e-6)/(3.0)) .gt. 0.0 ) THEN - ciihr(mgs) = ((1.69e17)/dthr) & + ciihr(mgs) = ((1.69e17)) & & *(log(cx(mgs,lc)*(1.e-6)/(3.0)) * & & ((1.e-3)*rho0(mgs)*qx(mgs,lc))/(cx(mgs,lc)*(1.e-6)))**(7./3.) - ciihr(mgs) = ciihr(mgs)*(1.0e6) + ciihr(mgs) = (ciihr(mgs)*(1.0e6) - cx(mgs,li) - cx(mgs,ls))/dthr qiihr(mgs) = hrifac*ciihr(mgs)/rho0(mgs) qiihr(mgs) = max(qiihr(mgs), 0.0) qiihr(mgs) = min(qiihr(mgs),qcmxd(mgs)) @@ -18349,8 +20198,8 @@ subroutine nssl_2mom_gs & ! end if end if - ENDIF ! ihrn end do + ENDIF ! ihrn ! ! ! @@ -18416,6 +20265,7 @@ subroutine nssl_2mom_gs & + ! ! Ventilation coeficients ! @@ -18455,6 +20305,7 @@ subroutine nssl_2mom_gs & ENDIF + ENDIF ! icond .eq. 1 end do @@ -18494,6 +20345,7 @@ subroutine nssl_2mom_gs & x = 1. + alpha(mgs,lr) IF ( ipconc >= 6 .and. lzr > 1 ) THEN ! 3 moment + tmp = 1. + alpr ! alpha(mgs,lr) i = Int(dgami*(tmp)) del = tmp - dgam*i @@ -18503,6 +20355,7 @@ subroutine nssl_2mom_gs & i = Int(dgami*(tmp)) del = tmp - dgam*i y = (gmoi(i) + (gmoi(i+1) - gmoi(i))*del*dgami)/g1palp ! ratio of gamma functions + ELSE y = ventrxn(mgs) ENDIF @@ -18520,12 +20373,14 @@ subroutine nssl_2mom_gs & rwventz(mgs) = 0.0 + ! rwventz(mgs) = & ! & 0.78*x + & ! & 0.308*fvent(mgs)*y* & ! & Sqrt(ax(lr)*rhovt(mgs))*(vent1/vent2) + ELSEIF ( iferwisventr == 2 ) THEN ! Following Wisner et al. (1972) but using gamma of volume. Note that Ferrier rain fall speed does not integrate with gamma of volume, so using Vr = ar*d^br @@ -18537,7 +20392,9 @@ subroutine nssl_2mom_gs & & *(xdia(mgs,lr,1)**((1.0+br)/2.0)) ) + IF ( ipconc >= 7 ) THEN + ! vent coeff. for reflectivity rate from evaporation alpr = Min(alpharmax,alpha(mgs,lr) ) tmp = alpr + 5.5 + br/2. @@ -18554,6 +20411,7 @@ subroutine nssl_2mom_gs & ENDIF + ENDIF ! iferwisventr @@ -18601,8 +20459,8 @@ subroutine nssl_2mom_gs & do mgs = 1,ngscnt IF ( qx(mgs,lh) .gt. qxmin(lh) ) THEN + IF ( icdx /= 6 .and. alpha(mgs,lh) .eq. 0.0 ) THEN hwventc = (4.0*gr/(3.0*cdxgs(mgs,lh)))**(0.25) - IF ( .false. .or. alpha(mgs,lh) .eq. 0.0 ) THEN hwvent(mgs) = & & ( hwventa + hwventb*hwventc*fvent(mgs) & & *((xdn(mgs,lh)/rho0(mgs))**(0.25)) & @@ -18643,6 +20501,7 @@ subroutine nssl_2mom_gs & end do + hlvent(:) = 0.0 hlventy(:) = 0.0 @@ -18654,9 +20513,9 @@ subroutine nssl_2mom_gs & ! hwventc = (4.0*gr/(3.0*cdx(lhl)))**(0.25) do mgs = 1,ngscnt IF ( qx(mgs,lhl) .gt. qxmin(lhl) ) THEN - hwventc = (4.0*gr/(3.0*cdxgs(mgs,lhl)))**(0.25) - IF ( .false. .or. alpha(mgs,lhl) .eq. 0.0 ) THEN + IF ( icdxhl /= 6 .and. alpha(mgs,lhl) .eq. 0.0 ) THEN + hwventc = (4.0*gr/(3.0*cdxgs(mgs,lhl)))**(0.25) hlvent(mgs) = & & ( hwventa + hwventb*hwventc*fvent(mgs) & & *((xdn(mgs,lhl)/rho0(mgs))**(0.25)) & @@ -18781,6 +20640,8 @@ subroutine nssl_2mom_gs & chlmlrr(:) = 0.0 + + if ( .not. mixedphase ) then !{ do mgs = 1,ngscnt ! @@ -18793,6 +20654,7 @@ subroutine nssl_2mom_gs & & , 0.0 ) ENDIF + ! IF ( qx(mgs,ls) .gt. 0.1e-4 ) write(0,*) 'qsmlr: ',qsmlr(mgs),qx(mgs,ls),cx(mgs,ls),fmlt1(mgs), ! : temcg(mgs),swvent(mgs),xdia(mgs,ls,1),qss0(mgs)-qx(mgs,lv) @@ -18816,6 +20678,7 @@ subroutine nssl_2mom_gs & ELSEIF ( ibinhmlr == 1 ) THEN ! use incomplete gamma functions to approximate the bin results + qhmlr(mgs) = & & min( & & fmlt1(mgs)*cx(mgs,lh)*hwvent(mgs)*xdia(mgs,lh,1) & @@ -19668,9 +21531,11 @@ subroutine nssl_2mom_gs & ! write(iunit,*) 'chmlrr parts: ',(qhmlr0-qhmlr05)/((qxd1-qxd05)/(cxd1-cxd05)), qhmlr05/(qxd05/cxd05), rho0(mgs)*(qhmlr2*mltmass1inv), rho0(mgs)*( qhmlr12*mltmass2inv) ! write(iunit,*) 'qhmlr0: ',qhmlr0,qhmlr05,qhmlr2,qhmlr12 ! ENDIF + ELSEIF ( ibinhmlr == 2 .or. ibinhmlr == 3 ) THEN + ENDIF @@ -19698,8 +21563,7 @@ subroutine nssl_2mom_gs & ELSEIF ( ibinhlmlr == 1 ) THEN ! use incomplete gamma functions to approximate the bin results -! #ifdef 1 -! #if (defined 1) && defined( COMMAS ) || defined( COMMASTMP ) + qhlmlr(mgs) = & & min( & @@ -20668,8 +22532,10 @@ subroutine nssl_2mom_gs & ENDIF !} + ELSEIF ( ibinhlmlr == -1 ) THEN ! OLD VERSION use incomplete gamma functions to approximate the bin results + ENDIF ! ibinhlmlr @@ -20695,6 +22561,7 @@ subroutine nssl_2mom_gs & IF ( .not. mixedphase ) THEN qhmlr(mgs) = max( qhmlr(mgs), Min( -qhmxd(mgs), -0.95*qx(mgs,lh)*dtpinv ) ) chmlr(mgs) = max( chmlr(mgs), Min( -chmxd(mgs), -0.95*cx(mgs,lh)*dtpinv ) ) + ENDIF ! qhmlr(mgs) = max( max( qhmlr(mgs), -qhmxd(mgs) ) , -0.5*qx(mgs,lh)*dtpinv ) !limits to 1/2 qh or max depletion qhmlh(mgs) = 0. ! not used @@ -20716,6 +22583,7 @@ subroutine nssl_2mom_gs & if ( ipconc .ge. 1 ) then do mgs = 1,ngscnt cimlr(mgs) = (cx(mgs,li)/(qx(mgs,li)+1.e-20))*qimlr(mgs) + IF ( .not. mixedphase ) THEN !{ IF ( xdia(mgs,ls,1) .gt. 1.e-6 .and. -qsmlr(mgs) .ge. 0.5*qxmin(ls) .and. ipconc .ge. 4 ) THEN ! csmlr(mgs) = rho0(mgs)*qsmlr(mgs)/(xv(mgs,ls)*rhosm) @@ -20734,6 +22602,7 @@ subroutine nssl_2mom_gs & + ! IF ( xdia(mgs,lh,1) .gt. 1.e-6 .and. Abs(qhmlr(mgs)) .ge. qxmin(lh) ) THEN ! chmlr(mgs) = rho0(mgs)*qhmlr(mgs)/(pi*xdn(mgs,lh)*xdia(mgs,lh,1)**3) ! out of hail ! chmlr(mgs) = Max( chmlr(mgs), -chmxd(mgs) ) @@ -20774,7 +22643,9 @@ subroutine nssl_2mom_gs & ! ENDIF + IF ( chmlr(mgs) < 0.0 .and. (ibinhmlr < 1 .or. lzh < 1) ) THEN ! { already done if ibinhmlr > 0 + IF ( ipconc >= 6 .and. lzr .gt. 1 .and. lzh < 1 .and. qx(mgs,lh) > qxmin(lh) ) THEN ! Only compute if rain is 3-moment but graupel is not, otherwise is computed later tmp = qx(mgs,lh)/cx(mgs,lh) alp = alpha(mgs,lh) @@ -20783,6 +22654,7 @@ subroutine nssl_2mom_gs & zhmlr(mgs) = g1*(6.*rho0(mgs)/(pi*xdn(mgs,lh)))**2*( 2.*tmp * qhmlr(mgs) - tmp**2 * chmlr(mgs) ) ENDIF + IF ( ibinhmlr == 0 .or. lzh < 1 ) THEN IF ( ihmlt .eq. 1 ) THEN @@ -20888,6 +22760,7 @@ subroutine nssl_2mom_gs & ENDIF !} + IF ( ipconc >= 8 .and. lzhl .gt. 1 .and. ibinhlmlr <= 0 ) THEN IF ( cx(mgs,lhl) > 0.0 ) THEN @@ -20899,6 +22772,7 @@ subroutine nssl_2mom_gs & zhlmlr(mgs) = g1*(6.*rho0(mgs)/(pi*xdn(mgs,lhl)))**2*( tmp * qhlmlr(mgs) ) ENDIF ENDIF + ENDIF ! } ENDIF ! }.not. mixedphase @@ -20917,6 +22791,7 @@ subroutine nssl_2mom_gs & rwcap(mgs) = (0.5)*xdia(mgs,lr,1) swcap(mgs) = (0.5)*xdia(mgs,ls,1) hwcap(mgs) = (0.5)*xdia(mgs,lh,1) + IF ( lhl .gt. 1 ) hlcap(mgs) = (0.5)*xdia(mgs,lhl,1) if ( qx(mgs,li).gt.qxmin(li) .and. xdia(mgs,li,1) .gt. 0.0 ) then @@ -20939,11 +22814,13 @@ subroutine nssl_2mom_gs & qhdsv(:) = 0.0 qhldsv(:) = 0.0 + do mgs = 1,ngscnt IF ( icond .eq. 1 .or. temg(mgs) .le. tfrh & & .or. (qx(mgs,lr) .le. qxmin(lr) .and. qx(mgs,lc) .le. qxmin(lc)) ) THEN qidsv(mgs) = & & fvds(mgs)*cx(mgs,li)*civent(mgs)*cicap(mgs)*depfac + qsdsv(mgs) = & & fvds(mgs)*cx(mgs,ls)*swvent(mgs)*swcap(mgs)*depfac @@ -20954,11 +22831,13 @@ subroutine nssl_2mom_gs & ! ENDIF ELSE qidsv(mgs) = 0.0 + qsdsv(mgs) = 0.0 ENDIF qhdsv(mgs) = & & fvds(mgs)*cx(mgs,lh)*hwvent(mgs)*hwcap(mgs)*depfac + IF ( lhl .gt. 1 ) qhldsv(mgs) = fvds(mgs)*cx(mgs,lhl)*hlvent(mgs)*hlcap(mgs)*depfac ! ! @@ -21008,6 +22887,7 @@ subroutine nssl_2mom_gs & qsstmp = qisstmp + dqwvtmp(mgs) = ( qvtmp(mgs) - qsstmp ) @@ -21030,6 +22910,7 @@ subroutine nssl_2mom_gs & ! evaporation and sublimation adjustment ! if( dqwv(mgs) .lt. 0. ) then ! { subsaturated + if( qitmp(mgs) .gt. -dqwv(mgs) ) then ! check if qi can make up all the deficit dqci(mgs) = dqwv(mgs) dqwv(mgs) = 0. @@ -21087,6 +22968,7 @@ subroutine nssl_2mom_gs & dqvcnd(mgs) = dqwv(mgs)/(1. + fcqv2(mgs)*qsstmp/ & & ((temg(mgs)-cbi)**2)) + if ( temg(mgs) .ge. tfr ) then dqvcnd(mgs) = dqwv(mgs)/(1. + fcqv1(mgs)*qsstmp/ & & ((temg(mgs)-cbw)**2)) @@ -21144,15 +23026,18 @@ subroutine nssl_2mom_gs & qvstmp = pqs(mgs)*tabqvs(ltemq) ELSEIF ( iqvsopt == 1 ) THEN qvstmp = rdorv*esbolton*tabqvs(ltemq)/(pres(mgs) - esbolton*tabqvs(ltemq)) + ENDIF qisstmp = pqs(mgs)*tabqis(ltemq) qctmp(mgs) = max( 0.0, qctmp(mgs) ) qitmp(mgs) = max( 0.0, qitmp(mgs) ) qvtmp(mgs) = max( 0.0, qvaptmp ) + ! qsstmp = qvstmp qsstmp = qisstmp + ELSE ! set max depletion @@ -21195,6 +23080,7 @@ subroutine nssl_2mom_gs & chlcev(:) = 0.0 qfcev(:) = 0.0 + do mgs = 1,ngscnt qisbv(mgs) = 0.0 qssbv(mgs) = 0.0 @@ -21203,6 +23089,7 @@ subroutine nssl_2mom_gs & qhsbv(mgs) = 0.0 qscev(mgs) = 0.0 cscev(mgs) = 0.0 + IF ( icond .eq. 1 .or. temg(mgs) .le. tfrh & & .or. (qx(mgs,lr) .le. qxmin(lr) .and. qx(mgs,lc) .le. qxmin(lc)) ) THEN ! last condition (qr qxmin(lh) .and. qx(mgs,lh) > hlcnhqmin .and. & + temg(mgs) .le. tfr + wetgrthtoffset .and. temg(mgs) .ge. 243.15 ) ) THEN +! dw = 0.01*( Exp( -temcg(mgs)/( 1.1e4 * rho0(mgs)*ehw(mgs)*qx(mgs,lc) - 1.3e3*rho0(mgs)*qx(mgs,li) + 1.0 ) ) - 1.0 ) +! dwr = 0.01*( Exp( -temcg(mgs)/( 1.1e4 * rho0(mgs)*(ehw(mgs)*qx(mgs,lc)+ehr(mgs)*qx(mgs,lr)) - & +! 1.3e3*rho0(mgs)*qx(mgs,li) + 1.0 ) ) - 1.0 ) + x = 1.1e4 * rho0(mgs)*(ehw(mgs)*qx(mgs,lc)+ehr(mgs)*qx(mgs,lr)) - & + 1.3e3*rho0(mgs)*qx(mgs,li) + 1.0 + IF ( x > 1.e-20 ) THEN + arg = Min(70.0, (-temcg(mgs)/x )) ! prevent overflow of the exp function in 32 bit + dwr = 0.01*(exp(arg) - 1.0) + ELSE + dwr = 1.e30 + ENDIF + d = dwr + + IF ( dwr < 0.2 .and. dwr > 0.0 .and. rho0(mgs)*(qx(mgs,lc)+qx(mgs,lr)) > 1.e-4 ) THEN + + + h1 = ( -ftka(mgs)*temcg(mgs) - felv(mgs)*fwvdf(mgs)*rho0(mgs)*(qx(mgs,lv) - qvs0) ) + h2 = ehi(mgs)*qx(mgs,li)*rho0(mgs)*fci(mgs)*temcg(mgs) + h3 = Max(dwehwmin, ehw(mgs))*qx(mgs,lc) + h4 = ehr(mgs)* qx(mgs,lr) + ! iterate to find minimum diameter for wet growth. Start with value of dwr + DO n = 1,10 + d = Max(d, 1.e-4) + dold = d + vth = axx(mgs,lh)*d**bxx(mgs,lh) + x2 = fventh*sqrtrhovt*Sqrt(d*vth) + IF ( x2 > 1.4 ) THEN + ah = 0.78 + 0.308*x2 ! heat ventillation + ELSE + ah = 1.0 + 0.108*x2**2 ! mass ventillation (Beard and Pruppacher 1971, eq. 9) + ENDIF + + + d = 8.*ah*h1/ & + ( ( Max(0.001,vth - vtxbar(mgs,lc,1))*h3 + & + Max(0.001,vth - vtxbar(mgs,lr,1))*h4) *rho0(mgs)*denomdp + & + Max(0.001,vth - vtxbar(mgs,li,1))*h2) + + + IF ( Abs(dold - d)/dold < 0.05 .or. ( n > 3 .and. d > dg0thresh ) ) EXIT + + ENDDO + ENDIF + + dhwet(mgs) = Min(dg0thresh + 0.0001, Max( d, dwetmin )) + ELSE + dhwet(mgs) = dg0thresh + 0.0001 + ENDIF + + IF (((qhlacw(mgs) + qhlacr(mgs))*dtp > qxmin(lhl) .and. qx(mgs,lhl) > 0.01e-3 & + .and. temg(mgs) .le. tfr + wetgrthtoffset .and. temg(mgs) .ge. 243.15 ) ) THEN +! dw = 0.01*( Exp( -temcg(mgs)/( 1.1e4 * rho0(mgs)*ehlw(mgs)*qx(mgs,lc) - 1.3e3*rho0(mgs)*qx(mgs,li) + 1.0 ) ) - 1.0 ) +! dwr = 0.01*( Exp( -temcg(mgs)/( 1.1e4 * rho0(mgs)*(ehlw(mgs)*qx(mgs,lc)+ehlr(mgs)*qx(mgs,lr)) - & +! 1.3e3*rho0(mgs)*qx(mgs,li) + 1.0 ) ) - 1.0 ) + IF ( dhwet(mgs) < dg0thresh ) THEN ! if there is graupel, then probably dhwet is good starting value + d = dhwet(mgs) + ELSE + x = 1.1e4 * rho0(mgs)*(ehlw(mgs)*qx(mgs,lc)+ehlr(mgs)*qx(mgs,lr)) - & + 1.3e3*rho0(mgs)*qx(mgs,li) + 1.0 + IF ( x > 1.e-20 ) THEN + arg = Min(70.0, (-temcg(mgs)/x )) ! prevent overflow of the exp function in 32 bit + dwr = 0.01*(exp(arg) - 1.0) + ELSE + dwr = 1.e30 + ENDIF + d = dwr + ENDIF + IF ( dwr < 0.2 .and. dwr > 0.0 .and. rho0(mgs)*(qx(mgs,lc)+qx(mgs,lr)) > 1.e-4 ) THEN + +! write(91,*) 'dw,dwr,temcg = ',100.*dw,100.*dwr,temcg(mgs) + h1 = ( -ftka(mgs)*temcg(mgs) - felv(mgs)*fwvdf(mgs)*rho0(mgs)*(qx(mgs,lv) - qvs0) ) + h2 = ehi(mgs)*qx(mgs,li)*rho0(mgs)*fci(mgs)*temcg(mgs) + h3 = Max(dwehwmin, ehlw(mgs))*qx(mgs,lc) + h4 = ehlr(mgs)* qx(mgs,lr) + ! iterate to find minimum diameter for wet growth. Start with value of dwr + DO n = 1,10 + d = Max(d, 1.e-4) + dold = d + vth = axx(mgs,lhl)*d**bxx(mgs,lhl) + x2 = fventh*sqrtrhovt*Sqrt(d*vth) + IF ( x2 > 1.4 ) THEN + ah = 0.78 + 0.308*x2 ! heat ventillation + ELSE + ah = 1.0 + 0.108*x2**2 ! mass ventillation (Beard and Pruppacher 1971, eq. 9) + ENDIF + + + d = 8.*ah*h1/ & + ( ( Max(0.001,vth - vtxbar(mgs,lc,1))*h3 + & + Max(0.001,vth - vtxbar(mgs,lr,1))*h4) *rho0(mgs)*denomdp + & + Max(0.001,vth - vtxbar(mgs,li,1))*h2) + + + IF ( Abs(dold - d)/dold < 0.05 .or. ( n > 3 .and. d > dg0thresh ) ) EXIT + + ENDDO + ENDIF + + dhlwet(mgs) = Min(dg0thresh + 0.0001, Max( d, dwetmin ) ) + + ELSE + dhlwet(mgs) = dg0thresh + 0.0001 + ENDIF + + + + ENDDO + + ENDIF ! incwet @@ -21429,6 +23464,7 @@ subroutine nssl_2mom_gs & & + qhacw(mgs) ! + qhldry(mgs) = 0.0 IF ( lhl .gt. 1 ) THEN qhldry(mgs) = qhlaci(mgs) + qhlacs(mgs) & @@ -21441,7 +23477,7 @@ subroutine nssl_2mom_gs & ! do mgs = 1,ngscnt - IF ( tfrdry < temg(mgs) .and. temg(mgs) < tfr ) THEN + IF ( tfrdry < temg(mgs) .and. temg(mgs) < tfr ) THEN ! { ! ! qswet(mgs) = ! > ( xdia(mgs,ls,1)*swvent(mgs)*cx(mgs,ls)*fwet1(mgs) @@ -21452,34 +23488,230 @@ subroutine nssl_2mom_gs & ! IF ( dnu(lh) .ne. 0. ) THEN ! qhwet(mgs) = qhdry(mgs) ! ELSE - IF ( incwet == 0 ) THEN + ! IF ( incwet == 0 ) THEN qhwet(mgs) = & & ( xdia(mgs,lh,1)*hwvent(mgs)*cx(mgs,lh)*fwet1(mgs) & & + fwet2(mgs)*(qhaci(mgs) + qhacs(mgs)) ) - qhwet(mgs) = max( 0.0, qhwet(mgs)) - ELSE + qhwet(mgs) = max( 0.0, qhwet(mgs)) + + IF ( incwet == 1 .and. qhwet(mgs) < qhdry(mgs) .and. dhwet(mgs) < dg0thresh ) THEN + ! ELSE + + ! IF ( dhwet(mgs) < dg0thresh ) THEN + ! find portion of qc and qr collection that are dry/wet growth for d > dwet + + ratio = Min( maxratiolu, dhwet(mgs)/xdia(mgs,lh,1) ) + + tmp1 = gaminterp(ratio,alpha(mgs,lh),13,1) ! alpha + 3 + tmp2 = gaminterp(ratio,alpha(mgs,lh),12,1) ! alpha + 2 + tmp3 = gaminterp(ratio,alpha(mgs,lh), 9,1) ! alpha + 1 + + IF ( qhacw(mgs)*dtp > qxmin(lh) ) THEN + vt = abs(vtxbar(mgs,lh,1)-vtxbar(mgs,lc,1)) + + ! dry growth of qc for D > Dwet to substract from qhacw + qxacwtmp = 0.25*pi*ehw(mgs)*cx(mgs,lh)*(qx(mgs,lc)-qcwresv(mgs))*vt* & + & ( tmp1*da0lh(mgs)*xdia(mgs,lh,3)**2 + & + & tmp2*dab1lh(mgs,lh,lc)*xdia(mgs,lh,3)*xdia(mgs,lc,3) + & + & tmp3*da1lc(mgs)*xdia(mgs,lc,3)**2 ) + ELSE + qxacwtmp = 0.0 + ENDIF + + IF ( qhacr(mgs)*dtp > qxmin(lh) ) THEN + + vt = Sqrt((vtxbar(mgs,lh,1)-vtxbar(mgs,lr,1))**2 + & + & 0.04*vtxbar(mgs,lh,1)*vtxbar(mgs,lr,1) ) + + ! dry growth of qr for D > Dwet to substract from qhacr + qxacrtmp = 0.25*pi*ehr(mgs)*cx(mgs,lh)*qx(mgs,lr)*vt* & + & ( tmp1*da0lh(mgs)*xdia(mgs,lh,3)**2 + & + & tmp2*dab1lh(mgs,lh,lr)*xdia(mgs,lh,3)*xdia(mgs,lr,3) + & + & tmp3*da1lr(mgs)*xdia(mgs,lr,3)**2 ) + ELSE + qxacrtmp = 0.0 + ENDIF + + ! hwvent is where the size dependency is, so hxventtmp gives the portion for d > dwet + x = gaminterp(ratio,alpha(mgs,lh),9,1) ! alpha + 1 + y = gaminterp(ratio,alpha(mgs,lh),3,1) ! alpha + b/2 + 5/2 + + hxventtmp = 0.78*x + y*hwventy(mgs) ! & + + ! find the ice and snow collection for d > dwet + qxacitmp = 0.0 + IF ( qhaci(mgs)*dtp > qxmin(lh) ) THEN + vt = abs(vtxbar(mgs,lh,1)-vtxbar(mgs,li,1)) + + ! note that ehi=1 implicitly here + qxacitmp = 0.25*pi*ehiclsn(mgs)*cx(mgs,lh)*qx(mgs,li)*vt* & + & ( tmp1*da0lh(mgs)*xdia(mgs,lh,3)**2 + & + & tmp2*dab1lh(mgs,lh,li)*xdia(mgs,lh,3)*xdia(mgs,li,3) + & + & tmp3*da1(li)*xdia(mgs,li,3)**2 ) + + cxacitmp = & + & 0.25*pi*ehiclsn(mgs)*cx(mgs,lh)*cx(mgs,li)*vt* & + & ( tmp1*da0lh(mgs)*xdia(mgs,lh,3)**2 + & + & tmp2*dab0lh(mgs,lh,li)*xdia(mgs,lh,3)*xdia(mgs,li,3) + & + & tmp3*da0(li)*xdia(mgs,li,3)**2 ) + ENDIF + + qxacstmp = 0.0 + IF ( qhacs(mgs)*dtp > qxmin(lh) ) THEN + vt = abs(vtxbar(mgs,lh,1)-vtxbar(mgs,ls,1)) + + ! note that ehs=1 implicitly here + qxacstmp = 0.25*pi*ehsclsn(mgs)*cx(mgs,lh)*qx(mgs,ls)*vt* & + & ( tmp1*da0lh(mgs)*xdia(mgs,lh,3)**2 + & + & tmp2*dab1lh(mgs,lh,ls)*xdia(mgs,lh,3)*xdia(mgs,ls,3) + & + & tmp3*da1(ls)*xdia(mgs,ls,3)**2 ) + + cxacstmp = 0.25*pi*ehsclsn(mgs)*cx(mgs,lh)*cx(mgs,ls)*vt* & + & ( tmp1*da0lh(mgs)*xdia(mgs,lh,3)**2 + & + & tmp2*dab0lh(mgs,lh,ls)*xdia(mgs,lh,3)*xdia(mgs,ls,3) + & + & tmp3*da0(ls)*xdia(mgs,ls,3)**2 ) + ENDIF + + qxwettmp = & + & xdia(mgs,lh,1)*hxventtmp*cx(mgs,lh)*fwet1(mgs) & + & + fwet2(mgs)*(qxacitmp + qxacstmp) + + tmp = qhwet(mgs) + ! as dry growth but subtract part for D > Dw and add wet growth for D > Dw + qhwet(mgs) = qhacw(mgs) + qhacr(mgs) + qhaci(mgs) + qhacs(mgs) & + - ehi(mgs)*qxacitmp - ehs(mgs)*qxacstmp & + - qxacwtmp - qxacrtmp + qxwettmp + + qhaci(mgs) = qhaci(mgs) + (1.0 - ehi(mgs))*qxacitmp + qhacs(mgs) = qhacs(mgs) + (1.0 - ehs(mgs))*qxacstmp + chaci(mgs) = chaci(mgs) + (1.0 - ehi(mgs))*cxacitmp + chacs(mgs) = chacs(mgs) + (1.0 - ehs(mgs))*cxacstmp + + + ! qhacw(mgs) = Min( qhacw(mgs), 0.5*qx(mgs,lc)*dtpinv ) + + ! ELSE ! for dwet > 15cm, just assume dry growth + ! qhwet(mgs) = qhdry(mgs) + ! ENDIF + ENDIF ! ENDIF + qhlwet(mgs) = 0.0 IF ( lhl .gt. 1 ) THEN - IF ( incwet == 0 ) THEN + !IF ( incwet == 0 ) THEN qhlwet(mgs) = & & ( xdia(mgs,lhl,1)*hlvent(mgs)*cx(mgs,lhl)*fwet1(mgs) & & + fwet2(mgs)*(qhlaci(mgs) + qhlacs(mgs)) ) qhlwet(mgs) = max( 0.0, qhlwet(mgs)) - ELSE + IF ( incwet == 1 .and. qhlwet(mgs) < qhldry(mgs) .and. dhlwet(mgs) < dg0thresh ) THEN + !ELSE + + ! IF ( dhlwet(mgs) < dg0thresh ) THEN + ! find portion of qc and qr collection that are dry/wet growth for d > dwet + + ratio = Min( maxratiolu, dhlwet(mgs)/xdia(mgs,lhl,1) ) + + tmp1 = gaminterp(ratio,alpha(mgs,lhl),13,2) ! alpha + 3 + tmp2 = gaminterp(ratio,alpha(mgs,lhl),12,2) ! alpha + 2 + tmp3 = gaminterp(ratio,alpha(mgs,lhl), 9,2) ! alpha + 1 + + IF ( qhlacw(mgs)*dtp > qxmin(lhl) ) THEN + vt = abs(vtxbar(mgs,lhl,1)-vtxbar(mgs,lc,1)) + + qxacwtmp = 0.25*pi*ehlw(mgs)*cx(mgs,lhl)*(qx(mgs,lc)-qcwresv(mgs))*vt* & + & ( tmp1*da0lhl(mgs)*xdia(mgs,lhl,3)**2 + & + & tmp2*dab1lh(mgs,lhl,lc)*xdia(mgs,lhl,3)*xdia(mgs,lc,3) + & + & tmp3*da1lc(mgs)*xdia(mgs,lc,3)**2 ) + ELSE + qxacwtmp = 0.0 + ENDIF + + IF ( qhlacr(mgs)*dtp > qxmin(lhl) ) THEN + + vt = Sqrt((vtxbar(mgs,lhl,1)-vtxbar(mgs,lr,1))**2 + & + & 0.04*vtxbar(mgs,lhl,1)*vtxbar(mgs,lr,1) ) + + qxacrtmp = 0.25*pi*ehlr(mgs)*cx(mgs,lhl)*qx(mgs,lr)*vt* & + & ( tmp1*da0lhl(mgs)*xdia(mgs,lhl,3)**2 + & + & tmp2*dab1lh(mgs,lhl,lr)*xdia(mgs,lhl,3)*xdia(mgs,lr,3) + & + & tmp3*da1lr(mgs)*xdia(mgs,lr,3)**2 ) + ELSE + qxacrtmp = 0.0 + ENDIF + + x = gaminterp(ratio,alpha(mgs,lhl),9,2) ! alpha + 1 + y = gaminterp(ratio,alpha(mgs,lhl),3,2) ! alpha + b/2 + 5/2 + + hxventtmp = 0.78*x + y*hlventy(mgs) ! & + + qxacitmp = 0.0 + IF ( qhlaci(mgs)*dtp > qxmin(lhl) ) THEN + vt = abs(vtxbar(mgs,lhl,1)-vtxbar(mgs,li,1)) + + qxacitmp = 0.25*pi*ehliclsn(mgs)*cx(mgs,lhl)*qx(mgs,li)*vt* & + & ( tmp1*da0lhl(mgs)*xdia(mgs,lhl,3)**2 + & + & tmp2*dab1lh(mgs,lhl,li)*xdia(mgs,lhl,3)*xdia(mgs,li,3) + & + & tmp3*da1(li)*xdia(mgs,li,3)**2 ) + + cxacitmp = & + & 0.25*pi*ehliclsn(mgs)*cx(mgs,lhl)*cx(mgs,li)*vt* & + & ( tmp1*da0lhl(mgs)*xdia(mgs,lhl,3)**2 + & + & tmp2*dab0lh(mgs,lhl,li)*xdia(mgs,lhl,3)*xdia(mgs,li,3) + & + & tmp3*da0(li)*xdia(mgs,li,3)**2 ) + + ENDIF + + qxacstmp = 0.0 + IF ( qhlacs(mgs)*dtp > qxmin(lhl) ) THEN + vt = abs(vtxbar(mgs,lhl,1)-vtxbar(mgs,ls,1)) + + qxacstmp = 0.25*pi*ehlsclsn(mgs)*cx(mgs,lhl)*qx(mgs,ls)*vt* & + & ( tmp1*da0lhl(mgs)*xdia(mgs,lhl,3)**2 + & + & tmp2*dab1lh(mgs,lhl,ls)*xdia(mgs,lhl,3)*xdia(mgs,ls,3) + & + & tmp3*da1(ls)*xdia(mgs,ls,3)**2 ) + + cxacstmp = 0.25*pi*ehlsclsn(mgs)*cx(mgs,lhl)*cx(mgs,ls)*vt* & + & ( tmp1*da0lhl(mgs)*xdia(mgs,lhl,3)**2 + & + & tmp2*dab0lh(mgs,lhl,ls)*xdia(mgs,lhl,3)*xdia(mgs,ls,3) + & + & tmp3*da0(ls)*xdia(mgs,ls,3)**2 ) + ENDIF + + qxwettmp = & + & xdia(mgs,lhl,1)*hxventtmp*cx(mgs,lhl)*fwet1(mgs) & + & + fwet2(mgs)*(qxacitmp + qxacstmp) + + ! qhlacw(mgs) + qhlacr(mgs) - qxacwtmp - qxacrtmp is the 'dry' growth + ! at smaller diameters +! qhlwet(mgs) = qhlacw(mgs) + qhlacr(mgs) - qxacwtmp - qxacrtmp + qxwettmp + ! as dry growth but subtract part for D > Dw and add wet growth for D > Dw + qhlwet(mgs) = qhlacw(mgs) + qhlacr(mgs) + qhlaci(mgs) + qhlacs(mgs) & + - ehli(mgs)*qxacitmp - ehls(mgs)*qxacstmp & + - qxacwtmp - qxacrtmp + qxwettmp + + qhlaci(mgs) = qhlaci(mgs) + (1.0 - ehli(mgs))*qxacitmp + qhlacs(mgs) = qhlacs(mgs) + (1.0 - ehls(mgs))*qxacstmp + chlaci(mgs) = chlaci(mgs) + (1.0 - ehli(mgs))*cxacitmp + chlacs(mgs) = chlacs(mgs) + (1.0 - ehls(mgs))*cxacstmp + + + ! ELSE + ! qhlwet(mgs) = qhldry(mgs) + ! ENDIF + ENDIF ! incwet ENDIF - ELSE + ELSE ! ( tfrdry < temg(mgs) .and. temg(mgs) < tfr ) qhwet(mgs) = qhdry(mgs) qhlwet(mgs) = qhldry(mgs) - ENDIF + + ENDIF ! } ( tfrdry < temg(mgs) .and. temg(mgs) < tfr ) ! ! qhlwet(mgs) = qhldry(mgs) @@ -21505,6 +23737,7 @@ subroutine nssl_2mom_gs & wetsfchl(:) = .false. wetgrowthhl(:) = .false. + do mgs = 1,ngscnt ! ! @@ -21515,6 +23748,7 @@ subroutine nssl_2mom_gs & qhlshr(mgs) = Min( 0.0, qhlwet(mgs) - qhldry(mgs) ) + ! ! limit wet growth to only higher density particles ! @@ -21533,6 +23767,7 @@ subroutine nssl_2mom_gs & wetgrowth(mgs) = .false. wetsfchl(mgs) = .false. wetgrowthhl(mgs) = .false. + end if ! ! shed all at temperatures > 273.15 @@ -21543,24 +23778,28 @@ subroutine nssl_2mom_gs & qsshr(mgs) = -qsdry(mgs) qhshr(mgs) = -qhdry(mgs) qhlshr(mgs) = -qhldry(mgs) + ELSE ! new and correct ! note that the qxacr terms should be zero here, so shedding at T > 0 is all from the droplets qsshr(mgs) = - qsacr(mgs) - qsacw(mgs) ! -qsdry(mgs) qhlshr(mgs) = - qhlacw(mgs) - qhlacr(mgs) ! -qhldry(mgs) qhshr(mgs) = - qhacw(mgs) - qhacr(mgs) ! -qhdry(mgs) + ENDIF vhshdr(mgs) = -vhacw(mgs) - vhacr(mgs) vhlshdr(mgs) = -vhlacw(mgs) - vhlacr(mgs) qhwet(mgs) = 0.0 qhlwet(mgs) = 0.0 + end if ! ! if (qhshr(mgs) .lt. 0.0 .and. temg(mgs) < tfr ) THEN wetsfc(mgs) = (qhshr(mgs) .lt. 0.0 .and. temg(mgs) < tfr ) .or. ( qhmlr(mgs) < -qxmin(lh) .and. temg(mgs) > tfr ) wetgrowth(mgs) = (qhshr(mgs) .lt. 0.0 .and. temg(mgs) < tfr ) ! ENDIF + if (qhlshr(mgs) .lt. 0.0 .and. temg(mgs) < tfr ) THEN wetsfchl(mgs) = (qhlshr(mgs) .lt. 0.0 .and. temg(mgs) < tfr ) .or. ( qhlmlr(mgs) < -qxmin(lhl) .and. temg(mgs) > tfr ) wetgrowthhl(mgs) = (qhlshr(mgs) .lt. 0.0 .and. temg(mgs) < tfr ) @@ -21571,6 +23810,7 @@ subroutine nssl_2mom_gs & if ( ipconc .ge. 1 ) then do mgs = 1,ngscnt csshr(mgs) = 0.0 ! (cx(mgs,ls)/(qx(mgs,ls)+1.e-20))*Min(0.0,qsshr(mgs)) + chshr(mgs) = 0.0 ! no change to graupel number concentration for wet-growth shedding @@ -21580,6 +23820,7 @@ subroutine nssl_2mom_gs & ! tmpdiam = (shedalp+alpha(mgs,lh))*xdia(mgs,lh,1) chshrr(mgs) = rho0(mgs)*qhshr(mgs)/(xdn(mgs,lr)*vshdgs(mgs,lh)) ! into rain + chlshr(mgs) = 0.0 @@ -21596,14 +23837,17 @@ subroutine nssl_2mom_gs & ! tmpdiam = (shedalp+alpha(mgs,lh))*xdia(mgs,lh,1) chlshrr(mgs) = rho0(mgs)*qhlshr(mgs)/(xdn(mgs,lr)*vshdgs(mgs,lhl)) ! into rain + ENDIF ! ( lhl > 1 ) + end do end if + ! ! final decisions ! @@ -21625,6 +23869,7 @@ subroutine nssl_2mom_gs & ! end if ! + ! graupel ! ! @@ -21669,18 +23914,23 @@ subroutine nssl_2mom_gs & chdpv(mgs) = 0.0 ! chsbv(mgs) = 0.0 + ! collection efficiency modification IF ( ehi(mgs) .gt. 0.0 ) THEN + IF ( incwet == 0 ) THEN qhaci(mgs) = Min(qimxd(mgs),qhaci0(mgs)) ! effectively sets collection eff to 1 chaci(mgs) = Min(cimxd(mgs),chaci0(mgs)) ! effectively sets collection eff to 1 + ENDIF ENDIF IF ( ehs(mgs) .gt. 0.0 ) THEN ! qhacs(mgs) = Min(qsmxd(mgs),qhacs(mgs)/ehs(mgs)) ! effectively sets collection eff to 1 + IF ( incwet == 0 ) THEN qhacs(mgs) = Min(qsmxd(mgs),qhacs0(mgs)) !/ehs(mgs) ! divide out the collection efficiency chacs(mgs) = Min(csmxd(mgs),chacs0(mgs)) !/ehs(mgs) ! divide out the collection efficiency - ehs(mgs) = ehsmax ! 1.0 ! min(ehsfrac*ehs(mgs),ehsmax) ! modify it qhacs(mgs) = Min(qsmxd(mgs),qhacs(mgs)) ! plug it back in + ENDIF + ehs(mgs) = ehsmax ! 1.0 ! min(ehsfrac*ehs(mgs),ehsmax) ! modify it ENDIF ! be sure to catch particles with wet surfaces but not in wet growth to turn off Hallett-Mossop @@ -21706,6 +23956,7 @@ subroutine nssl_2mom_gs & + IF ( lvol(lhl) .gt. 1 .and. .not. mixedphase ) THEN ! IF ( lvol(lhl) .gt. 1 .and. wetgrowthhl(mgs) ) THEN @@ -21746,7 +23997,7 @@ subroutine nssl_2mom_gs & ! vhlacr(mgs) = rho0(mgs)*qhlacr(mgs)/xdn0(lr) ENDIF - IF ( ehli(mgs) .gt. 0.0 ) THEN + IF ( ehli(mgs) .gt. 0.0 .and. incwet == 0 ) THEN qhlaci(mgs) = Min(qimxd(mgs),qhlaci0(mgs)) ! effectively sets collection eff to 1 chlaci(mgs) = Min(cimxd(mgs),chlaci0(mgs)) ! effectively sets collection eff to 1 ENDIF @@ -21754,7 +24005,7 @@ subroutine nssl_2mom_gs & ! IF ( ehls(mgs) .gt. 0.0 ) THEN ! qhlacs(mgs) = Min(qsmxd(mgs),qhlacs(mgs)/ehls(mgs)) ! ENDIF - IF ( ehls(mgs) .gt. 0.0 ) THEN + IF ( ehls(mgs) .gt. 0.0 .and. incwet == 0 ) THEN qhlacs(mgs) = Min(qsmxd(mgs),qhlacs0(mgs)) !/ehls(mgs) ! divide out the collection efficiency chlacs(mgs) = Min(csmxd(mgs),chlacs0(mgs)) !/ehls(mgs) ! divide out the collection efficiency ehls(mgs) = ehsmax ! 1.0 ! min(ehsfrac*ehs(mgs),ehsmax) ! modify it @@ -21773,6 +24024,7 @@ subroutine nssl_2mom_gs & ! qhlwet(mgs) = 0.0 end if + end do ! ! Ice -> graupel conversion @@ -21861,6 +24113,7 @@ subroutine nssl_2mom_gs & zhcnhl(:) = 0.0 + IF ( lhl .gt. 1 ) THEN IF ( ihlcnh == 1 .or. ihlcnh == 3 ) THEN @@ -21880,14 +24133,21 @@ subroutine nssl_2mom_gs & ltest = xdia(mgs,lh,1)*(4. + alpha(mgs,lh)) > Abs( hlcnhdia ) ! test on mass-weighted diameter ENDIF + + ! if incwet > 0, then should use dhwet here to avoid calculating again IF ( iusedw == 0 .and. ihlcnh == 1 ) THEN dg0(mgs) = -1. ELSE - IF (((qhacw(mgs) + qhacr(mgs))*dtp > qxmin(lh) .and. qx(mgs,lh) > hlcnhqmin .and. temg(mgs) .le. tfr-2.0 & - .and. temg(mgs) .gt. dwtempmin ) .or. ( wetgrowth(mgs) .and. qx(mgs,lh) > hlcnhqmin ) ) THEN + IF ( temg(mgs) .le. tfr+hailcnvtoffset .and. & + (( (qhacw(mgs) + qhacr(mgs))*dtp > qxmin(lh) .and. qx(mgs,lh) > hlcnhqmin & + .and. temg(mgs) .gt. dwtempmin ) .or. ( wetgrowth(mgs) .and. qx(mgs,lh) > hlcnhqmin )) ) THEN ! dw = 0.01*( Exp( -temcg(mgs)/( 1.1e4 * rho0(mgs)*ehw(mgs)*qx(mgs,lc) - 1.3e3*rho0(mgs)*qx(mgs,li) + 1.0 ) ) - 1.0 ) ! dwr = 0.01*( Exp( -temcg(mgs)/( 1.1e4 * rho0(mgs)*(ehw(mgs)*qx(mgs,lc)+ehr(mgs)*qx(mgs,lr)) - & ! 1.3e3*rho0(mgs)*qx(mgs,li) + 1.0 ) ) - 1.0 ) + IF ( incwet > 0 ) THEN + d = dhwet(mgs) + ELSE + ! First guess for dwet (not that good, but it is something) x = 1.1e4 * rho0(mgs)*(ehw(mgs)*qx(mgs,lc)+ehr(mgs)*qx(mgs,lr)) - & 1.3e3*rho0(mgs)*qx(mgs,li) + 1.0 IF ( x > 1.e-20 ) THEN @@ -21896,7 +24156,7 @@ subroutine nssl_2mom_gs & ELSE dwr = 1.e30 ENDIF - d = dwr + d = Min(dwr, dg0thresh + 0.0001) IF ( dwr < 0.2 .and. dwr > 0.0 .and. rho0(mgs)*(qx(mgs,lc)+qx(mgs,lr)) > 1.e-4 ) THEN sqrtrhovt = Sqrt( rhovt(mgs) ) fventh = sqrtrhovt*(fpndl(mgs)**(1./3.)) * (fakvisc(mgs))**(-0.5) @@ -21946,28 +24206,37 @@ subroutine nssl_2mom_gs & Max(0.001,vth - vtxbar(mgs,li,1))*h2) ENDIF + IF ( Abs(dold - d)/dold < 0.05 .or. ( n > 3 .and. d > dg0thresh ) ) EXIT ENDDO - ENDIF + + d = Min( d, dg0thresh + 0.0001 ) + dhwet(mgs) = d + ENDIF ! dwr < 0.2 .and. dwr > 0.0 + ENDIF ! incwet - dg0(mgs) = Min( dwmax, Max( d, dwmin ) ) + ! dg0(mgs) = Min( dwmax, Max( d, dwmin ) ) + dg0(mgs) = Max( d, dwmin ) + ELSE - IF ( qx(mgs,lh) > qxmin(lh) .and. qx(mgs,lh) > hlcnhqmin .and. temg(mgs) .le. tfr-2.0 ) THEN - dg0(mgs) = dwmax - ELSE + ! IF ( qx(mgs,lh) > qxmin(lh) .and. qx(mgs,lh) > hlcnhqmin .and. temg(mgs) .le. tfr+hailcnvtoffset ) THEN + ! dg0(mgs) = dwmax + ! ELSE dg0(mgs) = dg0thresh + 0.0001 - ENDIF + ! ENDIF ENDIF IF ( ihlcnh == 3 .and. (qhacw(mgs) + qhacr(mgs))*dtp > qxmin(lh) .and. qx(mgs,lh) > hlcnhqmin & - .and. temg(mgs) .le. tfr-2.0 ) THEN + .and. temg(mgs) .le. tfr+hailcnvtoffset .and. temg(mgs) > 238.0 ) THEN ! set a secondary condition on to capture large graupel that is riming but not in wet growth - dg0(mgs) = Min( dg0(mgs), dg0thresh - 0.0001 ) +! dg0(mgs) = Min( dg0(mgs), dg0thresh - 0.0001 ) + dg0(mgs) = Min( dg0(mgs), dwmax ) ENDIF ENDIF + wtest = (dg0(mgs) > 0.0 .and. dg0(mgs) < dg0thresh ) IF ( ihlcnh == 1 ) THEN ! .or. iusedw == 0 THEN @@ -21977,7 +24246,7 @@ subroutine nssl_2mom_gs & & ltest .and. qx(mgs,lh) .gt. hlcnhqmin ) .or. wtest ) THEN ! { ! : xdia(mgs,lh,3) .gt. 2.e-3 .and. qx(mgs,lh) .gt. 1.0e-3 THEN ! 0823.2008 erm test ! IF ( xdia(mgs,lh,3) .gt. 1.e-3 ) THEN - IF ( qhacw(mgs) .gt. 0.0 .and. qhacw(mgs) .gt. qhaci(mgs) .and. temg(mgs) .le. tfr-2.0 ) THEN ! { + IF ( qhacw(mgs) .gt. 0.0 .and. qhacw(mgs) .gt. qhaci(mgs) .and. temg(mgs) .le. tfr+hailcnvtoffset ) THEN ! { ! dh0 is the diameter dividing wet growth from dry growth (Ziegler 1985), modified by MY05 ! dh0 = 0.01*(exp(temcg(mgs)/(1.1e4*(qx(mgs,lc)+qx(mgs,lr)) - ! : 1.3e3*qx(mgs,li) + 1.0e-3 ) ) - 1.0) @@ -21991,6 +24260,7 @@ subroutine nssl_2mom_gs & ELSE dh0 = 1.e30 ENDIF + dg0(mgs) = Min(dh0, dg0thresh + 0.0001) ENDIF ! wtest ! dh0 = Max( dh0, 5.e-3 ) @@ -22001,6 +24271,7 @@ subroutine nssl_2mom_gs & tmp = qhacw(mgs) + qhacr(mgs) + qhaci(mgs) + qhacs(mgs) ! qtmp = Min( 1.0, xdia(mgs,lh,3)/(2.0*dh0) )*(tmp) qtmp = Min( 100.0, xdia(mgs,lh,3)/(2.0*dh0) )*(tmp) + qhlcnh(mgs) = Min( qxmxd(mgs,lh), qtmp ) IF ( ipconc .ge. 5 ) THEN !{ @@ -22024,8 +24295,9 @@ subroutine nssl_2mom_gs & ELSEIF ( ihlcnh == 3 ) THEN !{ + IF ( wtest .and. & - ( qhacw(mgs)*dtp > qxmin(lh) .and. temg(mgs) .lt. tfr-2. .and. qx(mgs,lh) > hlcnhqmin ) ) THEN + ( qhacw(mgs)*dtp > qxmin(lh) .and. temg(mgs) .lt. tfr+hailcnvtoffset .and. qx(mgs,lh) > hlcnhqmin ) ) THEN ! convert number, mass, and reflectivity for d > dw IF ( ipconc == 5 ) THEN ! dg0(mgs) = Min( dg0(mgs), hldia1 ) @@ -22074,31 +24346,96 @@ subroutine nssl_2mom_gs & ENDIF + ! reflectivity IF ( ipconc >= 6 .and. lzh > 1 .and. lzhl > 1 ) THEN tmp3 = gaminterp(ratio,alpha(mgs,lh),11,1) zxd1 = flim*zx(mgs,lh)*(tmp3) zhlcnh(mgs) = dtpinv*zxd1 + + ! tmp4 is the Z from the converted particles assuming shape of alphamax + IF ( icorrecthaildbz >= 1 .and. zxd1 > zxmincorr .and. cxd1 > cxmincorr ) THEN + IF ( .true. ) THEN + ! tmp3 is cx that is consistent with increased q and Z + ! g1x(mgs,lhl) = (pi*xdn(mgs,lhl))**2*zx(mgs,lhl)*cx(mgs,lhl)/((6.*rho0(mgs)*qx(mgs,lhl))**2) + tmp3 = g1x(mgs,lhl)*(rho0(mgs)*(qx(mgs,lhl)+qxd1))**2/((pi*xdn(mgs,lhl)/6.0)**2*(zx(mgs,lhl)+zxd1) ) + chlcnhhl(mgs) = dtpinv*Max(0.0, tmp3 - cx(mgs,lhl) ) + ELSE + ! old version + tmp3 = g1xmax*(rho0(mgs)*qxd1)**2/((pi*xdn(mgs,lh)/6.0)**2) + tmp4 = tmp3/cxd1 + IF ( tmp4 > zxd1 ) THEN ! calculate new hail number to match zxd1 + ! increase cxd1 to make z,q,c rates consistent + ! cxd1 = g1xmax*(rho0(mgs)*qxd1)**2/(zxd1*(pi*xdn(mgs,lh)/6.0)**2) + cxd1 = tmp3/zxd1 + chlcnhhl(mgs) = dtpinv*cxd1 + ENDIF + ENDIF + ENDIF ! t/f + ELSE zxd1 = 0 ENDIF + IF ( ipconc == 5 .and. icorrecthaildbz >= 1 ) THEN ! Adjust cxd1 by reflectivity removed from graupel + tmp3 = gaminterp(ratio,alpha(mgs,lh),11,1) + ! tmp5 is graupel reflectivity moment + tmp5 = g1x(mgs,lh)*(rho0(mgs)*qx(mgs,lh))**2/((pi*xdn(mgs,lh)/6.)**2*cx(mgs,lh)) + zxd1 = flim*(tmp3)*tmp5 + IF ( zxd1 > zxmincorr .and. cxd1 > cxmincorr ) THEN + IF ( .true. ) THEN + ! tmp3 is cx that is consistent with increased q and Z + ! g1x(mgs,lhl) = (pi*xdn(mgs,lhl))**2*zx(mgs,lhl)*cx(mgs,lhl)/((6.*rho0(mgs)*qx(mgs,lhl))**2) + IF ( cx(mgs,lhl) > cxmin ) THEN + ! hail reflectivity + tmp = g1x(mgs,lhl)*(rho0(mgs)*qx(mgs,lhl))**2/((pi*xdn(mgs,lhl)/6.)**2*cx(mgs,lhl)) + ELSE + tmp = 0. + ENDIF + tmp3 = g1x(mgs,lhl)*(rho0(mgs)*(qx(mgs,lhl)+qxd1))**2/((pi*xdn(mgs,lhl)/6.0)**2*(tmp+zxd1) ) + chlcnhhl(mgs) = dtpinv*Max(0.0, tmp3 - cx(mgs,lhl) ) + ELSE + ! tmp4 is the reflectivity of the newly-converted graupel particles (use g1x(lh) for loss term) + ! which we want to match zxd1 to prevent spurious increase in total reflectivity + tmp3 = g1x(mgs,lh)*(rho0(mgs)*qxd1)**2/((pi*xdn(mgs,lh)/6.0)**2) + tmp4 = tmp3/cxd1 + + IF ( tmp4 > zxd1 ) THEN ! calculate new hail number to match zxd1 + ! cxd1 = g1x(mgs,lhl)*(rho0(mgs)*qxd1)**2/(zxd1*pi*xdn(mgs,lh)/6.0) ! trial form results in tiny hail + ! want the adjust size of the new hail so that Z is conserved, so increase number of + ! particles to make qxd1,zxd1, and C consistent. + ! want zxd1 = g1x(mgs,lh)*(rho0(mgs)*qxd1)**2/(c*(pi*xdn(mgs,lh)/6.0)**2) + ! Use g1x(mgs,lh) here instead of g1x(mgs,lhl) because rzxhlh will then multiply + ! by g1x(mgs,lhl)/g1x(mgs,lh) + ! cxd1 = g1x(mgs,lh)*(rho0(mgs)*qxd1)**2/(zxd1*(pi*xdn(mgs,lh)/6.0)**2) + cxd1 = tmp3/zxd1 + chlcnhhl(mgs) = dtpinv*cxd1 ! multiplied later by rzxhlh(mgs) + + ENDIF + ENDIF ! t/f + ENDIF + ENDIF + + ELSE qhlcnh(mgs) = 0.0 ENDIF + vhlcnh(mgs) = rho0(mgs)*qhlcnh(mgs)/xdn(mgs,lh) vhlcnhl(mgs) = rho0(mgs)*qhlcnh(mgs)/Max(xdnmn(lhl), xdn(mgs,lh)) ENDIF + ENDIF !} ENDDO ELSEIF ( ihlcnh == 2 ) THEN ! 10-ice type conversion + ! ! Staka and Mansell (2005) type conversion ! @@ -22108,7 +24445,7 @@ subroutine nssl_2mom_gs & ! convert number, mass, and reflectivity for d > hldia1, ! regardless of wet growth status, but as long as riming > 0 DO mgs = 1,ngscnt - IF ( qhacw(mgs)*dtp > qxmin(lh) .and. temg(mgs) .lt. tfr-2. .and. qx(mgs,lh) > qxmin(lh) ) THEN + IF ( qhacw(mgs)*dtp > qxmin(lh) .and. temg(mgs) .lt. tfr+hailcnvtoffset .and. qx(mgs,lh) > qxmin(lh) ) THEN ratio = Min( maxratiolu, hldia1/xdia(mgs,lh,1) ) ! number @@ -22122,6 +24459,7 @@ subroutine nssl_2mom_gs & qxd1 = qx(mgs,lh)*(tmp2) qhlcnh(mgs) = dtpinv*qxd1 + ! reflectivity IF ( lzh > 1 .and. lzhl > 1 ) THEN tmp3 = gaminterp(ratio,alpha(mgs,lh),11,1) @@ -22130,6 +24468,7 @@ subroutine nssl_2mom_gs & ELSE zxd1 = 0 ENDIF + vhlcnh(mgs) = rho0(mgs)*qhlcnh(mgs)/xdn(mgs,lh) vhlcnhl(mgs) = rho0(mgs)*qhlcnh(mgs)/Max(xdnmn(lhl), xdn(mgs,lh)) @@ -22137,13 +24476,14 @@ subroutine nssl_2mom_gs & ENDDO ! ENDIF + ELSEIF ( ihlcnh == 0 ) THEN do mgs = 1,ngscnt ! qhlcnh(mgs) = 0.0 ! chlcnh(mgs) = 0.0 if ( wetgrowth(mgs) .and. temg(mgs) .lt. tfr-5. .and. qx(mgs,lh) > qxmin(lh) ) then - if ( qhacw(mgs).gt.1.e-6 .and. xdn(mgs,lh) > 700. ) then + if ( qhacw(mgs).gt.1.e-6 .and. ( xdn(mgs,lh) > 700. .or. lvh == 0 ) ) then qhlcnh(mgs) = & ((pi*xdn(mgs,lh)*cx(mgs,lh)) / (6.0*rho0(mgs)*dtp)) & *exp(-hldia1/xdia(mgs,lh,1)) & @@ -22181,6 +24521,7 @@ subroutine nssl_2mom_gs & ENDIF ! lhl > 1 + @@ -22236,6 +24577,7 @@ subroutine nssl_2mom_gs & dqnet = qscnvi(mgs) + qscni(mgs) + qsacw(mgs) + qsdpv(mgs) + qssbv(mgs) a3 = 1./(rho0(mgs)*qx(mgs,ls)) + a1 = Exp( - xdn(mgs,ls)*cx(mgs,ls)*vgra*a3 ) !! EXP(-(ROS*XNS*VGRA/(RO*QI))) ! (1.-(XNS*VGRA*ROS/(RO*QI)))*DNNET a2 = (1.-(cx(mgs,ls)*vgra*xdn(mgs,ls)*a3))*dnnet @@ -22372,10 +24714,12 @@ subroutine nssl_2mom_gs & ciacrf(mgs) = qrzfac(mgs)*ciacrf(mgs) ciacrs(mgs) = qrzfac(mgs)*ciacrs(mgs) + ! IF ( lzh .gt. 1 ) THEN ! zrfrzf(mgs) = 3.6476*rho0(mgs)**2*(alpha(mgs,lr)+2.)/(xdn0(lr)**2*(alpha(mgs,lr)+1.)) * & ! ( 2.*tmp * qrfrzf(mgs) - tmp**2 * crfrzf(mgs) ) ! ENDIF + vrfrzf(mgs) = qrzfac(mgs)*vrfrzf(mgs) viacrf(mgs) = qrzfac(mgs)*viacrf(mgs) @@ -22443,6 +24787,7 @@ subroutine nssl_2mom_gs & ENDIF + ! ! ! @@ -22457,6 +24802,7 @@ subroutine nssl_2mom_gs & qhmul1(:) = 0.0 qhlmul1(:) = 0.0 qsmul1(:) = 0.0 + do mgs = 1,ngscnt ltest = qx(mgs,lh) .gt. qxmin(lh) @@ -22513,6 +24859,7 @@ subroutine nssl_2mom_gs & ! chmul1(mgs) = Min( ft*ex1*chacw(mgs), ft*(30.*1.e+06)*rho0(mgs)*qhacw(mgs) ) ! 1.e+6 converts kg to mg; Saunders & Hosseini (2001) average of about 30 crystals per mg qhmul1(mgs) = cimas0*chmul1(mgs)*rhoinv(mgs) ENDIF + IF ( lhl .gt. 1 ) THEN IF ( qx(mgs,lhl) .gt. qxmin(lhl) .and. (.not. wetsfchl(mgs)) ) THEN chlmul1(mgs) = (ft*ex1*chlacw(mgs)) @@ -22527,6 +24874,7 @@ subroutine nssl_2mom_gs & chmul1(mgs) = chmul1(mgs) + tmp qhmul1(mgs) = qhmul1(mgs) + cimas0*tmp*rhoinv(mgs) ENDIF + IF ( lhl .gt. 1 ) THEN IF ( qx(mgs,lhl) .gt. qxmin(lhl) .and. (.not. wetsfchl(mgs)) ) THEN tmp = ft*(3.5e+08)*rho0(mgs)*qhlacw(mgs) @@ -22536,6 +24884,7 @@ subroutine nssl_2mom_gs & ENDIF ENDIF ! itype1 + ENDIF ! ft @@ -22623,6 +24972,7 @@ subroutine nssl_2mom_gs & ! qhmul1(mgs) = chmul1(mgs)*(cimas0/rho0(mgs)) + IF ( lhl .gt. 1 ) THEN IF ( qx(mgs,lhl) .gt. qxmin(lhl) .and. (.not. wetsfchl(mgs)) ) THEN tmp = fimt1(mgs)*(fimta(mgs) + & @@ -22683,7 +25033,7 @@ subroutine nssl_2mom_gs & ! do mgs = 1,ngscnt qracif(mgs) = qraci(mgs) - cracif(mgs) = craci(mgs) +! cracif(mgs) = craci(mgs) ! ciacrf(mgs) = ciacr(mgs) end do ! @@ -22709,15 +25059,21 @@ subroutine nssl_2mom_gs & ! ! Meyers et al. (1992; JAS) and Ferrier (1994) primary ice nucleation ! - cmassin = cimasn ! 6.88e-13 + cmassin = cimas1 ! 6.88e-13 do mgs = 1,ngscnt qiint(mgs) = 0.0 ciint(mgs) = 0.0 + qiintv(mgs) = 0.0 + qidint(mgs) = 0.0 + cidint(mgs) = 0.0 + qiintd(mgs) = 0.0 + ciintd(mgs) = 0.0 qicicnt(mgs) = 0.0 cicint(mgs) = 0.0 qipipnt(mgs) = 0.0 cipint(mgs) = 0.0 ccitmp = 0.0 + IF ( icenucopt == 1 .or. icenucopt == -10 .or. icenucopt == -11 ) THEN if ( ( temg(mgs) .lt. 268.15 .or. & ! : ( imeyers5 .and. temg(mgs) .lt. 273.0) ) .and. & @@ -22738,7 +25094,9 @@ subroutine nssl_2mom_gs & & idqis*il5(mgs) & & *(cmassin/rho0(mgs)) & & *max(0.0,wvel(mgs)) & + & *max((cninp(mgs)-cninm(mgs)),0.0)/gz(igs(mgs),jgs,kgs(mgs)) & + & /((dzfacp+dzfacm)) qiint(mgs) = min(qiint(mgs), max(0.25*dqisdt(mgs),0.0)) @@ -22795,9 +25153,10 @@ subroutine nssl_2mom_gs & - ELSEIF ( icenucopt == 3 .or. icenucopt == 4 .or. icenucopt == 10 ) THEN + ELSEIF ( icenucopt == 3 .or. icenucopt == 4 .or. icenucopt == 6 .or. icenucopt == 10 ) THEN IF ( temg(mgs) .lt. 268.15 ) THEN IF ( lcin > 1 ) THEN + ! decrement available IN ciint(mgs) = Min(cnina(mgs), ccin(mgs)) ciint(mgs) = Min( ciint(mgs), Max(0.0, ciintmx - (cx(mgs,li) + ccitmp) ) ) ! do not initiate ice beyond concentration of ciintmx ccin(mgs) = ccin(mgs) - ciint(mgs) @@ -22809,16 +25168,46 @@ subroutine nssl_2mom_gs & ENDIF ENDIF + + IF ( icenucopt == 5 .or. icenucopt == 6 ) THEN + ! dust IN freezing droplets (immersion) + IF ( temg(mgs) .lt. 268.15 ) THEN + cidint(mgs) = Max( 0.0, cninda(mgs) - cinda(mgs) )*dtpinv + qidint(mgs) = ciint(mgs)*cmassin/rho0(mgs) + ENDIF + + ENDIF + ! - if ( xplate(mgs) .eq. 1 ) then - qipipnt(mgs) = qiint(mgs) - cipint(mgs) = ciint(mgs) - end if + IF ( inactopt >= 2 ) THEN ! IN are freezing droplets (immersion); need to expand to rain +! IF ( cx(mgs,lc) > 0. ) THEN + ! check overdepletion of droplets and rescale if needed + IF ( ciint(mgs) + cidint(mgs) > cx(mgs,lc)*dtpinv ) THEN + fac = cx(mgs,lc)*dtpinv / ( ciint(mgs) + cidint(mgs) ) + ciint(mgs) = fac*ciint(mgs) + cidint(mgs) = fac*cidint(mgs) + ENDIF + ! number and mass of frozen droplets + ciintd(mgs) = ciint(mgs) + cidint(mgs) + qiintd(mgs) = ciintd(mgs)*xmas(mgs,lc)*rhoinv(mgs) +! ENDIF + ciint(mgs) = 0.0 ! set to zero because ciint is used for vapor nucleation, but can recover from ciintd - cidint + qiint(mgs) = 0.0 + ELSE + ciint(mgs) = ciint(mgs) + cidint(mgs) + qiintv(mgs) = qiint(mgs) + qidint(mgs) + ! qiint(mgs) = 0.0 + ENDIF + +! if ( xplate(mgs) .eq. 1.0 ) then + qipipnt(mgs) = xplate(mgs)*Max( qiint(mgs), qiintd(mgs) ) + cipint(mgs) = xplate(mgs)*Max( ciint(mgs), ciintd(mgs) ) +! end if ! - if ( xcolmn(mgs) .eq. 1 ) then - qicicnt(mgs) = qiint(mgs) - cicint(mgs) = ciint(mgs) - end if +! if ( xcolmn(mgs) .eq. 1.0 ) then + qicicnt(mgs) = xcolmn(mgs)*Max( qiint(mgs), qiintd(mgs) ) + cicint(mgs) = xcolmn(mgs)*Max( ciint(mgs), ciintd(mgs) ) +! end if ! ! qipipnt(mgs) = 0.0 ! qicicnt(mgs) = qiint(mgs) @@ -22868,6 +25257,7 @@ subroutine nssl_2mom_gs & qrshr(mgs) = qsshr(mgs) + qhshr(mgs) + qhlshr(mgs) crshr(mgs) = chshrr(mgs)/rzxh(mgs) + chlshrr(mgs)/rzxhl(mgs) + IF ( ipconc .ge. 3 ) THEN ! crshr(mgs) = Max(crshr(mgs), rho0(mgs)*qrshr(mgs)/(xdn(mgs,lr)*vr1mm) ) @@ -22905,11 +25295,12 @@ subroutine nssl_2mom_gs & pcswd(:) = 0.0 pchwi(:) = 0.0 pchwd(:) = 0.0 + pchli(:) = 0.0 pchld(:) = 0.0 ! ENDDO ! -! Cloud ice +! Cloud ice (columns) ! ! IF ( ipconc .ge. 1 ) THEN if (ndebug .gt. 0 ) write(0,*) 'cloud ice sum' @@ -22923,6 +25314,7 @@ subroutine nssl_2mom_gs & & +cicichr(mgs)) & & +chmul1(mgs) & & +chlmul1(mgs) & + & + csplinter(mgs) + csplinter2(mgs) & & +csmul(mgs) @@ -22933,14 +25325,16 @@ subroutine nssl_2mom_gs & & il5(mgs)*(-cscni(mgs) - cscnvi(mgs) & ! - cwaci(mgs) & & -craci(mgs) & & -csaci(mgs) & + & -chaci(mgs) - chlaci(mgs) & & -chcni(mgs)) & & +il5(mgs)*cisbv(mgs) & & -(1.-il5(mgs))*cimlr(mgs) - pccin(mgs) = ciint(mgs) + pccin(mgs) = Max( ciint(mgs), ciintd(mgs) ) ! rate of IN activation + end do ENDIF ! ffrzs ELSEIF ( warmonly < 0.8 ) THEN @@ -22956,6 +25350,7 @@ subroutine nssl_2mom_gs & & +cicichr(mgs)) & & +chmul1(mgs) & & +chlmul1(mgs) & + & + csplinter(mgs) + csplinter2(mgs) & & +csmul(mgs) @@ -22969,7 +25364,9 @@ subroutine nssl_2mom_gs & & +il5(mgs)*cisbv(mgs) & & -(1.-il5(mgs))*cimlr(mgs) - pccin(mgs) = ciint(mgs) + pccin(mgs) = Max( ciint(mgs), ciintd(mgs) ) ! rate of IN activation + + ! cina(mgs) = cina(mgs) + (pccin(mgs) - cidint(mgs))*dtp end do ENDIF ! warmonly @@ -22988,8 +25385,10 @@ subroutine nssl_2mom_gs & pccwd(mgs) = & & - cautn(mgs) + & & il5(mgs)*(-ciacw(mgs)-cwfrz(mgs)-cwctfzp(mgs) & - & -cwctfzc(mgs) & + & -cwctfzc(mgs) - ciintd(mgs) & + & ) & + & -cracw(mgs) -csacw(mgs) -chacw(mgs) - chlacw(mgs) @@ -22998,6 +25397,7 @@ subroutine nssl_2mom_gs & & - cautn(mgs) + & & il5(mgs)*( & & -ciacw(mgs)-cwfrz(mgs)-cwctfzp(mgs) & + & -cwctfzc(mgs) & & ) & & -cracw(mgs) -chacw(mgs) -chlacw(mgs) @@ -23024,6 +25424,7 @@ subroutine nssl_2mom_gs & IF ( .false. .and. exwmindiam > 0.0 .and. ccwresv(mgs) > 0.0 ) THEN pccwdacc(mgs) = & & il5(mgs)*(-ciacw(mgs) & + & ) & & -cracw(mgs) -csacw(mgs) -chacw(mgs) - chlacw(mgs) @@ -23033,11 +25434,14 @@ subroutine nssl_2mom_gs & pccwdacc(mgs) = -(cx(mgs,lc) - ccwresv(mgs) )*dtpinv ciacw(mgs) = frac*ciacw(mgs) + cracw(mgs) = frac*cracw(mgs) csacw(mgs) = frac*csacw(mgs) chacw(mgs) = frac*chacw(mgs) cautn(mgs) = frac*cautn(mgs) + + IF ( lhl .gt. 1 ) chlacw(mgs) = frac*chlacw(mgs) ! resum @@ -23045,8 +25449,11 @@ subroutine nssl_2mom_gs & & - cautn(mgs) + & & il5(mgs)*(-ciacw(mgs)-cwfrzp(mgs)-cwctfzp(mgs) & & -cwfrzc(mgs)-cwctfzc(mgs) & - & -il5(mgs)*(ciihr(mgs)) & +! & -il5(mgs)*(ciihr(mgs)) & + & -il5(mgs)*(qiihr(mgs)/Max(cimas1,xmas(mgs,lc))) & + & ) & + & -cracw(mgs) -csacw(mgs) -chacw(mgs) - chlacw(mgs) ENDIF @@ -23065,18 +25472,25 @@ subroutine nssl_2mom_gs & pccwd(mgs) = -cx(mgs,lc)*dtpinv ciacw(mgs) = frac*ciacw(mgs) + cwfrz(mgs) = frac*cwfrz(mgs) cwfrzp(mgs) = frac*cwfrzp(mgs) cwctfzp(mgs) = frac*cwctfzp(mgs) cwfrzc(mgs) = frac*cwfrzc(mgs) cwctfzc(mgs) = frac*cwctfzc(mgs) - cwctfz(mgs) = frac*cwctfz(mgs) + ciintd(mgs) = frac*ciintd(mgs) + cidint(mgs) = frac*cidint(mgs) + + + cwctfz(mgs) = frac*cwctfz(mgs) cracw(mgs) = frac*cracw(mgs) csacw(mgs) = frac*csacw(mgs) chacw(mgs) = frac*chacw(mgs) cautn(mgs) = frac*cautn(mgs) + - pccii(mgs) = pccii(mgs) - (1.-frac)*il5(mgs)*(cwfrzc(mgs)+cwctfzc(mgs))*(1. - ffrzs) + pccii(mgs) = pccii(mgs) - (1.-frac)*il5(mgs)*(cwfrzc(mgs)+cwctfzc(mgs)+ciintd(mgs))*(1. - ffrzs) + IF ( lhl .gt. 1 ) chlacw(mgs) = frac*chlacw(mgs) @@ -23099,6 +25513,7 @@ subroutine nssl_2mom_gs & ! > cracw(mgs) + & & crcnw(mgs) & & +(1-il5(mgs))*( & + & -chmlrr(mgs)/rzxh(mgs) & & -chlmlrr(mgs)/rzxhl(mgs) & ! & -csmlr(mgs)/rzxs(mgs) & @@ -23109,6 +25524,7 @@ subroutine nssl_2mom_gs & pcrwd(mgs) = & & il5(mgs)*(-ciacr(mgs) - crfrz(mgs) ) & ! - cipacr(mgs)) ! > -csacr(mgs) & + & - chacr(mgs) - chlacr(mgs) & & +crcev(mgs) & & - Max(0.0,cracr(mgs)) @@ -23168,6 +25584,7 @@ subroutine nssl_2mom_gs & crcev(mgs) = frac*crcev(mgs) cracr(mgs) = frac*cracr(mgs) + ! STOP ENDIF @@ -23186,6 +25603,7 @@ subroutine nssl_2mom_gs & do mgs = 1,ngscnt pcswi(mgs) = & & il5(mgs)*(cscnis(mgs) + cscnvis(mgs) ) & + & + cwfrz2snowfrac*cwfrz(mgs)/cwfrz2snowratio & & + cscnh(mgs) @@ -23196,6 +25614,7 @@ subroutine nssl_2mom_gs & & +cicichr(mgs)) & & +chmul1(mgs) & & +chlmul1(mgs) & + & + csplinter(mgs) + csplinter2(mgs) & & +csmul(mgs) ) ENDIF @@ -23207,6 +25626,7 @@ subroutine nssl_2mom_gs & pcswd(mgs) = & ! : cracs(mgs) & + & -chacs(mgs) - chlacs(mgs) & & -chcns(mgs) & & +(1-il5(mgs))*csmlr(mgs) + csshr(mgs) & ! + csshrp(mgs) @@ -23228,6 +25648,7 @@ subroutine nssl_2mom_gs & csshr(mgs) = frac*csshr(mgs) cssbv(mgs) = frac*cssbv(mgs) csacs(mgs) = frac*csacs(mgs) + ENDIF ENDIF @@ -23263,10 +25684,12 @@ subroutine nssl_2mom_gs & & - il5(mgs)*chlcnh(mgs) & & - cscnh(mgs) + end do + ! ! @@ -23275,6 +25698,7 @@ subroutine nssl_2mom_gs & IF ( lhl .gt. 1 .and. lnhl > 1 ) THEN ! do mgs = 1,ngscnt pchli(mgs) = (ffrzh*(1.0-ifrzg)*crfrzf(mgs) +il5(mgs)*ffrzh*(1.0-ifiacrg)*(ciacrf(mgs) )) & + & + chlcnhhl(mgs) *rzxhlh(mgs) pchld(mgs) = & @@ -23298,6 +25722,7 @@ subroutine nssl_2mom_gs & ENDIF ENDIF + end do ENDIF @@ -23325,6 +25750,7 @@ subroutine nssl_2mom_gs & IF ( lhl .gt. 1 ) THEN ! do mgs = 1,ngscnt pchli(mgs) = (1.0-ifrzg)*(crfrzf(mgs)) & ! +il5(mgs)*(ciacrf(mgs) )) & + & + chlcnhhl(mgs) *rzxhl(mgs)/rzxh(mgs) pchld(mgs) = & @@ -23354,6 +25780,7 @@ subroutine nssl_2mom_gs & & pcrwi(mgs) +pcrwd(mgs) + & & pcswi(mgs) +pcswd(mgs) + & & pchwi(mgs) +pchwd(mgs) + & + & pchli(mgs) +pchld(mgs) end do ! @@ -23375,6 +25802,7 @@ subroutine nssl_2mom_gs & pqcwdacc(:) = 0.0 pqcii(:) = 0.0 pqcid(:) = 0.0 + pqrwi(:) = 0.0 pqrwd(:) = 0.0 pqswi(:) = 0.0 @@ -23393,6 +25821,7 @@ subroutine nssl_2mom_gs & pqlwlghld(:) = 0.0 pqlwhli(:) = 0.0 pqlwhld(:) = 0.0 + IF ( ipconc > 5 ) THEN pzhwi(:) = 0.0 pzhwd(:) = 0.0 @@ -23413,20 +25842,25 @@ subroutine nssl_2mom_gs & pqwvi(mgs) = & & -Min(0.0, qrcev(mgs)) & & -Min(0.0, qhcev(mgs)) & + & -Min(0.0, qhlcev(mgs)) & & -Min(0.0, qscev(mgs)) & ! > +il5(mgs)*(-qhsbv(mgs) - qhlsbv(mgs) ) & & -qhsbv(mgs) - qhlsbv(mgs) & & -qssbv(mgs) & + & -il5(mgs)*qisbv(mgs) pqwvd(mgs) = & & -Max(0.0, qrcev(mgs)) & & -Max(0.0, qhcev(mgs)) & + & -Max(0.0, qhlcev(mgs)) & & -Max(0.0, qscev(mgs)) & - & +il5(mgs)*(-qiint(mgs) & + & +il5(mgs)*(-qiintv(mgs) & + & -qhdpv(mgs) -qsdpv(mgs) - qhldpv(mgs)) & + & -il5(mgs)*qidpv(mgs) end do @@ -23437,11 +25871,13 @@ subroutine nssl_2mom_gs & & -Min(0.0, qrcev(mgs)) & & -il5(mgs)*qisbv(mgs) pqwvd(mgs) = & - & +il5(mgs)*(-qiint(mgs) & + & +il5(mgs)*(-qiintv(mgs) & ! & -qhdpv(mgs) ) & !- qhldpv(mgs)) & + & -qhdpv(mgs) - qhldpv(mgs)) & ! & -qhdpv(mgs) -qsdpv(mgs) - qhldpv(mgs)) & & -Max(0.0, qrcev(mgs)) & + & -il5(mgs)*qidpv(mgs) end do @@ -23464,7 +25900,9 @@ subroutine nssl_2mom_gs & IF ( warmonly < 0.5 ) THEN pqcwd(mgs) = & & il5(mgs)*(-qiacw(mgs)-qwfrz(mgs)-qwctfz(mgs)) & - & -il5(mgs)*(qiihr(mgs)) & + + & -il5(mgs)*(qiihr(mgs) + qiintd(mgs) ) & + & -qracw(mgs) -qsacw(mgs) -qrcnw(mgs) -qhacw(mgs) - qhlacw(mgs) !& ! & -il5(mgs)*(qwfrzp(mgs)) ELSEIF ( warmonly < 0.8 ) THEN @@ -23478,21 +25916,29 @@ subroutine nssl_2mom_gs & ENDIF + IF ( pqcwd(mgs) .lt. 0.0 .and. -pqcwd(mgs)*dtp .gt. qx(mgs,lc) ) THEN frac = -Max(0.0,qx(mgs,lc))/(pqcwd(mgs)*dtp) pqcwd(mgs) = -qx(mgs,lc)*dtpinv qiacw(mgs) = frac*qiacw(mgs) + ! qwfrzp(mgs) = frac*qwfrzp(mgs) ! qwctfzp(mgs) = frac*qwctfzp(mgs) qwfrzc(mgs) = frac*qwfrzc(mgs) qwfrz(mgs) = frac*qwfrz(mgs) qwctfzc(mgs) = frac*qwctfzc(mgs) + IF ( inactopt >= 2 ) THEN + qiintd(mgs) = frac*qiintd(mgs) + qicicnt(mgs) = frac*qicicnt(mgs) + ENDIF + qwctfz(mgs) = frac*qwctfz(mgs) qracw(mgs) = frac*qracw(mgs) qsacw(mgs) = frac*qsacw(mgs) qhacw(mgs) = frac*qhacw(mgs) + vhacw(mgs) = frac*vhacw(mgs) qrcnw(mgs) = frac*qrcnw(mgs) qwfrzp(mgs) = frac*qwfrzp(mgs) @@ -23520,6 +25966,7 @@ subroutine nssl_2mom_gs & & +il5(mgs)*(qicichr(mgs)) & & +qsmul(mgs) & & +qhmul1(mgs) + qhlmul1(mgs) & + & + qsplinter(mgs) + qsplinter2(mgs) ! > + cimas0*nsplinter*(crfrzf(mgs) + crfrz(mgs))/rho0(mgs) ENDIF @@ -23532,6 +25979,7 @@ subroutine nssl_2mom_gs & & il5(mgs)*(-qscni(mgs) - qscnvi(mgs) & ! -qwaci(mgs) & & -qraci(mgs) & & -qsaci(mgs) ) & + & -qhaci(mgs) & & -qhlaci(mgs) & & +il5(mgs)*qisbv(mgs) & @@ -23539,6 +25987,7 @@ subroutine nssl_2mom_gs & & - qhcni(mgs) end do + ELSEIF ( warmonly < 0.8 ) THEN @@ -23580,25 +26029,30 @@ subroutine nssl_2mom_gs & pqrwi(mgs) = & & qracw(mgs) + qrcnw(mgs) + Max(0.0, qrcev(mgs)) & & +(1-il5(mgs))*( & + & -qhmlr(mgs) & !null at this point when wet snow/graupel included & -qsmlr(mgs) - qhlmlr(mgs) & & -qimlr(mgs)) & ! & -qsshr(mgs) & !null at this point when wet snow/graupel included + ! & -qhshr(mgs) & !null at this point when wet snow/graupel included ! & -qhlshr(mgs) & & - qrshr(mgs) pqrwd(mgs) = & & il5(mgs)*(-qiacr(mgs)-qrfrz(mgs)) & + & - qsacr(mgs) - qhacr(mgs) - qhlacr(mgs) - qwcnr(mgs) & & + Min(0.0,qrcev(mgs)) ELSEIF ( warmonly < 0.8 ) THEN pqrwi(mgs) = & & qracw(mgs) + qrcnw(mgs) + Max(0.0, qrcev(mgs)) & & +(1-il5(mgs))*( & + & -qhlmlr(mgs) & !null at this point when wet snow/graupel included & -qhmlr(mgs) ) & !null at this point when wet snow/graupel included & -qhshr(mgs) & !null at this point when wet snow/graupel included + & -qhlshr(mgs) !null at this point when wet snow/graupel included pqrwd(mgs) = & & il5(mgs)*(-qrfrz(mgs)) & @@ -23639,6 +26093,7 @@ subroutine nssl_2mom_gs & qrcev(mgs) = frac*qrcev(mgs) qhlacr(mgs) = frac*qhlacr(mgs) vhlacr(mgs) = frac*vhlacr(mgs) + qhcev(mgs) = frac*qhcev(mgs) qhlcev(mgs) = frac*qhlcev(mgs) @@ -23647,10 +26102,12 @@ subroutine nssl_2mom_gs & pqrwd(mgs) = & & il5(mgs)*(-qiacr(mgs)-qrfrz(mgs) - qsacr(mgs)) & & - qhacr(mgs) - qhlacr(mgs) - qwcnr(mgs) & + & + Min(0.0,qrcev(mgs)) ELSEIF ( warmonly < 0.8 ) THEN pqrwd(mgs) = & & il5(mgs)*(-qrfrz(mgs)) & + & - qhacr(mgs) & & - qhlacr(mgs) & & + Min(0.0,qrcev(mgs)) @@ -23668,8 +26125,10 @@ subroutine nssl_2mom_gs & & -Min(0.0, qhlcev(mgs)) & & -Min(0.0, qscev(mgs)) & ! > +il5(mgs)*(-qhsbv(mgs) - qhlsbv(mgs) ) & + & -qhsbv(mgs) - qhlsbv(mgs) & & -qssbv(mgs) & + & -il5(mgs)*qisbv(mgs) pqwvd(mgs) = & @@ -23677,8 +26136,10 @@ subroutine nssl_2mom_gs & & -Max(0.0, qhcev(mgs)) & & -Max(0.0, qhlcev(mgs)) & & -Max(0.0, qscev(mgs)) & - & +il5(mgs)*(-qiint(mgs) & + & +il5(mgs)*(-qiintv(mgs) & + & -qhdpv(mgs) -qsdpv(mgs) - qhldpv(mgs)) & + & -il5(mgs)*qidpv(mgs) ENDIF @@ -23688,6 +26149,7 @@ subroutine nssl_2mom_gs & ENDIF + end do IF ( warmonly < 0.5 ) THEN @@ -23702,6 +26164,7 @@ subroutine nssl_2mom_gs & & + ifrzs*(qiacrs(mgs) + qrfrzs(mgs)) & & + il5(mgs)*(( qwfrzc(mgs) + qwctfzc(mgs) + qicichr(mgs) )*ffrzs & & + (1.0 - ffrzs)*cwfrz2snowfrac*qwfrz(mgs) ) & + & + il2(mgs)*qsacr(mgs)) & & + il5(mgs)*qicicnt(mgs)*ffrzs & & + il3(mgs)*(qiacrf(mgs)+qracif(mgs)) & ! only applies for ipconc <= 3 @@ -23713,6 +26176,7 @@ subroutine nssl_2mom_gs & pqswd(mgs) = & ! > -qfacs(mgs) ! -qwacs(mgs) & & -qracs(mgs)*(1-il2(mgs)) -qhacs(mgs) - qhlacs(mgs) & + & -qhcns(mgs) & & +(1-il5(mgs))*qsmlr(mgs) + qsshr(mgs) & !null at this point when wet snow included ! > +il5(mgs)*(qssbv(mgs)) & @@ -23735,6 +26199,7 @@ subroutine nssl_2mom_gs & qsshr(mgs) = frac*qsshr(mgs) qssbv(mgs) = frac*qssbv(mgs) qsmul(mgs) = frac*qsmul(mgs) + IF ( qscev(mgs) < 0.0 ) qscev(mgs) = frac*qscev(mgs) ENDIF @@ -23757,6 +26222,7 @@ subroutine nssl_2mom_gs & & +Max(0.0, qhcev(mgs)) & & +qhacr(mgs)+qhacw(mgs) & & +qhacs(mgs)+qhaci(mgs) & + & + f2h*qhcns(mgs) + f2h*qhcni(mgs) + qhcnhl(mgs) pqhwd(mgs) = & & qhshr(mgs) & !null at this point when wet graupel included @@ -23768,9 +26234,11 @@ subroutine nssl_2mom_gs & & - ffrzh*(qsplinter(mgs) + qsplinter2(mgs)) ! > - cimas0*nsplinter*(crfrzf(mgs) + crfrz(mgs))/rho0(mgs) + end do + ! ! Hail ! @@ -23782,6 +26250,7 @@ subroutine nssl_2mom_gs & & +Max(0.0, qhlcev(mgs)) & & +qhlacr(mgs)+qhlacw(mgs) & & +qhlacs(mgs)+qhlaci(mgs) & + & + qhlcnh(mgs) pqhld(mgs) = & & qhlshr(mgs) & @@ -23842,6 +26311,7 @@ subroutine nssl_2mom_gs & & +il5(mgs)*(1.0-ifrzg)*(qrfrzf(mgs) ) & & +qhlacr(mgs)+qhlacw(mgs) & ! & +qhlacs(mgs)+qhlaci(mgs) & + & + qhlcnh(mgs) pqhld(mgs) = & & qhlshr(mgs) & @@ -23865,7 +26335,9 @@ subroutine nssl_2mom_gs & vhfzh(:) = 0.0 vhlfzhl(:) = 0.0 + IF ( mixedphase ) THEN + ELSE ! set arrays for non-mixedphase graupel ! vhshdr(:) = 0.0 @@ -23877,10 +26349,13 @@ subroutine nssl_2mom_gs & ! vhlmlr(:) = rho0(:)*qhlmlr(:)/xdn(:,lhl) ! vhlsoak(:) = 0.0 + ENDIF ! mixedphase + + ! ! Graupel reflectivity ! @@ -23895,6 +26370,8 @@ subroutine nssl_2mom_gs & zhdsv(mgs) = 0.0 ! IF ( lf < 1 ) THEN IF ( ffrzh > 0.0 ) THEN + ! only initialize if frozen drops are turned off, otherwise is already set above + ! If ffrzh = 0, then ziacrf is zeroed out for graupel and can leave value set for diagnostics ziacr(mgs) = 0.0 ziacrf(mgs) = 0.0 ENDIF @@ -23921,10 +26398,15 @@ subroutine nssl_2mom_gs & zhacs(mgs) = g1*(6.*rho0(mgs)/(pi*xdn(mgs,lh)))**2*( 2.*( tmp ) * qhacs(mgs) ) IF ( .not. mixedphase .and. ibinhmlr < 1 ) THEN - zhmlr(mgs) = g1*(6.*rho0(mgs)/(pi*xdn(mgs,lh)))**2*( 2.*tmp * qhmlr(mgs) - tmp**2 * chmlr(mgs) ) + zhmlr(mgs) = zrateqn(dtpinv,dtp,g1x(mgs,lh),rho0(mgs),xdn(mgs,lh),qx(mgs,lh), & + cx(mgs,lh),chmlr(mgs),qhmlr(mgs),1) + ! zhmlr(mgs) = g1*(6.*rho0(mgs)/(pi*xdn(mgs,lh)))**2*( 2.*tmp * qhmlr(mgs) - tmp**2 * chmlr(mgs) ) ENDIF - zhshr(mgs) = g1*(6.*rho0(mgs)/(pi*xdn(mgs,lh)))**2*( 2.*tmp * qhshr(mgs) - tmp**2 * chshr(mgs) ) + ! combined with zhacr + zhshr(mgs) = 0.0 !zrateqn(dtpinv,dtp,g1x(mgs,lh),rho0(mgs),xdn(mgs,lh),qx(mgs,lh), & + ! cx(mgs,lh),chshr(mgs),qhshr(mgs)) +! zhshr(mgs) = g1*(6.*rho0(mgs)/(pi*xdn(mgs,lh)))**2*( 2.*tmp * qhshr(mgs) - tmp**2 * chshr(mgs) ) ! IF ( lzr > 0 .and. qhshr(mgs) /= 0.0 .and. chshrr(mgs) /= 0.0 .and. ibinhmlr < 1 ) THEN IF ( lzr > 0 .and. qhshr(mgs) /= 0.0 .and. chshrr(mgs) /= 0.0 ) THEN @@ -23959,14 +26441,6 @@ subroutine nssl_2mom_gs & zhshrr(mgs) = Min( 0.0, zhshrr(mgs) ) ENDIF - IF ( zhshr(mgs) > 0.0 ) THEN - write(0,*) 'Problem with zhshr! zhshr,qhshr,chshr = ',zhshr(mgs),qhshr(mgs),chshr(mgs) - write(0,*) 'g1,tmp, qx,cx,zx = ',g1,tmp,qx(mgs,lh),cx(mgs,lh),zx(mgs,lh) - write(0,*) ( 2.*tmp * qhshr(mgs) - tmp**2 * chshr(mgs) ), 2.*tmp * qhshr(mgs), - tmp**2 * chshr(mgs) - write(0,*) 'temcg = ',temcg(mgs),'chshr recalc = ',(cx(mgs,lh)/(qx(mgs,lh)+1.e-20))*qhshr(mgs) - - STOP - ENDIF ! zhshr(mgs) = (xdn0(lr)/(xdn(mgs,lh)))**2*( zx(mgs,lh) * qhshr(mgs) ) @@ -23986,17 +26460,13 @@ subroutine nssl_2mom_gs & ! g1r = 36.*(alpha(mgs,lr)+2.0)/((alpha(mgs,lr)+1.0)*pi**2) ! zhacr(mgs) = g1*(6.*rho0(mgs)/(pi*xdn(mgs,lh)))**2*( 2.*( qx(mgs,lh)/cx(mgs,lh)) * qhacr(mgs) ) - zhacr(mgs) = g1*(6.*rho0(mgs)/(pi*xdn(mgs,lh)))**2*( 2.*( qx(mgs,lh)/cx(mgs,lh)) * qhacr(mgs) ) + qtmp = qhacr(mgs) + qhacw(mgs) + qhshr(mgs) - qhmul1(mgs) + ctmp = chshr(mgs) + zhacr(mgs) = zrateqn(dtpinv,dtp,g1x(mgs,lh),rho0(mgs),xdn(mgs,lh),qx(mgs,lh), & + cx(mgs,lh),ctmp,qtmp,1) +! zhacr(mgs) = g1*(6.*rho0(mgs)/(pi*xdn(mgs,lh)))**2*( 2.*( qx(mgs,lh)/cx(mgs,lh)) * qhacr(mgs) ) ! zhacrf(mgs) = g1*zhacr - -! z = g1*(6.*rho0(mgs)/(pi*1000.))**2*( (qx(mgs,lh)+dtp*qhacr(mgs))**2)/(cx(mgs,lh)) - - IF ( z > zx(mgs,lh) ) THEN -! zhacr(mgs) = (z - zx(mgs,lh))*dtpinv - ELSE -! zhacr(mgs) = 0.0 - ENDIF ENDIF ! zhacr(mgs) = g1*(6.*rho0(mgs)/(pi*1000.))**2*( 2.*( tmp ) * qhacr(mgs) ) @@ -24007,28 +26477,28 @@ subroutine nssl_2mom_gs & ! : ((3.0 + alp)*(2.0 + alp)*(1.0 + alp)) IF ( qhacw(mgs) .gt. 0.0 ) THEN ! zhacw(mgs) = g1*(6.*rho0(mgs)/(pi*1000.))**2*( 2.*( qx(mgs,lh)/cx(mgs,lh)) * qhacw(mgs) ) - zhacw(mgs) = g1*(6.*rho0(mgs)/(pi*xdn(mgs,lh)))**2*( 2.*( qx(mgs,lh)/cx(mgs,lh)) * qhacw(mgs) ) - -! z = g1*(6.*rho0(mgs)/(pi*1000.))**2*( (qx(mgs,lh)+dtp*(qhacw(mgs)-qhmul1(mgs)))**2)/(cx(mgs,lh)) - IF ( z > zx(mgs,lh) ) THEN -! zhacw(mgs) = (z - zx(mgs,lh))*dtpinv - ENDIF + ! combined with zracr + zhacw(mgs) = 0.0 !zrateq(dtpinv,dtp,g1x(mgs,lh),rho0(mgs),xdn(mgs,lh),qx(mgs,lh), & + ! cx(mgs,lh),qhacw(mgs)) +! zhacw(mgs) = g1*(6.*rho0(mgs)/(pi*xdn(mgs,lh)))**2*( 2.*( qx(mgs,lh)/cx(mgs,lh)) * qhacw(mgs) ) ENDIF ELSE ! } { ! this is not used because of the 'true' above - IF ( qhacw(mgs) .gt. 0.0 .or. qhacr(mgs) .gt. 0.0 ) THEN - z = g1*(6.*rho0(mgs)/(pi*1000.))**2*( (qx(mgs,lh)+dtp*(qhacr(mgs) + qhacw(mgs)-qhmul1(mgs)))**2)/(cx(mgs,lh)) -! zhacw(mgs) = g1*(6.*rho0(mgs)/(pi*1000.))**2*( 2.*( qx(mgs,lh)/cx(mgs,lh)) * qhacw(mgs) ) - IF ( z > zx(mgs,lh) ) THEN - zhacw(mgs) = (z - zx(mgs,lh))*dtpinv - ENDIF - ENDIF +! IF ( qhacw(mgs) .gt. 0.0 .or. qhacr(mgs) .gt. 0.0 ) THEN +! z = g1*(6.*rho0(mgs)/(pi*1000.))**2*( (qx(mgs,lh)+dtp*(qhacr(mgs) + qhacw(mgs)-qhmul1(mgs)))**2)/(cx(mgs,lh)) +! ! zhacw(mgs) = g1*(6.*rho0(mgs)/(pi*1000.))**2*( 2.*( qx(mgs,lh)/cx(mgs,lh)) * qhacw(mgs) ) +! IF ( z > zx(mgs,lh) ) THEN +! zhacw(mgs) = (z - zx(mgs,lh))*dtpinv +! ENDIF +! ENDIF ENDIF ! } IF ( qhlcnh(mgs) .gt. 0.0 .and. ihlcnh < 2 ) THEN - zhlcnh(mgs) = g1*(6.*rho0(mgs)/(pi*xdn(mgs,lh)))**2*( 2.*( tmp ) * qhlcnh(mgs) - tmp**2 * chlcnh(mgs) ) + zhlcnh(mgs) = zrateqn(dtpinv,dtp,g1x(mgs,lh),rho0(mgs),xdn(mgs,lh),qx(mgs,lh), & + cx(mgs,lh),chlcnh(mgs),qhlcnh(mgs),1) + ! zhlcnh(mgs) = g1*(6.*rho0(mgs)/(pi*xdn(mgs,lh)))**2*( 2.*( tmp ) * qhlcnh(mgs) - tmp**2 * chlcnh(mgs) ) ENDIF ENDIF ! qsplinter(mgs) @@ -24041,12 +26511,17 @@ subroutine nssl_2mom_gs & ziacr(mgs) = 3.6476*rho0(mgs)**2*(alpha(mgs,lr)+2.)/(xdn0(lr)**2*(alpha(mgs,lr)+1.))* & & ( 2.*tmp * qiacrf(mgs) - tmp**2 * ciacrf(mgs) ) ELSE ! imurain == 1 - ziacr(mgs) = 3.6476*rho0(mgs)**2*g1x(mgs,lr)/(xdn0(lr)**2)* & - & ( 2.*tmp * qiacrf(mgs) - tmp**2 * ciacrf(mgs) ) + ziacr(mgs) = zrateqn(dtpinv,dtp,g1x(mgs,lr),rho0(mgs),xdn0(lr),qx(mgs,lr), & + cx(mgs,lr),ciacr(mgs),qiacr(mgs),1) +! ziacr(mgs) = 3.6476*rho0(mgs)**2*g1x(mgs,lr)/(xdn0(lr)**2)* & +! & ( 2.*tmp * qiacrf(mgs) - tmp**2 * ciacrf(mgs) ) ENDIF ziacr(mgs) = Min( ziacr(mgs), zxmxd(mgs,lr) ) ! ziacrf(mgs) = (xdn(mgs,lr)/xdn(mgs,lh))**2 * ziacr(mgs) - ziacrf(mgs) = (xdn(mgs,lr)/xdnmx(lh))**2 * ziacr(mgs) +! ziacrf(mgs) = (xdn(mgs,lr)/xdnmx(lh))**2 * ziacr(mgs) + ziacrf(mgs) = zrateqn(dtpinv,dtp,g1x(mgs,lh),rho0(mgs),rhofrz,qx(mgs,lh), & + cx(mgs,lh),ciacrf(mgs),qiacrf(mgs),1) + ! z = g1*(6.*rho0(mgs)/(pi*1000.))**2*( 2.*tmp * (qiacrf(mgs) - qsplinter(mgs)) - tmp**2 * ciacrf(mgs) ) ! ziacrf(mgs) = Min( ziacrf(mgs), z ) ENDIF @@ -24088,24 +26563,28 @@ subroutine nssl_2mom_gs & r = rho0(mgs)*qhcns(mgs)/vhcns(mgs) ! density of new graupel particles IF ( imusnow == 3 ) THEN zhcns(mgs) = 3.6476*rho0(mgs)**2*(alpha(mgs,ls)+2.)/(r**2*(alpha(mgs,ls)+1.)) * & - & ( 2.*tmp * qhcns(mgs) - tmp**2 * chcns(mgs) ) + & ( 2.*tmp * qhcns(mgs) - tmp**2 * chcnsh(mgs) ) + ELSE write(0,*) 'Value of imusnow not valid. Must be 3 (fix me for =1). imusnow = ',imusnow - STOP + + ! STOP + ENDIF ENDIF - IF ( qhcni(mgs) > 0.0 .and. chcni(mgs) > 0.0 .and. cx(mgs,li) > cxmin .and. vhcni(mgs) > 0 ) THEN + IF ( qhcni(mgs) > 0.0 .and. chcnih(mgs) > 0.0 .and. cx(mgs,li) > cxmin .and. vhcni(mgs) > 0 ) THEN tmp = qx(mgs,li)/cx(mgs,li) r = rho0(mgs)*qhcni(mgs)/vhcni(mgs) ! density of new graupel particles zhcni(mgs) = 3.6476*rho0(mgs)**2*(alpha(mgs,li)+2.)/(r**2*(alpha(mgs,li)+1.)) * & - & ( 2.*tmp * qhcni(mgs) - tmp**2 * chcni(mgs) ) + & ( 2.*tmp * qhcni(mgs) - tmp**2 * chcnih(mgs) ) + ENDIF pzhwi(mgs) = & & +ifrzg*ffrzh*(zrfrzf(mgs) & - & +il5(mgs)*ifiacrg*(ziacrf(mgs) ) ) & + & +il5(mgs)*ifiacrg*(ziacrf(mgs) ) ) & ! ffrzh turns this off if FD are turned on ! : + zhcnsh(mgs) + zhcnih(mgs) & & + zhacw(mgs) & & + zhacr(mgs) & @@ -24122,14 +26601,6 @@ subroutine nssl_2mom_gs & & - il5(mgs)*zhlcnh(mgs) - IF ( igs(mgs) == 44 .and. kgs(mgs) == 23 .or. dtp*( pqhwi(mgs) + pqhwd(mgs) ) > qxmin(lh) ) THEN -! write(0,*) 'i,k,time = ',igs(mgs),kgs(mgs),time_real -! write(0,*) 'pzhwi,d = ',pzhwi(mgs),pzhwd(mgs),dtp*( pzhwi(mgs) + pzhwd(mgs) ),zx(mgs,lh) -! write(0,*) 'pqhwi,d = ',pqhwi(mgs),pqhwd(mgs),dtp*( pqhwi(mgs) + pqhwd(mgs) ),qx(mgs,lh) -! write(0,*) 'pchwi,d = ',pchwi(mgs),pchwd(mgs),dtp*( pchwi(mgs) + pchwd(mgs) ),cx(mgs,lh) - ENDIF - - ! IF ( zhcnhl(mgs) < 0.0 ) THEN ! write(0,*) 'Problem with zhcnhl! zhcnhl,qhcnhl,chcnhl = ',zhcnhl(mgs),qhcnhl(mgs),chcnhl(mgs) ! write(0,*) 'g1,tmp = ',g1x(mgs,lhl),tmp @@ -24168,10 +26639,12 @@ subroutine nssl_2mom_gs & g1 = g1x(mgs,lhl) ! (6.0 + alp)*(5.0 + alp)*(4.0 + alp)/((3.0 + alp)*(2.0 + alp)*(1.0 + alp)) IF ( .not. mixedphase .and. qhlmlr(mgs) /= 0.0 .and. chlmlr(mgs) /= 0.0 .and. ibinhlmlr < 1 ) THEN - zhlmlr(mgs) = g1*(6.*rho0(mgs)/(pi*xdn(mgs,lhl)))**2*( 2.*tmp * qhlmlr(mgs) - tmp**2 * chlmlr(mgs) ) + zhlmlr(mgs) = zrateqn(dtpinv,dtp,g1x(mgs,lhl),rho0(mgs),xdn(mgs,lhl),qx(mgs,lhl), & + cx(mgs,lhl),chlmlr(mgs),qhlmlr(mgs),1) +! zhlmlr(mgs) = g1*(6.*rho0(mgs)/(pi*xdn(mgs,lhl)))**2*( 2.*tmp * qhlmlr(mgs) - tmp**2 * chlmlr(mgs) ) ENDIF - - zhlshr(mgs) = g1*(6.*rho0(mgs)/(pi*xdn(mgs,lhl)))**2*( 2.*tmp * qhlshr(mgs) - tmp**2 * chlshr(mgs) ) + ! combine zhlshr into zhlacr below + zhlshr(mgs) = 0.0 ! g1*(6.*rho0(mgs)/(pi*xdn(mgs,lhl)))**2*( 2.*tmp * qhlshr(mgs) - tmp**2 * chlshr(mgs) ) IF ( lzr > 1 .and. qhlshr(mgs) /= 0.0 .and. chlshrr(mgs) /= 0.0 ) THEN IF ( temg(mgs) >= tfr ) THEN ! zhlshrr(mgs) = g1*(6.*rho0(mgs)/(pi*xdn0(lr)))**2*( 2.*tmp * qhlshr(mgs) - tmp**2 * chlshrr(mgs) ) @@ -24193,14 +26666,7 @@ subroutine nssl_2mom_gs & zhlshrr(mgs) = Min( 0.0, zhlshrr(mgs) ) ENDIF - IF ( zhlshr(mgs) > 0.0 ) THEN - write(0,*) 'Problem with zhlshr! zhlshr,qhlshr,chlshr = ',zhlshr(mgs),qhlshr(mgs),chlshr(mgs) - write(0,*) 'g1,tmp, qx,cx,zx = ',g1,tmp,qx(mgs,lhl),cx(mgs,lhl),zx(mgs,lhl) - write(0,*) ( 2.*tmp * qhlshr(mgs) - tmp**2 * chlshr(mgs) ), 2.*tmp * qhlshr(mgs), - tmp**2 * chlshr(mgs) - write(0,*) 'temcg = ',temcg(mgs),'chlshr recalc = ',(cx(mgs,lhl)/(qx(mgs,lhl)+1.e-20))*qhlshr(mgs) - - STOP - ENDIF + ! zhlshr(mgs) = Min( 0.0, zhlshr(mgs) ) ! zhlshr(mgs) = (xdn0(lr)/(xdn(mgs,lhl)))**2*( zx(mgs,lhl) * qhlshr(mgs) ) @@ -24217,7 +26683,11 @@ subroutine nssl_2mom_gs & IF ( .true. ) THEN ! { IF ( qhlacr(mgs) .gt. 0.0 ) THEN ! z = g1*(6.*rho0(mgs)/(pi*1000.))**2*( (qx(mgs,lhl)+dtp*qhlacr(mgs))**2)/(cx(mgs,lhl)) - zhlacr(mgs) = g1*(6.*rho0(mgs)/(pi*xdn(mgs,lhl)))**2*( 2.*( tmp ) * qhlacr(mgs) ) + qtmp = qhlacr(mgs) + qhlacw(mgs) + qhlshr(mgs) - qhlmul1(mgs) + ctmp = chlshr(mgs) + zhlacr(mgs) = zrateqn(dtpinv,dtp,g1x(mgs,lhl),rho0(mgs),xdn(mgs,lhl),qx(mgs,lhl), & + cx(mgs,lhl),ctmp,qtmp,1) +! zhlacr(mgs) = g1*(6.*rho0(mgs)/(pi*xdn(mgs,lhl)))**2*( 2.*( tmp ) * qhlacr(mgs) ) ! zhlacr(mgs) = Min( zxmxd(mgs,lr), zhlacr(mgs) ) ! IF ( z > zx(mgs,lhl) ) THEN @@ -24230,29 +26700,29 @@ subroutine nssl_2mom_gs & ! zhacr(mgs) = g1*(6.*rho0(mgs)/(pi*1000.))**2*( 2.*( tmp ) * qhacr(mgs) ) ! zhacr(mgs) = g1*(6.*rho0(mgs)/(pi*1000.))**2*( 2.*( tmp ) * qhacr(mgs) - tmp**2 * chacr(mgs) ) - IF ( qhlacw(mgs) .gt. 0.0 ) THEN - alp = Max( 3.0, alpha(mgs,lhl)+1. ) - g1 = (6.0 + alp)*(5.0 + alp)*(4.0 + alp)/((3.0 + alp)*(2.0 + alp)*(1.0 + alp)) - -! z = g1*(6.*rho0(mgs)/(pi*1000.))**2*( (qx(mgs,lhl)+dtp*(qhlacw(mgs)-qhlmul1(mgs)))**2)/(cx(mgs,lhl)) -! zhlacw(mgs) = g1*(6.*rho0(mgs)/(pi*1000.))**2*( 2.*( qx(mgs,lhl)/cx(mgs,lhl)) * qhlacw(mgs) ) - zhlacw(mgs) = g1*(6.*rho0(mgs)/(pi*xdn(mgs,lhl)))**2*( 2.*tmp * qhlacw(mgs) ) - -! IF ( z > zx(mgs,lhl) ) THEN -! zhlacw(mgs) = (z - zx(mgs,lhl))*dtpinv -! ENDIF - g1 = g1x(mgs,lhl) ! (6.0 + alp)*(5.0 + alp)*(4.0 + alp)/((3.0 + alp)*(2.0 + alp)*(1.0 + alp)) - ENDIF +! IF ( qhlacw(mgs) .gt. 0.0 ) THEN +! alp = Max( 3.0, alpha(mgs,lhl)+1. ) +! g1 = (6.0 + alp)*(5.0 + alp)*(4.0 + alp)/((3.0 + alp)*(2.0 + alp)*(1.0 + alp)) +! +! ! z = g1*(6.*rho0(mgs)/(pi*1000.))**2*( (qx(mgs,lhl)+dtp*(qhlacw(mgs)-qhlmul1(mgs)))**2)/(cx(mgs,lhl)) +! ! zhlacw(mgs) = g1*(6.*rho0(mgs)/(pi*1000.))**2*( 2.*( qx(mgs,lhl)/cx(mgs,lhl)) * qhlacw(mgs) ) +! zhlacw(mgs) = g1*(6.*rho0(mgs)/(pi*xdn(mgs,lhl)))**2*( 2.*tmp * qhlacw(mgs) ) +! +! ! IF ( z > zx(mgs,lhl) ) THEN +! ! zhlacw(mgs) = (z - zx(mgs,lhl))*dtpinv +! ! ENDIF +! g1 = g1x(mgs,lhl) ! (6.0 + alp)*(5.0 + alp)*(4.0 + alp)/((3.0 + alp)*(2.0 + alp)*(1.0 + alp)) +! ENDIF ELSE ! } .false. { - IF ( qhlacw(mgs) .gt. 0.0 .or. qhlacr(mgs) .gt. 0.0 ) THEN - z = g1*(6.*rho0(mgs)/(pi*1000.))**2*( (qx(mgs,lhl)+dtp*(qhlacr(mgs) + qhlacw(mgs)-qhlmul1(mgs)))**2)/(cx(mgs,lhl)) -! zhlacw(mgs) = g1*(6.*rho0(mgs)/(pi*1000.))**2*( 2.*( qx(mgs,lhl)/cx(mgs,lhl)) * qhlacw(mgs) ) - IF ( z > zx(mgs,lhl) ) THEN - zhlacw(mgs) = (z - zx(mgs,lhl))*dtpinv - ENDIF - ENDIF +! IF ( qhlacw(mgs) .gt. 0.0 .or. qhlacr(mgs) .gt. 0.0 ) THEN +! z = g1*(6.*rho0(mgs)/(pi*1000.))**2*( (qx(mgs,lhl)+dtp*(qhlacr(mgs) + qhlacw(mgs)-qhlmul1(mgs)))**2)/(cx(mgs,lhl)) +! ! zhlacw(mgs) = g1*(6.*rho0(mgs)/(pi*1000.))**2*( 2.*( qx(mgs,lhl)/cx(mgs,lhl)) * qhlacw(mgs) ) +! IF ( z > zx(mgs,lhl) ) THEN +! zhlacw(mgs) = (z - zx(mgs,lhl))*dtpinv +! ENDIF +! ENDIF ENDIF ! } @@ -24263,6 +26733,7 @@ subroutine nssl_2mom_gs & pzhli(mgs) = ffrzh*(((1.0-ifrzg)*zrfrzf(mgs) & & +il5(mgs)*(1.0-ifiacrg)*ziacrf(mgs) )) & & + il5(mgs)*zhlcnh(mgs) & + & + zhlacw(mgs) & & + zhlacr(mgs) & ! : + zhlacs(mgs) & @@ -24301,7 +26772,7 @@ subroutine nssl_2mom_gs & DO mgs = 1,ngscnt zracw(mgs) = 0.0 - zracr(mgs) = 0.0 + ! zracr(mgs) = 0.0 ! already set to zero zrcev(mgs) = 0.0 zrach(mgs) = 0.0 zrachl(mgs) = 0.0 @@ -24310,6 +26781,7 @@ subroutine nssl_2mom_gs & ! zsmlr(mgs) = 0.0 zsmlrr(mgs) = 0.0 + IF ( qx(mgs,ls) .gt. qxmin(ls) .and. ( csmlr(mgs) /= 0.0 .or. csshr(mgs) /= 0.0 .or. & csmlrr(mgs) /= 0.0 .or. csshrr(mgs) /= 0.0) ) THEN !{ tmp = qx(mgs,ls)/cx(mgs,ls) @@ -24356,6 +26828,7 @@ subroutine nssl_2mom_gs & ! zhshrr(mgs) = (xdn(mgs,lh)/xdn(mgs,lr))**2 * zhshr(mgs) + IF ( lhl > 1 .and. qhlmlr(mgs) /= 0 .and. ibinhlmlr == 0) THEN tmp = qx(mgs,lhl)/cx(mgs,lhl) ! zhlmlrr(mgs) = Min(0.0, (xdn(mgs,lhl)/xdn(mgs,lr))**2 * & @@ -24391,9 +26864,14 @@ subroutine nssl_2mom_gs & zracw(mgs) = g1x(mgs,lr)*(6.*rho0(mgs)/(pi*1000.))**2*( 2.*tmp * qracw(mgs) ) ENDIF - IF ( cracr(mgs) /= 0.0 .and. cx(mgs,lr) > 0.0 ) THEN - zracr(mgs) = g1x(mgs,lr)*(6.*rho0(mgs)/(pi*1000.))**2*( tmp**2 * cracr(mgs) ) - ENDIF +! zracr is already done in breakup section +! IF ( ibincracr /= 2 .and. cracr(mgs) /= 0.0 .and. cx(mgs,lr) > 0.0 ) THEN + ! zracr(mgs) = g1x(mgs,lr)*(6.*rho0(mgs)/(pi*1000.))**2*( tmp**2 * cracr(mgs) ) + ! rewrite because original can overestimate zracr if -cracr*dtp is on the order of cx (i.e., + ! large increase in the number of drops, which violates differential assumption +! zracr(mgs) = dtpinv*g1x(mgs,lr)*(6.*rho0(mgs)*qx(mgs,lr)/(pi*1000.))**2 & +! * ( cracr(mgs) )/((cx(mgs,lr) - dtp*cracr(mgs))*(cx(mgs,lr))) +! ENDIF qtmp = qrcev(mgs) ctmp = crcev(mgs) @@ -24430,27 +26908,31 @@ subroutine nssl_2mom_gs & ENDIF + ENDIF - pzrwi(mgs) = zrcnw(mgs) + zracw(mgs) + zracr(mgs) & + pzrwi(mgs) = zrcnw(mgs) + zracw(mgs) + Max(0.0,zracr(mgs)) & & + Max( 0.,zrcev(mgs) ) & & - (1-il5(mgs))*zsmlrr(mgs) & & - zsshrr(mgs) & & - (1-il5(mgs))*zhmlrr(mgs) & & - zhshrr(mgs) & + & - (1-il5(mgs))*zhlmlrr(mgs) & & - zhlshrr(mgs) - pzrwd(mgs) = 0.0 & + pzrwd(mgs) = Min(0.0,zracr(mgs)) & & + Min(0.,zrcev(mgs) ) & & - zrach(mgs) & & - zrachl(mgs) & + & - zrfrz(mgs) & & - il5(mgs)*(ziacr(mgs) ) + IF ( zx(mgs,lr) + dtp*(pzrwi(mgs)+pzrwd(mgs)) <= 0.0 & .and. qx(mgs,lr) > qxmin(lr) ) THEN pzrwd(mgs) = -zx(mgs,lr)*dtpinv - pzrwi(mgs) @@ -24462,6 +26944,7 @@ subroutine nssl_2mom_gs & + ! ! Snow volume ! @@ -24535,7 +27018,9 @@ subroutine nssl_2mom_gs & ! > + rho0(mgs)*qhshr(mgs)/xdn(mgs,lh) !xdn(mgs,lr) ! ENDIF - IF ( lzh > 1 .and. qx(mgs,lh) > qxmin(lh) ) THEN + + IF ( lzh > 1 .and. qx(mgs,lh) > qxmin(lh) .and. & + vx(mgs,lh) + dtp*(pvhwi(mgs) + pvhwd(mgs)) > rho0(mgs)*qxmin(lh)/900. ) THEN ! Calculate change in reflectivity due to density changes xdn_new = rho0(mgs)*(qx(mgs,lh) + dtp*(pqhwi(mgs) + pqhwd(mgs) ))/ & @@ -24562,6 +27047,7 @@ subroutine nssl_2mom_gs & ENDIF + IF ( .false. .and. ny .eq. 2 .and. kgs(mgs) .eq. 9 .and. igs(mgs) .eq. 19 ) THEN write(iunit,*) @@ -24633,6 +27119,7 @@ subroutine nssl_2mom_gs & ! & + qhlacs(mgs) + qhlaci(mgs) )/xdnmn(lh) ) & ! yes, this is 'lh' on purpose & + qhlacs(mgs) + qhlaci(mgs) )/500. ) & ! changed to 500 instead of min graupel density to keep hail density from dropping too much & + rho0(mgs)*Max(0.0, qhlcev(mgs))/1000. & + & + vhlcnhl(mgs) + ((1.0-ifiacrg)*ffrzh*viacrf(mgs) + (1.0-ifrzg)*ffrzh*vrfrzf(mgs)) & & + vhlacr(mgs) + vhlacw(mgs) + vhlfzhl(mgs) ! qhlacw(mgs)/rimdn(mgs,lhl) @@ -24644,7 +27131,9 @@ subroutine nssl_2mom_gs & & + rho0(mgs)*(1-il5(mgs))*vhlmlr(mgs)/xdn(mgs,lhl) & & + vhlshdr(mgs) - vhlsoak(mgs) - IF ( lzhl > 1 .and. qx(mgs,lhl) > qxmin(lhl) ) THEN + + IF ( lzhl > 1 .and. qx(mgs,lhl) > qxmin(lhl) .and. & + vx(mgs,lhl) + dtp*(pvhli(mgs) + pvhld(mgs)) > rho0(mgs)*qxmin(lhl)/900. ) THEN ! Calculate change in reflectivity due to density changes xdn_new = rho0(mgs)*(qx(mgs,lhl) + dtp*(pqhli(mgs) + pqhld(mgs) ))/ & @@ -24671,13 +27160,17 @@ subroutine nssl_2mom_gs & ENDIF + ENDDO ENDIF ENDIF + + if ( ndebug .ge. 1 ) then + do mgs = 1,ngscnt ! ptotal(mgs) = 0. @@ -24688,10 +27181,13 @@ subroutine nssl_2mom_gs & & + pqrwi(mgs) + pqrwd(mgs) & & + pqswi(mgs) + pqswd(mgs) & & + pqhwi(mgs) + pqhwd(mgs) & + & + pqhli(mgs) + pqhld(mgs) ! + + ENDDO @@ -24725,7 +27221,7 @@ subroutine nssl_2mom_gs & write(iunit,*) 'rain cx,xv : ',cx(mgs,lr),xv(mgs,lr) - write(iunit,*) 'temcg = ', temcg(mgs) + write(iunit,*) 'temcg, w = ', temcg(mgs),wvel(mgs) write(iunit,*) 'v ', pqwvi(mgs) ,pqwvd(mgs) write(iunit,*) 'c ', pqcwi(mgs) ,pqcwd(mgs) @@ -24734,12 +27230,14 @@ subroutine nssl_2mom_gs & write(iunit,*) 's ', pqswi(mgs) ,pqswd(mgs) write(iunit,*) 'h ', pqhwi(mgs) ,pqhwd(mgs) write(iunit,*) 'hl', pqhli(mgs) ,pqhld(mgs) + tmp = pqwvi(mgs) + pqwvd(mgs) & & + pqcwi(mgs) + pqcwd(mgs) & & + pqcii(mgs) + pqcid(mgs) & & + pqrwi(mgs) + pqrwd(mgs) & & + pqswi(mgs) + pqswd(mgs) & & + pqhwi(mgs) + pqhwd(mgs) & + & + pqhli(mgs) + pqhld(mgs) write(iunit,*) 'total = ',tmp @@ -24761,12 +27259,13 @@ subroutine nssl_2mom_gs & write(iunit,*) -Max(0.0,qhcev(mgs)) write(iunit,*) -Max(0.0,qhlcev(mgs)) write(iunit,*) -Max(0.0,qscev(mgs)) - write(iunit,*) -il5(mgs)*qiint(mgs) + write(iunit,*) -il5(mgs)*qiintv(mgs) write(iunit,*) -il5(mgs)*qhdpv(mgs) write(iunit,*) -il5(mgs)*qhldpv(mgs) write(iunit,*) -il5(mgs)*qsdpv(mgs) write(iunit,*) -il5(mgs)*qidpv(mgs) write(iunit,*) 'pqwvd = ', pqwvd(mgs) + ! write(iunit,*) write(iunit,*) 'Cloud ice' @@ -24774,7 +27273,7 @@ subroutine nssl_2mom_gs & write(iunit,*) il5(mgs)*qicicnt(mgs) write(iunit,*) il5(mgs)*qidpv(mgs) write(iunit,*) il5(mgs)*qiacw(mgs) - write(iunit,*) il5(mgs)*qwfrzc(mgs) + write(iunit,*) il5(mgs)*qwfrzc(mgs), qiintd(mgs) write(iunit,*) il5(mgs)*qwctfzc(mgs) write(iunit,*) il5(mgs)*qicichr(mgs) write(iunit,*) qhmul1(mgs) @@ -24796,10 +27295,12 @@ subroutine nssl_2mom_gs & write(iunit,*) cwfrzc(mgs),cwctfzc(mgs) write(iunit,*) cicichr(mgs) write(iunit,*) chmul1(mgs) + write(iunit,*) chlmul1(mgs) write(iunit,*) csmul(mgs) ! ! + ! ! write(iunit,*) @@ -24807,8 +27308,9 @@ subroutine nssl_2mom_gs & ! write(iunit,*) 'pqcwi =', pqcwi(mgs) write(iunit,*) -il5(mgs)*qiacw(mgs) - write(iunit,*) -il5(mgs)*qwfrzc(mgs) + write(iunit,*) -il5(mgs)*qwfrz(mgs), qiintd(mgs) write(iunit,*) -il5(mgs)*qwctfzc(mgs) + ! write(iunit,*) -il5(mgs)*qwfrzp(mgs) ! write(iunit,*) -il5(mgs)*qwctfzp(mgs) write(iunit,*) -il5(mgs)*qiihr(mgs) @@ -24819,6 +27321,7 @@ subroutine nssl_2mom_gs & write(iunit,*) -qrcnw(mgs) write(iunit,*) -qhacw(mgs) write(iunit,*) -qhlacw(mgs) + write(iunit,*) 'pqcwd = ', pqcwd(mgs) @@ -24828,6 +27331,7 @@ subroutine nssl_2mom_gs & write(iunit,*) -cracw(mgs) write(iunit,*) -csacw(mgs) write(iunit,*) -chacw(mgs) + write(iunit,*) -ciacw(mgs) write(iunit,*) -cwfrzp(mgs) write(iunit,*) -cwctfzp(mgs) @@ -24857,6 +27361,7 @@ subroutine nssl_2mom_gs & write(iunit,*) -qhlacr(mgs) write(iunit,*) qrcev(mgs) write(iunit,*) 'pqrwd = ', pqrwd(mgs) + write(iunit,*) 'qrzfac = ', qrzfac(mgs) ! @@ -24881,12 +27386,18 @@ subroutine nssl_2mom_gs & ! write(iunit,*) il5(mgs)*qscni(mgs), qscnvi(mgs) write(iunit,*) il5(mgs)*qsaci(mgs) - write(iunit,*) il5(mgs)*qrfrzs(mgs) + write(iunit,*) il5(mgs)*qrfrzs(mgs), qiacrs(mgs) write(iunit,*) il5(mgs)*qiacrs(mgs),il3(mgs)*(qiacrf(mgs)+qracif(mgs)),il3(mgs),qiacrf(mgs),qracif(mgs) write(iunit,*) il5(mgs)*qsdpv(mgs), qscev(mgs) - write(iunit,*) qsacw(mgs) + write(iunit,*) qsacw(mgs),qwfrzc(mgs), qwctfzc(mgs), qicichr(mgs) write(iunit,*) qsacr(mgs), qscnh(mgs) - write(iunit,*) 'pqswi = ',pqswi(mgs) + + write(iunit,*) il2(mgs)*qsacr(mgs) + write(iunit,*) il5(mgs)*qicicnt(mgs)*ffrzs + write(iunit,*) il3(mgs)*(qiacrf(mgs)+qracif(mgs)) ! only applies for ipconc <= 3 + write(iunit,*) Max(0.0, qscev(mgs)) + write(iunit,*) qsacw(mgs) + qscnh(mgs) + write(iunit,*) 'pqswi = ',pqswi(mgs) write(iunit,*) -qhcns(mgs) write(iunit,*) -qracs(mgs) write(iunit,*) -qhacs(mgs) @@ -24931,6 +27442,7 @@ subroutine nssl_2mom_gs & write(iunit,*) chcns(mgs) write(iunit,*) ciacrf(mgs) + ! write(iunit,*) write(iunit,*) 'Hail' @@ -24962,6 +27474,7 @@ subroutine nssl_2mom_gs & end do ! + end if ! ( nstep/12*12 .eq. nstep ) ! @@ -24972,31 +27485,38 @@ subroutine nssl_2mom_gs & pfrz(mgs) = & & (1-il5(mgs))* & & (qhmlr(mgs)+ & + & qsmlr(mgs)+qhlmlr(mgs)) & !+qhmlh(mgs)) & + & +il5(mgs)*(1-imixedphase)*( & & qsacw(mgs)+qhacw(mgs) + qhlacw(mgs) & + & +qsacr(mgs)+qhacr(mgs) + qhlacr(mgs) & & +qsshr(mgs) & & +qhshr(mgs) & - & +qhlshr(mgs) & - & +qrfrz(mgs)+qiacr(mgs) & - & ) & + + & +qhlshr(mgs) ) & + & +il5(mgs)*qrfrzfrac(mgs)*(qrfrz(mgs)+qiacr(mgs) ) & & +il5(mgs)*(qwfrz(mgs) & & +qwctfz(mgs)+qiihr(mgs) & & +qiacw(mgs)) pmlt(mgs) = & & (1-il5(mgs))* & & (qhmlr(mgs)+qsmlr(mgs)+ & + & qhlmlr(mgs)) !+qhmlh(mgs)) ! NOTE: psub is sum of sublimation and deposition psub(mgs) = & & il5(mgs)*( & & + qsdpv(mgs) + qhdpv(mgs) & + & + qhldpv(mgs) & & + qidpv(mgs) + qisbv(mgs) ) & & + qssbv(mgs) + qhsbv(mgs) & + & + qhlsbv(mgs) & - & +il5(mgs)*(qiint(mgs)) + + & +il5(mgs)*(qiintv(mgs)) pvap(mgs) = & & qrcev(mgs) + qhcev(mgs) + qscev(mgs) + qhlcev(mgs) + qfcev(mgs) pevap(mgs) = & @@ -25006,9 +27526,11 @@ subroutine nssl_2mom_gs & pdep(mgs) = & & il5(mgs)*( & & + qsdpv(mgs) + qhdpv(mgs) & + & + qhldpv(mgs) & & + qidpv(mgs) ) & - & +il5(mgs)*(qiint(mgs)) + + & +il5(mgs)*(qiintv(mgs)) ELSEIF ( warmonly < 0.8 ) THEN pfrz(mgs) = & & (1-il5(mgs))* & @@ -25024,6 +27546,7 @@ subroutine nssl_2mom_gs & & +qhacr(mgs) + qhlacr(mgs) ) psub(mgs) = 0.0 + & & il5(mgs)*( & + & + qsdpv(mgs) & & + qhdpv(mgs) & & + qhldpv(mgs) & & + qidpv(mgs) + qisbv(mgs) ) & @@ -25052,6 +27575,7 @@ subroutine nssl_2mom_gs & + ! ! sum the sources and sinks for qwvp, qcw, qci, qrw, qsw ! @@ -25059,25 +27583,30 @@ subroutine nssl_2mom_gs & do mgs = 1,ngscnt + qwvp(mgs) = qwvp(mgs) + & & dtp*(pqwvi(mgs)+pqwvd(mgs)) + ! qcwresv(mgs) = qx(mgs,lc) ! temporary save of old qc value qx(mgs,lc) = qx(mgs,lc) + & & dtp*(pqcwi(mgs)+pqcwd(mgs)) qx(mgs,lr) = qx(mgs,lr) + & & dtp*(pqrwi(mgs)+pqrwd(mgs)) qx(mgs,li) = qx(mgs,li) + & & dtp*(pqcii(mgs)+pqcid(mgs)) + qx(mgs,ls) = qx(mgs,ls) + & & dtp*(pqswi(mgs)+pqswd(mgs)) qx(mgs,lh) = qx(mgs,lh) + & & dtp*(pqhwi(mgs)+pqhwd(mgs)) + IF ( lhl .gt. 1 ) THEN qx(mgs,lhl) = qx(mgs,lhl) + & & dtp*(pqhli(mgs)+pqhld(mgs)) ENDIF + end do ! sum sources for particle volume @@ -25097,6 +27626,7 @@ subroutine nssl_2mom_gs & ! > rho0(mgs)*dtp*(pqhwi(mgs)+pqhwd(mgs))/xdn0(lh) ENDIF + IF ( lhl .gt. 1 ) THEN IF ( lvol(lhl) .gt. 1 ) THEN vx(mgs,lhl) = vx(mgs,lhl) + & @@ -25118,10 +27648,13 @@ subroutine nssl_2mom_gs & do mgs = 1,ngscnt cx(mgs,li) = cx(mgs,li) + & & dtp*(pccii(mgs)+pccid(mgs)) - cina(mgs) = cina(mgs) + pccin(mgs)*dtp + cina(mgs) = cina(mgs) + (pccin(mgs) - cidint(mgs))*dtp + cinda(mgs) = cinda(mgs) + cidint(mgs)*dtp + IF ( ipconc .ge. 2 ) THEN cx(mgs,lc) = cx(mgs,lc) + & & dtp*(pccwi(mgs)+pccwd(mgs)) + ENDIF IF ( ipconc .ge. 3 ) THEN cx(mgs,lr) = cx(mgs,lr) + & @@ -25134,15 +27667,18 @@ subroutine nssl_2mom_gs & IF ( ipconc .ge. 5 ) THEN cx(mgs,lh) = cx(mgs,lh) + & & dtp*(pchwi(mgs)+pchwd(mgs)) + IF ( lhl .gt. 1 ) THEN cx(mgs,lhl) = cx(mgs,lhl) + & & dtp*(pchli(mgs)+pchld(mgs)) + ENDIF ENDIF + IF ( ipconc .ge. 6 ) THEN IF ( lzr .gt. 1 ) THEN zx(mgs,lr) = zx(mgs,lr) + & @@ -25156,17 +27692,17 @@ subroutine nssl_2mom_gs & zx(mgs,lh) = zx(mgs,lh) + & & dtp*(pzhwi(mgs)+pzhwd(mgs)) ENDIF + IF ( lzhl .gt. 1 ) THEN zx(mgs,lhl) = zx(mgs,lhl) + & & dtp*(pzhli(mgs)+pzhld(mgs)) -! IF ( pchli(mgs) .ne. 0. .or. pchld(mgs) .ne. 0 ) THEN -! write(0,*) 'dr: cx,pchli,pchld = ', cx(mgs,lhl),pchli(mgs),pchld(mgs), igs(mgs),kgs(mgs) -! ENDIF ENDIF ENDIF + end do end if + ! ! ! @@ -25223,6 +27759,7 @@ subroutine nssl_2mom_gs & end if end do + ! ! @@ -25311,7 +27848,9 @@ subroutine nssl_2mom_gs & ctmp = cx(mgs,lc)*qx(mgs,lc)*rho0(mgs)/qtmp ELSE cx(mgs,lc) = Max(0.0,wvel(mgs))*dtp*cwccn & + & /gz(igs(mgs),jgs,kgs(mgs)) + cx(mgs,lc) = cwccn ENDIF @@ -25358,11 +27897,11 @@ subroutine nssl_2mom_gs & ltemq = (temg(mgs)-163.15)/fqsat+1.5 ltemq = Min( nqsat, Max(1,ltemq) ) -! qvs(mgs) = pqs(mgs)*tabqvs(ltemq) IF ( iqvsopt == 0 ) THEN qvs(mgs) = pqs(mgs)*tabqvs(ltemq) ELSEIF ( iqvsopt == 1 ) THEN qvs(mgs) = rdorv*esbolton*tabqvs(ltemq)/(pres(mgs) - esbolton*tabqvs(ltemq)) + ENDIF IF ( ( qvap(mgs) > qvs(mgs) .or. qx(mgs,lc) > qxmin(lc) ) .and. temg(mgs) > tfrh ) THEN @@ -25407,11 +27946,11 @@ subroutine nssl_2mom_gs & ltemq = (temg(mgs)-163.15)/fqsat+1.5 ltemq = Min( nqsat, Max(1,ltemq) ) -! qvs(mgs) = pqs(mgs)*tabqvs(ltemq) IF ( iqvsopt == 0 ) THEN qvs(mgs) = pqs(mgs)*tabqvs(ltemq) ELSEIF ( iqvsopt == 1 ) THEN qvs(mgs) = rdorv*esbolton*tabqvs(ltemq)/(pres(mgs) - esbolton*tabqvs(ltemq)) + ENDIF qis(mgs) = pqs(mgs)*tabqis(ltemq) qss(mgs) = qvs(mgs) @@ -25574,11 +28113,12 @@ subroutine nssl_2mom_gs & tqvcon = temg(mgs)-cbw ltemq = (temg(mgs)-163.15)/fqsat+1.5 ltemq = Min( nqsat, Max(1,ltemq) ) -! qvs(mgs) = pqs(mgs)*tabqvs(ltemq) + IF ( iqvsopt == 0 ) THEN qvs(mgs) = pqs(mgs)*tabqvs(ltemq) ELSEIF ( iqvsopt == 1 ) THEN qvs(mgs) = rdorv*esbolton*tabqvs(ltemq)/(pres(mgs) - esbolton*tabqvs(ltemq)) + ENDIF qis(mgs) = pqs(mgs)*tabqis(ltemq) qx(mgs,lc) = max( 0.0, qx(mgs,lc) ) @@ -25629,18 +28169,24 @@ subroutine nssl_2mom_gs & ! ! end of saturation adjustment + ! ! + ! !DIR$ IVDEP + do mgs = 1,ngscnt t0(igs(mgs),jy,kgs(mgs)) = temg(mgs) end do ! ! Load the save arrays ! + IF ( numproc > 1 ) THEN DO mgs = 1,ngscnt + dv = dx1*dy1*gz(igs(mgs),1,kgs(mgs)) + IF ( ipconc > 2 ) THEN thproc(kzbeg-1+kgs(mgs),1) = thproc(kzbeg-1+kgs(mgs),1) + crfrzf(mgs)*dtp*dv ELSE @@ -25662,6 +28208,7 @@ subroutine nssl_2mom_gs & thproc(kzbeg-1+kgs(mgs),10) = thproc(kzbeg-1+kgs(mgs),10) + & & ( chmul1(mgs) + chlmul1(mgs) )*dtp*dv IF ( lf > 1 ) THEN + ELSE thproc(kzbeg-1+kgs(mgs),11) = thproc(kzbeg-1+kgs(mgs),11) + & & ( csplinter(mgs) + csplinter2(mgs) )*dtp*dv @@ -25700,25 +28247,29 @@ subroutine nssl_2mom_gs & thproc(kzbeg-1+kgs(mgs),32) = thproc(kzbeg-1+kgs(mgs),32) + qhlcnh(mgs)*rho0(mgs)*dtp*dv ! graupel mass conversion to hail IF ( ihrn > 0 ) THEN - thproc(kzbeg-1+kgs(mgs),33) = thproc(kzbeg-1+kgs(mgs),33) + ciihr(mgs)*dtp*dv ! contact freezing of droplets + thproc(kzbeg-1+kgs(mgs),33) = thproc(kzbeg-1+kgs(mgs),33) + ciihr(mgs)*dtp*dv ! Ferrier94 Hobbs-Ragno mulitplication process ELSE IF ( qwctfz(mgs)*dtp >= qxmin(li) ) THEN thproc(kzbeg-1+kgs(mgs),33) = thproc(kzbeg-1+kgs(mgs),33) + cwctfz(mgs)*dtp*dv ! contact freezing of droplets ENDIF ENDIF thproc(kzbeg-1+kgs(mgs),34) = thproc(kzbeg-1+kgs(mgs),34) + pevap(mgs)*rho0(mgs)*dv ! rain evaporation rate - IF ( qiint(mgs)*dtp >= qxmin(li) ) THEN - thproc(kzbeg-1+kgs(mgs),35) = thproc(kzbeg-1+kgs(mgs),35) + ciint(mgs)*dtp*dv ! primary ice initiation - ENDIF + ! IF ( qiint(mgs)*dtp >= qxmin(li) ) THEN + thproc(kzbeg-1+kgs(mgs),35) = thproc(kzbeg-1+kgs(mgs),35) + (ciintd(mgs)+ciint(mgs))*dtp*dv ! primary ice initiation + ! ENDIF IF ( lf > 1 ) THEN + ELSE thproc(kzbeg-1+kgs(mgs),38) = thproc(kzbeg-1+kgs(mgs),38) + (vhacw(mgs)+vhacr(mgs)+vhshdr(mgs))*dtp*dv ENDIF IF ( lhl > 1 ) THEN thproc(kzbeg-1+kgs(mgs),36) = thproc(kzbeg-1+kgs(mgs),36) + chlcnhhl(mgs)*dtp*dv + thproc(kzbeg-1+kgs(mgs),37) = thproc(kzbeg-1+kgs(mgs),37) + (vhlacw(mgs)+vhlacr(mgs)+vhlshdr(mgs))*dtp*dv + ELSE IF ( lf > 1 ) THEN + ELSE thproc(kzbeg-1+kgs(mgs),36) = thproc(kzbeg-1+kgs(mgs),36) + (pchwi(mgs))*dtp*dv thproc(kzbeg-1+kgs(mgs),39) = thproc(kzbeg-1+kgs(mgs),39) + (pchwd(mgs))*dtp*dv @@ -25728,10 +28279,13 @@ subroutine nssl_2mom_gs & ! IF ( numproc >= 44 ) THEN thproc(kzbeg-1+kgs(mgs),42) = thproc(kzbeg-1+kgs(mgs),42) - qhshr(mgs)*dtp*dv + thproc(kzbeg-1+kgs(mgs),43) = 0.0 + thproc(kzbeg-1+kgs(mgs),44) = thproc(kzbeg-1+kgs(mgs),44) - qhlshr(mgs)*dtp*dv ! ENDIF + ! thproc(kzbeg-1+kgs(mgs),35) = thproc(kzbeg-1+kgs(mgs),35) + pevap(mgs)*rho0(mgs)*dv ! rain evaporation rate @@ -25746,11 +28300,14 @@ subroutine nssl_2mom_gs & ENDIF + + ! Sample code for using the axtra array to load microphysical rates or quantities for output ! ! Note that indices 1 and 2 are used in the nucond subroutine for condensation/evap of droplets (1) and ! condensation of rain (2) ! + ! IF ( io_flag .and. nxtra > 1 ) THEN ! DO mgs = 1,ngscnt ! axtra(igs(mgs),jy,kgs(mgs),3) = pfrz(mgs) ! @@ -25763,6 +28320,9 @@ subroutine nssl_2mom_gs & + + + if (ndebug .gt. 0 ) write(0,*) 'gs 11' do mgs = 1,ngscnt @@ -25792,6 +28352,13 @@ subroutine nssl_2mom_gs & an(igs(mgs),jy,kgs(mgs),lcina) = cina(mgs) ENDIF + IF ( lcinda > 1 ) THEN + an(igs(mgs),jy,kgs(mgs),lcinda) = cinda(mgs) + ENDIF + + + + @@ -25816,6 +28383,7 @@ subroutine nssl_2mom_gs & ENDDO ENDIF + ! end do ! @@ -25850,7 +28418,8 @@ subroutine nssl_2mom_gs & ! 8/26/2015 erm: apply imaxdiaopt for 2-moment also IF ( imaxdiaopt == 1 .or. il == lc .or. il == li .or. (il == lr .and. imurain == 3) .or. & - & (il == ls .and. imusnow == 3 ) ) THEN + & (il == ls .and. imusnow == 3 ) .or. ( il >= lh .and. lh > 0 ) ) THEN +! IF ( imaxdiaopt == 1 .or. (il == lr .and. imurain == 3) .or. .not. (il == lr .and. imurain == 1) ) THEN xvbarmax = xvmx(il) ELSEIF ( imaxdiaopt == 2 ) THEN ! test against maximum mass diameter xvbarmax = xvmx(il) /((3. + alpha(mgs,il))**3/((3. + alpha(mgs,il))*(2. + alpha(mgs,il))*(1. + alpha(mgs,il)))) @@ -25880,6 +28449,7 @@ subroutine nssl_2mom_gs & ENDIF !} ENDDO ! mgs + ELSE ! } { is three-moment, so have to adjust Z if size is too large IF ( il == lr .and. imurain == 3 ) THEN ! { { RAIN @@ -26071,6 +28641,7 @@ subroutine nssl_2mom_gs & + IF ( iresetmoments == 1 .or. iresetmoments == il .or. iresetmoments == -1 ) THEN ! { .or. qx(mgs,il) <= qxmin(il) IF ( zx(mgs,il) <= zxmin ) THEN ! .and. qx(mgs,il) > 0.05e-3 !! write(91,*) 'zx=0; qx,cx = ',1000.*qx(mgs,il),cx(mgs,il) @@ -26104,6 +28675,7 @@ subroutine nssl_2mom_gs & ENDIF !} + IF ( zx(mgs,il) <= zxmin .and. cx(mgs,il) <= cxmin ) THEN zx(mgs,il) = 0.0 cx(mgs,il) = 0.0 @@ -26123,6 +28695,7 @@ subroutine nssl_2mom_gs & xv(mgs,il) = Min( xvmx(il), Max( xvmn(il),xv(mgs,il) ) ) xmas(mgs,il) = xv(mgs,il)*xdn(mgs,il) cx(mgs,il) = rho0(mgs)*qx(mgs,il)/(xmas(mgs,il)) + ENDIF IF ( zx(mgs,il) > 0.0 .and. cx(mgs,il) <= 0.0 ) THEN !{ @@ -26135,6 +28708,7 @@ subroutine nssl_2mom_gs & cx(mgs,il) = g1*dn(igs(mgs),jy,kgs(mgs))**2*(6.*qr)**2/(z*(pi*xdn(mgs,il))**2) + ELSEIF ( zx(mgs,il) <= zxmin .and. cx(mgs,il) > 0.0 ) THEN ! have mass and concentration but no reflectivity, so set reflectivity, using default alpha ! g1 = (6.0 + alpha(mgs,il))*(5.0 + alpha(mgs,il))*(4.0 + alpha(mgs,il))/ & @@ -26174,8 +28748,8 @@ subroutine nssl_2mom_gs & qr = qx(mgs,il) z = zx(mgs,il) - IF ( zx(mgs,il) .gt. 0. ) THEN !{ - + IF ( zx(mgs,il) .gt. zxmin .and. qr > qxmin(il) .and. chw > cxmin ) THEN !{ + ! rdi = z*(pi/6.*1000.)**2*chw/((rho0(mgs)*qr)**2) rdi = z*(pi/6.*xdn(mgs,il))**2*chw/((rho0(mgs)*qr)**2) @@ -26287,9 +28861,11 @@ subroutine nssl_2mom_gs & ENDIF ! !} + ENDIF !} + IF ( lzr > 1 ) THEN alpha2d(igs(mgs),kgs(mgs),1) = Max(alphamin, Min(alphamax, alpha(mgs,lr) )) ENDIF @@ -26300,6 +28876,7 @@ subroutine nssl_2mom_gs & alpha2d(igs(mgs),kgs(mgs),3) = Max(alphamin, Min(alphamax, alpha(mgs,lhl) )) ENDIF + IF ( il == lhl .and. lnhlf > 1 ) THEN ! update chxf in case cx has changed chxf(mgs,lhl) = frac*cx(mgs,lhl) @@ -26310,6 +28887,7 @@ subroutine nssl_2mom_gs & ENDIF + ! IF ( lf > 0 .and. il == lf .and. kgs(mgs) <= 20 .and. ( cx(mgs,lf) + dtp*( pcfwi(mgs) + pcfwd(mgs) ) > 200. .or. cx(mgs,lf) > 400. )) THEN ! write(0,*) 'ix,jy, kz, cf = ',igs(mgs)+ixbeg,jy+jybeg,kgs(mgs), an(igs(mgs),jy,kgs(mgs),ln(lf)),lfsave(mgs,5),lfsave(mgs,6) ! write(0,*) 'qold,qxold,zold,zxold = ',lfsave(mgs,1),lfsave(mgs,2),lfsave(mgs,3),lfsave(mgs,4) @@ -26329,6 +28907,7 @@ subroutine nssl_2mom_gs & ENDIF ! } } + ENDIF ! }} ENDIF ! } @@ -26346,6 +28925,7 @@ subroutine nssl_2mom_gs & ! an(igs(mgs),jy,kgs(mgs),lnhlf) = Min( cx(mgs,lhl), Max( chxf(mgs,lhl), 0.0) ) an(igs(mgs),jy,kgs(mgs),lnhlf) = Max( chxf(mgs,lhl), 0.0) ENDIF + ENDIF an(igs(mgs),jy,kgs(mgs),ln(il)) = Max(cx(mgs,il), 0.0) ENDDO @@ -26367,6 +28947,7 @@ subroutine nssl_2mom_gs & IF ( lccn > 1 ) THEN an(igs(mgs),jy,kgs(mgs),lccn) = Max(0.0, ccnc(mgs) ) ENDIF + end do ENDIF @@ -26404,6 +28985,7 @@ subroutine nssl_2mom_gs & + if (ndebug .gt. 0 ) write(0,*) 'gs 13' 9998 continue @@ -26438,6 +29020,97 @@ end subroutine nssl_2mom_gs !-------------------------------------------------------------------------- ! + real function galpha(a_in) + implicit none + real :: a_in + galpha = ((4. + a_in)*(5. + a_in)*(6. + a_in))/((1. + a_in)*(2. + a_in)*(3. + a_in)) + end function galpha +! +!-------------------------------------------------------------------------- +! + + real function dgalpha(a_in) + real :: a_in + dgalpha = (876. + 1260.*a_in + 621.*a_in**2 + 126.*a_in**3 + 9.*a_in**4)/ & + & (36. + 132.*a_in + 193.*a_in**2 + 144.*a_in**3 + 58.*a_in**4 + 12.*a_in**5 + a_in**6) + end function dgalpha +! +!-------------------------------------------------------------------------- +! +! Calculate reflectivity change when only number changes +! Differential version can have large error when crate is big and time step is big + real function zraten(dtpinv,dtp,g1x,rho0,xdn,qx,cx,crate) + implicit none + real, intent(in) :: dtpinv,dtp,g1x,rho0,qx,cx,crate,xdn + real, parameter :: pi = 3.141592653589793 + real :: tmp1 + + IF ( cx > 1.e-8 ) THEN + IF ( cx + dtp*crate > 1.e-8 ) THEN + zraten = (6./pi)**2*dtpinv*g1x*(rho0*qx/xdn)**2 & + * crate /((cx + dtp*crate)*cx) + ELSE + ! differential form + tmp1 = qx/cx + zraten = (6./pi)**2*g1x*(rho0/xdn)**2*( - tmp1**2 * crate ) + ENDIF + ELSE + zraten = 0.0 + ENDIF + + end function zraten +! +!-------------------------------------------------------------------------- +! +! Calculate reflectivity change when only mass changes + real function zrateq(dtpinv,dtp,g1x,rho0,xdn,qx,cx,qrate) + implicit none + real, intent(in) :: dtpinv,dtp,g1x,rho0,qx,cx,qrate,xdn + real :: tmp1,tmp2 + real, parameter :: pi = 3.141592653589793 + + IF ( cx > 1.e-8 ) THEN + tmp1 = qx**2 + tmp2 = (qx+dtp*qrate)**2 + zrateq = (6./pi)**2*dtpinv*g1x*(rho0/xdn)**2*(tmp2 - tmp1)/cx + ELSE + zrateq = 0.0 + ENDIF + + end function zrateq +! +!-------------------------------------------------------------------------- +! +! Calculate reflectivity change when both mass and number change + real function zrateqn(dtpinv,dtp,g1x,rho0,xdn,qx,cx,crate,qrate,ioldnew) + implicit none + real, intent(in) :: dtpinv,dtp,g1x,rho0,qx,cx,crate,xdn,qrate + integer, intent(in) :: ioldnew + real :: tmp1,tmp2 + real, parameter :: pi = 3.141592653589793 + + IF ( cx > 1.e-8 ) THEN + IF ( ioldnew == 1 .and. cx + dtp*crate > 1.e-8 .and. qx+dtp*qrate > 0. ) THEN + ! final-initial + tmp1 = qx**2/cx + tmp2 = (qx+dtp*qrate)**2/(cx + dtp*crate) + zrateqn = (6./pi)**2*dtpinv*g1x*(rho0/xdn)**2*(tmp2 - tmp1) + ELSE + ! differential form + tmp1 = qx/cx + zrateqn = (6./pi)**2*g1x*(rho0/xdn)**2*( 2.*tmp1*qrate - tmp1**2 * crate ) + ENDIF + ELSE + zrateqn = 0.0 + ENDIF + + end function zrateqn +! +!-------------------------------------------------------------------------- +! + + + ! @@ -26446,3 +29119,4 @@ end subroutine nssl_2mom_gs END MODULE module_mp_nssl_2mom + diff --git a/src/module_mp_p3.F b/src/module_mp_p3.F index 9c39bb2..b679a54 100644 --- a/src/module_mp_p3.F +++ b/src/module_mp_p3.F @@ -51,6 +51,158 @@ MODULE microphy_p3 integer, parameter, public :: STATUS_OK = 0 integer, save :: global_status = STATUS_OK +! Phase-1 checksum instrumentation for the category-swap divergence diagnosis +! (see NOTES.md / p3_category_swap_audit.md). When log_chksum=.true., +! mp_p3_wrapper_wrf writes a bitwise, position-weighted XOR checksum of each +! prognostic field both immediately BEFORE and immediately AFTER every call +! to p3_main — two tagged lines ('PRE '/'POST') per (itimestep, j-slab) — to +! the per-rank file p3_chksum_NNNN.out (NNNN = chksum_myid). Equal checksums +! <=> bit-identical fields. Diffing two runs: first divergence on a PRE line +! means the seed entered between the previous POST and this call (host +! dynamics/advection); PRE matching while POST diverges means the seed is +! inside p3_main. +! Both switches are set by the host model (CM1: param.F, namelist p3_params, +! option p3_chksum). Note: the output file is replaced at the first write of +! each run (including restarted runs). + logical, public, save :: log_chksum = .false. + integer, public, save :: chksum_myid = 0 ! MPI rank used in checksum filename + integer, save :: chksum_unit = -1 ! output unit from newunit= (negative!) + logical, save :: chksum_opened = .false. ! file opened on first write + +! Per-point dump (log_chkpts=.true., host namelist option p3_chkpts): writes +! the raw 32-bit bit pattern (hex Z8.8, no hashing) of every field at every +! tile point, PRE and POST p3_main, to the per-rank file p3_chkpts_NNNN.out. +! Each line carries the local (i,j,k) AND the full-grid (i,j,k) — global +! index = local + chksum_i0/chksum_j0 (set by the host from its decomposition; +! k is not decomposed in CM1, so local k = global k). This is the Phase-2 +! point-isolation tool: bitwise-comparing two runs' files pinpoints the exact +! first divergent grid point and field. WARNING: output is one line per tile +! point per slab per PRE/POST — orders of magnitude larger than the checksum +! lines. Enable only for short (restart-bracketing) runs around the first +! divergent timestep found with p3_chksum. + logical, public, save :: log_chkpts = .false. + integer, public, save :: chksum_i0 = 0 ! global-i offset of local i=1 (myi1-1) + integer, public, save :: chksum_j0 = 0 ! global-j offset of local j=1 (myj1-1) + integer, save :: chkpts_unit = -1 + logical, save :: chkpts_opened = .false. + +! Limiter-firing log (log_limlog=.true., host namelist option p3_limlog): +! records every grid point at which one of the point-local limiters/gates in +! p3_main binds, to the per-rank file p3_limlog_NNNN.out. Purpose: diagnose +! grid-point ("checkerboard") noise in the moments and in th/qv/p, which is +! the expected signature of an all-or-nothing limiter that fires at one point +! but not its neighbours. One line per firing: +! +! event it i j k (global) iice ratio v1 v2 v3 v4 +! +! Events logged (see limlog_write calls): +! MAXNI impose_max_Ni clipped nitot for this category (N clipped alone, +! leaving qitot/zitot untouched -> inconsistent 3-moment triple). +! ratio = nitot_after/nitot_before; v1..v4 = nitot_before, nitot_after, +! qitot, zitot. +! NGATE qitot>=qsmall but nitot=nsmall conjuncts stripped from the downstream process gates, +! the process block then runs at an implied mean particle mass of +! q/nsmall, which can be absurdly large at advection/sedimentation +! leading edges. v1..v4 = q, n_before, nsmall, q/nsmall. +! SATC0/SATCR/SATER saturation-adjustment limit on condensation/evaporation +! SATD0/SATDR saturation-adjustment limit on deposition/nucleation +! MELT melt+shed bound on available ice mass +! CLOUD/RAIN/ICE/QILIQ/VAPOR the mass-conservation source/sink ratio limiters +! For all of these, ratio = the applied scaling factor and v1,v2 = +! sources, sinks (v3,v4 = supporting values, event-dependent). +! +! Conservation limiters bind routinely and harmlessly, so only firings with +! ratio < limlog_ratmin are recorded (host namelist p3_limlog_rat, default 0.9); +! MAXNI and NGATE are always recorded when they fire. limlog_maxrec caps the +! number of lines per rank so a long run cannot fill the disk. + logical, public, save :: log_limlog = .false. + real, public, save :: limlog_ratmin = 0.9 + integer, public, save :: limlog_maxrec = 2000000 + integer, save :: limlog_unit = -1 + integer, save :: limlog_nrec = 0 + logical, save :: limlog_opened = .false. + logical, save :: limlog_full = .false. +! limlog_write and qsmall are public so the host can log its own PRE-call state +! check into the same file (see mp_driver.F, ptype 54 block) + public :: limlog_write + public :: qsmall + +!====================== TEMPORARY DIAGNOSTIC SWITCH ========================== +! log_nifloor (host namelist option p3_nifloor, default .true. = current +! behaviour). TEMPORARY -- added solely to A/B one hypothesis about grid-point +! noise; REMOVE once that test concludes, along with the three code sites it +! guards. Do not build anything on it. +! +! .true. : unchanged. The entry clip floors nitot to nsmall, so a category +! with mass but no number is given 1e-8 #/kg and then runs the full +! process block at a mean particle mass of qitot/1e-8, which the +! lookup-table index clamp silently pins to the largest size bin. +! +! .false. : the entry-clip floor is skipped, so such a category keeps nitot=0 +! and fails the existing 'nitot >= nsmall' gates -- no process rates, +! no sedimentation, no lookup access -- and is cleared at the exit +! clip. Two lookup call sites (in k_loop_fz and qi_not_small_merge) +! gate only on qitot and would otherwise divide by zero, so their +! gates pick up an nitot condition here too. Note log_maxnsmall does +! NOT cover this: the floors it switches sit inside gates that already +! require nitot >= nsmall (and ntiny == nsmall), so they are no-ops, +! while the entry-clip floor it does not switch is the one that acts. + logical, public, save :: log_nifloor = .true. +! +! log_nrfloor (host namelist p3_nrfloor, default .true. = current behaviour). +! TEMPORARY, same terms as log_nifloor -- remove when the test concludes. +! .false. rejects rain with mass but no number at the entry clip (qr returned +! to vapour) instead of flooring nr to nsmall. Unlike the ice case this needs +! no downstream gate changes: get_rain_dsd2 guards itself, the two qr/nr +! divisions in the warm-rain block already test nr > nsmall, and the resulting +! post-clip invariant (qr=0,nr=0) or (qr>=qsmall .and. nr>=nsmall) is stronger +! than the one the floor provided. + logical, public, save :: log_nrfloor = .true. +!============================================================================= + +! Targeted single-point dump (host namelist p3_dbg_i / p3_dbg_j / p3_dbg_k; +! disabled when p3_dbg_i <= 0). Writes one line per timestep for one grid +! point to p3_dbgpt_NNNN.out, from whichever rank owns it: the final reflectivity +! components and the liquid/ice distribution parameters behind them. Intended +! for isolated-pixel diagnosis where event counting cannot separate causes -- +! point it at a suspicious grid point and read the actual values. Indices are +! FULL-GRID and are compared against local + chksum_i0/chksum_j0. + integer, public, save :: dbgpt_i = 0 + integer, public, save :: dbgpt_j = 0 + integer, public, save :: dbgpt_k = 0 + ! half-width of the block dumped around (dbgpt_i,dbgpt_j,dbgpt_k): 0 = that + ! point only, 1 = the surrounding 3x3x3, etc. A halo also makes the dump + ! immune to an off-by-one between the analysis tool's index convention and + ! CM1's 1-based global indices, so every line carries its own i,j,k. + integer, public, save :: dbgpt_halo = 1 + integer, save :: dbgpt_unit = -1 + logical, save :: dbgpt_opened = .false. + ! ice microphysics lookup table array dimensions integer, parameter :: isize = 50 integer, parameter :: iisize = 25 @@ -89,6 +241,11 @@ MODULE microphy_p3 ! integer switch for warm rain autoconversion/accretion schemes integer :: iparam +! integer switch for primary ice nucleation (ERM) + integer :: iparamice + + logical :: log_nislf = .true. ! default flag for ice self-aggregation + logical :: log_maxnsmall ! number of diagnostic ice-phase hydrometeor types integer, public, parameter :: n_qiType = 6 @@ -110,16 +267,89 @@ MODULE microphy_p3 inv_rhow,qsmall,nsmall,bsmall,zsmall,cp,g,rd,rv,ep_2,inv_cp,mw,osm, & vi,epsm,rhoa,map,ma,rr,bact,inv_rm1,inv_rm2,sig1,nanew1,f11,f21,sig2, & nanew2,f12,f22,pi,thrd,sxth,piov3,piov6,rho_rimeMin, & - rho_rimeMax,inv_rho_rimeMax,max_total_Ni,dbrk,nmltratio,minVIS, & - maxVIS,mu_i_initial,mu_r_constant,inv_Drmax,Dmin_HM,Dinit_HM - + rho_rimeMax,inv_rho_rimeMax,max_Ni,dbrk,nmltratio,minVIS, & + maxVIS,mu_i_initial,mu_r_constant,inv_Drmax,ntiny,Dmin_HM,Dinit_HM + real, parameter :: rho00 = 1.225 ! ERM integer :: n_iceCat = -1 !used for GEM interface + ! Added by ERM + integer :: rssflg = 1 ! Rain size-sorting allowed (1, default), or disallowed (0). If 0, sets N and Z-weighted fall speeds to q-weighted value + integer :: sssflg = 1 ! As above but for ice (all ice) + integer :: ccn_on = 0 + integer :: merge_opt = 1 ! -1 = no merging with explicit ice category destination for ncat=2 only (Ted's original hardcoded test with merge_opt = 0) + ! 0 = no merging; 1 = diameter-difference merge (original); 2 = percent difference in diam. (Cholette 2024) + integer :: qrcol_opt = 0 ! 0 = no size check on qrcol; 1 = only allow qrcol for ice larger than rain + ! for merge_opt=0 with qrcol_opt=2 and ncat=2, this disables qrcol for iice=2 + ! DTD: Hallett-Mossop rime-splintering source selection (host namelist p3_hm_opt). + ! Which riming source feeds the splinter production in the calc_HM block; both + ! sources use the same 350 splinters per mg of rime accreted, and the splinter + ! mass is removed from the corresponding collection tendency. Previously this + ! was chosen by commenting one of the two blocks in or out. + ! 0 = off entirely (no rime splintering, regardless of log_hmossopOn) + ! 1 = riming of cloud droplets only (qccol -> qcmul) + ! 2 = riming of rain only (qrcol -> qrmul) [original P3 behaviour] + ! 3 = both + integer :: hm_opt = 1 + logical :: cat_init_new = .true. ! default for mechanism-based ice category initialization + logical :: log_iceice_interaction = .true. ! default for allowing ice categories to interact + ! DTD: the _n5/_n6 defaults continue the progressive split of the _n2..._n4 + ! series: each additional category takes over one more initiation mechanism, + ! so that no category is left without a source. For nCat=5 deposition + ! nucleation moves to its own category (5), and for nCat=6 homogeneous + ! freezing of rain moves to its own category (6). + integer :: catdest_contact_n2 = 1 + integer :: catdest_contact_n3 = 3 + integer :: catdest_contact_n4 = 4 + integer :: catdest_contact_n5 = 4 + integer :: catdest_contact_n6 = 4 + integer :: catdest_rainimm_n2 = 2 + integer :: catdest_rainimm_n3 = 2 + integer :: catdest_rainimm_n4 = 2 + integer :: catdest_rainimm_n5 = 2 + integer :: catdest_rainimm_n6 = 2 + integer :: catdest_rimesplinter_n2 = 1 + integer :: catdest_rimesplinter_n3 = 3 + integer :: catdest_rimesplinter_n4 = 3 + integer :: catdest_rimesplinter_n5 = 3 + integer :: catdest_rimesplinter_n6 = 3 + integer :: catdest_depnuc_n2 = 1 + integer :: catdest_depnuc_n3 = 3 + integer :: catdest_depnuc_n4 = 4 + integer :: catdest_depnuc_n5 = 5 + integer :: catdest_depnuc_n6 = 5 + integer :: catdest_homocloud_n2 = 1 + integer :: catdest_homocloud_n3 = 1 + integer :: catdest_homocloud_n4 = 1 + integer :: catdest_homocloud_n5 = 1 + integer :: catdest_homocloud_n6 = 1 + integer :: catdest_homorain_n2 = 2 + integer :: catdest_homorain_n3 = 2 + integer :: catdest_homorain_n4 = 2 + integer :: catdest_homorain_n5 = 2 + integer :: catdest_homorain_n6 = 6 + ! End ERM contains !==================================================================================================! - subroutine p3_init(lookup_file_dir,nCat,trplMomI,liqfrac,model,stat,abort_on_err,dowr) + subroutine p3_init(lookup_file_dir,nCat,trplMomI,liqfrac,model,stat,abort_on_err,dowr, & + nanew1_in,iparam_in,p3_ccn_on,p3_merge_opt,p3_qrcol_opt,p3_hm_opt,iparamice_in, & + rssflg_in,sssflg_in,max_Ni_in,cat_init_new_in, & + log_nislf_in, & + log_iceice_interaction_in, & + catdest_contact_n2_in,catdest_contact_n3_in,catdest_contact_n4_in, & + catdest_rainimm_n2_in,catdest_rainimm_n3_in,catdest_rainimm_n4_in, & + catdest_rimesplinter_n2_in,catdest_rimesplinter_n3_in, & + catdest_rimesplinter_n4_in,catdest_depnuc_n2_in,catdest_depnuc_n3_in, & + catdest_depnuc_n4_in,catdest_homocloud_n2_in,catdest_homocloud_n3_in, & + catdest_homocloud_n4_in,catdest_homorain_n2_in,catdest_homorain_n3_in, & + catdest_homorain_n4_in, & + catdest_contact_n5_in,catdest_contact_n6_in, & + catdest_rainimm_n5_in,catdest_rainimm_n6_in, & + catdest_rimesplinter_n5_in,catdest_rimesplinter_n6_in, & + catdest_depnuc_n5_in,catdest_depnuc_n6_in, & + catdest_homocloud_n5_in,catdest_homocloud_n6_in, & + catdest_homorain_n5_in,catdest_homorain_n6_in) !------------------------------------------------------------------------------------------! ! This subroutine initializes all physical constants and parameters needed by the P3 ! @@ -143,7 +373,26 @@ subroutine p3_init(lookup_file_dir,nCat,trplMomI,liqfrac,model,stat,abort_on_err logical, intent(in), optional :: abort_on_err ! abort when an error is encountered [.false.] character(len=*), intent(in), optional :: model ! driving model logical, intent(in), optional :: dowr - + ! Added by ERM + real, intent(in), optional :: nanew1_in, max_Ni_in + integer, intent(in), optional :: iparam_in,p3_ccn_on,p3_merge_opt,p3_qrcol_opt, & + p3_hm_opt,iparamice_in,rssflg_in,sssflg_in + logical, intent(in), optional :: cat_init_new_in + logical, intent(in), optional :: log_nislf_in + logical, intent(in), optional :: log_iceice_interaction_in + integer, intent(in), optional :: catdest_contact_n2_in,catdest_contact_n3_in,catdest_contact_n4_in + integer, intent(in), optional :: catdest_rainimm_n2_in,catdest_rainimm_n3_in,catdest_rainimm_n4_in + integer, intent(in), optional :: catdest_rimesplinter_n2_in,catdest_rimesplinter_n3_in,catdest_rimesplinter_n4_in + integer, intent(in), optional :: catdest_depnuc_n2_in,catdest_depnuc_n3_in,catdest_depnuc_n4_in + integer, intent(in), optional :: catdest_homocloud_n2_in,catdest_homocloud_n3_in,catdest_homocloud_n4_in + integer, intent(in), optional :: catdest_homorain_n2_in,catdest_homorain_n3_in,catdest_homorain_n4_in + integer, intent(in), optional :: catdest_contact_n5_in,catdest_contact_n6_in + integer, intent(in), optional :: catdest_rainimm_n5_in,catdest_rainimm_n6_in + integer, intent(in), optional :: catdest_rimesplinter_n5_in,catdest_rimesplinter_n6_in + integer, intent(in), optional :: catdest_depnuc_n5_in,catdest_depnuc_n6_in + integer, intent(in), optional :: catdest_homocloud_n5_in,catdest_homocloud_n6_in + integer, intent(in), optional :: catdest_homorain_n5_in,catdest_homorain_n6_in + ! End ERM ! Local variables and parameters: logical, save :: is_init = .false. character(len=1024), parameter :: version_p3 = '5.4.1' @@ -197,15 +446,71 @@ subroutine p3_init(lookup_file_dir,nCat,trplMomI,liqfrac,model,stat,abort_on_err piov3 = pi*thrd piov6 = pi*sxth -! maximum total ice concentration (sum of all categories) - max_total_Ni = 2000.e+3 !(m) +! maximum total ice concentration (per category). DTD NOTE: back ported this from a later P3 +! version for now in lieu of rebasing everything onto the latest version, which will happen soon. +! The original approach here native to this version is to limit the total ice concentration across +! all categories proportionally, which creates issues for those categories that are just minding +! their own business and not trying to produce unholy amounts of ice particles ;). +! Note: set to a negative number to turn off the max Ni limiter. + max_Ni = 2000.e+3 !(m) + IF ( present( max_Ni_in ) ) max_Ni = max_Ni_in ! Added by ERM ! switch for warm-rain parameterization ! = 1 Seifert and Beheng 2001 ! = 2 Beheng 1994 ! = 3 Khairoutdinov and Kogan 2000 ! = 4 Kogan 2013 - iparam = 3 + iparam = 3 ! set default +! Below added by ERM + IF ( present( iparam_in ) ) iparam = iparam_in + + IF ( present( iparamice_in ) ) iparamice = iparamice_in + IF ( present( rssflg_in ) ) rssflg = rssflg_in + IF ( present( sssflg_in ) ) sssflg = sssflg_in + IF ( present( p3_ccn_on ) ) ccn_on = p3_ccn_on + IF ( present( p3_merge_opt ) ) merge_opt = p3_merge_opt + IF ( present( p3_qrcol_opt ) ) qrcol_opt = p3_qrcol_opt + IF ( present( p3_hm_opt ) ) hm_opt = min(3,max(0,p3_hm_opt)) + IF ( present( cat_init_new_in ) ) cat_init_new = cat_init_new_in + IF ( present( log_nislf_in ) ) log_nislf = log_nislf_in + IF ( present( log_iceice_interaction_in ) ) log_iceice_interaction = log_iceice_interaction_in + IF ( present( catdest_contact_n2_in ) ) catdest_contact_n2 = min(2,max(1,catdest_contact_n2_in)) + IF ( present( catdest_contact_n3_in ) ) catdest_contact_n3 = min(3,max(1,catdest_contact_n3_in)) + IF ( present( catdest_contact_n4_in ) ) catdest_contact_n4 = min(4,max(1,catdest_contact_n4_in)) + IF ( present( catdest_rainimm_n2_in ) ) catdest_rainimm_n2 = min(2,max(1,catdest_rainimm_n2_in)) + IF ( present( catdest_rainimm_n3_in ) ) catdest_rainimm_n3 = min(3,max(1,catdest_rainimm_n3_in)) + IF ( present( catdest_rainimm_n4_in ) ) catdest_rainimm_n4 = min(4,max(1,catdest_rainimm_n4_in)) + IF ( present( catdest_rimesplinter_n2_in ) ) catdest_rimesplinter_n2 = min(2,max(1,catdest_rimesplinter_n2_in)) + IF ( present( catdest_rimesplinter_n3_in ) ) catdest_rimesplinter_n3 = min(3,max(1,catdest_rimesplinter_n3_in)) + IF ( present( catdest_rimesplinter_n4_in ) ) catdest_rimesplinter_n4 = min(4,max(1,catdest_rimesplinter_n4_in)) + IF ( present( catdest_depnuc_n2_in ) ) catdest_depnuc_n2 = min(2,max(1,catdest_depnuc_n2_in)) + IF ( present( catdest_depnuc_n3_in ) ) catdest_depnuc_n3 = min(3,max(1,catdest_depnuc_n3_in)) + IF ( present( catdest_depnuc_n4_in ) ) catdest_depnuc_n4 = min(4,max(1,catdest_depnuc_n4_in)) + IF ( present( catdest_homocloud_n2_in ) ) catdest_homocloud_n2 = min(2,max(1,catdest_homocloud_n2_in)) + IF ( present( catdest_homocloud_n3_in ) ) catdest_homocloud_n3 = min(3,max(1,catdest_homocloud_n3_in)) + IF ( present( catdest_homocloud_n4_in ) ) catdest_homocloud_n4 = min(4,max(1,catdest_homocloud_n4_in)) + IF ( present( catdest_homorain_n2_in ) ) catdest_homorain_n2 = min(2,max(1,catdest_homorain_n2_in)) + IF ( present( catdest_homorain_n3_in ) ) catdest_homorain_n3 = min(3,max(1,catdest_homorain_n3_in)) + IF ( present( catdest_homorain_n4_in ) ) catdest_homorain_n4 = min(4,max(1,catdest_homorain_n4_in)) + IF ( present( catdest_contact_n5_in ) ) catdest_contact_n5 = min(5,max(1,catdest_contact_n5_in)) + IF ( present( catdest_contact_n6_in ) ) catdest_contact_n6 = min(6,max(1,catdest_contact_n6_in)) + IF ( present( catdest_rainimm_n5_in ) ) catdest_rainimm_n5 = min(5,max(1,catdest_rainimm_n5_in)) + IF ( present( catdest_rainimm_n6_in ) ) catdest_rainimm_n6 = min(6,max(1,catdest_rainimm_n6_in)) + IF ( present( catdest_rimesplinter_n5_in ) ) catdest_rimesplinter_n5 = min(5,max(1,catdest_rimesplinter_n5_in)) + IF ( present( catdest_rimesplinter_n6_in ) ) catdest_rimesplinter_n6 = min(6,max(1,catdest_rimesplinter_n6_in)) + IF ( present( catdest_depnuc_n5_in ) ) catdest_depnuc_n5 = min(5,max(1,catdest_depnuc_n5_in)) + IF ( present( catdest_depnuc_n6_in ) ) catdest_depnuc_n6 = min(6,max(1,catdest_depnuc_n6_in)) + IF ( present( catdest_homocloud_n5_in ) ) catdest_homocloud_n5 = min(5,max(1,catdest_homocloud_n5_in)) + IF ( present( catdest_homocloud_n6_in ) ) catdest_homocloud_n6 = min(6,max(1,catdest_homocloud_n6_in)) + IF ( present( catdest_homorain_n5_in ) ) catdest_homorain_n5 = min(5,max(1,catdest_homorain_n5_in)) + IF ( present( catdest_homorain_n6_in ) ) catdest_homorain_n6 = min(6,max(1,catdest_homorain_n6_in)) + log_maxnsmall = .true. !flag for resetting n up to nsmall + +! Primary ice nucleation +! 1 = Cooper +! 2 = Meyers-Ferrier + iparamice = 1 +! End ERM ! droplet concentration (m-3) nccnst = 200.e+6 @@ -218,7 +523,7 @@ subroutine p3_init(lookup_file_dir,nCat,trplMomI,liqfrac,model,stat,abort_on_err cp = 1005. inv_cp = 1./cp g = 9.816 - rd = 287.15 + rd = 287.05 ! Corrected from 287.15 - ERM detected, I think rv = 461.51 ep_2 = 0.622 rhosur = 100000./(rd*273.15) @@ -242,8 +547,9 @@ subroutine p3_init(lookup_file_dir,nCat,trplMomI,liqfrac,model,stat,abort_on_err inv_rho_rimeMax = 1./rho_rimeMax ! minium allowable prognostic variables - qsmall = 1.e-14 - nsmall = 1.e-16 + qsmall = 1.e-12 ! 1.e-14 Mod by ERM + nsmall = 1.e-8 ! 1.e-16 Mod by ERM + ntiny = nsmall ! *1.e-8 ! 1.e-16 Added by ERM bsmall = qsmall*inv_rho_rimeMax zsmall = 1.e-35 @@ -297,6 +603,7 @@ subroutine p3_init(lookup_file_dir,nCat,trplMomI,liqfrac,model,stat,abort_on_err inv_rm1 = 2.e+7 ! inverse aerosol mean size (m-1) sig1 = 2.0 ! aerosol standard deviation nanew1 = 300.e6 ! aerosol number mixing ratio (kg-1) + IF ( present( nanew1_in ) ) nanew1 = nanew1_in/rho00 ! ERM f11 = 0.5*exp(2.5*(log(sig1))**2) f21 = 1. + 0.25*log(sig1) @@ -762,7 +1069,7 @@ END subroutine p3_init #ifndef ECCCGEM SUBROUTINE mp_p3_wrapper_wrf( th,qv,qc,qr,qnr,th_old,qv_old,pii,p,dz,w,dt,itimestep, & - rainnc,rainncv,sr,snownc,snowncv, & + rainnc,rainncv,sr,snownc,snowncv, & ids, ide, jds, jde, kds, kde , & ims, ime, jms, jme, kms, kme , & its, ite, jts, jte, kts, kte , & @@ -771,8 +1078,11 @@ SUBROUTINE mp_p3_wrapper_wrf( th,qv,qc,qr,qnr,th_old,qv_old,pii,p,dz,w,dt,itimes qit_2, qni_2, qir_2, qib_2, diag_vmi_2, diag_dmi_2, diag_rhoi_2, qzi_2, qli_2, & qit_3, qni_3, qir_3, qib_3, diag_vmi_3, diag_dmi_3, diag_rhoi_3, qzi_3, qli_3, & qit_4, qni_4, qir_4, qib_4, diag_vmi_4, diag_dmi_4, diag_rhoi_4, qzi_4, qli_4, & - nc, diag2d_01, diag2d_02, diag3d_01, diag3d_02, diag3d_03, & - diag_dhmax_1, diag_dhmax_2, diag_dhmax_3, diag_dhmax_4 ) + qit_5, qni_5, qir_5, qib_5, diag_vmi_5, diag_dmi_5, diag_rhoi_5, qzi_5, qli_5, & ! DTD added categories 5 and 6 + qit_6, qni_6, qir_6, qib_6, diag_vmi_6, diag_dmi_6, diag_rhoi_6, qzi_6, qli_6, & + nc, cn, diag2d_01, diag2d_02, diag3d_01, diag3d_02, diag3d_03, & ! ERM added cn + diag_dhmax_1, diag_dhmax_2, diag_dhmax_3, diag_dhmax_4, & + diag_dhmax_5, diag_dhmax_6, diagflag, j_index) ! DTD added j index for debugging, ERM added diagflag !------------------------------------------------------------------------------------------! ! This is the main WRF interface with the P3 microphysics scheme. ! @@ -834,7 +1144,7 @@ SUBROUTINE mp_p3_wrapper_wrf( th,qv,qc,qr,qnr,th_old,qv_old,pii,p,dz,w,dt,itimes real, dimension(ims:ime, kms:kme, jms:jme), intent(inout):: th,qv,qc,qr,qnr,th_old,qv_old, & diag_zdbz,diag_effc, & qit_1,qni_1,qir_1,qib_1 - real, dimension(ims:ime, kms:kme, jms:jme), intent(inout), optional :: nc + real, dimension(ims:ime, kms:kme, jms:jme), intent(inout), optional :: nc, cn ! ERM added cn real, dimension(ims:ime, kms:kme, jms:jme), intent(inout), optional :: qzi_1 real, dimension(ims:ime, kms:kme, jms:jme), intent(inout), optional :: qli_1 @@ -860,27 +1170,46 @@ SUBROUTINE mp_p3_wrapper_wrf( th,qv,qc,qr,qnr,th_old,qv_old,pii,p,dz,w,dt,itimes real, dimension(ims:ime, kms:kme, jms:jme), intent(inout), optional :: qzi_4 real, dimension(ims:ime, kms:kme, jms:jme), intent(inout), optional :: qli_4 + real, dimension(ims:ime, kms:kme, jms:jme), intent(inout), optional :: qit_5 + real, dimension(ims:ime, kms:kme, jms:jme), intent(inout), optional :: qni_5 + real, dimension(ims:ime, kms:kme, jms:jme), intent(inout), optional :: qir_5 + real, dimension(ims:ime, kms:kme, jms:jme), intent(inout), optional :: qib_5 + real, dimension(ims:ime, kms:kme, jms:jme), intent(inout), optional :: qzi_5 + real, dimension(ims:ime, kms:kme, jms:jme), intent(inout), optional :: qli_5 + + real, dimension(ims:ime, kms:kme, jms:jme), intent(inout), optional :: qit_6 + real, dimension(ims:ime, kms:kme, jms:jme), intent(inout), optional :: qni_6 + real, dimension(ims:ime, kms:kme, jms:jme), intent(inout), optional :: qir_6 + real, dimension(ims:ime, kms:kme, jms:jme), intent(inout), optional :: qib_6 + real, dimension(ims:ime, kms:kme, jms:jme), intent(inout), optional :: qzi_6 + real, dimension(ims:ime, kms:kme, jms:jme), intent(inout), optional :: qli_6 + real, dimension(ims:ime, kms:kme, jms:jme), intent(out) :: diag_effi_ave real, dimension(ims:ime, kms:kme, jms:jme), intent(out) :: diag_vmi_1, diag_dmi_1, diag_rhoi_1 real, dimension(ims:ime, kms:kme, jms:jme), intent(out), optional :: diag_vmi_2, diag_dmi_2, diag_rhoi_2 real, dimension(ims:ime, kms:kme, jms:jme), intent(out), optional :: diag_vmi_3, diag_dmi_3, diag_rhoi_3 real, dimension(ims:ime, kms:kme, jms:jme), intent(out), optional :: diag_vmi_4, diag_dmi_4, diag_rhoi_4 + real, dimension(ims:ime, kms:kme, jms:jme), intent(out), optional :: diag_vmi_5, diag_dmi_5, diag_rhoi_5 + real, dimension(ims:ime, kms:kme, jms:jme), intent(out), optional :: diag_vmi_6, diag_dmi_6, diag_rhoi_6 real, dimension(ims:ime, jms:jme), intent(out), optional :: diag2d_01, diag2d_02 real, dimension(ims:ime, kms:kme, jms:jme), intent(out), optional :: diag3d_01, diag3d_02, diag3d_03 real, dimension(ims:ime, kms:kme, jms:jme), intent(out), optional :: diag_dhmax_1, diag_dhmax_2, diag_dhmax_3, diag_dhmax_4 + real, dimension(ims:ime, kms:kme, jms:jme), intent(out), optional :: diag_dhmax_5, diag_dhmax_6 real, dimension(ims:ime, kms:kme, jms:jme), intent(in) :: pii,p,dz,w real, dimension(ims:ime, jms:jme), intent(inout) :: rainnc,rainncv,sr,snownc,snowncv real, intent(in) :: dt integer, intent(in) :: itimestep integer, intent(in) :: n_iceCat + integer, intent(in), optional :: j_index ! DTD added + logical, intent(in), optional :: diagflag ! ERM added !--- local variables/parameters: character(len=16), parameter :: model = 'WRF' - real, dimension(ims:ime, kms:kme) ::nc_loc,ssat + real, dimension(ims:ime, kms:kme) ::nc_loc,cn_loc,ssat ! ERM added cn_loc real, dimension(ims:ime, kms:kme, n_iceCat) :: qitot,qirim,nitot,birim,diag_dmi,diag_vmi, & diag_rhoi,diag_effi @@ -893,6 +1222,11 @@ SUBROUTINE mp_p3_wrapper_wrf( th,qv,qc,qr,qnr,th_old,qv_old,pii,p,dz,w,dt,itimes real, dimension(its:ite) :: pcprt_liq,pcprt_sol real :: dum1,dum2,dum3,dum4 integer :: i,k,j + integer :: iice_ave ! category index for the effective-radius weighting + integer :: j_model ! true model j-slab index for the checksum/point + ! dumps: CM1 calls this wrapper once per j with + ! 2D slabs (jts=jte=1) and the real j in j_index, + ! so the local loop j is always 1 there integer, parameter :: n_diag2d = 2 integer, parameter :: n_diag3d = 3 @@ -904,6 +1238,7 @@ SUBROUTINE mp_p3_wrapper_wrf( th,qv,qc,qr,qnr,th_old,qv_old,pii,p,dz,w,dt,itimes logical :: log_liqFrac logical, parameter :: log_scpf = .false. ! switch for activation of SCPF scheme logical, parameter :: log_debug = .false. ! switch for internal real-time debug checking + logical :: log_diag ! ERM added real, dimension(ims:ime, kms:kme) :: cldfrac ! cloud fraction computed by SCPF real :: scpf_pfrac ! precipitation fraction factor (SCPF) @@ -920,14 +1255,32 @@ SUBROUTINE mp_p3_wrapper_wrf( th,qv,qc,qr,qnr,th_old,qv_old,pii,p,dz,w,dt,itimes scpf_pfrac = 0. ! SCPF currently not used in WRF/CM1 scpf_resfact = 0. ! SCPF currently not used in WRF/CM1 + ! Begin ERM + IF ( present( diagflag ) ) THEN + log_diag = diagflag + ELSE + log_diag = .false. + ENDIF + ! End ERM j_loop: do j = jts,jte ! j loop (north-south) + j_model = j + if (present(j_index)) j_model = j_index + if (log_predictNc) then nc_loc(:,:) = nc(:,:,j) else nc_loc = 0. endif + ! Begin ERM + if ( present( cn ) .and. ccn_on > 0 ) then + cn_loc(:,:) = cn(:,:,j) ! # of activated CCN + else + cn_loc = nc_loc(:,:) + endif + ! End ERM + ssat = 0. ! note: code for prediction of ssat not currently avaiable ! contruct full ice arrays (with dimension n_iceCat) from individual ice category arrays: @@ -961,6 +1314,24 @@ SUBROUTINE mp_p3_wrapper_wrf( th,qv,qc,qr,qnr,th_old,qv_old,pii,p,dz,w,dt,itimes birim(:,:,4) = qib_4(:,:,j) if (log_3momIce) zitot(:,:,4) = qzi_4(:,:,j) if (log_liqFrac) qiliq(:,:,4) = qli_4(:,:,j) + + if (n_iceCat.ge.5) then + qitot(:,:,5) = qit_5(:,:,j) + qirim(:,:,5) = qir_5(:,:,j) + nitot(:,:,5) = qni_5(:,:,j) + birim(:,:,5) = qib_5(:,:,j) + if (log_3momIce) zitot(:,:,5) = qzi_5(:,:,j) + if (log_liqFrac) qiliq(:,:,5) = qli_5(:,:,j) + + if (n_iceCat.ge.6) then + qitot(:,:,6) = qit_6(:,:,j) + qirim(:,:,6) = qir_6(:,:,j) + nitot(:,:,6) = qni_6(:,:,j) + birim(:,:,6) = qib_6(:,:,j) + if (log_3momIce) zitot(:,:,6) = qzi_6(:,:,j) + if (log_liqFrac) qiliq(:,:,6) = qli_6(:,:,j) + endif ! >=6 + endif ! >=5 endif ! >=4 endif ! >=3 endif ! >=2 @@ -968,6 +1339,13 @@ SUBROUTINE mp_p3_wrapper_wrf( th,qv,qc,qr,qnr,th_old,qv_old,pii,p,dz,w,dt,itimes if (.not. log_3momIce) zitot = 0. !not used, but avoids passing uninialized values if (.not. log_liqFrac) qiliq = 0. !not used, but avoids passing uninialized values + !--- Phase-1 checksum instrumentation, PRE line (see NOTES.md): state + ! entering p3_main, so a diff of two runs can attribute the first + ! flipped bit to the host (PRE diverges first) or to p3_main + ! (PRE matches, POST diverges). + if (log_chksum) call chksum_write('PRE ') + if (log_chkpts) call chkpts_write('PRE ') + call p3_main( qc(its:ite,kts:kte,j),nc_loc(its:ite,kts:kte),qr(its:ite,kts:kte,j), & qnr(its:ite,kts:kte,j),th_old(its:ite,kts:kte,j),th(its:ite,kts:kte,j), & qv_old(its:ite,kts:kte,j),qv(its:ite,kts:kte,j),dt, & @@ -976,13 +1354,13 @@ SUBROUTINE mp_p3_wrapper_wrf( th,qv,qc,qr,qnr,th_old,qv_old,pii,p,dz,w,dt,itimes birim(its:ite,kts:kte,1:n_iceCat),zitot(its:ite,kts:kte,1:n_iceCat), & ssat(its:ite,kts:kte),w(its:ite,kts:kte,j),p(its:ite,kts:kte,j), & dz(its:ite,kts:kte,j),itimestep,pcprt_liq,pcprt_sol,its,ite,kts,kte, & - n_iceCat,diag_zdbz(its:ite,kts:kte,j),diag_effc(its:ite,kts:kte,j), & + n_iceCat,diag_zdbz(its:ite,kts:kte,j),diag_effc(its:ite,kts:kte,j),cn_loc, & ! ERM added cn_loc diag_effi(its:ite,kts:kte,1:n_iceCat),diag_vmi(its:ite,kts:kte,1:n_iceCat), & diag_dmi(its:ite,kts:kte,1:n_iceCat),diag_rhoi(its:ite,kts:kte,1:n_iceCat), & n_diag2d,diag2d(its:ite,1:n_diag2d),n_diag3d,diag3d(its:ite,kts:kte,1:n_diag3d), & log_predictNc,trim(model),clbfact_dep,clbfact_sub,log_debug,log_scpf, & scpf_pfrac,scpf_resfact,cldfrac,log_3momIce,log_liqFrac, & - diag_dhmax = diag_dhmax ) + diag_dhmax = diag_dhmax, j_index = j_index, log_diag = log_diag) ! DTD added j-index for debugging, ERM added log_diag !surface precipitation output: dum1 = 1000.*dt @@ -993,6 +1371,17 @@ SUBROUTINE mp_p3_wrapper_wrf( th,qv,qc,qr,qnr,th_old,qv_old,pii,p,dz,w,dt,itimes sr(its:ite,j) = pcprt_sol(:)/(pcprt_liq(:)+pcprt_sol(:)+1.e-12) ! solid-to-total ratio if (log_predictNc) nc(:,:,j) = nc_loc(:,:) + ! ERM begin + if ( present( cn ) .and. ccn_on > 0 ) then + cn(:,:,j) = cn_loc(:,:) + endif + ! ERM end + + !--- Phase-1 checksum instrumentation, POST line (see NOTES.md): state + ! after p3_main. Compare ice categories under the swap mapping when + ! diffing a category-swap experiment. + if (log_chksum) call chksum_write('POST') + if (log_chkpts) call chkpts_write('POST') !set background effective radii (i.e. with no explicit condensate) to prescribed values: ! where (qc(:,:,j) < 1.e-14) diag_effc(:,:,j) = 10.e-6 @@ -1045,6 +1434,32 @@ SUBROUTINE mp_p3_wrapper_wrf( th,qv,qc,qr,qnr,th_old,qv_old,pii,p,dz,w,dt,itimes if (log_3momIce) qzi_4(:,:,j) = zitot(:,:,4) if (log_liqFrac) qli_4(:,:,j) = qiliq(:,:,4) if (present(diag_dhmax_4)) diag_dhmax_4(:,:,j) = diag_dhmax(:,:,4) + + if (n_iceCat.ge.5) then + qit_5(:,:,j) = qitot(:,:,5) + qir_5(:,:,j) = qirim(:,:,5) + qni_5(:,:,j) = nitot(:,:,5) + qib_5(:,:,j) = birim(:,:,5) + diag_vmi_5(:,:,j) = diag_vmi(:,:,5) + diag_dmi_5(:,:,j) = diag_dmi(:,:,5) + diag_rhoi_5(:,:,j) = diag_rhoi(:,:,5) + if (log_3momIce) qzi_5(:,:,j) = zitot(:,:,5) + if (log_liqFrac) qli_5(:,:,j) = qiliq(:,:,5) + if (present(diag_dhmax_5)) diag_dhmax_5(:,:,j) = diag_dhmax(:,:,5) + + if (n_iceCat.ge.6) then + qit_6(:,:,j) = qitot(:,:,6) + qir_6(:,:,j) = qirim(:,:,6) + qni_6(:,:,j) = nitot(:,:,6) + qib_6(:,:,j) = birim(:,:,6) + diag_vmi_6(:,:,j) = diag_vmi(:,:,6) + diag_dmi_6(:,:,j) = diag_dmi(:,:,6) + diag_rhoi_6(:,:,j) = diag_rhoi(:,:,6) + if (log_3momIce) qzi_6(:,:,j) = zitot(:,:,6) + if (log_liqFrac) qli_6(:,:,j) = qiliq(:,:,6) + if (present(diag_dhmax_6)) diag_dhmax_6(:,:,j) = diag_dhmax(:,:,6) + endif ! >=6 + endif ! >=5 endif ! >=4 endif ! >=3 endif ! >=2 @@ -1054,34 +1469,28 @@ SUBROUTINE mp_p3_wrapper_wrf( th,qv,qc,qr,qnr,th_old,qv_old,pii,p,dz,w,dt,itimes do i=its,ite do k=kts,kte - dum1 = 0. - dum2 = 0. - dum3 = 0. - dum4 = 0. + !DTD: generalized from the previous hard-coded nCat<=4 expressions to a + ! sequential loop over categories, so that 5- and 6-category + ! configurations are covered. The accumulation order (left to + ! right over the category index) is the same one the old explicit + ! sums used, so results for nCat<=4 are unchanged bit-for-bit. + dum1 = 0. ! sum over categories of qitot/effi (the weighting denominator) + dum2 = 0. ! sum over categories of qitot (the numerator) diag_effi_ave(i,k,j) = 25.e-6 ! set to default 25 microns if (n_iceCat.ge.2) then - if (qitot(i,k,1).ge.qsmall) dum1 = qitot(i,k,1)/diag_effi(i,k,1) - if (qitot(i,k,2).ge.qsmall) dum2 = qitot(i,k,2)/diag_effi(i,k,2) - if (n_iceCat.ge.3) then - if (qitot(i,k,3).ge.qsmall) dum3 = qitot(i,k,3)/diag_effi(i,k,3) - if (n_iceCat.ge.4) then - if (qitot(i,k,4).ge.qsmall) dum4 = qitot(i,k,4)/diag_effi(i,k,4) - endif - endif + do iice_ave = 1,n_iceCat + dum2 = dum2 + qitot(i,k,iice_ave) + if (qitot(i,k,iice_ave).ge.qsmall) dum1 = dum1 + qitot(i,k,iice_ave)/diag_effi(i,k,iice_ave) + enddo + !guard against 0/0 at ice-free points (division previously ran + !unconditionally, silently filling diag_effi_ave with NaNs there; + !the 25-micron default set above is retained instead) + if (dum1.gt.0.) diag_effi_ave(i,k,j) = dum2/dum1 + else + diag_effi_ave(i,k,j) = diag_effi(i,k,1) endif - select case (n_iceCat) - case (1) - diag_effi_ave(i,k,j) = diag_effi(i,k,1) - case (2) - diag_effi_ave(i,k,j) = (qitot(i,k,1)+qitot(i,k,2))/(dum1+dum2) - case (3) - diag_effi_ave(i,k,j) = (qitot(i,k,1)+qitot(i,k,2)+qitot(i,k,3))/(dum1+dum2+dum3) - case (4) - diag_effi_ave(i,k,j) = (qitot(i,k,1)+qitot(i,k,2)+qitot(i,k,3)+qitot(i,k,4))/(dum1+dum2+dum3+dum4) - end select - enddo !k-loop enddo !i-loop @@ -1100,10 +1509,147 @@ SUBROUTINE mp_p3_wrapper_wrf( th,qv,qc,qr,qnr,th_old,qv_old,pii,p,dz,w,dt,itimes stop endif + contains + + subroutine chksum_write(tag) + + !--- Phase-1 checksum instrumentation (see NOTES.md): writes one tagged + ! line of bitwise field checksums for the current (itimestep, j-slab); + ! tag = 'PRE ' (state entering p3_main) or 'POST' (state after). + ! Fields and loop index j are accessed by host association. + + character(len=4), intent(in) :: tag + + character(len=32) :: chksum_fname + integer :: iice_chk + + if (.not. chksum_opened) then + ! note: newunit= assigns a NEGATIVE unit number, so the opened state + ! must be tracked with a separate flag, not a sign test on the unit + write(chksum_fname,'(a,i4.4,a)') 'p3_chksum_', chksum_myid, '.out' + open(newunit=chksum_unit, file=trim(chksum_fname), status='replace', & + form='formatted', action='write') + chksum_opened = .true. + write(chksum_unit,'(a)') '# itimestep j tag qv th qc nc qr qnr w p then per ice '// & + 'category: qitot qirim nitot birim [zitot] [qiliq] (hex Z16.16)' + endif + write(chksum_unit,'(i8,1x,i5,1x,a4)',advance='no') itimestep, j_model, tag + write(chksum_unit,'(8(1x,z16.16))',advance='no') & + bitsum2(qv(its:ite,kts:kte,j)), & + bitsum2(th(its:ite,kts:kte,j)), & + bitsum2(qc(its:ite,kts:kte,j)), & + bitsum2(nc_loc(its:ite,kts:kte)), & + bitsum2(qr(its:ite,kts:kte,j)), & + bitsum2(qnr(its:ite,kts:kte,j)), & + bitsum2(w(its:ite,kts:kte,j)), & + bitsum2(p(its:ite,kts:kte,j)) + do iice_chk = 1,n_iceCat + write(chksum_unit,'(4(1x,z16.16))',advance='no') & + bitsum2(qitot(its:ite,kts:kte,iice_chk)), & + bitsum2(qirim(its:ite,kts:kte,iice_chk)), & + bitsum2(nitot(its:ite,kts:kte,iice_chk)), & + bitsum2(birim(its:ite,kts:kte,iice_chk)) + if (log_3momIce) write(chksum_unit,'(1x,z16.16)',advance='no') & + bitsum2(zitot(its:ite,kts:kte,iice_chk)) + if (log_liqFrac) write(chksum_unit,'(1x,z16.16)',advance='no') & + bitsum2(qiliq(its:ite,kts:kte,iice_chk)) + enddo + write(chksum_unit,'(a)') '' + if (j == jte .and. tag == 'POST') flush(chksum_unit) + + end subroutine chksum_write + + subroutine chkpts_write(tag) + + !--- Per-point dump (see NOTES.md): raw 32-bit bit patterns of every + ! field at every tile point of the current (itimestep, j-slab), with + ! local and full-grid indices, for exact divergent-point isolation. + ! tag = 'PRE ' (state entering p3_main) or 'POST' (state after). + ! Fields and loop index j are accessed by host association. Large + ! output: enable (p3_chkpts) only for short bracketing runs. + + character(len=4), intent(in) :: tag + + character(len=32) :: chkpts_fname + integer :: ii,kk,iice_chk + integer(kind=4) :: i4dum + + i4dum = 0 + + if (.not. chkpts_opened) then + ! newunit= assigns a NEGATIVE unit number; track opened state with a + ! separate flag, not a sign test on the unit + write(chkpts_fname,'(a,i4.4,a)') 'p3_chkpts_', chksum_myid, '.out' + open(newunit=chkpts_unit, file=trim(chkpts_fname), status='replace', & + form='formatted', action='write') + chkpts_opened = .true. + write(chkpts_unit,'(a)') '# itimestep tag i j k (local) i j k (full grid) '// & + 'qv th qc nc qr qnr w p then per ice category: qitot qirim nitot birim '// & + '[zitot] [qiliq] (hex Z8.8 raw bit patterns)' + endif + + do kk = kts,kte + do ii = its,ite + write(chkpts_unit,'(i8,1x,a4,3(1x,i5),3(1x,i6))',advance='no') & + itimestep, tag, ii, j_model, kk, ii+chksum_i0, j_model+chksum_j0, kk + write(chkpts_unit,'(8(1x,z8.8))',advance='no') & + transfer(qv(ii,kk,j),i4dum), & + transfer(th(ii,kk,j),i4dum), & + transfer(qc(ii,kk,j),i4dum), & + transfer(nc_loc(ii,kk),i4dum), & + transfer(qr(ii,kk,j),i4dum), & + transfer(qnr(ii,kk,j),i4dum), & + transfer(w(ii,kk,j),i4dum), & + transfer(p(ii,kk,j),i4dum) + do iice_chk = 1,n_iceCat + write(chkpts_unit,'(4(1x,z8.8))',advance='no') & + transfer(qitot(ii,kk,iice_chk),i4dum), & + transfer(qirim(ii,kk,iice_chk),i4dum), & + transfer(nitot(ii,kk,iice_chk),i4dum), & + transfer(birim(ii,kk,iice_chk),i4dum) + if (log_3momIce) write(chkpts_unit,'(1x,z8.8)',advance='no') & + transfer(zitot(ii,kk,iice_chk),i4dum) + if (log_liqFrac) write(chkpts_unit,'(1x,z8.8)',advance='no') & + transfer(qiliq(ii,kk,iice_chk),i4dum) + enddo + write(chkpts_unit,'(a)') '' + enddo + enddo + if (j == jte .and. tag == 'POST') flush(chkpts_unit) + + end subroutine chkpts_write + END SUBROUTINE mp_p3_wrapper_wrf #endif +!==================================================================================================! + +! Phase-1 checksum instrumentation (see NOTES.md): bitwise, position-weighted +! XOR hash of a field, used to locate the first divergent timestep between two +! runs. The bit patterns are reinterpreted as integers (transfer, no +! rounding), so equal checksums <=> bit-identical field contents. + + function bitsum(arr) result(cs) + implicit none + real, intent(in) :: arr(:) + integer(kind=8) :: cs + integer(kind=4) :: bits(size(arr)) + integer :: n + bits = transfer(arr, bits) ! reinterpret bits; no rounding + cs = 0 + do n = 1, size(arr) + cs = ieor(cs, int(bits(n),8) * int(n,8)) + enddo + end function bitsum + + function bitsum2(arr) result(cs) + implicit none + real, intent(in) :: arr(:,:) + integer(kind=8) :: cs + cs = bitsum(reshape(arr, (/size(arr)/))) + end function bitsum2 + !==================================================================================================! #ifdef ECCCGEM @@ -1481,7 +2027,7 @@ function mp_p3_wrapper_gem(ttend,qtend,qctend,qrtend,qitend, if (.not. log_trplMomI) zitot = 0. !not used, but avoids passing uninialized values if (.not. log_liqFrac) qiliq = 0. !not used, but avoids passing uninialized values - call p3_main(qc,nc,qr,nr,theta_m,theta,qvapm,qvap,dt_mp,qitot,qirim,qiliq,nitot,birim, & + call p3_main(qc,nc,qr,nr,theta_m,theta,qvapm,qvap,dt_mp,qitot,qirim,qiliq,nitot,birim, & zitot,ssat,ww,pres,DZ,kount,prt_liq,prt_sol,i_strt,ni,k_strt,nk,n_iceCat, & diag_Zet,diag_effc,diag_effi,diag_vmi,diag_di,diag_rhoi,n_diag_2d,diag_2d, & n_diag_3d,diag_3d,log_predictNc,trim(model),clbfact_dep,clbfact_sub, & @@ -1914,12 +2460,12 @@ END SUBROUTINE compute_SCPF SUBROUTINE p3_main(qc,nc,qr,nr,th_old,th,qv_old,qv,dt,qitot,qirim,qiliq,nitot,birim, & zitot,ssat,uzpl,pres,dzq,it,prt_liq,prt_sol,its,ite,kts,kte,nCat, & - diag_ze,diag_effc,diag_effi,diag_vmi,diag_di,diag_rhoi,n_diag_2d, & + diag_ze,diag_effc,cn,diag_effi,diag_vmi,diag_di,diag_rhoi,n_diag_2d, & ! ERM added cn diag_2d,n_diag_3d,diag_3d,log_predictNc,model,clbfact_dep, & clbfact_sub,debug_on,scpf_on,scpf_pfrac,scpf_resfact,SCF_out, & log_3momentIce,log_LiquidFrac,prt_drzl,prt_rain,prt_crys,prt_snow, & prt_grpl,prt_pell,prt_hail,prt_sndp,prt_wsnow,qi_type, & - diag_vis,diag_vis1,diag_vis2,diag_vis3,diag_dhmax) + diag_vis,diag_vis1,diag_vis2,diag_vis3,diag_dhmax,j_index,log_diag) ! DTD added j-index for debugging, ERM added log_diag !----------------------------------------------------------------------------------------! ! ! @@ -1948,6 +2494,7 @@ SUBROUTINE p3_main(qc,nc,qr,nr,th_old,th,qv_old,qv,dt,qitot,qirim,qiliq,nitot,bi real, intent(inout), dimension(its:ite,kts:kte) :: qc ! cloud, mass mixing ratio kg kg-1 ! note: Nc may be specified or predicted (set by log_predictNc) real, intent(inout), dimension(its:ite,kts:kte) :: nc ! cloud, number mixing ratio # kg-1 + real, intent(inout), dimension(its:ite,kts:kte) :: cn ! act. CCN, number mixing ratio # kg-1 (ERM) real, intent(inout), dimension(its:ite,kts:kte) :: qr ! rain, mass mixing ratio kg kg-1 real, intent(inout), dimension(its:ite,kts:kte) :: nr ! rain, number mixing ratio # kg-1 real, intent(inout), dimension(its:ite,kts:kte,nCat) :: qitot ! ice, total mass mixing ratio kg kg-1 @@ -2011,6 +2558,8 @@ SUBROUTINE p3_main(qc,nc,qr,nr,th_old,th,qv_old,qv,dt,qitot,qirim,qiliq,nitot,bi real, intent(in) :: scpf_pfrac ! precipitation fraction factor (SCPF) real, intent(in) :: scpf_resfact ! model resolution factor (SCPF) real, intent(out), dimension(its:ite,kts:kte) :: SCF_out ! cloud fraction from SCPF + integer, intent(in), optional :: j_index ! DTD added j-index for debugging + logical, intent(in) :: log_diag ! ERM added !----- Local variables and parameters: -------------------------------------------------! @@ -2018,6 +2567,14 @@ SUBROUTINE p3_main(qc,nc,qr,nr,th_old,th,qv_old,qv,dt,qitot,qirim,qiliq,nitot,bi real, dimension(its:ite,kts:kte) :: t ! temperature at the beginning of the microhpysics step [K] real, dimension(its:ite,kts:kte) :: t_old ! temperature at the beginning of the model time step [K] real, dimension(its:ite,nCat) :: prt_soli ! precipitation rate, solid iice-dep m s-1 + ! Begin ERM + real, dimension(its:ite,kts:kte) :: q_old,qr_old,qc_old,qv_old1 ! starting total mass + real, dimension(its:ite,kts:kte,nCat) :: qitot_old ! ice, total mass mixing ratio kg kg-1 + real, dimension(its:ite,kts:kte) :: q_new ! starting total mass + real :: qtolmax,qtolmin + real, parameter :: qtol = 1.e-9 + integer :: iqtolcnt + ! End ERM logical, parameter :: log_liqsatadj = .false. ! temporary; to be put as GEM namelist @@ -2080,6 +2637,7 @@ SUBROUTINE p3_main(qc,nc,qr,nr,th_old,th,qv_old,qv,dt,qitot,qirim,qiliq,nitot,bi real, dimension(nCat) :: nrheti ! immersion freezing rain real, dimension(nCat) :: nrshdr ! source for rain number from collision of rain/ice above freezing and shedding real, dimension(nCat) :: qcshd ! source for rain mass due to cloud water/ice collision above freezing and shedding or wet growth and shedding + real, dimension(nCat) :: qcmul ! change in q, ice multiplication from rime-splintering of cloud (not included in the paper) (added by DTD) real, dimension(nCat) :: qrmul ! change in q, ice multiplication from rime-splitnering of rain (not included in the paper) real, dimension(nCat) :: nimul ! change in Ni, ice multiplication from rime-splintering (not included in the paper) real, dimension(nCat) :: ncshdc ! source for rain number due to cloud water/ice collision above freezing and shedding (combined with NRSHD in the paper) @@ -2121,7 +2679,7 @@ SUBROUTINE p3_main(qc,nc,qr,nr,th_old,th,qv_old,qv,dt,qitot,qirim,qiliq,nitot,bi real, dimension(its:ite,kts:kte) :: inv_dzq,inv_rho,ze_ice,ze_rain,prec,acn,rho, & rhofacr,rhofaci,xxls,xxlv,xlf,qvs,qvi,sup,supi,vtrmi1,tmparr1,mflux_r, & - mflux_i,invexn + mflux_i,invexn, t7 ! ERM added t7 real, dimension(kts:kte) :: V_qr,V_qit,V_nit,V_nr,V_qc,V_nc,V_zit,flux_qit,flux_qx, & flux_nx,flux_nit,flux_qir,flux_bir,flux_zit,flux_qil @@ -2138,12 +2696,39 @@ SUBROUTINE p3_main(qc,nc,qr,nr,th_old,th,qv_old,qv,dt,qitot,qirim,qiliq,nitot,bi timeScaleFactor,dt_left,qv_tmp,t_tmp,dum1z,dum7c,dum7,fluxdiv_qil,epsiw_tot double precision :: tmpdbl1,tmpdbl2,tmpdbl3 - + double precision :: clipsum_qv,clipsum_th ! category-order-invariant entry clipping (permanent) + double precision :: epsi_totdp,epsiw_totdp ! category-order-invariant epsi accumulation (permanent) + double precision :: nitotsum_dp ! category-order-invariant sum(nitot) in dep. nucleation (permanent) + ! category-order-invariant (permutation-invariant) fused tendency application: + ! per-category increments to the SHARED prognostic fields are accumulated over + ! ice categories in double precision inside the category loop, then applied to + ! each shared field once (rounded once) after the loop, so the result is + ! independent of which slot holds which species (NEXT PROJECT / audit sec. 4(c)). + double precision :: dqc_dp,dnc_dp,dqr_dp,dnr_dp,dqv_dp,dth_dp ! iice_loop3 shared-field tendencies + double precision :: clipsum_qr,clipsum_nr ! post-loop3 liquid-fraction shed clip (qr/nr/th deferred) + double precision :: nimul_dp,qcmul_dp,qrmul_dp ! category-order-invariant Hallett-Mossop accumulation into iice_dest + ! deferred ice-ice interaction cross-category contributions to the per-category + ! ice fields, accumulated in double precision so the result is invariant to + ! category slot order (applied once, after iice_loop3, before the per-category + ! clipping/densification). All zero when log_iceice_interaction=.false., in + ! which case the application is an exact no-op (behavior identical to before). + double precision, dimension(nCat) :: qitot_col_dp,qirim_col_dp,birim_col_dp,qiliq_col_dp,nitot_col_dp + + ! ERM begin + integer, parameter :: dmrauto = 0 + integer :: dmropt = 0 ! extra option for crcnw + double precision t2s, xdp, xvc, xvr, rwrad + double precision xl2p,rb + real :: alphac, alphar, volb, xdiac, rh, nh, erw + real, parameter :: aa1 = 9.44e15, aa2 = 5.78e3 + ! ERM end integer :: dumi,i,k,ii,iice,iice_dest,dumj,dumii,dumjj,dumzz,tmpint1,ktop,kbot,kdir, & dumic,dumiic,dumjjc,catcoll,k_qxbot,k_qxtop,k_temp,dumll,dumllc logical :: log_nucleationPossible,log_hydrometeorsPresent,log_predictSsat, & - log_exitlevel,log_hmossopOn,log_qxpresent + log_exitlevel,log_hmossopOn,log_qxpresent,log_test ! ERM added log_test + ! DTD: decoded form of hm_opt (host namelist p3_hm_opt), set once below + logical :: hm_cloud,hm_rain ! quantities related to process rates/parameters, interpolated from lookup tables: @@ -2205,11 +2790,27 @@ SUBROUTINE p3_main(qc,nc,qr,nr,th_old,th,qv_old,qv,dt,qitot,qirim,qiliq,nitot,bi logical, parameter :: debug_ABORT = .true. !.true. will result in forced abort in s/r 'check_values' logical :: force_abort integer :: location_ind !return value of location index from sr/ 'check_values' + integer :: limlog_j !local j-slab index for the limiter-firing log (see log_limlog) + ! rain-number attribution for the targeted point dump (dbgpt_i>0 only): nr at + ! four checkpoints through the step, plus the warm-phase rates. Differences + ! between consecutive checkpoints attribute the change to ice interactions, + ! warm processes, and sedimentation+clipping respectively. + real, dimension(kts:kte) :: dbg_nr_entry, dbg_nr_posti, dbg_nr_postw, dbg_nr_posts + real, dimension(kts:kte) :: dbg_qr_entry, dbg_qr_posti, dbg_qr_postw, dbg_qr_posts + real, dimension(kts:kte) :: dbg_ncautr, dbg_nrslf, dbg_nrevp, dbg_dnr_ice + real, dimension(kts:kte) :: dbg_qcacc_r, dbg_qcacc_f, dbg_accbr, dbg_rwrad, dbg_xvr ! added for triple moment ice real :: mu_i !shape parameter for ice real :: mu_i_new !shape parameter for processes that specify mu_i real, dimension(nCat) :: dumm0,dumm3,mu_i_s + real, dimension(nCat) :: f1pr16_s ! per-category copy of f1pr16 (mass-weighted mean density) from + ! THIS category's lookup this step; -1 = lookup not accessed. + ! Fixes stale-scalar bug: iice_loop2 formerly read the plain + ! scalar f1pr16, i.e. the density of whichever category last + ! ran the lookup in iice_loop1 (wrong species for all others, + ! and dependent on category slot order -- the seed of the + ! category-swap divergence; found by an FP-trap stale-state hunt) ! add integers for mu_i index integer :: imu @@ -2275,6 +2876,12 @@ SUBROUTINE p3_main(qc,nc,qr,nr,th_old,th,qv_old,qv,dt,qitot,qirim,qiliq,nitot,bi tmp1 = uzpl(1,1) !avoids compiler warning for unused variable 'uzpl' + ! local j-slab index used by the limiter-firing log (log_limlog). j_index is + ! optional; when the host does not supply it, log 0 rather than an undefined + ! value. limlog_write converts this to a full-grid index via chksum_j0. + limlog_j = 0 + if (present(j_index)) limlog_j = j_index + ! direction of vertical leveling: if (trim(model)=='GEM' .or. trim(model)=='KIN1D') then ktop = kts !k of top level @@ -2299,6 +2906,17 @@ SUBROUTINE p3_main(qc,nc,qr,nr,th_old,th,qv_old,qv,dt,qitot,qirim,qiliq,nitot,bi endif endif + ! ERM begin + where (nitot<0.) + nitot = 0. + endwhere + where (nr<0.) + nr = 0. + endwhere + where (nc<0.) + nc = 0. + endwhere + ! ERM end ! Determine threshold size difference [m] as a function of nCat ! (used for destination category upon ice initiation) ! note -- this code could be moved to 'p3_init' @@ -2333,6 +2951,11 @@ SUBROUTINE p3_main(qc,nc,qr,nr,th_old,th,qv_old,qv,dt,qitot,qirim,qiliq,nitot,bi ! note: '1./max(30.,dt)' = '1.*min(1./30., 1./dt)' timeScaleFactor = min(1./120., odt) + ! ERM begin + qtolmax = 0. + qtolmin = 0. + iqtolcnt = 0 + ! ERM end prt_liq = 0. prt_sol = 0. prt_soli = 0. @@ -2367,12 +2990,27 @@ SUBROUTINE p3_main(qc,nc,qr,nr,th_old,th,qv_old,qv,dt,qitot,qirim,qiliq,nitot,bi t = th *tmparr1 !compute temperature from theta (value at beginning of microphysics step) t_old = th_old*tmparr1 !compute temperature from theta (value at beginning of model time step) qv = max(qv,0.) !clip water vapor to prevent negative values passed in (beginning of microphysics) + ! ERM begin + q_old(:,:) = 0. + qv_old1(:,:) = 0. + qc_old(:,:) = 0. + qr_old(:,:) = 0. + qitot_old(:,:,:) = 0. + q_new(:,:) = 0. + ! ERM end !== !log_hmossopOn = (nCat.gt.1) !default: off for nCat=1, off for nCat>1 !log_hmossopOn = .true. !switch to have Hallet-Mossop ON !log_hmossopOn = .false. !switch to have Hallet-Mossop OFF +! DTD: decode the Hallett-Mossop source selection (host namelist p3_hm_opt). +! 0 = off, 1 = riming of cloud only, 2 = riming of rain only, 3 = both. +! hm_opt = 0 shuts the calc_HM block off outright, independently of the +! nCat=1 seasonal log_hmossopOn switch set in the i-loop below. + hm_cloud = (hm_opt == 1 .or. hm_opt == 3) + hm_rain = (hm_opt == 2 .or. hm_opt == 3) + ! Note (BUG), I think SCF, SPF,... should be initialize here with scpf_on=.false. ! initialize the qiliq to 0. to allow gereralized use even if liqFrac is not used @@ -2381,6 +3019,17 @@ SUBROUTINE p3_main(qc,nc,qr,nr,th_old,th,qv_old,qv,dt,qitot,qirim,qiliq,nitot,bi !-----------------------------------------------------------------------------------! i_loop_main: do i = its,ite ! main i-loop (around the entire scheme) + ! reset the rain-number attribution arrays for this column, so a level whose + ! process rates are skipped shows zero rather than the previous column's value + if (dbgpt_i .gt. 0) then + dbg_nr_entry = 0.; dbg_nr_posti = 0.; dbg_nr_postw = 0.; dbg_nr_posts = 0. + dbg_qr_entry = 0.; dbg_qr_posti = 0.; dbg_qr_postw = 0.; dbg_qr_posts = 0. + dbg_ncautr = 0.; dbg_nrslf = 0.; dbg_nrevp = 0. + dbg_dnr_ice = 0. + dbg_qcacc_r = 0.; dbg_qcacc_f = 0.; dbg_accbr = 0. + dbg_rwrad = 0.; dbg_xvr = 0. + endif + if (nCat.eq.1) then !for nCat = 1, rime-splinter is shut off during the summer (dilution of rimed ice sizes !weakens convection) but on during the winter. The temperature threshold of +5 C (278 K) @@ -2452,41 +3101,89 @@ SUBROUTINE p3_main(qc,nc,qr,nr,th_old,th,qv_old,qv,dt,qitot,qirim,qiliq,nitot,bi !--- apply mass clipping if dry and mass is sufficiently small ! (implying all mass is expected to evaporate/sublimate in one time step) - - if (qc(i,k).lt.qsmall .or. (qc(i,k).lt.1.e-8 .and. sup(i,k).lt.-0.1)) then + if (qc(i,k).lt.qsmall .or. (qc(i,k).lt.1.e-12 .and. sup(i,k).lt.-0.1)) then ! DTD changed to 1.e-12 from 1.e-8 qv(i,k) = qv(i,k) + qc(i,k) th(i,k) = th(i,k) - invexn(i,k)*qc(i,k)*xxlv(i,k)*inv_cp qc(i,k) = 0. nc(i,k) = 0. else + if (log_limlog .and. nc(i,k).lt.nsmall) & + call limlog_write('NFLRC ',it,i,limlog_j,k,0,0., & + qc(i,k),nc(i,k),nsmall,qc(i,k)/nsmall) + ! TEMPORARY (log_nifloor): as for nitot -- skipping this floor leaves + ! nc=0, which get_cloud_dsd2 rejects internally (lamc=0), so the gates + ! guarding the lamc divisions below must carry an nc condition too + if ( log_nifloor ) nc(i,k) = Max( nc(i,k), nsmall ) ! ERM log_hydrometeorsPresent = .true. ! updated further down endif - if (qr(i,k).lt.qsmall .or. (qr(i,k).lt.1.e-8 .and. sup(i,k).lt.-0.1)) then + ! TEMPORARY (log_nrfloor): with the floor off, rain that has mass but no + ! number is neither floored nor clipped here -- it passes through and is + ! rejected by the nr conditions on the rain paths downstream, mirroring how + ! a number-less ice category is handled. Flooring it instead would leave + ! qr/nr enormous, and get_rain_dsd2 would pin the distribution at the + ! maximum mean diameter, making ze_rain the largest value attainable for + ! that mass -- an isolated bright reflectivity pixel. + ! NOTE the asymmetry with ice, which is deliberate for now: the ice exit + ! clip fires when qitot < qsmall OR nitot < nsmall, so a number-less ice + ! category is cleared at the end of the step. The rain exit clip tests + ! qr only, so number-less rain persists instead of being cleared. + if (qr(i,k).lt.qsmall .or. & + (qr(i,k).lt.1.e-12 .and. sup(i,k).lt.-0.1)) then ! DTD changed to 1.e-12 from 1.e-8 + ! CLIPR: now provably dead -- qsmall == 1.e-12 makes the second clause + ! imply the first, so this branch cannot be reached with qr >= qsmall. + ! Kept as a canary: any firing means the trigger has changed. + ! ratio = the theta increment (K, negative = evaporative cooling); + ! v1..v4 = qr destroyed, nr, qv before, th before. + if (log_limlog .and. qr(i,k).ge.qsmall) & + call limlog_write('CLIPR ',it,i,limlog_j,k,0, & + -invexn(i,k)*qr(i,k)*xxlv(i,k)*inv_cp, & + qr(i,k),nr(i,k),qv(i,k),th(i,k)) qv(i,k) = qv(i,k) + qr(i,k) th(i,k) = th(i,k) - invexn(i,k)*qr(i,k)*xxlv(i,k)*inv_cp qr(i,k) = 0. nr(i,k) = 0. else + if (log_limlog .and. nr(i,k).lt.nsmall) & + call limlog_write('NFLRR ',it,i,limlog_j,k,0,0., & + qr(i,k),nr(i,k),nsmall,qr(i,k)/nsmall) + if ( log_nrfloor ) nr(i,k) = Max( nr(i,k), nsmall ) ! ERM log_hydrometeorsPresent = .true. ! updated further down endif + clipsum_qv = 0.d0 + clipsum_th = 0.d0 do iice = 1,nCat - if (qitot(i,k,iice).lt.qsmall .or. (qitot(i,k,iice).lt.1.e-8 .and. & - supi(i,k).lt.-0.1)) then - qv(i,k) = qv(i,k) + qitot(i,k,iice) - th(i,k) = th(i,k) - invexn(i,k)*(qitot(i,k,iice)-qiliq(i,k,iice))*xxls(i,k)*inv_cp - th(i,k) = th(i,k) - invexn(i,k)*qiliq(i,k,iice)*xxlv(i,k)*inv_cp + if (qitot(i,k,iice).lt.qsmall .or. (qitot(i,k,iice).lt.1.e-12 .and. & + supi(i,k).lt.-0.1)) then ! Note that ERM removed second sup criterion for testing. May try later + ! category-order-invariant (permanent): + ! defer the qv/th increments; accumulated in double precision and + ! applied once after this loop + clipsum_qv = clipsum_qv + dble(qitot(i,k,iice)) + clipsum_th = clipsum_th & + - dble(invexn(i,k)*(qitot(i,k,iice)-qiliq(i,k,iice))*xxls(i,k)*inv_cp) & + - dble(invexn(i,k)*qiliq(i,k,iice)*xxlv(i,k)*inv_cp) qitot(i,k,iice) = 0. nitot(i,k,iice) = 0. qirim(i,k,iice) = 0. qiliq(i,k,iice) = 0. birim(i,k,iice) = 0. else + ! limiter-firing log: the nsmall floor is about to invent number for a + ! category that has mass but essentially none. v4 is the implied mean + ! particle mass the process block will then run with. + if (log_limlog .and. nitot(i,k,iice).lt.nsmall) & + call limlog_write('NFLRI ',it,i,limlog_j,k,iice,0., & + qitot(i,k,iice),nitot(i,k,iice),nsmall,qitot(i,k,iice)/nsmall) + ! TEMPORARY (log_nifloor): skipping this floor leaves nitot=0 so the + ! existing 'nitot >= nsmall' gates downstream reject the category + if ( log_nifloor ) nitot(i,k,iice) = Max (nitot(i,k,iice), nsmall) ! ERM log_hydrometeorsPresent = .true. ! final update endif - if (log_LiquidFrac .and. qitot(i,k,iice).ge.qsmall .and. (qiliq(i,k,iice)/qitot(i,k,iice)).gt.0.99) then + ! if (log_LiquidFrac .and. qitot(i,k,iice).ge.qsmall .and. (qiliq(i,k,iice)/qitot(i,k,iice)).gt.0.99) then + if (log_LiquidFrac .and. qitot(i,k,iice).ge.qsmall ) then ! ERM split line in case qitot = 0 + if (( qiliq(i,k,iice)/qitot(i,k,iice)).gt.0.99) then qr(i,k) = qr(i,k) + qitot(i,k,iice) nr(i,k) = nr(i,k) + nitot(i,k,iice) th(i,k) = th(i,k) - invexn(i,k)*(qitot(i,k,iice)-qiliq(i,k,iice))*xlf(i,k)*inv_cp @@ -2495,9 +3192,10 @@ SUBROUTINE p3_main(qc,nc,qr,nr,th_old,th,qv_old,qv,dt,qitot,qirim,qiliq,nitot,bi qirim(i,k,iice) = 0. qiliq(i,k,iice) = 0. birim(i,k,iice) = 0. + endif endif - if (qitot(i,k,iice).ge.qsmall .and. qitot(i,k,iice).lt.1.e-8 .and. & + if (qitot(i,k,iice).ge.qsmall .and. qitot(i,k,iice).lt.1.e-12 .and. & t(i,k).ge.273.15) then qr(i,k) = qr(i,k) + qitot(i,k,iice) nr(i,k) = nr(i,k) + nitot(i,k,iice) @@ -2511,11 +3209,31 @@ SUBROUTINE p3_main(qc,nc,qr,nr,th_old,th,qv_old,qv,dt,qitot,qirim,qiliq,nitot,bi enddo !iice-loop + ! apply the deferred clipping increments in one rounded update each + ! (before the q_old conservation diagnostic below, which must see + ! the clipped qv) + qv(i,k) = sngl(dble(qv(i,k)) + clipsum_qv) + th(i,k) = sngl(dble(th(i,k)) + clipsum_th) + + ! ERM begin + if (dbgpt_i .gt. 0) then ! checkpoint 1: post entry-clip + dbg_nr_entry(k) = nr(i,k) + dbg_qr_entry(k) = qr(i,k) + endif + q_old(i,k) = qv(i,k) + qc(i,k) + qr(i,k) + Sum( qitot(i,k,1:nCat) ) + qv_old1(i,k) = qv(i,k) + qc_old(i,k) = qc(i,k) + qr_old(i,k) = qr(i,k) + do iice = 1,nCat + qitot_old(i,k,iice) = qitot(i,k,iice) + enddo + ! ERM end !=== enddo k_loop_1 !zero out zitot if there is no qitot for triple moment + ! DTD do we want to check for nitot < nsmall as well? if (log_3momentIce) where (qitot(i,:,:).lt.qsmall) zitot(i,:,:) = 0. if (debug_on) then @@ -2586,7 +3304,7 @@ SUBROUTINE p3_main(qc,nc,qr,nr,th_old,th,qv_old,qv,dt,qitot,qirim,qiliq,nitot,bi nrhetc = 0.; ninuc = 0.; qidep = 0. nrheti = 0.; nisub = 0.; qwgrth = 0. qrmul = 0.; nimul = 0.; qicol = 0. - nicol = 0. + nicol = 0.; qcmul = 0. ! DTD: added qcmul ! Liquid fraction microphysical process rates (log_LiquidFrac) qrmlt = 0.; qifrz = 0. @@ -2621,8 +3339,19 @@ SUBROUTINE p3_main(qc,nc,qr,nr,th_old,th,qv_old,qv,dt,qitot,qirim,qiliq,nitot,bi if (ssat(i,k).lt.0.) epsilon = min(0.,epsilon) ! now do the adjustment - if (abs(epsilon).ge.1.e-15) then +! if (abs(epsilon).ge.1.e-15) then + if (abs(epsilon).ge.qsmall) then ! ERM qc(i,k) = qc(i,k)+epsilon + ! TEMPORARY (log_nifloor): same treatment as the other nc floors. + ! Currently unreachable -- log_predictSsat is hardwired .false. above -- + ! but gated here so that enabling supersaturation prediction cannot + ! reintroduce cloud mass carrying a manufactured droplet number. + ! NOTE (separate issue, deliberately left alone): this floor fires on + ! any |epsilon| >= qsmall, so it also manufactures droplet number when + ! epsilon < 0, i.e. while cloud water is being evaporated away. That + ! is nonsensical independently of the switch and should be revisited + ! if log_predictSsat is ever turned on. + if ( log_nifloor ) nc(i,k) = Max(nc(i,k), nsmall) ! ERM qv(i,k) = qv(i,k)-epsilon th(i,k) = th(i,k)+epsilon*invexn(i,k)*xxlv(i,k)*inv_cp ! recalculate variables if there was adjustment @@ -2676,21 +3405,35 @@ SUBROUTINE p3_main(qc,nc,qr,nr,th_old,th,qv_old,qv,dt,qitot,qirim,qiliq,nitot,bi call get_rain_dsd2(qr(i,k),nr(i,k),mu_r(i,k),lamr(i,k),cdistr(i,k),logn0r(i,k), & - iSPF(k)) + iSPF(k),it,i,limlog_j,k,1) ! initialize inverse supersaturation relaxation timescale for combined ice categories epsi_tot = 0. epsiw_tot = 0. - - call impose_max_total_Ni(nitot(i,k,:),max_total_Ni,inv_rho(i,k)) + epsi_totdp = 0.d0 ! category-order-invariant epsi accumulation (permanent) + epsiw_totdp = 0.d0 + ! DTD: turned off for testing + ! call impose_max_total_Ni(nitot(i,k,:),max_total_Ni,inv_rho(i,k)) + ! DTD: added call to new per-category Ni limiter + if (max_Ni .gt. 0.) call impose_max_Ni(nitot(i,k,:),max_Ni,inv_rho(i,k), & + it,i,limlog_j,k,qitot(i,k,:),zitot(i,k,:)) iice_loop1: do iice = 1,nCat + Eii_fact(iice) = 1.0 ! DTD: set default value of ice-ice collection efficiency factor to 1.0 to avoid potential stale value issue + f1pr16_s(iice) = -1. ! no lookup accessed for this category yet this step (see declaration) + + ! limiter-firing log: mass present but number below nsmall, so the whole + ! process block below is skipped for this category this step (diagnostic + ! only; the test itself is unchanged) + if (log_limlog .and. qitot(i,k,iice).ge.qsmall .and. nitot(i,k,iice).lt.nsmall) & + call limlog_write('NGATE ',it,i,limlog_j,k,iice,0., & + qitot(i,k,iice),nitot(i,k,iice),qirim(i,k,iice),birim(i,k,iice)) - qitot_notsmall_1: if (qitot(i,k,iice).ge.qsmall) then + qitot_notsmall_1: if (qitot(i,k,iice).ge.qsmall .and. nitot(i,k,iice) .ge. nsmall ) then ! ERM added nitot check ! DTD changed to .ge. from > to ensure case where nitot = nsmall is included !impose lower limits to prevent taking log of # < 0 - nitot(i,k,iice) = max(nitot(i,k,iice),nsmall) - nr(i,k) = max(nr(i,k),nsmall) + if ( log_maxnsmall .and. log_nifloor ) nitot(i,k,iice) = max(nitot(i,k,iice),ntiny) ! ERM + if ( log_maxnsmall .and. log_nrfloor ) nr(i,k) = max(nr(i,k),ntiny) ! ERM !compute mean-mass ice diameters (estimated; rigorous approach to be implemented later) !dum2 = 500. !ice density @@ -2853,6 +3596,10 @@ SUBROUTINE p3_main(qc,nc,qr,nr,th_old,th,qv_old,qv,dt,qitot,qirim,qiliq,nitot,bi endif !if log_3momentIce + ! save this category's mean density for consumers outside iice_loop1 + ! (f1pr16 itself is a scalar and only retains the LAST category's value) + f1pr16_s(iice) = f1pr16 + ! Compute ice diameter (volume equivalent -- for multi-cat) diam_ice(i,k,iice) = ((qitot(i,k,iice)*6.)/(nitot(i,k,iice)*f1pr16*pi))**thrd @@ -2880,6 +3627,7 @@ SUBROUTINE p3_main(qc,nc,qr,nr,th_old,th,qv_old,qv,dt,qitot,qirim,qiliq,nitot,bi ! Determine additional collection efficiency factor to be applied to ice-ice collection. ! The computed values of qicol and nicol are multipiled by Eii_fact to gradually shut off collection ! if the ice in iice is highly rimed. + tmp1 = 0. ! DTD initialize to avoid stale value issue if (qirim(i,k,iice)>0.) then if ((qitot(i,k,iice)-qiliq(i,k,iice))>0.) then tmp1 = qirim(i,k,iice)/(qitot(i,k,iice)-qiliq(i,k,iice)) !rime mass fraction @@ -2919,8 +3667,7 @@ SUBROUTINE p3_main(qc,nc,qr,nr,th_old,th,qv_old,qv,dt,qitot,qirim,qiliq,nitot,bi ! ex: rhofaci is grid-mean, f1pr04 is grid-mean, qc*iSCF is in-cloud, ! eci is a constant, rho(i,k) is grid-mean, nitot*iSCF is in-cloud ! (qc*iSCF*nitot*iSCF)*SCF = (qc*nitot)*iSCF to obtain grid-mean qccol - - if (qitot(i,k,iice).ge.qsmall .and. qc(i,k).ge.qsmall .and. t(i,k).le.273.15) then + if (qitot(i,k,iice).ge.qsmall .and. nitot(i,k,iice) .ge. nsmall .and. qc(i,k).ge.qsmall .and. nc(i,k).ge.nsmall .and. t(i,k).le.273.15) then ! diam_ice(i,k,iice).ge.200.e-6) then ! DTD added ice size check, ERM added nitot check ! DTD: changed to .ge. from > to ensure case where nitot = nsmall is included. qccol(iice) = rhofaci(i,k)*f1pr04*qc(i,k)*eci*rho(i,k)*nitot(i,k,iice)*iSCF(k) nccol(iice) = rhofaci(i,k)*f1pr04*nc(i,k)*eci*rho(i,k)*nitot(i,k,iice)*iSCF(k) @@ -2929,19 +3676,31 @@ SUBROUTINE p3_main(qc,nc,qr,nr,th_old,th,qv_old,qv,dt,qitot,qirim,qiliq,nitot,bi endif endif - - if (qitot(i,k,iice).ge.qsmall .and. qr(i,k).ge.qsmall .and. t(i,k).le.273.15) then + ! if (qitot(i,k,iice).ge.qsmall .and. qr(i,k).ge.qsmall .and. t(i,k).le.273.15 .and. iice==2) then ! .and. diam_ice(i,k,iice).ge.200.e-6) then ! DTD added ice size check ! DTD: only allow qrcol for iice==2 (ice from Biggs freezing) + ! if (qitot(i,k,iice).ge.qsmall .and. qr(i,k).ge.qsmall .and. t(i,k).le.273.15) then ! orig check + ! TEMPORARY (log_nrfloor): nr condition guards logn0r, which is 0 (not + ! -infinity) on the skipped path, so 10.**(f1pr08+logn0r) would silently + ! evaluate with n0r = 1 rather than vanishing + if (qitot(i,k,iice).ge.qsmall .and. nitot(i,k,iice) .ge. nsmall .and. qr(i,k).ge.qsmall .and. & + (log_nrfloor .or. nr(i,k).ge.nsmall) .and. t(i,k).le.273.15) then ! ERM added nitot check ! DTD: changed to .ge. from > to ensure case where nitot = nsmall is included. + IF ( qitot(i,k,iice)/nitot(i,k,iice) > qr(i,k)/nr(i,k) .or. qrcol_opt == 0 ) THEN ! ERM ice size check (Must be larger than rain in mean size) ! qrcol(iice)=f1pr08*logn0r(i,k)*rho(i,k)*rhofaci(i,k)*eri*nitot(i,k,iice) ! nrcol(iice)=f1pr07*logn0r(i,k)*rho(i,k)*rhofaci(i,k)*eri*nitot(i,k,iice) ! note: f1pr08 and logn0r are already calculated as log_10 (in-precip) ! note: (SPF(k)-SPF_clr(k)) is SPF_cld(k) qrcol(iice) = 10.**(f1pr08+logn0r(i,k))*rho(i,k)*rhofaci(i,k)*eri*nitot(i,k,iice)*iSCF(k)*(SPF(k)-SPF_clr(k)) nrcol(iice) = 10.**(f1pr07+logn0r(i,k))*rho(i,k)*rhofaci(i,k)*eri*nitot(i,k,iice)*iSCF(k)*(SPF(k)-SPF_clr(k)) - if (log_3momentIce) then zqrcol(iice) = 10.**(logn0r(i,k))*f1pr36*rho(i,k)*rhofaci(i,k)*eri*iSCF(k)*(SPF(k)-SPF_clr(k)) endif - + ! ERM begin + IF ( ncat == 2 .and. merge_opt == -1 .and. iice == 2 .and. qrcol_opt == 2. .and. .not. cat_init_new) THEN ! DTD added additional cat_init_new check + qrcol(iice) = 0.0 + nrcol(iice) = 0.0 + zqrcol(iice) = 0.0 ! DTD + ENDIF + ! ERM end + ENDIF endif !....................... @@ -2951,7 +3710,7 @@ SUBROUTINE p3_main(qc,nc,qr,nr,th_old,th,qv_old,qv,dt,qitot,qirim,qiliq,nitot,bi ! for T > 273.15, assume cloud water is collected and shed as rain drops if (log_LiquidFrac) then ! assume cloud water is collected by qiliq - if (qitot(i,k,iice).ge.qsmall .and. qc(i,k).ge.qsmall .and. t(i,k).gt.273.15) then + if (qitot(i,k,iice).ge.qsmall .and. nitot(i,k,iice).ge.nsmall .and. qc(i,k).ge.qsmall .and. nc(i,k).ge.nsmall .and. t(i,k).gt.273.15) then qccoll(iice) = rhofaci(i,k)*f1pr04*qc(i,k)*eci*rho(i,k)*nitot(i,k,iice)*iSCF(k) nccoll(iice) = rhofaci(i,k)*f1pr04*nc(i,k)*eci*rho(i,k)*nitot(i,k,iice)*iSCF(k) if(log_3momentIce) then @@ -2959,7 +3718,9 @@ SUBROUTINE p3_main(qc,nc,qr,nr,th_old,th,qv_old,qv,dt,qitot,qirim,qiliq,nitot,bi endif endif ! assume collected rain by qiliq - if (qitot(i,k,iice).ge.qsmall .and. qr(i,k).ge.qsmall .and. t(i,k).gt.273.15) then + ! TEMPORARY (log_nrfloor): nr condition guards logn0r (see above) + if (qitot(i,k,iice).ge.qsmall .and. nitot(i,k,iice).ge.nsmall .and. qr(i,k).ge.qsmall .and. & + (log_nrfloor .or. nr(i,k).ge.nsmall) .and. t(i,k).gt.273.15) then ! note: f1pr08 and logn0r are already calculated as log_10 qrcoll(iice) = 10.**(f1pr08+logn0r(i,k))*rho(i,k)*rhofaci(i,k)*eri*nitot(i,k,iice)*iSCF(k)*(SPF(k)-SPF_clr(k)) nrcoll(iice) = 10.**(f1pr07+logn0r(i,k))*rho(i,k)*rhofaci(i,k)*eri*nitot(i,k,iice)*iSCF(k)*(SPF(k)-SPF_clr(k)) @@ -2969,7 +3730,7 @@ SUBROUTINE p3_main(qc,nc,qr,nr,th_old,th,qv_old,qv,dt,qitot,qirim,qiliq,nitot,bi endif else ! assume cloud water is collected and shed as rain drops (original code) - if (qitot(i,k,iice).ge.qsmall .and. qc(i,k).ge.qsmall .and. t(i,k).gt.273.15) then + if (qitot(i,k,iice).ge.qsmall .and. nitot(i,k,iice).ge.nsmall .and. qc(i,k).ge.qsmall .and. nc(i,k).ge.nsmall .and. t(i,k).gt.273.15) then ! sink for cloud water mass and number, note qcshed is source for rain mass qcshd(iice) = rhofaci(i,k)*f1pr04*qc(i,k)*eci*rho(i,k)*nitot(i,k,iice)*iSCF(k) nccol(iice) = rhofaci(i,k)*f1pr04*nc(i,k)*eci*rho(i,k)*nitot(i,k,iice)*iSCF(k) @@ -2980,7 +3741,9 @@ SUBROUTINE p3_main(qc,nc,qr,nr,th_old,th,qv_old,qv,dt,qitot,qirim,qiliq,nitot,bi endif ! assume collected rain number is shed as 1 mm drops (original code) ! collection of rain above freezing does not impact total rain mass - if (qitot(i,k,iice).ge.qsmall .and. qr(i,k).ge.qsmall .and. t(i,k).gt.273.15) then + ! TEMPORARY (log_nrfloor): nr condition guards logn0r (see above) + if (qitot(i,k,iice).ge.qsmall .and. nitot(i,k,iice).ge.nsmall .and. qr(i,k).ge.qsmall .and. & + (log_nrfloor .or. nr(i,k).ge.nsmall) .and. t(i,k).gt.273.15) then ! rain number sink due to collection nrcol(iice) = 10.**(f1pr07 + logn0r(i,k))*rho(i,k)*rhofaci(i,k)*eri*nitot(i,k,iice)*iSCF(k)*(SPF(k)-SPF_clr(k)) ! rain number source due to shedding = collected rain mass/mass of 1 mm drop @@ -2996,7 +3759,7 @@ SUBROUTINE p3_main(qc,nc,qr,nr,th_old,th,qv_old,qv,dt,qitot,qirim,qiliq,nitot,bi ! collection between ice categories ! iceice_interaction1: if (.false.) then !for testing (to suppress ice-ice interaction) - iceice_interaction1: if (iice.ge.2) then + iceice_interaction1: if (iice.ge.2 .and. log_iceice_interaction) then !note: In this version, lookupTable_2 (LT2, for ice category interactions) is computed for a maximum ! mean ice size of Dm_max=2000.e-6 m (the old lambda_i limiter); thus it is compatible with @@ -3007,9 +3770,9 @@ SUBROUTINE p3_main(qc,nc,qr,nr,th_old,th,qv_old,qv,dt,qitot,qirim,qiliq,nitot,bi ! In a forthcoming version, both LT1-2momI and LT2 (and LT1-3momI) will all be computed ! using the unconstrained size limited (i.e. Dm_max=400000.e-6). - qitot_notsmall: if (qitot(i,k,iice).ge.qsmall) then + qitot_notsmall: if (qitot(i,k,iice).ge.qsmall .and. nitot(i,k,iice).ge.nsmall) then catcoll_loop: do catcoll = 1,iice-1 - qitotcatcoll_notsmall: if (qitot(i,k,catcoll).ge.qsmall) then + qitotcatcoll_notsmall: if (qitot(i,k,catcoll).ge.qsmall .and. nitot(i,k,catcoll).ge.nsmall) then ! first, calculate collection of catcoll category by iice category @@ -3095,7 +3858,7 @@ SUBROUTINE p3_main(qc,nc,qr,nr,th_old,th,qv_old,qv,dt,qitot,qirim,qiliq,nitot,bi ! in the lookup table calculations ! note 'f1pr' values are normalized, so we need to multiply by N - if (qitot(i,k,iice).ge.qsmall) then + if (qitot(i,k,iice).ge.qsmall .and. nitot(i,k,iice).ge.nsmall .and. log_nislf) then ! ERM added log_nislf. nislf(iice) = f1pr03*rho(i,k)*eii*Eii_fact(iice)*rhofaci(i,k)*nitot(i,k,iice)*nitot(i,k,iice)*iSCF(k) if (log_3momentIce) then ! NOTE: already correct sign from lookup table, thus not multiplied by -1 @@ -3113,7 +3876,7 @@ SUBROUTINE p3_main(qc,nc,qr,nr,th_old,th,qv_old,qv,dt,qitot,qirim,qiliq,nitot,bi if (log_LiquidFrac) then ! some portion of the melted water stays into qiliq --> qimlt(iice) (D>Dth) ! the other portion melts into rain --> qrmlt(iice) (D<=Dth) - if ((qitot(i,k,iice)-qiliq(i,k,iice)).ge.qsmall .and. t(i,k).gt.273.15) then + if ((qitot(i,k,iice)-qiliq(i,k,iice)).ge.qsmall .and. nitot(i,k,iice).ge.nsmall .and. t(i,k).gt.273.15) then qsat0 = 0.622*e0/(pres(i,k)-e0) dum = 0. qrmlt(iice) = ((f1pr24+f1pr25*sc**thrd*(rhofaci(i,k)*rho(i,k)/mu)**0.5)*((t(i,k)- & @@ -3128,6 +3891,10 @@ SUBROUTINE p3_main(qc,nc,qr,nr,th_old,th,qv_old,qv,dt,qitot,qirim,qiliq,nitot,bi sinks = qimlt(iice)+qrmlt(iice) if (sinks.gt.0. .and. sinks .gt. (qitot(i,k,iice)-qiliq(i,k,iice))*odt) then ratio = (qitot(i,k,iice)-qiliq(i,k,iice))*odt/sinks + if (log_limlog .and. ratio.lt.limlog_ratmin) & + call limlog_write('MELT ',it,i,limlog_j,k,iice,ratio, & + (qitot(i,k,iice)-qiliq(i,k,iice))*odt,sinks, & + qrmlt(iice),qimlt(iice)) qrmlt(iice) = qrmlt(iice)*ratio qimlt(iice) = qimlt(iice)*ratio endif @@ -3139,7 +3906,7 @@ SUBROUTINE p3_main(qc,nc,qr,nr,th_old,th,qv_old,qv,dt,qitot,qirim,qiliq,nitot,bi endif endif else - if (qitot(i,k,iice).ge.qsmall .and. t(i,k).gt.273.15) then + if (qitot(i,k,iice).ge.qsmall .and. nitot(i,k,iice).ge.nsmall .and. t(i,k).gt.273.15) then qsat0 = 0.622*e0/(pres(i,k)-e0) ! dum=cpw/xlf(i,k)*(t(i,k)-273.15)*(pracsw1+qcshd(iice)) ! currently enhanced melting from collision is neglected @@ -3167,7 +3934,7 @@ SUBROUTINE p3_main(qc,nc,qr,nr,th_old,th,qv_old,qv,dt,qitot,qirim,qiliq,nitot,bi ! similar to Musil (1970), JAS ! note 'f1pr' values are normalized, so we need to multiply by N - if (qitot(i,k,iice).ge.qsmall .and. (qc(i,k)+qr(i,k)).ge.1.e-6 .and. t(i,k).lt.273.15) then + if (qitot(i,k,iice).ge.qsmall .and. nitot(i,k,iice).ge.nsmall .and. (qc(i,k)+qr(i,k)).ge.1.e-6 .and. t(i,k).lt.273.15) then qsat0 = 0.622*e0/(pres(i,k)-e0) qwgrth(iice) = ((f1pr05+f1pr14*sc**thrd*(rhofaci(i,k)*rho(i,k)/mu)**0.5)*((t(i,k)- & @@ -3221,16 +3988,18 @@ SUBROUTINE p3_main(qc,nc,qr,nr,th_old,th,qv_old,qv,dt,qitot,qirim,qiliq,nitot,bi !Note (BUG) insert *iSCF(k) because epsi and epsiw needs to be in-cloud (to be done) !if (log_LiquidFrac) then - if (qitot(i,k,iice).ge.qsmall) then + if (qitot(i,k,iice).ge.qsmall .and. nitot(i,k,iice).ge.nsmall) then if ((qiliq(i,k,iice)/qitot(i,k,iice)).lt.0.01) then epsi(iice) = ((f1pr05+f1pr14*sc**thrd*(rhofaci(i,k)*rho(i,k)/mu)**0.5)*2.*pi* & rho(i,k)*dv)*nitot(i,k,iice) - epsi_tot = epsi_tot + epsi(iice) + ! category-order-invariant (permanent; category-order-invariant) + epsi_totdp = epsi_totdp + dble(epsi(iice)) epsiw(iice) = 0. else epsiw(iice) = ((f1pr05+f1pr14*sc**thrd*(rhofaci(i,k)*rho(i,k)/mu)**0.5)*2.*pi* & rho(i,k)*dv)*nitot(i,k,iice) - epsiw_tot = epsiw_tot + epsiw(iice) + ! category-order-invariant (permanent; category-order-invariant) + epsiw_totdp = epsiw_totdp + dble(epsiw(iice)) epsi(iice) = 0. endif @@ -3267,7 +4036,7 @@ SUBROUTINE p3_main(qc,nc,qr,nr,th_old,th,qv_old,qv,dt,qitot,qirim,qiliq,nitot,bi !............................................................ if (log_LiquidFrac) then - if (qiliq(i,k,iice).ge.qsmall .and. qitot(i,k,iice).ge.qsmall) then + if (qiliq(i,k,iice).ge.qsmall .and. qitot(i,k,iice).ge.qsmall .and. nitot(i,k,iice).ge.nsmall) then ! Refreezing if (t(i,k).lt.273.15) then qsat0 = 0.622*e0/(pres(i,k)-e0) @@ -3278,7 +4047,7 @@ SUBROUTINE p3_main(qc,nc,qr,nr,th_old,th,qv_old,qv,dt,qitot,qirim,qiliq,nitot,bi endif ! Shedding tmp1=0. - if ((qitot(i,k,iice)-qiliq(i,k,iice)).ge.qsmall) tmp1 = qirim(i,k,iice)/(qitot(i,k,iice)-qiliq(i,k,iice)) + if ((qitot(i,k,iice)-qiliq(i,k,iice)).ge.qsmall .and. nitot(i,k,iice).ge.nsmall) tmp1 = qirim(i,k,iice)/(qitot(i,k,iice)-qiliq(i,k,iice)) ! Shedding qlshd(iice) = tmp1*f1pr28*nitot(i,k,iice)*qiliq(i,k,iice)/qitot(i,k,iice) qlshd(iice) = min(max(0.,qlshd(iice)),qiliq(i,k,iice)*odt) @@ -3312,7 +4081,9 @@ SUBROUTINE p3_main(qc,nc,qr,nr,th_old,th,qv_old,qv,dt,qitot,qirim,qiliq,nitot,bi iTc = 1./min(-0.001,t(i,k)-273.15) ! cloud: - if (qc(i,k).ge.qsmall) then + ! TEMPORARY (log_nifloor): nc condition guards the lamc divisions below + if (qc(i,k).ge.qsmall .and. & + (log_nifloor .or. nc(i,k).ge.nsmall)) then ! droplet fall speed ! (use Stokes' formulation (thus use analytic solution) Vt_qc(i,k) = acn(i,k)*gamma(4.+bcn+mu_c(i,k))/(lamc(i,k)**bcn*gamma(mu_c(i,k)+4.)) @@ -3353,8 +4124,29 @@ SUBROUTINE p3_main(qc,nc,qr,nr,th_old,th,qv_old,qv,dt,qitot,qirim,qiliq,nitot,bi !-------------------- enddo iice_loop1 + + ! apply the deferred category-order-invariant epsi accumulations + ! (permanent; category-order-invariant) + epsi_tot = sngl(epsi_totdp) + epsiw_tot = sngl(epsiw_totdp) !-------------------- + if (debug_on) then + location_ind = 250 + force_abort =.false. + tmparr1(i,k:k) = th(i,k:k)*(pres(i,k:k)*1.e-5)**(rd*inv_cp) + if (log_3momentIce) then + call check_values(qv(i,k:k),tmparr1(i,k:k),qc(i,k:k),nc(i,k:k),qr(i,k:k),nr(i,k:k),qitot(i,k:k,:), & + qirim(i,k:k,:),nitot(i,k:k,:),birim(i,k:k,:),i,it,force_abort,location_ind, & + Zitot=zitot(i,k:k,:),Qiliq=qiliq(i,k:k,:)) + else + call check_values(qv(i,k:k),tmparr1(i,k:k),qc(i,k:k),nc(i,k:k),qr(i,k:k),nr(i,k:k),qitot(i,k:k,:), & + qirim(i,k:k,:),nitot(i,k:k,:),birim(i,k:k,:),i,it,force_abort,location_ind, & + Qiliq=qiliq(i,k:k,:)) + endif + if (global_status /= STATUS_OK) return + endif + !............................................................ ! contact and immersion freezing droplets @@ -3366,7 +4158,9 @@ SUBROUTINE p3_main(qc,nc,qr,nr,th_old,th,qv_old,qv,dt,qitot,qirim,qiliq,nitot,bi ! (6.*pi*rin*mu) ! nacnt=exp(-2.80+0.262*(273.15-t(i,k)))*1000. - if (qc(i,k).ge.qsmall .and. t(i,k).le.269.15) then + ! TEMPORARY (log_nifloor): nc condition guards the lamc division below + if (qc(i,k).ge.qsmall .and. t(i,k).le.269.15 .and. & + (log_nifloor .or. nc(i,k).ge.nsmall)) then ! DTD added nc check ! qchetc(iice) = pi*pi/3.*Dap*Nacnt*rhow*cdist1(i,k)*gamma(mu_c(i,k)+5.)/lamc(i,k)**4 ! nchetc(iice) = 2.*pi*Dap*Nacnt*cdist1(i,k)*gamma(mu_c(i,k)+2.)/lamc(i,k) ! for future: calculate gamma(mu_c+4) in one place since its used multiple times @@ -3387,9 +4181,29 @@ SUBROUTINE p3_main(qc,nc,qr,nr,th_old,th,qv_old,qv,dt,qitot,qirim,qiliq,nitot,bi if (nCat>1) then !determine destination ice-phase category: - dum1 = 900. !density of new ice - D_new = ((Q_nuc*6.)/(pi*dum1*N_nuc))**thrd - call icecat_destination(qitot(i,k,:)*iSCF(k),diam_ice(i,k,:),D_new,deltaD_init,iice_dest) + if (.not. cat_init_new) then + dum1 = 900. !density of new ice + D_new = ((Q_nuc*6.)/(pi*dum1*N_nuc))**thrd + ! ERM begin + IF ( merge_opt == -1 .and. nCat == 2 ) THEN + iice_dest = 2 + ELSE + call icecat_destination(qitot(i,k,:)*iSCF(k),diam_ice(i,k,:),D_new,deltaD_init,iice_dest) + ENDIF + ! ERM end (call of icecat_destination is still there in orig code of course + else + if (nCat == 2) then + iice_dest = catdest_contact_n2 + elseif (nCat == 3) then + iice_dest = catdest_contact_n3 + elseif (nCat == 4) then + iice_dest = catdest_contact_n4 + elseif (nCat == 5) then + iice_dest = catdest_contact_n5 + elseif (nCat == 6) then + iice_dest = catdest_contact_n6 + endif + endif if (global_status /= STATUS_OK) return else @@ -3405,7 +4219,10 @@ SUBROUTINE p3_main(qc,nc,qr,nr,th_old,th,qv_old,qv,dt,qitot,qirim,qiliq,nitot,bi ! Note (BUG): is *iSPF(k) necessary here - if (qr(i,k)*iSPF(k).ge.qsmall.and.t(i,k).le.269.15) then + ! TEMPORARY (log_nrfloor): nr condition guards log(cdistr) and log(lamr) below, + ! both of which are 0 on the skipped path + if (qr(i,k)*iSPF(k).ge.qsmall .and. t(i,k).le.269.15 .and. & + (log_nrfloor .or. nr(i,k)*iSPF(k).ge.nsmall)) then ! Q_nuc = cons6*exp(log(cdistr(i,k))+log(gamma(7.+mu_r(i,k)))-6.*log(lamr(i,k)))*exp(aimm*(273.15-t(i,k)))*SPF(k) ! N_nuc = cons5*exp(log(cdistr(i,k))+log(gamma(mu_r(i,k)+4.))-3.*log(lamr(i,k)))*exp(aimm*(273.15-t(i,k)))*SPF(k) @@ -3417,14 +4234,36 @@ SUBROUTINE p3_main(qc,nc,qr,nr,th_old,th,qv_old,qv,dt,qitot,qirim,qiliq,nitot,bi if (nCat>1) then !determine destination ice-phase category: - dum1 = 900. !density of new ice - D_new = ((Q_nuc*6.)/(pi*dum1*N_nuc))**thrd - call icecat_destination(qitot(i,k,:)*iSCF(k),diam_ice(i,k,:),D_new, & + if (.not. cat_init_new) then + dum1 = 900. !density of new ice + D_new = ((Q_nuc*6.)/(pi*dum1*N_nuc))**thrd + ! ERM begin + diag_3d(i,k,2) = 1000.*D_new + IF ( merge_opt == -1 .and. nCat == 2 ) THEN + iice_dest = 1 + ELSE + call icecat_destination(qitot(i,k,:)*iSCF(k),diam_ice(i,k,:),D_new, & deltaD_init,iice_dest) + ENDIF + diag_3d(i,k,1) = iice_dest + ! ERM end (call of icecat_destination is still there in original of course) + else + if (nCat == 2) then + iice_dest = catdest_rainimm_n2 + elseif (nCat == 3) then + iice_dest = catdest_rainimm_n3 + elseif (nCat == 4) then + iice_dest = catdest_rainimm_n4 + elseif (nCat == 5) then + iice_dest = catdest_rainimm_n5 + elseif (nCat == 6) then + iice_dest = catdest_rainimm_n6 + endif + endif if (global_status /= STATUS_OK) return - else - iice_dest = 1 - endif + else + iice_dest = 1 + endif qrheti(iice_dest) = Q_nuc nrheti(iice_dest) = N_nuc endif @@ -3434,33 +4273,68 @@ SUBROUTINE p3_main(qc,nc,qr,nr,th_old,th,qv_old,qv,dt,qitot,qirim,qiliq,nitot,bi ! rime splintering (Hallet-Mossop 1974) ! Rime splintering occurs from accretion of large drops (>25 microns diameter) -! by large, rimed, fully-frozen ice. For simplicitly it is assumed that all -! accreted rain contributes to splintering, but accreted cloud water does not. +! by large, rimed, fully-frozen ice. Which riming source is allowed to produce +! splinters is set by hm_opt (host namelist p3_hm_opt): 0 = off, 1 = cloud only, +! 2 = rain only (the original P3 assumption, that all accreted rain contributes +! but accreted cloud water does not), 3 = both. ! It only occurs in the temperature range of -8C < T -3C. - calc_HM: if (log_hmossopOn .and. t(i,k).gt.265.15 .and. t(i,k).lt.270.15) then + calc_HM: if (hm_opt.gt.0 .and. log_hmossopOn .and. t(i,k).gt.265.15 .and. t(i,k).lt.270.15) then if (nCat>1) then !determine destination ice-phase category - D_new = 10.e-6 !assumes ice crystals from rime splintering are tiny - call icecat_destination(qitot(i,k,:)*iSCF(k),diam_ice(i,k,:),D_new,deltaD_init,iice_dest) - if (global_status /= STATUS_OK) return + if (.not. cat_init_new) then + D_new = 10.e-6 !assumes ice crystals from rime splintering are tiny + ! ERM begin + IF ( merge_opt == -1 .and. nCat == 2 ) THEN + iice_dest = 2 + ELSE + call icecat_destination(qitot(i,k,:)*iSCF(k),diam_ice(i,k,:),D_new,deltaD_init,iice_dest) + ENDIF + ! ERM end (call of icecat_destination is still there in original of course) + else + if (nCat == 2) then + iice_dest = catdest_rimesplinter_n2 + elseif (nCat == 3) then + iice_dest = catdest_rimesplinter_n3 + elseif (nCat == 4) then + iice_dest = catdest_rimesplinter_n4 + elseif (nCat == 5) then + iice_dest = catdest_rimesplinter_n5 + elseif (nCat == 6) then + iice_dest = catdest_rimesplinter_n6 + endif + endif + if (global_status /= STATUS_OK) return else iice_dest = 1 endif + ! category-order-invariant Hallett-Mossop accumulation: sum the + ! per-source-category splinter production in double precision and apply + ! it to the destination category once after the loop. iice_dest is the + ! (swapped) rimesplinter destination, so the original fixed-slot-order + ! sum over source categories was a category-relabeling roundoff seed. + qcmul_dp = 0.d0 + qrmul_dp = 0.d0 + nimul_dp = 0.d0 + iice_loop_HM: do iice = 1,nCat - ice_present: if (qitot(i,k,iice)-qiliq(i,k,iice) .ge. qsmall) then + ice_present: if (qitot(i,k,iice)-qiliq(i,k,iice) .ge. qsmall .and. nitot(i,k,iice) .ge. nsmall) then tmp1 = qirim(i,k,iice)/(qitot(i,k,iice)-qiliq(i,k,iice)) ! rime fraction tmp2 = qiliq(i,k,iice)/qitot(i,k,iice) ! liquid fraction + ! DTD: hm_opt selects which riming source(s) may splinter; at least + ! one enabled source must actually be collecting for the block to do + ! anything, so the source positivity tests are folded in here (and + ! repeated per branch below). HM_conditions_met: if (diam_ice(i,k,iice).ge.Dmin_HM .and. & tmp1.gt.0.5 .and. & - tmp2.lt.0.1 .and. & -! qccol(iice).gt.0. .and. & - qrcol(iice).gt.0.) then + tmp2.lt.0.1 .and. & ! tmp2.lt.0.1 .and. & DTD: changed to 0.01 + ( (hm_cloud .and. qccol(iice).gt.0.) .or. & + (hm_rain .and. qrcol(iice).gt.0.) ) ) then if (t(i,k).lt.270.15 .and. t(i,k).gt.268.15) then dum = (270.15-t(i,k))*0.5 @@ -3468,33 +4342,39 @@ SUBROUTINE p3_main(qc,nc,qr,nr,th_old,th,qv_old,qv,dt,qitot,qirim,qiliq,nitot,bi dum = (t(i,k)-265.15)*thrd endif - !rime splintering from riming of cloud droplets: - ! (commented out to exclude rime splintering from accretion of cloud, - ! but code is retained in case of possible future use) -! dum1 = 35.e+4*qccol(iice)*dum*1000. ! 1000 is to convert kg to g -! dum2 = dum1*piov6*900.*Dinit_HM**3 -! qccol(iice) = qccol(iice)-dum2 ! subtract splintering from rime mass transfer -! if (qccol(iice) .lt. 0.) then -! dum2 = qccol(iice) + dum2 -! qccol(iice) = 0. -! endif -! qcmul(iice_dest) = qcmul(iice_dest) + dum2 -! nimul(iice_dest) = nimul(iice_dest) + dum1 - - !rime splintering from riming of rain: - dum1 = 35.e+4*qrcol(iice)*dum*1000. ! 1000 is to convert kg to g - dum2 = dum1*piov6*900.*Dinit_HM**3 - dum3 = (qrcol(iice)-dum2)/qrcol(iice) - qrcol(iice) = qrcol(iice) - dum2 ! subtract splintering from rime mass transfer - if (log_3momentIce) then - zqrcol(iice) = dum3*zqrcol(iice) - endif - if (qrcol(iice) .lt. 0.) then - dum2 = qrcol(iice) + dum2 - qrcol(iice) = 0. + !rime splintering from riming of cloud droplets: (hm_opt = 1 or 3) + if (hm_cloud .and. qccol(iice).gt.0.) then + dum1 = 35.e+4*qccol(iice)*dum*1000. ! 1000 is to convert kg to g + dum2 = dum1*piov6*900.*Dinit_HM**3 + dum3 = (qccol(iice)-dum2)/qccol(iice) + qccol(iice) = qccol(iice)-dum2 ! subtract splintering from rime mass transfer + if (log_3momentIce) then + zqccol(iice) = dum3*zqccol(iice) + endif + if (qccol(iice) .lt. 0.) then + dum2 = qccol(iice) + dum2 + qccol(iice) = 0. + endif + qcmul_dp = qcmul_dp + dble(dum2) + nimul_dp = nimul_dp + dble(dum1) + endif + + !rime splintering from riming of rain: (hm_opt = 2 or 3) + if (hm_rain .and. qrcol(iice).gt.0.) then + dum1 = 35.e+4*qrcol(iice)*dum*1000. ! 1000 is to convert kg to g + dum2 = dum1*piov6*900.*Dinit_HM**3 + dum3 = (qrcol(iice)-dum2)/qrcol(iice) + qrcol(iice) = qrcol(iice) - dum2 ! subtract splintering from rime mass transfer + if (log_3momentIce) then + zqrcol(iice) = dum3*zqrcol(iice) + endif + if (qrcol(iice) .lt. 0.) then + dum2 = qrcol(iice) + dum2 + qrcol(iice) = 0. + endif + qrmul_dp = qrmul_dp + dble(dum2) + nimul_dp = nimul_dp + dble(dum1) endif - qrmul(iice_dest) = qrmul(iice_dest) + dum2 - nimul(iice_dest) = nimul(iice_dest) + dum1 endif HM_conditions_met @@ -3502,6 +4382,11 @@ SUBROUTINE p3_main(qc,nc,qr,nr,th_old,th,qv_old,qv,dt,qitot,qirim,qiliq,nitot,bi enddo iice_loop_HM + ! apply the deferred, category-order-invariant HM accumulation once + qcmul(iice_dest) = qcmul(iice_dest) + sngl(qcmul_dp) + qrmul(iice_dest) = qrmul(iice_dest) + sngl(qrmul_dp) + nimul(iice_dest) = nimul(iice_dest) + sngl(nimul_dp) + endif calc_HM @@ -3512,7 +4397,11 @@ SUBROUTINE p3_main(qc,nc,qr,nr,th_old,th,qv_old,qv,dt,qitot,qirim,qiliq,nitot,bi ! Note (BUG): is *iSPF(k) necessary here (epsr is in-precip anyway) !calculate rain evaporation including ventilation - if (qr(i,k)*iSPF(k).ge.qsmall) then + ! TEMPORARY (log_nrfloor): nr condition guards the division by lamr below; + ! the existing else sets epsr = 0, so number-less rain simply does not + ! contribute to the supersaturation relaxation (and cannot evaporate) + if (qr(i,k)*iSPF(k).ge.qsmall .and. & + (log_nrfloor .or. nr(i,k)*iSPF(k).ge.nsmall)) then call find_lookupTable_indices_3(dumii,dumjj,dum1,rdumii,rdumjj,inv_dum3,mu_r(i,k),lamr(i,k)) !interpolate value at mu_r dum1 = revap_table(dumii,dumjj)+(rdumii-real(dumii))* & @@ -3529,7 +4418,7 @@ SUBROUTINE p3_main(qc,nc,qr,nr,th_old,th,qv_old,qv,dt,qitot,qirim,qiliq,nitot,bi epsr = 0. endif - if (qc(i,k).ge.qsmall) then + if (qc(i,k).ge.qsmall .and. nc(i,k).ge.nsmall) then epsc = 2.*pi*rho(i,k)*dv*cdist(i,k) else epsc = 0. @@ -3589,7 +4478,7 @@ SUBROUTINE p3_main(qc,nc,qr,nr,th_old,th,qv_old,qv,dt,qitot,qirim,qiliq,nitot,bi ! endif !endif - xx = max(1.e-20,xx) ! set lower bound on xx to prevent division by zero + xx = max(1.e-30,xx) ! set lower bound on xx to prevent division by zero. DTD changed 1.e-20 to 1.e-30 oxx = 1./xx if (.not. scpf_ON) then @@ -3612,14 +4501,16 @@ SUBROUTINE p3_main(qc,nc,qr,nr,th_old,th,qv_old,qv,dt,qitot,qirim,qiliq,nitot,bi !Note (BUG) the following three bug fixed change the solution with scpf_on=.false. - if (qc(i,k).ge.qsmall) & + if (qc(i,k).ge.qsmall .and. nc(i,k).ge.nsmall) & !Note (BUG): Cholette (Jul 2022), remove *SCF(k) for ssat_cld and multiplication *CF for grid-mean qccon ! qccon = ((aaa*epsc*oxx+(ssat_cld-aaa*oxx)*odt*epsc*oxx*(1.-sngl(dexp(-dble(xx*dt)))))/ab)*SCF(k) - qccon = (aaa*epsc*oxx+(ssat_cld*SCF(k)-aaa*oxx)*odt*epsc*oxx*(1.-sngl(dexp(-dble(xx*dt)))))/ab - if (qr(i,k).ge.qsmall) & + ! DTD: updated to use double precision for part of the calculation to fix thresholding issues with small values of qc + qccon = (aaa*epsc*oxx+(ssat_cld*SCF(k)-aaa*oxx)*odt*epsc*oxx*(1.d0-dexp(-dble(xx*dt))))/ab + if (qr(i,k).ge.qsmall .and. nr(i,k).ge.nsmall) & !Note (BUG): Cholette (Jul 2022), remove *SPF(k) for ssat_r and multiplication *SPF for grid-mean qccon ! qrcon = ((aaa*epsr*oxx+(ssat_r-aaa*oxx)*odt*epsr*oxx*(1.-sngl(dexp(-dble(xx*dt)))))/ab)*SPF(k) - qrcon = (aaa*epsr*oxx+(ssat_r*SPF(k)-aaa*oxx)*odt*epsr*oxx*(1.-sngl(dexp(-dble(xx*dt)))))/ab + ! DTD: updated to use double precision for part of the calculation to fix thresholding issues with small values of qr + qrcon = (aaa*epsr*oxx+(ssat_r*SPF(k)-aaa*oxx)*odt*epsr*oxx*(1.d0-dexp(-dble(xx*dt))))/ab !evaporate instantly for very small water contents if (sup_cld.lt.-0.001 .and. qc(i,k).lt.1.e-12) qccon = -qc(i,k)*odt @@ -3641,24 +4532,45 @@ SUBROUTINE p3_main(qc,nc,qr,nr,th_old,th,qv_old,qv,dt,qitot,qirim,qiliq,nitot,bi qrcon = min(qrcon, qv(i,k)*odt) endif + if (debug_on) then + location_ind = 260 + force_abort =.false. + tmparr1(i,k:k) = th(i,k:k)*(pres(i,k:k)*1.e-5)**(rd*inv_cp) + if (log_3momentIce) then + call check_values(qv(i,k:k),tmparr1(i,k:k),qc(i,k:k),nc(i,k:k),qr(i,k:k),nr(i,k:k),qitot(i,k:k,:), & + qirim(i,k:k,:),nitot(i,k:k,:),birim(i,k:k,:),i,it,force_abort,location_ind, & + Zitot=zitot(i,k:k,:),Qiliq=qiliq(i,k:k,:)) + else + call check_values(qv(i,k:k),tmparr1(i,k:k),qc(i,k:k),nc(i,k:k),qr(i,k:k),nr(i,k:k),qitot(i,k:k,:), & + qirim(i,k:k,:),nitot(i,k:k,:),birim(i,k:k,:),i,it,force_abort,location_ind, & + Qiliq=qiliq(i,k:k,:)) + endif + if (global_status /= STATUS_OK) return + endif + iice_loop_depsub: do iice = 1,nCat ! if (log_LiquidFrac) then - if (qitot(i,k,iice).ge.qsmall .and. (qiliq(i,k,iice)/qitot(i,k,iice)).lt.0.01) then + if (qitot(i,k,iice).ge.qsmall .and. nitot(i,k,iice).ge.nsmall) then + if ( (qiliq(i,k,iice)/qitot(i,k,iice)).lt.0.01) then ! ERM split off second part into separate if ! Sublimation/deposition of ice !note: diffusional growth/decay rate: (stored as 'qidep' temporarily; may go to qisub below) !Note (BUG): Cholette (Jul 2022), remove *SCF(k) for ssat_cld and multiplication *CF for grid-mean qccon ! qidep(iice) = ((aaa*epsi(iice)*oxx+(ssat_cld-aaa*oxx)*odt*epsi(iice)*oxx* & ! (1.-dexp(-dble(xx*dt))))*oabi+(qvs(i,k)-dumqvi)*epsi(iice)*oabi)*SCF(k) + ! DTD: updated to use double precision for part of the calculation to fix thresholding issues with small values of qi qidep(iice) = (aaa*epsi(iice)*oxx+(ssat_cld*SCF(k)-aaa*oxx)*odt*epsi(iice)*oxx* & - (1.-dexp(-dble(xx*dt))))*oabi+(qvs(i,k)-dumqvi)*epsi(iice)*oabi + (1.d0-dexp(-dble(xx*dt))))*oabi+(qvs(i,k)-dumqvi)*epsi(iice)*oabi + endif ! ERM inner if/else endif - !for very small ice contents in dry air, sublimate all ice instantly - if (supi_cld.lt.-0.001 .and. qitot(i,k,iice).lt.1.e-12 .and. qitot(i,k,iice).ge.qsmall .and. & - (qiliq(i,k,iice)/qitot(i,k,iice)).lt.0.01) & + !for very small ice contents in dry air, sublimate all ice instantly. DTD: check if we need an nitot check here + if (supi_cld.lt.-0.001 .and. qitot(i,k,iice).lt.1.e-12 .and. qitot(i,k,iice).ge.qsmall .and. nitot(i,k,iice).ge.nsmall) then ! ERM split off second part into separate if + if (qiliq(i,k,iice)/qitot(i,k,iice).lt.0.01) then qidep(iice) = -(qitot(i,k,iice)-qiliq(i,k,iice))*odt + endif + endif !note: 'clbfact_dep' and 'clbfact_sub' calibration factors for ice deposition and sublimation ! These are adjustable ad hoc factors used to increase or decrease deposition and/or @@ -3687,18 +4599,21 @@ SUBROUTINE p3_main(qc,nc,qr,nr,th_old,th,qv_old,qv,dt,qitot,qirim,qiliq,nitot,bi endif - if (qitot(i,k,iice).ge.qsmall .and. (qiliq(i,k,iice)/qitot(i,k,iice)).ge.0.01) then + if (qitot(i,k,iice).ge.qsmall .and. nitot(i,k,iice).ge.nsmall) then + if ((qiliq(i,k,iice)/qitot(i,k,iice)).ge.0.01) then ! ERM split off second part into separate if ! Condensation/evaporation fo qiliq !Note (BUG) Cholette (Jul 2022), remove *SCF(k) for ssat_cld and multiplication *CF for grid-mean qccon ! qlcon(iice) = ((aaa*epsiw(iice)*oxx+(ssat_cld-aaa*oxx)*odt*epsiw(iice)*oxx* & ! (1.-dexp(-dble(xx*dt))))/ab)*SCF(k) + ! DTD: updated to use double precision for part of the calculation to fix thresholding issues with small values of qi qlcon(iice) = (aaa*epsiw(iice)*oxx+(ssat_cld*SCF(k)-aaa*oxx)*odt*epsiw(iice)*oxx* & - (1.-dexp(-dble(xx*dt))))/ab + (1.d0-dexp(-dble(xx*dt))))/ab + endif ! ERM inner if/else + endif + ! DTD: check if we need an nitot check here + if (sup_cld.lt.-0.001 .and. qitot(i,k,iice).lt.1.e-12 .and. qitot(i,k,iice).ge.qsmall .and. nitot(i,k,iice).ge.nsmall) then ! ERM split off second part into separate if + if ( (qiliq(i,k,iice)/qitot(i,k,iice)).ge.0.01) qlcon(iice) = -qiliq(i,k,iice)*odt endif - - if (sup_cld.lt.-0.001 .and. qitot(i,k,iice).lt.1.e-12 .and. qitot(i,k,iice).ge.qsmall .and. & - (qiliq(i,k,iice)/qitot(i,k,iice)).ge.0.01) & - qlcon(iice) = -qiliq(i,k,iice)*odt if (qlcon(iice).lt.0.) then qlevp(iice) = -qlcon(iice) @@ -3713,8 +4628,10 @@ SUBROUTINE p3_main(qc,nc,qr,nr,th_old,th,qv_old,qv,dt,qitot,qirim,qiliq,nitot,bi else qlcon(iice) = min(qlcon(iice), qv(i,k)*odt) - if (log_3momentIce.and.epsiw(iice).gt.0..and.(qiliq(i,k,iice)/qitot(i,k,iice)).ge.0.01) then - zidep(iice) = epsiz(iice)/epsiw(iice)*qlcon(iice) + if (log_3momentIce.and.epsiw(iice).gt.0.) then ! split conditional: .and. does not + if ((qiliq(i,k,iice)/qitot(i,k,iice)).ge.0.01) then ! short-circuit, so the division + zidep(iice) = epsiz(iice)/epsiw(iice)*qlcon(iice) ! was 0/0 at empty categories + endif endif endif @@ -3765,6 +4682,23 @@ SUBROUTINE p3_main(qc,nc,qr,nr,th_old,th,qv_old,qv,dt,qitot,qirim,qiliq,nitot,bi enddo iice_loop_depsub + if (debug_on) then + location_ind = 270 + force_abort =.false. + tmparr1(i,k:k) = th(i,k:k)*(pres(i,k:k)*1.e-5)**(rd*inv_cp) + if (log_3momentIce) then + call check_values(qv(i,k:k),tmparr1(i,k:k),qc(i,k:k),nc(i,k:k),qr(i,k:k),nr(i,k:k),qitot(i,k:k,:), & + qirim(i,k:k,:),nitot(i,k:k,:),birim(i,k:k,:),i,it,force_abort,location_ind, & + Zitot=zitot(i,k:k,:),Qiliq=qiliq(i,k:k,:)) + else + call check_values(qv(i,k:k),tmparr1(i,k:k),qc(i,k:k),nc(i,k:k),qr(i,k:k),nr(i,k:k),qitot(i,k:k,:), & + qirim(i,k:k,:),nitot(i,k:k,:),birim(i,k:k,:),i,it,force_abort,location_ind, & + Qiliq=qiliq(i,k:k,:)) + endif + if (global_status /= STATUS_OK) return + endif + + 444 continue @@ -3780,21 +4714,50 @@ SUBROUTINE p3_main(qc,nc,qr,nr,th_old,th,qv_old,qv,dt,qitot,qirim,qiliq,nitot,bi sup_cld = Qv_cld(k)/qvs(i,k)-1.!in-cloud sub/sur-saturation w.r.t. liq in % endif - if (t(i,k).lt.258.15 .and. supi_cld.ge.0.05) then -! dum = exp(-0.639+0.1296*100.*supi(i,k))*1000.*inv_rho(i,k) !Meyers et al. (1992) - dum = 0.005*exp(0.304*(273.15-t(i,k)))*1000.*inv_rho(i,k) !Cooper (1986) + ! ERM modified logic below to choose between either Meyers or Cooper approach + if ( ( ( iparamice == 1 .and. t(i,k).lt.258.15) .or. & + ( iparamice == 2 .and. t(i,k).lt.268.15) ) & + .and. supi_cld.ge.0.05) then + if (iparamice == 1 ) then + dum = 0.005*exp(0.304*(273.15-t(i,k)))*1000./rho00 ! *inv_rho(i,k) !Cooper (1986) + elseif (iparamice == 2 ) then + dum = exp(-0.639+0.1296*100.*supi(i,k))*1000./rho00 ! *inv_rho(i,k) !Meyers et al. (1992) + endif ! dum = 0.005*dexp(dble(0.304*(273.15-t(i,k))))*1000.*inv_rho(i,k) !Cooper (1986) dum = min(dum,100.e3*inv_rho(i,k)*SCF(k)) - N_nuc = max(0.,(dum-sum(nitot(i,k,:)))*odt) + ! category-order-invariant (permanent): + ! total ice number computed once, in double precision + nitotsum_dp = sum(dble(nitot(i,k,:))) + N_nuc = max(0.,(dum-sngl(nitotsum_dp))*odt) if (N_nuc.ge.1.e-20) then - Q_nuc = max(0.,(dum-sum(nitot(i,k,:)))*mi0*odt) + Q_nuc = max(0.,(dum-sngl(nitotsum_dp))*mi0*odt) if (nCat>1) then !determine destination ice-phase category: - dum1 = 900. !density of new ice - D_new = ((Q_nuc*6.)/(pi*dum1*N_nuc))**thrd - call icecat_destination(qitot(i,k,:)*iSCF(k),diam_ice(i,k,:),D_new,deltaD_init,iice_dest) - if (global_status /= STATUS_OK) return + if (.not. cat_init_new) then + dum1 = 900. !density of new ice + D_new = ((Q_nuc*6.)/(pi*dum1*N_nuc))**thrd + ! ERM begin + IF ( merge_opt == -1 .and. nCat == 2 ) THEN + iice_dest = 2 + ELSE + call icecat_destination(qitot(i,k,:)*iSCF(k),diam_ice(i,k,:),D_new,deltaD_init,iice_dest) + ENDIF + ! ERM end (call of icecat_destination is still there in original of course) + else + if (nCat == 2) then + iice_dest = catdest_depnuc_n2 + elseif (nCat == 3) then + iice_dest = catdest_depnuc_n3 + elseif (nCat == 4) then + iice_dest = catdest_depnuc_n4 + elseif (nCat == 5) then + iice_dest = catdest_depnuc_n5 + elseif (nCat == 6) then + iice_dest = catdest_depnuc_n6 + endif + endif + if (global_status /= STATUS_OK) return else iice_dest = 1 endif @@ -3803,6 +4766,21 @@ SUBROUTINE p3_main(qc,nc,qr,nr,th_old,th,qv_old,qv,dt,qitot,qirim,qiliq,nitot,bi endif endif + if (debug_on) then + location_ind = 280 + force_abort =.false. + tmparr1(i,k:k) = th(i,k:k)*(pres(i,k:k)*1.e-5)**(rd*inv_cp) + if (log_3momentIce) then + call check_values(qv(i,k:k),tmparr1(i,k:k),qc(i,k:k),nc(i,k:k),qr(i,k:k),nr(i,k:k),qitot(i,k:k,:), & + qirim(i,k:k,:),nitot(i,k:k,:),birim(i,k:k,:),i,it,force_abort,location_ind, & + Zitot=zitot(i,k:k,:),Qiliq=qiliq(i,k:k,:)) + else + call check_values(qv(i,k:k),tmparr1(i,k:k),qc(i,k:k),nc(i,k:k),qr(i,k:k),nr(i,k:k),qitot(i,k:k,:), & + qirim(i,k:k,:),nitot(i,k:k,:),birim(i,k:k,:),i,it,force_abort,location_ind, & + Qiliq=qiliq(i,k:k,:)) + endif + if (global_status /= STATUS_OK) return + endif !................................................................. ! droplet activation @@ -3837,7 +4815,11 @@ SUBROUTINE p3_main(qc,nc,qr,nr,th_old,th,qv_old,qv,dt,qitot,qirim,qiliq,nitot,bi dum2 = nanew2*0.5*(1.-derf(uu2)) ! activated number in kg-1 mode 2 ! make sure this value is not greater than total number of aerosol dum2 = min((nanew1+nanew2),dum1+dum2) - dum2 = (dum2-nc(i,k)*iSCF(k))*odt*SCF(k) + if (ccn_on > 0) then + dum2 = (dum2-cn(i,k)*iSCF(k))*odt*SCF(k) ! ERM changed from nc to cn + else + dum2 = (dum2-nc(i,k)*iSCF(k))*odt*SCF(k) + endif dum2 = max(0.,dum2) ncnuc = dum2 ! don't include mass increase from droplet activation during first time step @@ -3867,22 +4849,63 @@ SUBROUTINE p3_main(qc,nc,qr,nr,th_old,th,qv_old,qv,dt,qitot,qirim,qiliq,nitot,bi if (qccon.le.1.e-7) qccon = 0. endif + if(isnan(qcaut)) then + print*,'qcaut is NaN before autoconversion i=',i,' k=',k + print*,'iparam=',iparam,' qc=',qc(i,k),' nc=',nc(i,k) + ! stop + endif + !................................................................ ! autoconversion - + ! ERM begin + if (iparam.eq.5) then + alphar = 0.0 + erw = 1.0 + if ( qr(i,k) > qsmall .and. nr(i,k) > nsmall ) then + xvr = Max((4./3.)*pi*(10.e-6)**3, qr(i,k)/(nr(i,k)*1000.)) + rwrad = 0.5*(6.*xvr/pi)**(1./3.) + diag_3d(i,k,3) = 1000.*rwrad + else + xvr = 0.0 + rwrad = 0.0 + endif + else + if ( qr(i,k) > qsmall .and. nr(i,k) > nsmall ) then + xvr = Max((4./3.)*pi*(10.e-6)**3, qr(i,k)/(nr(i,k)*1000.)) + rwrad = 0.5*(6.*xvr/pi)**(1./3.) + diag_3d(i,k,3) = 1000.*rwrad + endif + endif + ! ERM end !Note (BUG), needs to be in-cloud condition - qc_not_small_1: if (qc(i,k)*iSCF(k).ge.1.e-8) then + ! TEMPORARY (log_nifloor): the iparam=5 (Cohard-Pinty) branch forms + ! xvc = qc/(nc*1000) below, so nc=0 gives xvc=Inf and then qcacc = 0*Inf = NaN. + ! The rain-side equivalents at the top of this block already test nr > nsmall; + ! the cloud side never tested nc. The else branch already zeroes xvc. + qc_not_small_1: if (qc(i,k)*iSCF(k).ge.qsmall .and. & + (log_nifloor .or. nc(i,k)*iSCF(k).ge.nsmall)) then ! DTD changed to use qsmall if (iparam.eq.1) then !Seifert and Beheng (2001) dum = 1.-qc(i,k)*iSCF(k)/(qc(i,k)*iSCF(k)+qr(i,k)*iSPF(k)*(SPF(k)-SPF_clr(k))) dum1 = 600.*dum**0.68*(1.-dum**0.68)**3 - qcaut = kc*1.9230769e-5*(nu(i,k)+2.)*(nu(i,k)+4.)/(nu(i,k)+1.)**2* & + if(dum .lt. 1.) then + qcaut = kc*1.9230769e-5*(nu(i,k)+2.)*(nu(i,k)+4.)/(nu(i,k)+1.)**2* & (rho(i,k)*qc(i,k)*iSCF(k)*1.e-3)**4/ & (rho(i,k)*nc(i,k)*iSCF(k)*1.e-6)**2*(1.+ & dum1/(1.-dum)**2)*1000.*inv_rho(i,k)*SCF(k) + else + qcaut = 0.0 + endif + if(isnan(qcaut)) then + print*,'Error: NaN detected in autoconversion calculation at i=',i,' k=',k + print*,'iSCF=',iSCF(k),'qc=',qc(i,k),' nc=',nc(i,k),' rho=',rho(i,k),'SCF=',SCF(k) + print*,'qr=',qr(i,k),' SPF=',SPF(k),' SPF_clr=',SPF_clr(k),' nu=',nu(i,k) + print*,'dum=',dum,' dum1=',dum1,' kc=',kc,' inv_rho=',inv_rho(i,k) + stop + endif ncautc = qcaut*7.6923076e+9 elseif (iparam.eq.2) then @@ -3910,6 +4933,11 @@ SUBROUTINE p3_main(qc,nc,qr,nr,th_old,th,qv_old,qv,dt,qitot,qirim,qiliq,nitot,bi !Khroutdinov and Kogan (2000) dum = qc(i,k)*iSCF(k) qcaut = 1350.*dum**2.47*(nc(i,k)*iSCF(k)*1.e-6*rho(i,k))**(-1.79)*SCF(k) + if(isnan(qcaut)) then + print*,'Error: NaN detected in autoconversion calculation at i=',i,' k=',k + print*,'iSCF=',iSCF(k),'qc=',qc(i,k),' nc=',nc(i,k),' rho=',rho(i,k),'SCF=',SCF(k) + stop + endif ! note: ncautr is change in Nr; ncautc is change in Nc ncautr = qcaut*cons3 ncautc = qcaut*nc(i,k)/qc(i,k) @@ -3921,18 +4949,117 @@ SUBROUTINE p3_main(qc,nc,qr,nr,th_old,th,qv_old,qv,dt,qitot,qirim,qiliq,nitot,bi qcaut = 7.98e10*dum**4.22*(nc(i,k)*iSCF(k)*1.e-6*rho(i,k))**(-3.01)*SCF(k) ncautr = qcaut*cons8 ncautc = qcaut*nc(i,k)/qc(i,k) + ! ERM begin adding Cohard and Pinty autoconversion + elseif (iparam.eq.5) then + ! Cohard and Pinty (2000) + xvc = qc(i,k)/(nc(i,k)*1000.) + + alphac = 0.0 + + xdiac = ((6.*xvc)/pi)**thrd + rb = 0.5*xdiac*(1./(1.+alphac))**(1./6.) + xl2p = Max(0.0d0, 2.7e-2*900.0*rho(i,k)*nc(i,k)*xvc* & + & ((0.5e20*rb**3*xdiac)-0.4) ) + IF ( rb .gt. 3.51e-6 ) THEN + rh = Max( 41.d-6, 6.3d-4/(1.d6*(rb - 3.5d-6)) ) + ELSE + rh = 41.d-6 + ENDIF + IF ( xl2p .gt. 0.0 ) THEN + nh = 4.2d9*xl2p + ELSE + nh = 1.e30 + ENDIF + + !volb = xvc*(1./(1.+alphac))**(1./2.) + ncautc = Max(0.0, ((alphac+2.)/(alphac+1.))*aa1*rho(i,k)*(nc(i,k))**2*xvc**2 ) + + IF ( rb .le. 7.51d-6 ) THEN + t2s = 1.d30 + qcaut = 0.0 + ncautr = 0.0 + ncslf = -ncautc + ELSE + t2s = 3.72/(1.e6*(rb-7.500d-6)*rho(i,k)*qc(i,k)) + + qcaut = Max( 0.0d0, xl2p/(t2s*rho(i,k)) ) + + IF ( qr(i,k)*rho(i,k) > 1.2*xl2p .and. rho(i,k)*nc(i,k) > 1.e-8 ) THEN ! Cohard and Pinty (2000a) switch over from (18) to (19) + ncautr = nr(i,k)/qr(i,k)*qcaut + ELSE + ncautr = Max( 0.0d0, Min(3.5e9*xl2p/t2s*inv_rho(i,k),0.5*ncautc) ) + ENDIF + ncslf = 0.0 + ENDIF + +! IF ( i == 15 ) write(6,*) 'ncautr,k = ',k,ncautr,qc(i,k),nc(i,k),ncautc,xvc + + IF ( qr(i,k) > qsmall .and. qr(i,k)*rho(i,k) > 1.2*xl2p ) THEN + ! xvr = Max((4./3.)*pi*(40.e-6)**3, qr(i,k)/(nr(i,k)*900.)) + + ! accretion-branch trace for the targeted point dump. Codes: + ! 0 = block never reached (qc_not_small_1 skipped, or the outer + ! qr > qsmall .and. qr*rho > 1.2*xl2p test failed) + ! 2 = reached, but rwrad <= rh, so no accretion + ! 3 = large-drop branch: qcacc linear in xvr + ! 4 = small-drop branch: qcacc in xvr**2, hence ~ 1/nr**2 + if (dbgpt_i .gt. 0) then + dbg_accbr(k) = 2. + dbg_rwrad(k) = rwrad + dbg_xvr(k) = xvr + endif + IF ( rwrad > rh ) THEN + + IF ( rwrad > 50.e-6 ) THEN + if (dbgpt_i .gt. 0) dbg_accbr(k) = 3. + ncacc = aa2*nr(i,k)*(rho(i,k)*nc(i,k))*(xvc + xvr) + + ! IF ( qr(i,k)*rho(i,k) > 1.2*xl2p ) THEN + qcacc = erw*aa2*nr(i,k)*rho(i,k)*qc(i,k)* & + & ((alphac + 2.)*xvc/(alphac + 1.) + xvr) !*rhoinv(mgs) + ELSE + if (dbgpt_i .gt. 0) dbg_accbr(k) = 4. + qcacc = aa1*nc(i,k)*rho(i,k)*qc(i,k)* & + & ((alphac + 3.)*(alphac + 2.)*xvc**2/(alphac + 1.)**2 + & + & (alphar + 6.)*(alphar + 5.)*(alphar + 4.)*xvr**2/ & + & ((alphar + 3.)*(alphar + 2.)*(alphar + 1.))) + + ncacc = aa1*nr(i,k)*nc(i,k)*rho(i,k)* & + & ((alphac + 2.)*xvc**2/(alphac + 1.) + & + & (alphar + 6.)*(alphar + 5.)*(alphar + 4.)*xvr**2/ & + & ((alphar + 3.)*(alphar + 2.)*(alphar + 1.)) ) + ENDIF ! rwrad + + ! ncacc = Min(ncacc, 0.10*nc(i,k)*odt ) + ! qcacc = Min(qcacc, 0.10*qc(i,k)*odt ) + + ENDIF ! rwrad > rh + ENDIF ! qr > qsmall + ! ERM end Cohard and Pinty endif + if (dbgpt_i .gt. 0) dbg_qcacc_r(k) = qcacc ! raw rate, before the conservation limiters + if (qcaut .eq.0.) ncautc = 0. if (ncautc.eq.0.) qcaut = 0. + else ! ERM Cohard and Pinty + if (iparam.eq.5) then + xvc = 0.0 + endif endif qc_not_small_1 + if(isnan(qcaut)) then + print*,'qcaut is NaN after autoconversion i=',i,' k=',k + print*,'iparam=',iparam,' qc=',qc(i,k),' nc=',nc(i,k) + ! stop + endif + !............................ ! self-collection of droplets - if (qc(i,k).ge.qsmall) then + if (qc(i,k).ge.qsmall .and. nc(i,k).ge.nsmall) then if (iparam.eq.1) then !Seifert and Beheng (2001) @@ -3944,6 +5071,8 @@ SUBROUTINE p3_main(qc,nc,qr,nr,th_old,th,qv_old,qv,dt,qitot,qirim,qiliq,nitot,bi elseif (iparam.eq.3.or.iparam.eq.4) then !Khroutdinov and Kogan (2000) ncslf = 0. + elseif (iparam.eq.5) then ! ERM + ncslf = 0. endif endif @@ -3951,7 +5080,7 @@ SUBROUTINE p3_main(qc,nc,qr,nr,th_old,th,qv_old,qv,dt,qitot,qirim,qiliq,nitot,bi !............................ ! accretion of cloud by rain - if (qr(i,k).ge.qsmall .and. qc(i,k).ge.qsmall) then + if (qr(i,k).ge.qsmall .and. qc(i,k).ge.qsmall .and. nc(i,k).ge.nsmall .and. nr(i,k).ge.nsmall) then if (iparam.eq.1) then !Seifert and Beheng (2001) @@ -3978,6 +5107,9 @@ SUBROUTINE p3_main(qc,nc,qr,nr,th_old,th,qv_old,qv,dt,qitot,qirim,qiliq,nitot,bi dum2 = (SPF(k)-SPF_clr(k)) !in-cloud Precipitation fraction qcacc = 8.53*(qc(i,k)*iSCF(k))**1.05*(qr(i,k)*iSPF(k))**0.98 *dum2 ncacc = qcacc*nc(i,k)/qc(i,k) + elseif (iparam.eq.5) then ! ERM + ! Cohard and Pinty 2000 + ! Done in section with autoconversion endif if (qcacc.eq.0.) ncacc = 0. @@ -3989,11 +5121,11 @@ SUBROUTINE p3_main(qc,nc,qr,nr,th_old,th,qv_old,qv,dt,qitot,qirim,qiliq,nitot,bi ! self-collection and breakup of rain ! (breakup following modified Verlinde and Cotton scheme) - if (qr(i,k).ge.qsmall) then + if (qr(i,k).ge.qsmall .and. nr(i,k) .ge. nsmall ) then ! ERM added nsmall check ! DTD changed from > to .ge. ! include breakup - dum1 = 280.e-6 - nr(i,k) = max(nr(i,k),nsmall) + dum1 = 280.e-6 ! DTD changed to 500.e-6 from 280.e-6. Update: changed back for testing + if ( log_maxnsmall .and. log_nrfloor ) nr(i,k) = max(nr(i,k),ntiny) ! ERM added log_maxnsmall check and using ntiny instead of nsmall ! use mass-mean diameter (do this by using ! the old version of lambda w/o mu dependence) ! note there should be a factor of 6^(1/3), but we @@ -4013,10 +5145,50 @@ SUBROUTINE p3_main(qc,nc,qr,nr,th_old,th,qv_old,qv,dt,qitot,qirim,qiliq,nitot,bi nrslf = dum*5.78*nr(i,k)*iSPF(k)*qr(i,k)*iSPF(k)*rho(i,k)*SPF(k) elseif (iparam.eq.4) then nrslf = dum*205.*(qr(i,k)*iSPF(k))**1.55*(nr(i,k)*1.e-6*rho(i,k)*iSPF(k))**0.6*1.e6/rho(i,k)*SPF(k) ! 1.e6 converts cm-3 to m-3 + elseif (iparam.eq.5) then ! ERM + ! xvr = qr(i,k)/(nr(i,k)*900.) + ! alphar = 0 + ! rwrad = 0.5*((6.*xvr)/pi)**thrd ! (6.*qr(i,k)/(pi*900.*nr(i,k)))**(1./3.) + dum2 = (3.67+alphar)*2.*rwrad + IF ( dum1 > 1.9e-3 ) THEN + dum = 0.0 + ELSE + IF ( 2.*rwrad .lt. 6.1e-4 ) THEN + dum = 1.0 + ELSE + dum = Exp(-50.0*(50.0*(2.*rwrad - 6.0e-4))) + ENDIF + ENDIF + IF ( rwrad .ge. 50.e-6 ) THEN + nrslf = dum*aa2*rho(i,k)*(nr(i,k))**2*xvr + ELSE + nrslf = aa1*rho(i,k)*(nr(i,k)*xvr)**2* & + & (alphar + 6.)*(alphar + 5.)*(alphar + 4.)/ & + & ((alphar + 3.)*(alphar + 2.)*(alphar + 1.)) + + ENDIF +! IF ( i == 15 ) write(6,*) 'nrslf,k = ',k,nrslf,qr(i,k),nr(i,k),dum,rwrad endif endif + if (debug_on) then + location_ind = 290 + force_abort =.false. + tmparr1(i,k:k) = th(i,k:k)*(pres(i,k:k)*1.e-5)**(rd*inv_cp) + if (log_3momentIce) then + call check_values(qv(i,k:k),tmparr1(i,k:k),qc(i,k:k),nc(i,k:k),qr(i,k:k),nr(i,k:k),qitot(i,k:k,:), & + qirim(i,k:k,:),nitot(i,k:k,:),birim(i,k:k,:),i,it,force_abort,location_ind, & + Zitot=zitot(i,k:k,:),Qiliq=qiliq(i,k:k,:)) + else + call check_values(qv(i,k:k),tmparr1(i,k:k),qc(i,k:k),nc(i,k:k),qr(i,k:k),nr(i,k:k),qitot(i,k:k,:), & + qirim(i,k:k,:),nitot(i,k:k,:),birim(i,k:k,:),i,it,force_abort,location_ind, & + Qiliq=qiliq(i,k:k,:)) + endif + if (global_status /= STATUS_OK) return + endif + + !................................................................. ! conservation of mass @@ -4031,6 +5203,8 @@ SUBROUTINE p3_main(qc,nc,qr,nr,th_old,th,qv_old,qv,dt,qitot,qirim,qiliq,nitot,bi tmp1 = qccon+qrcon+qcnuc+sum(qlcon) if (tmp1>0. .and. qcon_satadj<0.) then + if (log_limlog) call limlog_write('SATC0 ',it,i,limlog_j,k,0,0., & + tmp1,qcon_satadj,qccon,qcnuc) qccon = 0. qrcon = 0. qcnuc = 0. @@ -4040,6 +5214,9 @@ SUBROUTINE p3_main(qc,nc,qr,nr,th_old,th,qv_old,qv,dt,qitot,qirim,qiliq,nitot,bi if (tmp1.gt.0. .and. tmp1.gt.qcon_satadj) then ratio = max(0.,qcon_satadj)/tmp1 ratio = min(1.,ratio) + if (log_limlog .and. ratio.lt.limlog_ratmin) & + call limlog_write('SATCR ',it,i,limlog_j,k,0,ratio, & + qcon_satadj,tmp1,qccon,qcnuc) qccon = qccon*ratio qrcon = qrcon*ratio qcnuc = qcnuc*ratio @@ -4048,6 +5225,9 @@ SUBROUTINE p3_main(qc,nc,qr,nr,th_old,th,qv_old,qv,dt,qitot,qirim,qiliq,nitot,bi elseif (qcevp+qrevp+sum(qlevp).gt.0.) then ratio = max(0.,-qcon_satadj)/(qcevp+qrevp+sum(qlevp)) ratio = min(1.,ratio) + if (log_limlog .and. ratio.lt.limlog_ratmin) & + call limlog_write('SATER ',it,i,limlog_j,k,0,ratio, & + -qcon_satadj,qcevp+qrevp+sum(qlevp),qcevp,qrevp) qcevp = qcevp*ratio qrevp = qrevp*ratio nrevp = nrevp*ratio @@ -4062,8 +5242,11 @@ SUBROUTINE p3_main(qc,nc,qr,nr,th_old,th,qv_old,qv,dt,qitot,qirim,qiliq,nitot,bi dumqvi = qv_sat(t_tmp,pres(i,k),1) qdep_satadj = (qv_tmp-dumqvi)/(1.+xxls(i,k)**2*dumqvi/(cp*rv*t_tmp**2))*odt*SCF(k) - tmp1 = sum(qidep)+sum(qinuc) + ! category-order-invariant (permanent; category-order-invariant) + tmp1 = sngl(sum(dble(qidep))+sum(dble(qinuc))) if (tmp1>0. .and. qdep_satadj<0.) then + if (log_limlog) call limlog_write('SATD0 ',it,i,limlog_j,k,0,0., & + tmp1,qdep_satadj,sngl(sum(dble(qidep))),sngl(sum(dble(qinuc)))) qidep = 0. qinuc = 0. ninuc = 0. @@ -4071,13 +5254,19 @@ SUBROUTINE p3_main(qc,nc,qr,nr,th_old,th,qv_old,qv,dt,qitot,qirim,qiliq,nitot,bi if (tmp1.gt.0. .and. tmp1.gt.qdep_satadj) then ratio = max(0.,qdep_satadj)/tmp1 ratio = min(1.,ratio) + if (log_limlog .and. ratio.lt.limlog_ratmin) & + call limlog_write('SATDR ',it,i,limlog_j,k,0,ratio, & + qdep_satadj,tmp1,sngl(sum(dble(qidep))),sngl(sum(dble(qinuc)))) qidep = qidep*ratio qinuc = qinuc*ratio ninuc = ninuc*ratio endif + ! category-order-invariant (permanent; category-order-invariant) + tmp2 = sngl(sum(dble(qisub))) ! DTD sum up qisub *before* changing individual category qisub values below do iice = 1,nCat dum = max(qisub(iice),1.e-20) - qisub(iice) = qisub(iice)*min(1.,max(0.,-qdep_satadj)/max(sum(qisub), 1.e-20)) !optimized (avoids IF(qisub.gt.0.) ) + ! DTD: replaced sum(qisub) with tmp2 to avoid repeated summation (and potential order-dependent results) + qisub(iice) = qisub(iice)*min(1.,max(0.,-qdep_satadj)/max(tmp2, 1.e-20)) !optimized (avoids IF(qisub.gt.0.) ) nisub(iice) = nisub(iice)*min(1.,qisub(iice)/dum) enddo !qchetc = qchetc*min(1.,qc(i,k)*odt/max(sum(qchetc),1.e-20)) !currently not used @@ -4086,11 +5275,16 @@ SUBROUTINE p3_main(qc,nc,qr,nr,th_old,th,qv_old,qv,dt,qitot,qirim,qiliq,nitot,bi ! cloud - sinks = (qcaut+qcacc+sum(qccol)+qcevp+sum(qchetc)+sum(qcheti)+sum(qcshd)+ & - sum(qccoll)+sum(qwgrth1c))*dt + ! category-order-invariant (permanent; category-order-invariant) + sinks = sngl( dble(qcaut)+dble(qcacc)+sum(dble(qccol))+dble(qcevp)+sum(dble(qchetc))+ & + sum(dble(qcheti))+sum(dble(qcshd))+sum(dble(qcmul))+ & + sum(dble(qccoll))+sum(dble(qwgrth1c)) )*dt sources = qc(i,k) + (qccon+qcnuc)*dt if (sinks.gt.sources .and. sinks.ge.1.e-20) then ratio = sources/sinks + if (log_limlog .and. ratio.lt.limlog_ratmin) & + call limlog_write('CLOUD ',it,i,limlog_j,k,0,ratio, & + sources,sinks,qc(i,k),qcaut+qcacc) qcaut = qcaut*ratio qcacc = qcacc*ratio qcevp = qcevp*ratio @@ -4099,6 +5293,7 @@ SUBROUTINE p3_main(qc,nc,qr,nr,th_old,th,qv_old,qv,dt,qitot,qirim,qiliq,nitot,bi qcshd = qcshd*ratio qwgrth1c = qwgrth1c*ratio qccoll = qccoll*ratio + qcmul = qcmul*ratio ! DTD: added qcmul !qchetc = qchetc*ratio !currently not used !if (log_predictNc) then ! note: the conditional is present for strict code logic but commented for efficiency @@ -4113,12 +5308,16 @@ SUBROUTINE p3_main(qc,nc,qr,nr,th_old,th,qv_old,qv,dt,qitot,qirim,qiliq,nitot,bi endif ! rain - sinks = (qrevp+sum(qrcol)+sum(qrhetc)+sum(qrheti)+sum(qrmul)+ & - sum(qrcoll)+sum(qwgrth1r))*dt - sources = qr(i,k) + (qrcon+qcaut+qcacc+sum(qrmlt)+sum(qcshd)+ & - sum(qlshd))*dt + ! category-order-invariant (permanent; category-order-invariant) + sinks = sngl( dble(qrevp)+sum(dble(qrcol))+sum(dble(qrhetc))+sum(dble(qrheti))+ & + sum(dble(qrmul))+sum(dble(qrcoll))+sum(dble(qwgrth1r)) )*dt + sources = qr(i,k) + sngl( dble(qrcon)+dble(qcaut)+dble(qcacc)+sum(dble(qrmlt))+ & + sum(dble(qcshd))+sum(dble(qlshd)) )*dt if (sinks.gt.sources .and. sinks.ge.1.e-20) then ratio = sources/sinks + if (log_limlog .and. ratio.lt.limlog_ratmin) & + call limlog_write('RAIN ',it,i,limlog_j,k,0,ratio, & + sources,sinks,qr(i,k),qrevp) qrevp = qrevp*ratio qrcol = qrcol*ratio qrheti = qrheti*ratio @@ -4138,17 +5337,26 @@ SUBROUTINE p3_main(qc,nc,qr,nr,th_old,th,qv_old,qv,dt,qitot,qirim,qiliq,nitot,bi do iice = 1,nCat sinks = (qisub(iice)+qrmlt(iice)+qlevp(iice)+qlshd(iice))*dt sources = qitot(i,k,iice) + (qidep(iice)+qinuc(iice)+qrcol(iice)+qccol(iice)+ & - qrhetc(iice)+qrheti(iice)+qchetc(iice)+qcheti(iice)+qrmul(iice)+ & + qrhetc(iice)+qrheti(iice)+qchetc(iice)+qcheti(iice)+qcmul(iice)+qrmul(iice)+ & !DTD: added qcmul qrcoll(iice)+qccoll(iice)+qlcon(iice)+qwgrth1c(iice)+qwgrth1r(iice))*dt + ! category-order-invariant qicol summation (exact no-op when + ! log_iceice_interaction=.false., i.e. qicol=0) + tmpdbl1 = 0.d0 + tmpdbl2 = 0.d0 do catcoll = 1,nCat !Note: qicol = 0 if iice=catcoll, optimised to not insert an if (catcoll.ne.iice) !category interaction leading to source for iice category - sources = sources + qicol(catcoll,iice)*dt + tmpdbl1 = tmpdbl1 + dble(qicol(catcoll,iice)*dt) !category interaction leading to sink for iice category - sinks = sinks + qicol(iice,catcoll)*dt + tmpdbl2 = tmpdbl2 + dble(qicol(iice,catcoll)*dt) enddo + sources = sngl(dble(sources) + tmpdbl1) + sinks = sngl(dble(sinks) + tmpdbl2) if (sinks.gt.sources .and. sinks.ge.1.e-20) then ratio = sources/sinks + if (log_limlog .and. ratio.lt.limlog_ratmin) & + call limlog_write('ICE ',it,i,limlog_j,k,iice,ratio, & + sources,sinks,qitot(i,k,iice),qisub(iice)) qisub(iice) = qisub(iice)*ratio qrmlt(iice) = qrmlt(iice)*ratio qlshd(iice) = qlshd(iice)*ratio @@ -4171,15 +5379,24 @@ SUBROUTINE p3_main(qc,nc,qr,nr,th_old,th,qv_old,qv,dt,qitot,qirim,qiliq,nitot,bi sinks = (qifrz(iice)+qlshd(iice)+qlevp(iice))*dt sources = qiliq(i,k,iice) + (qimlt(iice)+qrcoll(iice)+qccoll(iice)+qlcon(iice)+ & qwgrth1c(iice)+qwgrth1r(iice))*dt + ! category-order-invariant qicol summation (exact no-op when + ! log_iceice_interaction=.false., i.e. qicol=0) + tmpdbl1 = 0.d0 + tmpdbl2 = 0.d0 do catcoll = 1,nCat !Note: qicol = 0 if iice=catcoll, optimised to not insert an if (catcoll.ne.iice) !category interaction leading to source for iice category - sources = sources + qicol(catcoll,iice)*dt + tmpdbl1 = tmpdbl1 + dble(qicol(catcoll,iice)*dt) !category interaction leading to sink for iice category - sinks = sinks + qicol(iice,catcoll)*dt + tmpdbl2 = tmpdbl2 + dble(qicol(iice,catcoll)*dt) enddo + sources = sngl(dble(sources) + tmpdbl1) + sinks = sngl(dble(sinks) + tmpdbl2) if (sinks.gt.sources .and. sinks.ge.1.e-20) then ratio = sources/sinks + if (log_limlog .and. ratio.lt.limlog_ratmin) & + call limlog_write('QILIQ ',it,i,limlog_j,k,iice,ratio, & + sources,sinks,qiliq(i,k,iice),qifrz(iice)) qifrz(iice) = qifrz(iice)*ratio qlshd(iice) = qlshd(iice)*ratio qlevp(iice) = qlevp(iice)*ratio @@ -4195,10 +5412,15 @@ SUBROUTINE p3_main(qc,nc,qr,nr,th_old,th,qv_old,qv,dt,qitot,qirim,qiliq,nitot,bi endif ! vapor - sinks = (qccon+qrcon+qcnuc+sum(qidep)+sum(qinuc)+sum(qlcon))*dt - sources = qv(i,k) + (qcevp+qrevp+sum(qisub)+sum(qlevp))*dt + ! category-order-invariant (permanent; category-order-invariant) + sinks = sngl( dble(qccon)+dble(qrcon)+dble(qcnuc)+sum(dble(qidep))+ & + sum(dble(qinuc))+sum(dble(qlcon)) )*dt + sources = qv(i,k) + sngl( dble(qcevp)+dble(qrevp)+sum(dble(qisub))+sum(dble(qlevp)) )*dt if (sinks.gt.sources .and. sinks.ge.1.e-20) then ratio = sources/sinks + if (log_limlog .and. ratio.lt.limlog_ratmin) & + call limlog_write('VAPOR ',it,i,limlog_j,k,0,ratio, & + sources,sinks,qv(i,k),sngl(sum(dble(qidep))+sum(dble(qinuc)))) qccon = qccon*ratio qrcon = qrcon*ratio qcnuc = qcnuc*ratio @@ -4211,6 +5433,22 @@ SUBROUTINE p3_main(qc,nc,qr,nr,th_old,th,qv_old,qv,dt,qitot,qirim,qiliq,nitot,bi !======================================================================================! + if (debug_on) then + location_ind = 291 + force_abort =.false. + tmparr1(i,k:k) = th(i,k:k)*(pres(i,k:k)*1.e-5)**(rd*inv_cp) + if (log_3momentIce) then + call check_values(qv(i,k:k),tmparr1(i,k:k),qc(i,k:k),nc(i,k:k),qr(i,k:k),nr(i,k:k),qitot(i,k:k,:), & + qirim(i,k:k,:),nitot(i,k:k,:),birim(i,k:k,:),i,it,force_abort,location_ind, & + Zitot=zitot(i,k:k,:),Qiliq=qiliq(i,k:k,:)) + else + call check_values(qv(i,k:k),tmparr1(i,k:k),qc(i,k:k),nc(i,k:k),qr(i,k:k),nr(i,k:k),qitot(i,k:k,:), & + qirim(i,k:k,:),nitot(i,k:k,:),birim(i,k:k,:),i,it,force_abort,location_ind, & + Qiliq=qiliq(i,k:k,:)) + endif + if (global_status /= STATUS_OK) return + endif + !--------------------------------------------------------------------------------- ! update prognostic microphysics and thermodynamics variables @@ -4221,7 +5459,7 @@ SUBROUTINE p3_main(qc,nc,qr,nr,th_old,th,qv_old,qv,dt,qitot,qirim,qiliq,nitot,bi ! compute fractions before update (assumed constant during ice-ice coll.) iice_loop2: do iice = 1,nCat - if ((qitot(i,k,iice)-qiliq(i,k,iice)).ge.qsmall) then + if ((qitot(i,k,iice)-qiliq(i,k,iice)).ge.qsmall .and. (nitot(i,k,iice)).ge.nsmall) then tmp1 = 1./(qitot(i,k,iice)-qiliq(i,k,iice)) rimevolume(i,k,iice) = birim(i,k,iice)*tmp1 rimefraction(i,k,iice) = qirim(i,k,iice)*tmp1 @@ -4233,10 +5471,14 @@ SUBROUTINE p3_main(qc,nc,qr,nr,th_old,th,qv_old,qv,dt,qitot,qirim,qiliq,nitot,bi mu_i_s(iice)=mu_i_initial - if (qitot(i,k,iice).ge.qsmall) then + if (qitot(i,k,iice).ge.qsmall .and. nitot(i,k,iice).ge.nsmall & + .and. f1pr16_s(iice).gt.0.) then + ! f1pr16_s check: use THIS category's density from its own lookup + ! this step; if the lookup did not run, keep mu_i_initial rather + ! than consuming another category's stale density (former bug) dumqi=qitot(i,k,iice) dumni=nitot(i,k,iice) - dumden=f1pr16 + dumden=f1pr16_s(iice) dum1 = dumqi*6./(dumden*pi) mu_i = compute_mu_3moment(dumni,dum1,zitot(i,k,iice),mu_i_max) @@ -4252,26 +5494,65 @@ SUBROUTINE p3_main(qc,nc,qr,nr,th_old,th,qv_old,qv,dt,qitot,qirim,qiliq,nitot,bi enddo iice_loop2 + if (debug_on) then + location_ind = 292 + force_abort =.false. + tmparr1(i,k:k) = th(i,k:k)*(pres(i,k:k)*1.e-5)**(rd*inv_cp) + if (log_3momentIce) then + call check_values(qv(i,k:k),tmparr1(i,k:k),qc(i,k:k),nc(i,k:k),qr(i,k:k),nr(i,k:k),qitot(i,k:k,:), & + qirim(i,k:k,:),nitot(i,k:k,:),birim(i,k:k,:),i,it,force_abort,location_ind, & + Zitot=zitot(i,k:k,:),Qiliq=qiliq(i,k:k,:)) + else + call check_values(qv(i,k:k),tmparr1(i,k:k),qc(i,k:k),nc(i,k:k),qr(i,k:k),nr(i,k:k),qitot(i,k:k,:), & + qirim(i,k:k,:),nitot(i,k:k,:),birim(i,k:k,:),i,it,force_abort,location_ind, & + Qiliq=qiliq(i,k:k,:)) + endif + if (global_status /= STATUS_OK) return + endif + + + ! Permutation-invariant fused tendency application (audit sec. 4(c)): + ! accumulate the per-category increments to the SHARED prognostic fields + ! (qc, nc, qr, nr, qv, th) over ice categories in double precision, then + ! apply each shared field once after the loop. The per-category array + ! fields (qitot, qirim, birim, qiliq, nitot) are slot-local and stay in + ! the loop. Each category's increment is formed in single precision + ! exactly as before, so only the cross-category accumulation changes + ! (result now independent of category slot order). + dqc_dp = 0.d0 + dnc_dp = 0.d0 + dqr_dp = 0.d0 + dnr_dp = 0.d0 + dqv_dp = 0.d0 + dth_dp = 0.d0 + ! deferred ice-ice interaction cross-category contributions (all zero, hence + ! an exact no-op, when log_iceice_interaction=.false.) + qitot_col_dp(:) = 0.d0 + qirim_col_dp(:) = 0.d0 + birim_col_dp(:) = 0.d0 + qiliq_col_dp(:) = 0.d0 + nitot_col_dp(:) = 0.d0 + iice_loop3: do iice = 1,nCat - qc(i,k) = qc(i,k) + (-qchetc(iice)-qcheti(iice)-qccol(iice)-qcshd(iice)- & - qccoll(iice)-qwgrth1c(iice))*dt + dqc_dp = dqc_dp + dble((-qchetc(iice)-qcheti(iice)-qccol(iice)-qcshd(iice)-qcmul(iice)- & !DTD: added qcmul + qccoll(iice)-qwgrth1c(iice))*dt) if (log_predictNc) then - nc(i,k) = nc(i,k) + (-nccol(iice)-nchetc(iice)-ncheti(iice)-nccoll(iice))*dt + dnc_dp = dnc_dp + dble((-nccol(iice)-nchetc(iice)-ncheti(iice)-nccoll(iice))*dt) endif - qr(i,k) = qr(i,k) + (-qrcol(iice)+qrmlt(iice)-qrhetc(iice)-qrheti(iice)+ & - qcshd(iice)-qrmul(iice)-qrcoll(iice)+qlshd(iice)-qwgrth1r(iice))*dt + dqr_dp = dqr_dp + dble((-qrcol(iice)+qrmlt(iice)-qrhetc(iice)-qrheti(iice)+ & + qcshd(iice)-qrmul(iice)-qrcoll(iice)+qlshd(iice)-qwgrth1r(iice))*dt) ! apply factor to source for rain number from melting of ice, (ad-hoc ! but accounts for rapid evaporation of small melting ice particles) if (log_LiquidFrac) then - nr(i,k) = nr(i,k) + (-nrcol(iice)-nrhetc(iice)-nrheti(iice)+nimlt(iice)+ & - nrshdr(iice)+ncshdc(iice)-nrcoll(iice)+nlshd(iice))*dt + dnr_dp = dnr_dp + dble((-nrcol(iice)-nrhetc(iice)-nrheti(iice)+nimlt(iice)+ & + nrshdr(iice)+ncshdc(iice)-nrcoll(iice)+nlshd(iice))*dt) else - nr(i,k) = nr(i,k) + (-nrcol(iice)-nrhetc(iice)-nrheti(iice)+nmltratio*nimlt(iice)+ & - nrshdr(iice)+ncshdc(iice))*dt + dnr_dp = dnr_dp + dble((-nrcol(iice)-nrhetc(iice)-nrheti(iice)+nmltratio*nimlt(iice)+ & + nrshdr(iice)+ncshdc(iice))*dt) endif ! if ((qitot(i,k,iice)-qiliq(i,k,iice)).ge.qsmall) then ! not needed in 5.1.1.4.1 @@ -4285,14 +5566,14 @@ SUBROUTINE p3_main(qc,nc,qr,nr,th_old,th,qv_old,qv,dt,qitot,qirim,qiliq,nitot,bi ! endif dum = (qrcol(iice)+qccol(iice)+qrhetc(iice)+qrheti(iice)+ & - qchetc(iice)+qcheti(iice)+qrmul(iice))*dt + qchetc(iice)+qcheti(iice)+qcmul(iice)+qrmul(iice))*dt ! DTD: added qcmul qitot(i,k,iice) = qitot(i,k,iice) + (qidep(iice)+qinuc(iice)-qlshd(iice)- & qlevp(iice)+qlcon(iice)+qwgrth1c(iice)+qwgrth1r(iice)+ & qrcoll(iice)+qccoll(iice))*dt + dum qirim(i,k,iice) = qirim(i,k,iice) + qifrz(iice)*dt + dum birim(i,k,iice) = birim(i,k,iice) + ((qifrz(iice)+qrcol(iice))*inv_rho_rimeMax+ & qccol(iice)/rhorime_c(iice)+(qrhetc(iice)+qrheti(iice)+ & - qchetc(iice)+qcheti(iice)+qrmul(iice))*inv_rho_rimeMax)*dt + qchetc(iice)+qcheti(iice)+qcmul(iice)+qrmul(iice))*inv_rho_rimeMax)*dt ! DTD: added qcmul qiliq(i,k,iice) = qiliq(i,k,iice) + (qrcoll(iice)+qccoll(iice)-qifrz(iice)- & qlshd(iice)+qlcon(iice)-qlevp(iice)+qwgrth1c(iice)+ & qwgrth1r(iice))*dt @@ -4301,39 +5582,74 @@ SUBROUTINE p3_main(qc,nc,qr,nr,th_old,th,qv_old,qv,dt,qitot,qirim,qiliq,nitot,bi nislf(iice)+nrhetc(iice)+nrheti(iice)+nchetc(iice)+ & ncheti(iice)+nimul(iice)-nlevp(iice))*dt - if (nCat.gt.1) then + if (nCat.gt.1 .and. log_iceice_interaction) then interactions_loop: do catcoll = 1,nCat diff_categories: if (iice.ne.catcoll) then ! add ice-ice category interaction collection tendencies ! note: nicol is a sink for the collectee category, but NOT a source for collector + ! + ! category-order-invariant: accumulate the cross-category transfers into + ! per-category double-precision accumulators instead of updating the + ! fields in slot order. qicol/nicol and the rime/volume/liquid + ! fractions are all precomputed (read-only here), so every increment is + ! bit-identical to the original; only the cross-category summation + ! becomes order-invariant. The accumulators are applied once, and the + ! per-category clipping/densification is likewise deferred, to a single + ! pass after iice_loop3 that sees the fully-accumulated fields (so its + ! result no longer depends on which category slot ran first). ! now modify rime mass and density, assume collection does not modify rime or liquid mass ! fractions or density of the collectee, consistent with the assumption that ! these are constant over the PSD - ! if ((qitot(i,k,catcoll)-qiliq(i,k,catcoll)).ge.qsmall) then ! not needed in 5.1.1.4.1 - !source for collector category - qirim(i,k,iice) = qirim(i,k,iice)+qicol(catcoll,iice)*dt* & - rimefraction(i,k,catcoll) - birim(i,k,iice) = birim(i,k,iice)+qicol(catcoll,iice)*dt* & - rimevolume(i,k,catcoll) - qiliq(i,k,iice) = qiliq(i,k,iice)+qicol(catcoll,iice)*dt* & - liquidfraction(i,k,catcoll) - !sink for collectee category - qirim(i,k,catcoll) = qirim(i,k,catcoll)-qicol(catcoll,iice)*dt* & - rimefraction(i,k,catcoll) - birim(i,k,catcoll) = birim(i,k,catcoll)-qicol(catcoll,iice)*dt* & - rimevolume(i,k,catcoll) - qiliq(i,k,catcoll) = qiliq(i,k,catcoll)-qicol(catcoll,iice)*dt* & - liquidfraction(i,k,catcoll) - ! endif - qitot(i,k,catcoll) = qitot(i,k,catcoll) - qicol(catcoll,iice)*dt - nitot(i,k,catcoll) = nitot(i,k,catcoll) - nicol(catcoll,iice)*dt - qitot(i,k,iice) = qitot(i,k,iice) + qicol(catcoll,iice)*dt + !source for collector category (iice) + qirim_col_dp(iice) = qirim_col_dp(iice) + dble(qicol(catcoll,iice)*dt*rimefraction(i,k,catcoll)) + birim_col_dp(iice) = birim_col_dp(iice) + dble(qicol(catcoll,iice)*dt*rimevolume(i,k,catcoll)) + qiliq_col_dp(iice) = qiliq_col_dp(iice) + dble(qicol(catcoll,iice)*dt*liquidfraction(i,k,catcoll)) + !sink for collectee category (catcoll) + qirim_col_dp(catcoll) = qirim_col_dp(catcoll) - dble(qicol(catcoll,iice)*dt*rimefraction(i,k,catcoll)) + birim_col_dp(catcoll) = birim_col_dp(catcoll) - dble(qicol(catcoll,iice)*dt*rimevolume(i,k,catcoll)) + qiliq_col_dp(catcoll) = qiliq_col_dp(catcoll) - dble(qicol(catcoll,iice)*dt*liquidfraction(i,k,catcoll)) + qitot_col_dp(catcoll) = qitot_col_dp(catcoll) - dble(qicol(catcoll,iice)*dt) + nitot_col_dp(catcoll) = nitot_col_dp(catcoll) - dble(nicol(catcoll,iice)*dt) + qitot_col_dp(iice) = qitot_col_dp(iice) + dble(qicol(catcoll,iice)*dt) endif diff_categories enddo interactions_loop ! catcoll loop endif + ! NOTE: the per-category clipping (qirim<0) and wet-growth / melt + ! densification formerly here are deferred to the post-loop pass below, + ! so they act on the fully-accumulated ice-ice interaction fields. + + dqv_dp = dqv_dp + dble((-qidep(iice)+qisub(iice)-qinuc(iice)-qlcon(iice)+ & + qlevp(iice))*dt) + + ! Update theta. Note temperature is not updated here even though it is used below for + ! the homogeneous freezing threshold. This is done for simplicity - the error will be + ! very small and the homogeneous temp. freezing threshold is approximate anyway. + dth_dp = dth_dp + dble(invexn(i,k)*((qidep(iice)-qisub(iice)+qinuc(iice))* & + xxls(i,k)*inv_cp +(qrcol(iice)+qccol(iice)+qchetc(iice)+ & + qcheti(iice)+qrhetc(iice)+qrheti(iice)+qcmul(iice)+ & ! DTD: added qcmul + qrmul(iice)-qrmlt(iice)-qimlt(iice)+qifrz(iice))* & + xlf(i,k)*inv_cp+(qlcon(iice)-qlevp(iice))*xxlv(i,k)* & + inv_cp)*dt) + + enddo iice_loop3 + + ! Apply the deferred ice-ice interaction cross-category contributions (one + ! rounded update per field per category), then do the per-category clipping + ! and wet-growth / melt densification on the fully-accumulated fields. When + ! log_iceice_interaction=.false. every accumulator is zero, so the apply is + ! an exact no-op and this pass is byte-identical to doing the clipping inside + ! iice_loop3. When it is .true., the fields are complete before clipping, so + ! both the transfers and the clipping are invariant to category slot order. + do iice = 1,nCat + qitot(i,k,iice) = sngl(dble(qitot(i,k,iice)) + qitot_col_dp(iice)) + qirim(i,k,iice) = sngl(dble(qirim(i,k,iice)) + qirim_col_dp(iice)) + birim(i,k,iice) = sngl(dble(birim(i,k,iice)) + birim_col_dp(iice)) + qiliq(i,k,iice) = sngl(dble(qiliq(i,k,iice)) + qiliq_col_dp(iice)) + nitot(i,k,iice) = sngl(dble(nitot(i,k,iice)) + nitot_col_dp(iice)) + if (qirim(i,k,iice).lt.0.) then qirim(i,k,iice) = 0. birim(i,k,iice) = 0. @@ -4347,34 +5663,63 @@ SUBROUTINE p3_main(qc,nc,qr,nr,th_old,th,qv_old,qv,dt,qitot,qirim,qiliq,nitot,bi birim(i,k,iice) = qirim(i,k,iice)*inv_rho_rimeMax endif ! densify rimed ice during melting (tend rime density towards solid ice [917 kg m-3]) - if (.not. log_LiquidFrac .and. qitot(i,k,iice).ge.qsmall .and. birim(i,k,iice).ge.bsmall .and. qrmlt(iice)>0.) then + if (.not. log_LiquidFrac .and. qitot(i,k,iice).ge.qsmall .and. nitot(i,k,iice).ge.nsmall .and. birim(i,k,iice).ge.bsmall .and. qrmlt(iice)>0.) then tmp1 = qirim(i,k,iice)/birim(i,k,iice) ! rho_i before densification tmp2 = qitot(i,k,iice) + qrmlt(iice)*dt ! qitot before melting (but after all other updates) birim(i,k,iice) = qirim(i,k,iice)/(tmp1+(917.-tmp1)*qrmlt(iice)*dt/tmp2) endif + enddo - qv(i,k) = qv(i,k) + (-qidep(iice)+qisub(iice)-qinuc(iice)-qlcon(iice)+ & - qlevp(iice))*dt + ! apply the fused, category-order-invariant shared-field tendencies (one + ! rounded update each) before any subsequent read of these fields + qc(i,k) = sngl(dble(qc(i,k)) + dqc_dp) + if (log_predictNc) nc(i,k) = sngl(dble(nc(i,k)) + dnc_dp) + qr(i,k) = sngl(dble(qr(i,k)) + dqr_dp) + if (dbgpt_i .gt. 0) dbg_dnr_ice(k) = sngl(dnr_dp) + nr(i,k) = sngl(dble(nr(i,k)) + dnr_dp) + if (dbgpt_i .gt. 0) then ! checkpoint 2: post ice-interaction + dbg_nr_posti(k) = nr(i,k) + dbg_qr_posti(k) = qr(i,k) + endif + qv(i,k) = sngl(dble(qv(i,k)) + dqv_dp) + th(i,k) = sngl(dble(th(i,k)) + dth_dp) + !== - ! Update theta. Note temperature is not updated here even though it is used below for - ! the homogeneous freezing threshold. This is done for simplicity - the error will be - ! very small and the homogeneous temp. freezing threshold is approximate anyway. - th(i,k) = th(i,k) + invexn(i,k)*((qidep(iice)-qisub(iice)+qinuc(iice))* & - xxls(i,k)*inv_cp +(qrcol(iice)+qccol(iice)+qchetc(iice)+ & - qcheti(iice)+qrhetc(iice)+qrheti(iice)+ & - qrmul(iice)-qrmlt(iice)-qimlt(iice)+qifrz(iice))* & - xlf(i,k)*inv_cp+(qlcon(iice)-qlevp(iice))*xxlv(i,k)* & - inv_cp)*dt + if (debug_on) then + location_ind = 293 + force_abort =.false. + tmparr1(i,k:k) = th(i,k:k)*(pres(i,k:k)*1.e-5)**(rd*inv_cp) + if (log_3momentIce) then + call check_values(qv(i,k:k),tmparr1(i,k:k),qc(i,k:k),nc(i,k:k),qr(i,k:k),nr(i,k:k),qitot(i,k:k,:), & + qirim(i,k:k,:),nitot(i,k:k,:),birim(i,k:k,:),i,it,force_abort,location_ind, & + Zitot=zitot(i,k:k,:),Qiliq=qiliq(i,k:k,:)) + else + call check_values(qv(i,k:k),tmparr1(i,k:k),qc(i,k:k),nc(i,k:k),qr(i,k:k),nr(i,k:k),qitot(i,k:k,:), & + qirim(i,k:k,:),nitot(i,k:k,:),birim(i,k:k,:),i,it,force_abort,location_ind, & + Qiliq=qiliq(i,k:k,:)) + endif + if (global_status /= STATUS_OK) return + endif - enddo iice_loop3 - !== !-- warm-phase only processes: + ! Check if any of the tendencies are NaN + if (any([isnan(qcevp), isnan(qcacc), isnan(qcaut), isnan(qcnuc), isnan(qccon)])) then + print*,'NaN tendency detected in warm-phase processes at i=', i, ' k=', k + print*,'qcacc=', qcacc, ' qcaut=', qcaut, ' qcnuc=', qcnuc, ' qccon=', qccon, ' qcevp=', qcevp + endif + ! Now for rain processes + if (any([isnan(qcacc), isnan(qcaut), isnan(qrcon), isnan(qrevp)])) then + print*,'NaN tendency detected in rain processes at i=', i, ' k=', k + print*,'qcacc=', qcacc, ' qcaut=', qcaut, ' qrcon=', qrcon, ' qrevp=', qrevp + endif + if (dbgpt_i .gt. 0) dbg_qcacc_f(k) = qcacc ! after the conservation limiters qc(i,k) = qc(i,k) + (-qcacc-qcaut+qcnuc+qccon-qcevp)*dt qr(i,k) = qr(i,k) + (qcacc+qcaut+qrcon-qrevp)*dt if (log_predictNc) then nc(i,k) = nc(i,k) + (-ncacc-ncautc+ncslf+ncnuc)*dt + cn(i,k) = cn(i,k) + ncnuc*dt ! ERM else nc(i,k) = nccnst*inv_rho(i,k) endif @@ -4383,6 +5728,13 @@ SUBROUTINE p3_main(qc,nc,qr,nr,th_old,th,qv_old,qv,dt,qitot,qirim,qiliq,nitot,bi else nr(i,k) = nr(i,k) + (ncautr-nrslf-nrevp)*dt endif + if (dbgpt_i .gt. 0) then + dbg_ncautr(k) = ncautr ! rate, per second (source) + dbg_nrslf(k) = nrslf ! rate, per second (sink) + dbg_nrevp(k) = nrevp ! rate, per second (sink) + dbg_nr_postw(k) = nr(i,k) ! checkpoint 3: post warm-phase + dbg_qr_postw(k) = qr(i,k) + endif qv(i,k) = qv(i,k) + (-qcnuc-qccon-qrcon+qcevp+qrevp)*dt th(i,k) = th(i,k) + invexn(i,k)*((qcnuc+qccon+qrcon-qcevp-qrevp)*xxlv(i,k)* & @@ -4390,19 +5742,29 @@ SUBROUTINE p3_main(qc,nc,qr,nr,th_old,th,qv_old,qv,dt,qitot,qirim,qiliq,nitot,bi !== ! clipping for Filiq > 0.99 (transfer unmelted ice to rain) + ! (category-order-invariant: defer the shared qr/nr/th increments, + ! accumulate in double precision, apply once after the loop) if (log_LiquidFrac) then + clipsum_qr = 0.d0 + clipsum_nr = 0.d0 + clipsum_th = 0.d0 do iice = 1,nCat - if (qitot(i,k,iice).ge.qsmall .and. (qiliq(i,k,iice)/qitot(i,k,iice)).gt.0.99) then - qr(i,k) = qr(i,k) + qitot(i,k,iice) - nr(i,k) = nr(i,k) + nitot(i,k,iice) - th(i,k) = th(i,k) - invexn(i,k)*(qitot(i,k,iice)-qiliq(i,k,iice))*xlf(i,k)*inv_cp + if (qitot(i,k,iice).ge.qsmall .and. nitot(i,k,iice).ge.nsmall) then + if ((qiliq(i,k,iice)/qitot(i,k,iice)).gt.0.99) then ! ERM split conditional to avoid div by zero + clipsum_qr = clipsum_qr + dble(qitot(i,k,iice)) + clipsum_nr = clipsum_nr + dble(nitot(i,k,iice)) + clipsum_th = clipsum_th - dble(invexn(i,k)*(qitot(i,k,iice)-qiliq(i,k,iice))*xlf(i,k)*inv_cp) qitot(i,k,iice) = 0. nitot(i,k,iice) = 0. qirim(i,k,iice) = 0. qiliq(i,k,iice) = 0. birim(i,k,iice) = 0. + endif endif enddo !iice-loop + qr(i,k) = sngl(dble(qr(i,k)) + clipsum_qr) + nr(i,k) = sngl(dble(nr(i,k)) + clipsum_nr) + th(i,k) = sngl(dble(th(i,k)) + clipsum_th) endif ! clipping for small hydrometeor values @@ -4424,11 +5786,15 @@ SUBROUTINE p3_main(qc,nc,qr,nr,th_old,th,qv_old,qv,dt,qitot,qirim,qiliq,nitot,bi log_hydrometeorsPresent = .true. endif + ! (category-order-invariant: defer the shared qv/th increments, + ! accumulate in double precision, apply once after the loop) + clipsum_qv = 0.d0 + clipsum_th = 0.d0 do iice = 1,nCat if (qitot(i,k,iice).lt.qsmall) then - qv(i,k) = qv(i,k) + qitot(i,k,iice) - th(i,k) = th(i,k) - invexn(i,k)*(qitot(i,k,iice)-qiliq(i,k,iice))*xxls(i,k)*inv_cp - th(i,k) = th(i,k) - invexn(i,k)*qiliq(i,k,iice)*xxlv(i,k)*inv_cp + clipsum_qv = clipsum_qv + dble(qitot(i,k,iice)) + clipsum_th = clipsum_th - dble(invexn(i,k)*(qitot(i,k,iice)-qiliq(i,k,iice))*xxls(i,k)*inv_cp) + clipsum_th = clipsum_th - dble(invexn(i,k)*qiliq(i,k,iice)*xxlv(i,k)*inv_cp) qitot(i,k,iice) = 0. nitot(i,k,iice) = 0. qirim(i,k,iice) = 0. @@ -4438,29 +5804,54 @@ SUBROUTINE p3_main(qc,nc,qr,nr,th_old,th,qv_old,qv,dt,qitot,qirim,qiliq,nitot,bi log_hydrometeorsPresent = .true. endif enddo !iice-loop + qv(i,k) = sngl(dble(qv(i,k)) + clipsum_qv) + th(i,k) = sngl(dble(th(i,k)) + clipsum_th) qv(i,k) = max(0., qv(i,k)) - call impose_max_total_Ni(nitot(i,k,:),max_total_Ni,inv_rho(i,k)) + ! DTD turned off for testing + ! call impose_max_total_Ni(nitot(i,k,:),max_total_Ni,inv_rho(i,k)) + ! DTD: added call to new per-category Ni limiter + if (max_Ni .gt. 0.) call impose_max_Ni(nitot(i,k,:),max_Ni,inv_rho(i,k), & + it,i,limlog_j,k,qitot(i,k,:),zitot(i,k,:)) !--------------------------------------------------------------------------------- + if (debug_on) then + location_ind = 294 + force_abort =.false. + tmparr1(i,k:k) = th(i,k:k)*(pres(i,k:k)*1.e-5)**(rd*inv_cp) + if (log_3momentIce) then + call check_values(qv(i,k:k),tmparr1(i,k:k),qc(i,k:k),nc(i,k:k),qr(i,k:k),nr(i,k:k),qitot(i,k:k,:), & + qirim(i,k:k,:),nitot(i,k:k,:),birim(i,k:k,:),i,it,force_abort,location_ind, & + Zitot=zitot(i,k:k,:),Qiliq=qiliq(i,k:k,:)) + else + call check_values(qv(i,k:k),tmparr1(i,k:k),qc(i,k:k),nc(i,k:k),qr(i,k:k),nr(i,k:k),qitot(i,k:k,:), & + qirim(i,k:k,:),nitot(i,k:k,:),birim(i,k:k,:),i,it,force_abort,location_ind, & + Qiliq=qiliq(i,k:k,:)) + endif + if (global_status /= STATUS_OK) return + endif + + if (log_3momentIce) then do iice = 1,nCat ! include all processes **except** group 2 processes which are added later below ! thus, all group 2 processes are subtracted from the ice variables below + ! DTD: should we also gate on dumni > nsmall? dumqi = qitot(i,k,iice) - (qinuc(iice)+qrhetc(iice)+qrheti(iice)+qchetc(iice)+qcheti(iice))*dt + dumni = nitot(i,k,iice) - (ninuc(iice)+nrhetc(iice)+nrheti(iice)+nchetc(iice)+ncheti(iice)+nimul(iice))*dt - if (dumqi.ge.qsmall) then + if (dumqi.ge.qsmall .and. dumni.ge.nsmall) then - dumni = nitot(i,k,iice) - (ninuc(iice)+nrhetc(iice)+nrheti(iice)+nchetc(iice)+ncheti(iice)+nimul(iice))*dt + ! dumni = nitot(i,k,iice) - (ninuc(iice)+nrhetc(iice)+nrheti(iice)+nchetc(iice)+ncheti(iice)+nimul(iice))*dt dumzi = zitot(i,k,iice) - dumqr = qirim(i,k,iice) - (qrhetc(iice)+qrheti(iice)+qchetc(iice)+qcheti(iice)+qrmul(iice))*dt - dumbi = birim(i,k,iice) - (qrhetc(iice)+qrheti(iice)+qchetc(iice)+qcheti(iice)+qrmul(iice))*inv_rho_rimeMax*dt + dumqr = qirim(i,k,iice) - (qrhetc(iice)+qrheti(iice)+qchetc(iice)+qcheti(iice)+qcmul(iice)+qrmul(iice))*dt ! DTD: added qcmul + dumbi = birim(i,k,iice) - (qrhetc(iice)+qrheti(iice)+qchetc(iice)+qcheti(iice)+qcmul(iice)+qrmul(iice))*inv_rho_rimeMax*dt ! DTD: added qcmul dumql = qiliq(i,k,iice) - dumni = max(dumni,nsmall) ! impose limit on dummy ni + ! dumni = max(dumni,nsmall) ! impose limit on dummy ni dumzi = max(dumzi,zsmall) ! impose limit on dummy zi !....................... @@ -4564,9 +5955,10 @@ SUBROUTINE p3_main(qc,nc,qr,nr,th_old,th,qv_old,qv,dt,qitot,qirim,qiliq,nitot,bi !---- Group 2 (initiation processes, where mu_i for the new ice resulting from that process (only) is assigned ! note: mu_i_new is the mu_i associated with the new added ice for that process + ! DTD: changed qsmall checks to nsmall checks below, since these are number-based processes !proceses with rain freezing: tmp2 = nrhetc(iice) + nrheti(iice) !moment_0 tendency - if (tmp2.ge.qsmall) then + if (tmp2.ge.nsmall) then tmp1 = (qrhetc(iice) + qrheti(iice))*6./(900.*pi) !estimate of moment_3 tendency mu_i_new = mu_r(i,k) zitot(i,k,iice) = zitot(i,k,iice) + G_of_mu(mu_i_new)*tmp1**2/tmp2*dt @@ -4574,7 +5966,7 @@ SUBROUTINE p3_main(qc,nc,qr,nr,th_old,th,qv_old,qv,dt,qitot,qirim,qiliq,nitot,bi !proceses with cloud freezing: tmp2 = nchetc(iice) + ncheti(iice) !moment_0 tendency - if (tmp2.ge.qsmall) then + if (tmp2.ge.nsmall) then tmp1 = (qchetc(iice) + qcheti(iice))*6./(900.*pi) !estimate of moment_3 tendency mu_i_new = mu_c(i,k) zitot(i,k,iice) = zitot(i,k,iice) + G_of_mu(mu_i_new)*tmp1**2/tmp2*dt @@ -4582,7 +5974,7 @@ SUBROUTINE p3_main(qc,nc,qr,nr,th_old,th,qv_old,qv,dt,qitot,qirim,qiliq,nitot,bi !proceses of deposition nucleation tmp2 = ninuc(iice) !moment_0 tendency - if (tmp2.ge.qsmall) then + if (tmp2.ge.nsmall) then tmp1 = qinuc(iice)*6./(900.*pi) !estimate of moment_3 tendency mu_i_new = mu_i_initial !estimated assigned value zitot(i,k,iice) = zitot(i,k,iice) + G_of_mu(mu_i_new)*tmp1**2/tmp2*dt @@ -4590,8 +5982,8 @@ SUBROUTINE p3_main(qc,nc,qr,nr,th_old,th,qv_old,qv,dt,qitot,qirim,qiliq,nitot,bi !proceses of ice multiplication tmp2 = nimul(iice) !moment_0 tendency - if (tmp2.ge.qsmall) then - tmp1 = qrmul(iice)*6./(900.*pi) !estimate of moment_3 tendency + if (tmp2.ge.nsmall) then + tmp1 = (qcmul(iice)+qrmul(iice))*6./(900.*pi) !estimate of moment_3 tendency ! DTD: added qcmul mu_i_new = mu_i_initial !estimated assigned value zitot(i,k,iice) = zitot(i,k,iice) + G_of_mu(mu_i_new)*tmp1**2/tmp2*dt endif @@ -4608,6 +6000,16 @@ SUBROUTINE p3_main(qc,nc,qr,nr,th_old,th,qv_old,qv,dt,qitot,qirim,qiliq,nitot,bi 555 continue + ! ERM begin + q_new(i,k) = qv(i,k) + qc(i,k) + qr(i,k) + Sum( qitot(i,k,1:nCat) ) + + qtolmax = Max( qtolmax, q_new(i,k) - q_old(i,k) ) + qtolmin = Min( qtolmin, q_new(i,k) - q_old(i,k) ) + IF ( Abs( q_new(i,k) - q_old(i,k) ) > qtol ) THEN + iqtolcnt = iqtolcnt + 1 + ENDIF + ! ERM end + enddo k_loop_main !-- for sedimentation-only tests: @@ -4616,7 +6018,7 @@ SUBROUTINE p3_main(qc,nc,qr,nr,th_old,th,qv_old,qv,dt,qitot,qirim,qiliq,nitot,bi !== !...................................... -! zero out zitot if there is no qitot for triple moment +! zero out zitot if there is no qitot for triple moment. DTD: check if we need to check nitot as well if (log_3momentIce) then do iice = 1,nCat do k = kbot,ktop,kdir @@ -4701,7 +6103,7 @@ SUBROUTINE p3_main(qc,nc,qr,nr,th_old,th,qv_old,qv,dt,qitot,qirim,qiliq,nitot,bi kloop_sedi_c2: do k = k_qxtop,k_qxbot,-kdir - if (qc(i,k)*iSCF(k).ge.qsmall) then + if (qc(i,k)*iSCF(k).ge.qsmall .and. nc(i,k)*iSCF(k) .ge. nsmall) then ! ERM added nc check DTD changed from > to .ge. call get_cloud_dsd2(qc(i,k),nc(i,k),mu_c(i,k),rho(i,k),nu(i,k),dnu, & lamc(i,k),lammin,lammax,tmp1,tmp2,iSCF(k)) dum = 1./lamc(i,k)**bcn @@ -4761,7 +6163,9 @@ SUBROUTINE p3_main(qc,nc,qr,nr,th_old,th,qv_old,qv,dt,qitot,qirim,qiliq,nitot,bi kloop_sedi_c1: do k = k_qxtop,k_qxbot,-kdir - if (qc(i,k)*iSCF(k).ge.qsmall) then + ! TEMPORARY (log_nifloor): nc condition guards the lamc division below + if (qc(i,k)*iSCF(k).ge.qsmall .and. & + (log_nifloor .or. nc(i,k)*iSCF(k).ge.nsmall)) then call get_cloud_dsd2(qc(i,k),nc(i,k),mu_c(i,k),rho(i,k),nu(i,k),dnu, & lamc(i,k),lammin,lammax,tmp1,tmp2,iSCF(k)) dum = 1./lamc(i,k)**bcn @@ -4846,12 +6250,12 @@ SUBROUTINE p3_main(qc,nc,qr,nr,th_old,th,qv_old,qv,dt,qitot,qirim,qiliq,nitot,bi kloop_sedi_r1: do k = k_qxtop,k_qxbot,-kdir - qr_not_small_1: if (qr(i,k)*iSPF(k).ge.qsmall) then + qr_not_small_1: if (qr(i,k)*iSPF(k).ge.qsmall .and. nr(i,k)*iSPF(k) .ge. nsmall ) then ! ERM added nr check ! DTD changed from > to .ge. !Compute Vq, Vn: - nr(i,k) = max(nr(i,k),nsmall) + if ( log_maxnsmall .and. log_nrfloor ) nr(i,k) = max(nr(i,k),ntiny) ! ERM added log_maxnsmall and ntiny instead of nsmall call get_rain_dsd2(qr(i,k),nr(i,k),mu_r(i,k),lamr(i,k),cdistr(i,k), & - logn0r(i,k),iSPF(k)) + logn0r(i,k),iSPF(k),it,i,limlog_j,k,2) call find_lookupTable_indices_3(dumii,dumjj,dum1,rdumii,rdumjj,inv_dum3, & mu_r(i,k),lamr(i,k)) @@ -4873,6 +6277,7 @@ SUBROUTINE p3_main(qc,nc,qr,nr,th_old,th,qv_old,qv,dt,qitot,qirim,qiliq,nitot,bi V_nr(k) = dum1+(rdumjj-real(dumjj))*(dum2-dum1) !interpolated V_nr(k) = V_nr(k)*rhofacr(i,k) !corrected for air density + if ( rssflg /= 1 ) V_nr(k) = V_qr(k) ! ERM endif qr_not_small_1 Co_max = max(Co_max, V_qr(k)*dt_left*inv_dzq(i,k)) @@ -4973,10 +6378,10 @@ SUBROUTINE p3_main(qc,nc,qr,nr,th_old,th,qv_old,qv,dt,qitot,qirim,qiliq,nitot,bi kloop_sedi_i1: do k = k_qxtop,k_qxbot,-kdir !-- compute Vq, Vn (get values from lookup table) - qi_notsmall_i1: if (qitot(i,k,iice).ge.qsmall) then + qi_notsmall_i1: if (qitot(i,k,iice).ge.qsmall .and. nitot(i,k,iice) .ge. nsmall ) then ! ERM added nitot check DTD changed to .ge. from > to ensure that nitot = nsmall is included !--Compute Vq, Vn: - nitot(i,k,iice) = max(nitot(i,k,iice),nsmall) !impose lower limits to prevent log(<0) + if ( log_maxnsmall .and. log_nifloor ) nitot(i,k,iice) = max(nitot(i,k,iice),ntiny) !impose lower limits to prevent log(<0) ERM added log_maxnsmall and ntiny call calc_bulkRhoRime(qitot(i,k,iice),qirim(i,k,iice),qiliq(i,k,iice),birim(i,k,iice),rhop) call find_lookupTable_indices_1a(dumi,dumjj,dumii,dumll,dum1,dum4,dum5,dum7, & @@ -4993,6 +6398,7 @@ SUBROUTINE p3_main(qc,nc,qr,nr,th_old,th,qv_old,qv,dt,qitot,qirim,qiliq,nitot,bi V_qit(k) = f1pr02*rhofaci(i,k) !mass-weighted fall speed (with density factor) V_nit(k) = f1pr01*rhofaci(i,k) !number-weighted fall speed (with density factor) !== + if ( sssflg /= 1 ) V_nit(k) = V_qit(k) ! ERM endif qi_notsmall_i1 @@ -5066,10 +6472,10 @@ SUBROUTINE p3_main(qc,nc,qr,nr,th_old,th,qv_old,qv,dt,qitot,qirim,qiliq,nitot,bi kloop_sedi_i2: do k = k_qxtop,k_qxbot,-kdir !-- compute Vq, Vn (get values from lookup table) - qi_notsmall_i2: if (qitot(i,k,iice).ge.qsmall) then + qi_notsmall_i2: if (qitot(i,k,iice).ge.qsmall .and. nitot(i,k,iice) .ge. nsmall ) then ! ERM added nitot check DTD changed to .ge. from > to ensure that nitot = nsmall is included !--Compute Vq, Vn: - nitot(i,k,iice) = max(nitot(i,k,iice),nsmall) !impose lower limits to prevent log(<0) + if ( log_maxnsmall .and. log_nifloor ) nitot(i,k,iice) = max(nitot(i,k,iice),ntiny) !impose lower limits to prevent log(<0) ERM added log_maxnsmall and ntiny call calc_bulkRhoRime(qitot(i,k,iice),qirim(i,k,iice),qiliq(i,k,iice),birim(i,k,iice),rhop) call find_lookupTable_indices_1a(dumi,dumjj,dumii,dumll,dum1,dum4,dum5,dum7, & isize,rimsize,liqsize,densize,qitot(i,k,iice),nitot(i,k,iice), & @@ -5085,6 +6491,7 @@ SUBROUTINE p3_main(qc,nc,qr,nr,th_old,th,qv_old,qv,dt,qitot,qirim,qiliq,nitot,bi V_qit(k) = f1pr02*rhofaci(i,k) !mass-weighted fall speed (with density factor) V_nit(k) = f1pr01*rhofaci(i,k) !number-weighted fall speed (with density factor) !== + if ( sssflg /= 1 ) V_nit(k) = V_qit(k) ! ERM endif qi_notsmall_i2 @@ -5169,10 +6576,10 @@ SUBROUTINE p3_main(qc,nc,qr,nr,th_old,th,qv_old,qv,dt,qitot,qirim,qiliq,nitot,bi kloop_sedi_i3: do k = k_qxtop,k_qxbot,-kdir !-- compute Vq, Vn (get values from lookup table) - qi_notsmall_i3: if (qitot(i,k,iice).ge.qsmall) then + qi_notsmall_i3: if (qitot(i,k,iice).ge.qsmall .and. nitot(i,k,iice) >= nsmall ) then ! ERM added nitot check !--Compute Vq, Vn: - nitot(i,k,iice) = max(nitot(i,k,iice),nsmall) !impose lower limits to prevent log(<0) + if ( log_maxnsmall .and. log_nifloor ) nitot(i,k,iice) = max(nitot(i,k,iice),ntiny) !impose lower limits to prevent log(<0) ! ERM added log_maxnsmall and ntiny call calc_bulkRhoRime(qitot(i,k,iice),qirim(i,k,iice),qiliq(i,k,iice),birim(i,k,iice),rhop) call find_lookupTable_indices_1a(dumi,dumjj,dumii,dumll,dum1,dum4,dum5,dum7, & @@ -5215,6 +6622,29 @@ SUBROUTINE p3_main(qc,nc,qr,nr,th_old,th,qv_old,qv,dt,qitot,qirim,qiliq,nitot,bi V_nit(k) = f1pr01*rhofaci(i,k) !number-weighted fall speed (with density factor) V_zit(k) = f1pr19*rhofaci(i,k) !reflectivity-weighted fall speed (with density factor) + ! ERM begin + if ( sssflg /= 1 ) then + V_nit(k) = V_qit(k) + V_zit(k) = V_qit(k) + endif + ! ERM end + + ! DTD: Ted also had this section in his code. It's not in the original P3 + ! version he was working off of, and I'm not sure if it is necessary. Placing here + ! and commenting out just in case we want it at some point. + + ! else + ! + ! qv(i,k) = qv(i,k) + qitot(i,k,iice) + ! th(i,k) = th(i,k) - invexn(i,k)*(qitot(i,k,iice)-qiliq(i,k,iice))*xxls(i,k)*inv_cp + ! th(i,k) = th(i,k) - invexn(i,k)*qiliq(i,k,iice)*xxlv(i,k)*inv_cp + ! qitot(i,k,iice) = 0. + ! nitot(i,k,iice) = 0. + ! qirim(i,k,iice) = 0. + ! qiliq(i,k,iice) = 0. + ! birim(i,k,iice) = 0. + + endif qi_notsmall_i3 ! use V_zit for calculating sub-stepping since it is larger than V_qit @@ -5295,10 +6725,10 @@ SUBROUTINE p3_main(qc,nc,qr,nr,th_old,th,qv_old,qv,dt,qitot,qirim,qiliq,nitot,bi kloop_sedi_i4: do k = k_qxtop,k_qxbot,-kdir !-- compute Vq, Vn (get values from lookup table) - qi_notsmall_i4: if (qitot(i,k,iice).ge.qsmall) then + qi_notsmall_i4: if (qitot(i,k,iice).ge.qsmall .and. nitot(i,k,iice) .ge. nsmall ) then ! ERM added nitot check DTD changed to .ge. from > to ensure that nitot = nsmall is included !--Compute Vq, Vn: - nitot(i,k,iice) = max(nitot(i,k,iice),nsmall) !impose lower limits to prevent log(<0) + if ( log_maxnsmall .and. log_nifloor ) nitot(i,k,iice) = max(nitot(i,k,iice),ntiny) !impose lower limits to prevent log(<0) ! ERM added log_maxnsmall and ntiny call calc_bulkRhoRime(qitot(i,k,iice),qirim(i,k,iice),qiliq(i,k,iice),birim(i,k,iice),rhop) call find_lookupTable_indices_1a(dumi,dumjj,dumii,dumll,dum1,dum4,dum5,dum7, & @@ -5336,11 +6766,33 @@ SUBROUTINE p3_main(qc,nc,qr,nr,th_old,th,qv_old,qv,dt,qitot,qirim,qiliq,nitot,bi zitot(i,k,iice) = min(zitot(i,k,iice),tmp1*dum1**2/nitot(i,k,iice)) zitot(i,k,iice) = max(zitot(i,k,iice),tmp2*dum1**2/nitot(i,k,iice)) !............. - + ! dum = 1.0 + ! if (f1pr02 .gt. 5.0 .and. f1pr02 .lt. 10.0) then + ! dum = 1. - (f1pr02 - 5.0)/5.0*0.5 + ! elseif (f1pr02 .ge. 10.0) then + ! dum = 0.5 + ! else + ! dum = 1. + ! endif + ! dum = 1.0 + ! if (f1pr02 .lt. 8.0 .and. f1pr02 .gt. 4.0) then + ! dum = 1. + (8.0 - f1pr02)/4.0*1.0 + ! elseif (f1pr02 .le. 4.0) then + ! dum = 2.0 + ! endif + ! V_qit(k) = dum*f1pr02*rhofaci(i,k) !mass-weighted fall speed (with density factor) + ! V_nit(k) = dum*f1pr01*rhofaci(i,k) !number-weighted fall speed (with density factor) + ! V_zit(k) = dum*f1pr19*rhofaci(i,k) !reflectivity-weighted fall speed (with density factor) V_qit(k) = f1pr02*rhofaci(i,k) !mass-weighted fall speed (with density factor) V_nit(k) = f1pr01*rhofaci(i,k) !number-weighted fall speed (with density factor) V_zit(k) = f1pr19*rhofaci(i,k) !reflectivity-weighted fall speed (with density factor) + ! ERM begin + if ( sssflg /= 1 ) then + V_nit(k) = V_qit(k) + V_zit(k) = V_qit(k) + endif + ! ERM end endif qi_notsmall_i4 ! use V_zit for calculating sub-stepping since it is larger than V_qit @@ -5425,6 +6877,16 @@ SUBROUTINE p3_main(qc,nc,qr,nr,th_old,th,qv_old,qv,dt,qitot,qirim,qiliq,nitot,bi enddo iice_loop_sedi_ice !iice-loop + ! checkpoint 4: post-sedimentation, before the final clipping loops. Splits + ! the remaining interval so a change in qr/nr can be attributed either to the + ! sedimentation solvers or to the clipping that follows them. + if (dbgpt_i .gt. 0) then + do k = kbot,ktop,kdir + dbg_nr_posts(k) = nr(i,k) + dbg_qr_posts(k) = qr(i,k) + enddo + endif + !................................................................................ ! diagnose mu tendency from sedimentation @@ -5467,8 +6929,12 @@ SUBROUTINE p3_main(qc,nc,qr,nr,th_old,th,qv_old,qv,dt,qitot,qirim,qiliq,nitot,bi ! compute mean-mass ice diameters diam_ice(i,k,:) = 0. do iice = 1,nCat - if (qitot(i,k,iice).ge.qsmall) then - nitot(i,k,iice) = max(nitot(i,k,iice),nsmall) + ! TEMPORARY (log_nifloor): the nitot condition is a no-op when the + ! entry-clip floor is on, and prevents a divide-by-zero in the + ! lookup call below when it is off + if (qitot(i,k,iice).ge.qsmall .and. & + (log_nifloor .or. nitot(i,k,iice).ge.nsmall)) then + if ( log_maxnsmall .and. log_nifloor ) nitot(i,k,iice) = max(nitot(i,k,iice),ntiny) ! ERM added log_maxnsmall and ntiny call calc_bulkRhoRime(qitot(i,k,iice),qirim(i,k,iice),qiliq(i,k,iice),birim(i,k,iice),rhop) call find_lookupTable_indices_1a(dumi,dumjj,dumii,dumll,dum1,dum4,dum5,dum7,isize, & rimsize,liqsize,densize,qitot(i,k,iice),nitot(i,k,iice),qirim(i,k,iice), & @@ -5501,18 +6967,41 @@ SUBROUTINE p3_main(qc,nc,qr,nr,th_old,th,qv_old,qv,dt,qitot,qirim,qiliq,nitot,bi endif multicat1 - qc_not_small_2: if (qc(i,k).ge.qsmall .and. t(i,k).lt.233.15) then + ! TEMPORARY (log_nifloor): without an nc condition, homogeneous freezing of a + ! number-less cloud creates a number-less ice category -- feeding the same problem + qc_not_small_2: if (qc(i,k).ge.qsmall .and. t(i,k).lt.233.15 .and. & + (log_nifloor .or. nc(i,k).ge.nsmall)) then Q_nuc = qc(i,k) - nc(i,k) = max(nc(i,k),nsmall) + if ( log_maxnsmall ) nc(i,k) = max(nc(i,k),ntiny) ! ERM added log_maxnsmall and ntiny N_nuc = nc(i,k) if (nCat>1) then !determine destination ice-phase category: - dum1 = 900. !density of new ice - D_new = ((Q_nuc*6.)/(pi*dum1*N_nuc))**thrd - call icecat_destination(qitot(i,k,:)*iSCF(k),diam_ice(i,k,:),D_new,deltaD_init, & - iice_dest) + if (.not. cat_init_new) then + dum1 = 900. !density of new ice + D_new = ((Q_nuc*6.)/(pi*dum1*N_nuc))**thrd + ! ERM begin + IF ( merge_opt == -1 .and. nCat == 2 ) THEN + iice_dest = 2 + ELSE + call icecat_destination(qitot(i,k,:)*iSCF(k),diam_ice(i,k,:),D_new,deltaD_init, & + iice_dest) + ENDIF + ! ERM end (call of icecat_destination is still there in orig code of course + else + if (nCat == 2) then + iice_dest = catdest_homocloud_n2 + elseif (nCat == 3) then + iice_dest = catdest_homocloud_n3 + elseif (nCat == 4) then + iice_dest = catdest_homocloud_n4 + elseif (nCat == 5) then + iice_dest = catdest_homocloud_n5 + elseif (nCat == 6) then + iice_dest = catdest_homocloud_n6 + endif + endif if (global_status /= STATUS_OK) return else iice_dest = 1 @@ -5539,16 +7028,36 @@ SUBROUTINE p3_main(qc,nc,qr,nr,th_old,th,qv_old,qv,dt,qitot,qirim,qiliq,nitot,bi endif qc_not_small_2 - qr_not_small_2: if (qr(i,k).ge.qsmall .and. t(i,k).lt.233.15) then + qr_not_small_2: if (qr(i,k).ge.qsmall .and. nr(i,k).ge.nsmall .and. t(i,k).lt.233.15) then Q_nuc = qr(i,k) - nr(i,k) = max(nr(i,k),nsmall) + if ( log_maxnsmall .and. log_nrfloor ) nr(i,k) = max(nr(i,k),ntiny) ! ERM added log_maxnsmall and ntiny N_nuc = nr(i,k) if (nCat>1) then !determine destination ice-phase category: - dum1 = 900. !density of new ice - D_new = ((Q_nuc*6.)/(pi*dum1*N_nuc))**thrd - call icecat_destination(qitot(i,k,:)*iSCF(k),diam_ice(i,k,:),D_new,deltaD_init,iice_dest) + if (.not. cat_init_new) then + dum1 = 900. !density of new ice + D_new = ((Q_nuc*6.)/(pi*dum1*N_nuc))**thrd + ! ERM begin + IF ( merge_opt == -1 .and. nCat == 2 ) THEN + iice_dest = 1 + ELSE + call icecat_destination(qitot(i,k,:)*iSCF(k),diam_ice(i,k,:),D_new,deltaD_init,iice_dest) + ENDIF + ! ERM end (call of icecat_destination is still there in orig code of course + else + if (nCat == 2) then + iice_dest = catdest_homorain_n2 + elseif (nCat == 3) then + iice_dest = catdest_homorain_n3 + elseif (nCat == 4) then + iice_dest = catdest_homorain_n4 + elseif (nCat == 5) then + iice_dest = catdest_homorain_n5 + elseif (nCat == 6) then + iice_dest = catdest_homorain_n6 + endif + endif if (global_status /= STATUS_OK) return else iice_dest = 1 @@ -5559,7 +7068,7 @@ SUBROUTINE p3_main(qc,nc,qr,nr,th_old,th,qv_old,qv,dt,qitot,qirim,qiliq,nitot,bi birim(i,k,iice_dest) = birim(i,k,iice_dest) + Q_nuc*inv_rho_rimeMax nitot(i,k,iice_dest) = nitot(i,k,iice_dest) + N_nuc ! z tendency for triple moment ice - if (log_3momentIce .and. N_nuc.ge.qsmall) then + if (log_3momentIce .and. N_nuc.ge.nsmall) then ! DTD: bugfix changed from N_nuc.ge.qsmall tmp1 = Q_nuc*6./(900.*pi) !estimate of moment_3 tendency mu_i_new = mu_r(i,k) zitot(i,k,iice_dest) = zitot(i,k,iice_dest) + G_of_mu(mu_i_new)*tmp1**2/N_nuc @@ -5575,113 +7084,132 @@ SUBROUTINE p3_main(qc,nc,qr,nr,th_old,th,qv_old,qv,dt,qitot,qirim,qiliq,nitot,bi !.............................................. ! Merge ice categories with similar properties (based on specified similarly condition) + if (.not. cat_init_new) then ! DTD turn off category merging for the new category initialization option for now + multicat: if (nCat.gt.1 .and. merge_opt >= 1) then ! ERM added merge_opt check + ! multicat: if (.FALSE.) then ! **** TEST + + !step 1: adjustments and calculation of mean diameters + k_loop_check_before_merge: do k = kbot,ktop,kdir + iice_loop_check_before_merge: do iice = 1,nCat + ! TEMPORARY (log_nifloor): see the k_loop_fz gate above -- same + ! divide-by-zero protection for the lookup call below + qi_not_small_merge: if (qitot(i,k,iice).ge.qsmall .and. & + (log_nifloor .or. nitot(i,k,iice).ge.nsmall)) then + + if ( log_maxnsmall .and. log_nifloor ) nitot(i,k,iice) = max(nitot(i,k,iice),ntiny) ! ERM added log_maxnsmall and ntiny + call calc_bulkRhoRime(qitot(i,k,iice),qirim(i,k,iice),qiliq(i,k,iice),birim(i,k,iice),rhop) + call find_lookupTable_indices_1a(dumi,dumjj,dumii,dumll,dum1,dum4,dum5,dum7,isize, & + rimsize,liqsize,densize,qitot(i,k,iice),nitot(i,k,iice),qirim(i,k,iice), & + qiliq(i,k,iice),rhop) - multicat: if (nCat.gt.1) then -! multicat: if (.FALSE.) then ! **** TEST - - !step 1: adjustments and calculation of mean diameters - k_loop_check_before_merge: do k = kbot,ktop,kdir - iice_loop_check_before_merge: do iice = 1,nCat - qi_not_small_merge: if (qitot(i,k,iice).ge.qsmall) then - - nitot(i,k,iice) = max(nitot(i,k,iice),nsmall) - call calc_bulkRhoRime(qitot(i,k,iice),qirim(i,k,iice),qiliq(i,k,iice),birim(i,k,iice),rhop) - call find_lookupTable_indices_1a(dumi,dumjj,dumii,dumll,dum1,dum4,dum5,dum7,isize, & - rimsize,liqsize,densize,qitot(i,k,iice),nitot(i,k,iice),qirim(i,k,iice), & - qiliq(i,k,iice),rhop) - - if (.not. log_3momentIce) then + if (.not. log_3momentIce) then - if (log_LiquidFrac) then - call access_lookup_table_LF(dumjj,dumii,dumll,dumi,11,dum1,dum4,dum5,dum7,f1pr15) - else - call access_lookup_table(dumjj,dumii,dumi,11,dum1,dum4,dum5,f1pr15) - endif + if (log_LiquidFrac) then + call access_lookup_table_LF(dumjj,dumii,dumll,dumi,11,dum1,dum4,dum5,dum7,f1pr15) + else + call access_lookup_table(dumjj,dumii,dumi,11,dum1,dum4,dum5,f1pr15) + endif - else ! triple moment ice + else ! triple moment ice - ! get Znorm indices + ! get Znorm indices - ! impose lower limits to prevent taking log of # < 0 - zitot(i,k,iice) = max(zitot(i,k,iice),zsmall) + ! impose lower limits to prevent taking log of # < 0 + zitot(i,k,iice) = max(zitot(i,k,iice),zsmall) - dum1z = 6./(200.*pi)*qitot(i,k,iice) !estimate of moment3, as starting point use 200 kg m-3 estimate of bulk density + dum1z = 6./(200.*pi)*qitot(i,k,iice) !estimate of moment3, as starting point use 200 kg m-3 estimate of bulk density - do imu=1,niter_mui - mu_i = compute_mu_3moment(nitot(i,k,iice),dum1z,zitot(i,k,iice),mu_i_max) - call find_lookupTable_indices_1c(dumzz,dum6,zsize,mu_i) - call access_lookup_table_3mom_LF(dumzz,dumjj,dumii,dumll,dumi,12,dum1,dum4,dum5,dum6,dum7,f1pr16) - dum1z = 6./(f1pr16*pi)*qitot(i,k,iice) !estimate of moment3 - enddo - - if (log_LiquidFrac) then - call access_lookup_table_3mom_LF(dumzz,dumjj,dumii,dumll,dumi,11,dum1,dum4,dum5,dum6,dum7,f1pr15) - else - call access_lookup_table_3mom(dumzz,dumjj,dumii,dumi,11,dum1,dum4,dum5,dum6,f1pr15) - endif - endif - - ! adjust Zitot to make sure mu is in bounds - ! note that the Zmax and Zmin are normalized and thus need to be multiplied by existing Q - if (log_3momentIce) then - dum1 = 6./(f1pr16*pi)*qitot(i,k,iice) !estimate of moment3 - tmp1 = G_of_mu(0.) - tmp2 = G_of_mu(20.) - zitot(i,k,iice) = min(zitot(i,k,iice),tmp1*dum1**2/nitot(i,k,iice)) - zitot(i,k,iice) = max(zitot(i,k,iice),tmp2*dum1**2/nitot(i,k,iice)) - endif + do imu=1,niter_mui + mu_i = compute_mu_3moment(nitot(i,k,iice),dum1z,zitot(i,k,iice),mu_i_max) + call find_lookupTable_indices_1c(dumzz,dum6,zsize,mu_i) + call access_lookup_table_3mom_LF(dumzz,dumjj,dumii,dumll,dumi,12,dum1,dum4,dum5,dum6,dum7,f1pr16) + dum1z = 6./(f1pr16*pi)*qitot(i,k,iice) !estimate of moment3 + enddo - !--this should already be done in s/r 'calc_bulkRhoRime' - if (qirim(i,k,iice).lt.qsmall) then - qirim(i,k,iice) = 0. - birim(i,k,iice) = 0. - endif - if (qiliq(i,k,iice).lt.qsmall) qiliq(i,k,iice) = 0. + if (log_LiquidFrac) then + call access_lookup_table_3mom_LF(dumzz,dumjj,dumii,dumll,dumi,11,dum1,dum4,dum5,dum6,dum7,f1pr15) + else + call access_lookup_table_3mom(dumzz,dumjj,dumii,dumi,11,dum1,dum4,dum5,dum6,f1pr15) + endif + endif - diag_di(i,k,iice) = f1pr15 ! used for merging + ! adjust Zitot to make sure mu is in bounds + ! note that the Zmax and Zmin are normalized and thus need to be multiplied by existing Q + if (log_3momentIce) then + dum1 = 6./(f1pr16*pi)*qitot(i,k,iice) !estimate of moment3 + tmp1 = G_of_mu(0.) + tmp2 = G_of_mu(20.) + zitot(i,k,iice) = min(zitot(i,k,iice),tmp1*dum1**2/nitot(i,k,iice)) + zitot(i,k,iice) = max(zitot(i,k,iice),tmp2*dum1**2/nitot(i,k,iice)) + endif - else + !--this should already be done in s/r 'calc_bulkRhoRime' + if (qirim(i,k,iice).lt.qsmall) then + qirim(i,k,iice) = 0. + birim(i,k,iice) = 0. + endif + if (qiliq(i,k,iice).lt.qsmall) qiliq(i,k,iice) = 0. - qv(i,k) = qv(i,k) + qitot(i,k,iice) - th(i,k) = th(i,k) - invexn(i,k)*(qitot(i,k,iice)-qiliq(i,k,iice))*xxls(i,k)*inv_cp - th(i,k) = th(i,k) - invexn(i,k)*qiliq(i,k,iice)*xxlv(i,k)*inv_cp - qitot(i,k,iice) = 0. - nitot(i,k,iice) = 0. - qirim(i,k,iice) = 0. - qiliq(i,k,iice) = 0. - birim(i,k,iice) = 0. - if (log_3momentIce) zitot(i,k,iice) = 0 - diag_di(i,k,iice) = 0. + diag_di(i,k,iice) = f1pr15 ! used for merging - endif qi_not_small_merge - enddo iice_loop_check_before_merge - enddo k_loop_check_before_merge + else - !step 2: merge ice with similar properties into one category - do k = kbot,ktop,kdir - do iice = nCat,2,-1 - tmp1 = abs(diag_di(i,k,iice)-diag_di(i,k,iice-1)) - if (tmp1.le.deltaD_init .and. qitot(i,k,iice).gt.0. .and. & - qitot(i,k,iice-1).gt.0.) then - qitot(i,k,iice-1) = qitot(i,k,iice-1) + qitot(i,k,iice) - nitot(i,k,iice-1) = nitot(i,k,iice-1) + nitot(i,k,iice) - qirim(i,k,iice-1) = qirim(i,k,iice-1) + qirim(i,k,iice) - birim(i,k,iice-1) = birim(i,k,iice-1) + birim(i,k,iice) - if (log_LiquidFrac) qiliq(i,k,iice-1) = qiliq(i,k,iice-1) + qiliq(i,k,iice) - if (log_3momentIce) then - zitot(i,k,iice-1) = zitot(i,k,iice-1) + zitot(i,k,iice) - zitot(i,k,iice) = 0. - endif - qitot(i,k,iice) = 0. - nitot(i,k,iice) = 0. - qirim(i,k,iice) = 0. - birim(i,k,iice) = 0. - qiliq(i,k,iice) = 0. - endif - enddo !iice loop - enddo !k loop + qv(i,k) = qv(i,k) + qitot(i,k,iice) + th(i,k) = th(i,k) - invexn(i,k)*(qitot(i,k,iice)-qiliq(i,k,iice))*xxls(i,k)*inv_cp + th(i,k) = th(i,k) - invexn(i,k)*qiliq(i,k,iice)*xxlv(i,k)*inv_cp + qitot(i,k,iice) = 0. + nitot(i,k,iice) = 0. + qirim(i,k,iice) = 0. + qiliq(i,k,iice) = 0. + birim(i,k,iice) = 0. + if (log_3momentIce) zitot(i,k,iice) = 0 + diag_di(i,k,iice) = 0. + + endif qi_not_small_merge + enddo iice_loop_check_before_merge + enddo k_loop_check_before_merge + + !step 2: merge ice with similar properties into one category + do k = kbot,ktop,kdir + do iice = nCat,2,-1 + ! ERM begin new merge options + log_test = .false. + IF ( merge_opt == 1 ) THEN + ! absolute difference + tmp1 = abs(diag_di(i,k,iice)-diag_di(i,k,iice-1)) + log_test = tmp1.le.deltaD_init + ELSEIF ( merge_opt == 2 ) THEN + ! relative difference + tmp1 = 100. + IF ( diag_di(i,k,iice)+diag_di(i,k,iice-1) > 0.0 ) THEN + tmp1 = 100.*abs(diag_di(i,k,iice)-diag_di(i,k,iice-1))/ & + (diag_di(i,k,iice)+diag_di(i,k,iice-1)) + ENDIF + log_test = tmp1.le.10. + ENDIF + ! ERM end new merge options + if ( log_test .and. qitot(i,k,iice).gt.0. .and. & + qitot(i,k,iice-1).gt.0.) then + qitot(i,k,iice-1) = qitot(i,k,iice-1) + qitot(i,k,iice) + nitot(i,k,iice-1) = nitot(i,k,iice-1) + nitot(i,k,iice) + qirim(i,k,iice-1) = qirim(i,k,iice-1) + qirim(i,k,iice) + birim(i,k,iice-1) = birim(i,k,iice-1) + birim(i,k,iice) + if (log_LiquidFrac) qiliq(i,k,iice-1) = qiliq(i,k,iice-1) + qiliq(i,k,iice) + if (log_3momentIce) then + zitot(i,k,iice-1) = zitot(i,k,iice-1) + zitot(i,k,iice) + zitot(i,k,iice) = 0. + endif + qitot(i,k,iice) = 0. + nitot(i,k,iice) = 0. + qirim(i,k,iice) = 0. + birim(i,k,iice) = 0. + qiliq(i,k,iice) = 0. + endif + enddo !iice loop + enddo !k loop - endif multicat + endif multicat + endif ! cat_init_new !................................................... ! note: This debug check is commented since small negative qx,nx values are possible here @@ -5711,7 +7239,9 @@ SUBROUTINE p3_main(qc,nc,qr,nr,th_old,th,qv_old,qv,dt,qitot,qirim,qiliq,nitot,bi k_loop_final_diagnostics: do k = kbot,ktop,kdir ! cloud: - if (qc(i,k)*iSCF(k).ge.qsmall) then + ! TEMPORARY (log_nifloor): nc condition guards the lamc division below + if (qc(i,k)*iSCF(k).ge.qsmall .and. & + (log_nifloor .or. nc(i,k)*iSCF(k).ge.nsmall)) then call get_cloud_dsd2(qc(i,k),nc(i,k),mu_c(i,k),rho(i,k),nu(i,k),dnu,lamc(i,k), & lammin,lammax,tmp1,tmp2, iSCF(k)) diag_effc(i,k) = 0.5*(mu_c(i,k)+3.)/lamc(i,k) @@ -5723,9 +7253,19 @@ SUBROUTINE p3_main(qc,nc,qr,nr,th_old,th,qv_old,qv,dt,qitot,qirim,qiliq,nitot,bi endif ! rain: + ! NOTE: the else branch of this test clips qr to vapour, so the nr condition + ! must NOT be attached here -- doing so would merely relocate the clipping + ! from the entry clip to the exit clip. It guards the DSD/reflectivity + ! block only, immediately below. if (qr(i,k).ge.qsmall) then - call get_rain_dsd2(qr(i,k),nr(i,k),mu_r(i,k),lamr(i,k),tmp1,tmp2,1.) + ! TEMPORARY (log_nrfloor): number-less rain skips the DSD and keeps + ! ze_rain at its initialised 1.e-22, contributing nothing to the + ! diagnosed reflectivity, but its mass is left untouched. + if (log_nrfloor .or. nr(i,k).ge.nsmall) then + + call get_rain_dsd2(qr(i,k),nr(i,k),mu_r(i,k),lamr(i,k),tmp1,tmp2,1., & + it,i,limlog_j,k,3) ! hm, turn off soft lambda limiter ! impose size limits for rain with 'soft' lambda limiter @@ -5744,6 +7284,9 @@ SUBROUTINE p3_main(qc,nc,qr,nr,th_old,th,qv_old,qv,dt,qitot,qirim,qiliq,nitot,bi ze_rain(i,k) = rho(i,k)*nr(i,k)*(mu_r(i,k)+6.)*(mu_r(i,k)+5.)*(mu_r(i,k)+4.)* & (mu_r(i,k)+3.)*(mu_r(i,k)+2.)*(mu_r(i,k)+1.)/lamr(i,k)**6 ze_rain(i,k) = max(ze_rain(i,k),1.e-22) + + endif ! log_nrfloor .or. nr >= nsmall + else qv(i,k) = qv(i,k)+qr(i,k) th(i,k) = th(i,k)-invexn(i,k)*qr(i,k)*xxlv(i,k)*inv_cp @@ -5752,16 +7295,33 @@ SUBROUTINE p3_main(qc,nc,qr,nr,th_old,th,qv_old,qv,dt,qitot,qirim,qiliq,nitot,bi endif ! ice: + ! DTD turned off for testing + ! call impose_max_total_Ni(nitot(i,k,:),max_total_Ni,inv_rho(i,k)) + ! DTD: added call to new per-category Ni limiter + if (max_Ni .gt. 0.) call impose_max_Ni(nitot(i,k,:),max_Ni,inv_rho(i,k), & + it,i,limlog_j,k,qitot(i,k,:),zitot(i,k,:)) - call impose_max_total_Ni(nitot(i,k,:),max_total_Ni,inv_rho(i,k)) + ! (category-order-invariant: defer the shared qv/th increments from the + ! ice clip, accumulate in double precision, apply once after the loop) + clipsum_qv = 0.d0 + clipsum_th = 0.d0 iice_loop_final_diagnostics: do iice = 1,nCat - qi_not_small: if (qitot(i,k,iice).ge.qsmall) then + ! NOTE: the else branch of this test clears the category (mass to vapour), + ! so the nitot condition must NOT be attached here -- that would clear + ! number-less ice rather than leave it alone. It guards the lookup and + ! diagnostic block only, immediately below. Mirrors the rain exit block. + qi_not_small: if (qitot(i,k,iice).ge.qsmall) then ! ERM added nitot check + + ! TEMPORARY (log_nifloor): number-less ice skips the lookups and + ! diagnostics -- ze_ice keeps its initialised 1.e-22 and diag_di is + ! left alone -- but its mass is preserved rather than dumped to vapour. + if (log_nifloor .or. nitot(i,k,iice).ge.nsmall) then !impose lower limits to prevent taking log of # < 0 - nitot(i,k,iice) = max(nitot(i,k,iice),nsmall) - nr(i,k) = max(nr(i,k),nsmall) + if ( log_maxnsmall .and. log_nifloor ) nitot(i,k,iice) = max(nitot(i,k,iice),ntiny) ! ERM added log_maxnsmall and ntiny + if ( log_maxnsmall .and. log_nrfloor ) nr(i,k) = max(nr(i,k),ntiny) ! ERM added log_maxnsmall and ntiny call calc_bulkRhoRime(qitot(i,k,iice),qirim(i,k,iice),qiliq(i,k,iice),birim(i,k,iice),rhop) @@ -5911,11 +7471,13 @@ SUBROUTINE p3_main(qc,nc,qr,nr,th_old,th,qv_old,qv,dt,qitot,qirim,qiliq,nitot,bi ze_ice(i,k) = ze_ice(i,k) + f1pr13*nitot(i,k,iice)*rho(i,k) ze_ice(i,k) = max(ze_ice(i,k),1.e-22) + endif ! log_nifloor .or. nitot >= nsmall + else - qv(i,k) = qv(i,k) + qitot(i,k,iice) - th(i,k) = th(i,k) - invexn(i,k)*(qitot(i,k,iice)-qiliq(i,k,iice))*xxls(i,k)*inv_cp - th(i,k) = th(i,k) - invexn(i,k)*qiliq(i,k,iice)*xxlv(i,k)*inv_cp + clipsum_qv = clipsum_qv + dble(qitot(i,k,iice)) + clipsum_th = clipsum_th - dble(invexn(i,k)*(qitot(i,k,iice)-qiliq(i,k,iice))*xxls(i,k)*inv_cp) + clipsum_th = clipsum_th - dble(invexn(i,k)*qiliq(i,k,iice)*xxlv(i,k)*inv_cp) qitot(i,k,iice) = 0. nitot(i,k,iice) = 0. qirim(i,k,iice) = 0. @@ -5927,11 +7489,64 @@ SUBROUTINE p3_main(qc,nc,qr,nr,th_old,th,qv_old,qv,dt,qitot,qirim,qiliq,nitot,bi endif qi_not_small enddo iice_loop_final_diagnostics + qv(i,k) = sngl(dble(qv(i,k)) + clipsum_qv) + th(i,k) = sngl(dble(th(i,k)) + clipsum_th) ! sum ze components and convert to dBZ ! for reflectivity paper diag_ze(i,k) = 10.*log10((ze_ice(i,k)+ze_rain(i,k))*1.e+18) + ! targeted single-point dump: every value below is final for this step + if (dbgpt_i .gt. 0 .and. & + abs(i+chksum_i0 - dbgpt_i) .le. dbgpt_halo .and. & + abs(limlog_j+chksum_j0 - dbgpt_j) .le. dbgpt_halo .and. & + abs(k - dbgpt_k) .le. dbgpt_halo) & + call dbgpt_write(it,i,limlog_j,k,qc(i,k),nc(i,k),mu_c(i,k),lamc(i,k), & + qr(i,k),nr(i,k),mu_r(i,k),lamr(i,k),ze_ice(i,k),ze_rain(i,k),diag_ze(i,k), & + dbg_nr_entry(k),dbg_nr_posti(k),dbg_nr_postw(k),dbg_nr_posts(k), & + dbg_qr_entry(k),dbg_qr_posti(k),dbg_qr_postw(k),dbg_qr_posts(k), & + dbg_dnr_ice(k),dbg_ncautr(k),dbg_nrslf(k),dbg_nrevp(k), & + dbg_qcacc_r(k),dbg_qcacc_f(k),dbg_accbr(k),dbg_rwrad(k),dbg_xvr(k), & + qitot(i,k,:),nitot(i,k,:),qirim(i,k,:),birim(i,k,:),zitot(i,k,:), & + diag_di(i,k,:)) + + ! DTD: for reflectivity > 85 dBZ, print out the location and all prognostic moments for rain and ice + ! for debugging purposes + ! DTD: changed to check on ice mean diameter above 2 cm for cat 2 + ! DTD: changed back to reflectivity check + !if (diag_di(i,k,2).gt.2.e-2) then + if (diag_ze(i,k).gt.85. .and. .false.) then + tmparr1(i,k) = th(i,k)*(pres(i,k)*1.e-5)**(rd*inv_cp) + print*,'i,j,k, ze_ice, ze_rain, ze_total, dbz',i,j_index,k,ze_ice(i,k),ze_rain(i,k),ze_ice(i,k)+ze_rain(i,k),diag_ze(i,k) + print*,'qv, T, qc, nc, qr, nr' + print*,qv(i,k),tmparr1(i,k),qc(i,k),nc(i,k),qr(i,k),nr(i,k) + do iice = 1,nCat + if (qitot(i,k,iice).ge.qsmall) then + + call calc_bulkRhoRime(qitot(i,k,iice),qirim(i,k,iice),qiliq(i,k,iice),birim(i,k,iice),rhop) + + call find_lookupTable_indices_1a(dumi,dumjj,dumii,dumll,dum1,dum4,dum5,dum7,isize, & + rimsize,liqsize,densize,qitot(i,k,iice),nitot(i,k,iice),qirim(i,k,iice), & + qiliq(i,k,iice),rhop) + + dum1z = 6./(200.*pi)*qitot(i,k,iice) + do imu=1,niter_mui + dummu_i = compute_mu_3moment1(nitot(i,k,iice),dum1z,zitot(i,k,iice),mu_i_max) + call find_lookupTable_indices_1c(dumzz,dum6,zsize,dummu_i) + call access_lookup_table_3mom_LF(dumzz,dumjj,dumii,dumll,dumi,12,dum1,dum4,dum5,dum6,dum7,dumden) + dum1z = 6./(dumden*pi)*qitot(i,k,iice) + end do + dummu_i = compute_mu_3moment1(nitot(i,k,iice),dum1z,zitot(i,k,iice),mu_i_max) + + ! diag_3d(i,k,3) = dummu_i + + endif ! qitot > qsmall + print*,'ice_cat, qitot, qirim, qiliq, nitot, birim, zitot' + print*,iice,qitot(i,k,iice),qirim(i,k,iice),qiliq(i,k,iice),nitot(i,k,iice),birim(i,k,iice),zitot(i,k,iice) + print*,'mu_i,Dmi',dummu_i,diag_di(i,k,iice) + enddo + endif + ! if qr is very small then set Nr to 0 (needs to be done here after call ! to ice lookup table because a minimum Nr of nsmall will be set otherwise even if qr=0) !Note (OPT) I think this is not needed @@ -6101,13 +7716,19 @@ SUBROUTINE p3_main(qc,nc,qr,nr,th_old,th,qv_old,qv,dt,qitot,qirim,qiliq,nitot,bi ! partition surface precipitation rates into types (and aslo for the ! maximum hail size, dhmax). - if (freq3DtypeDiag>0. .and. mod(it*dt,freq3DtypeDiag*60.)==0. .and. trim(model)=='WRF') then + ! ERM modified below to add log_diag + if ( (log_diag .or. (freq3DtypeDiag>0. .and. mod(it*dt,freq3DtypeDiag*60.)==0.)) & + .and. trim(model)=='WRF') then do i = its,ite do k = ktop,kbot,-kdir do iice = 1,nCat + if ( nitot(i,k,iice) > nsmall .and. qitot(i,k,iice) > qsmall ) then ! ERM added diag_dhmax(i,k,iice) = maxHailSize(rho(i,k),nitot(i,k,iice),rhofaci(i,k), & arr_lami(i,k,iice),arr_mui(i,k,iice)) + else + diag_dhmax(i,k,iice) = 0.0 + endif enddo diag_3d(i,k,1) = sum(qitot(i,k,:)) diag_3d(i,k,2) = maxval(diag_dhmax(i,k,:)) @@ -6141,7 +7762,7 @@ SUBROUTINE p3_main(qc,nc,qr,nr,th_old,th,qv_old,qv,dt,qitot,qirim,qiliq,nitot,bi if (present(qi_type)) qi_type(:,:,:) = 0. - if (freq3DtypeDiag>0. .and. mod(it*dt,freq3DtypeDiag*60.)==0.) then + if (log_diag .or. (freq3DtypeDiag>0. .and. mod(it*dt,freq3DtypeDiag*60.)==0.)) then ! ERM added log_diag !diagnose hydrometeor types for full columns ktop_typeDiag = ktop else @@ -11111,7 +12732,8 @@ subroutine find_lookupTable_indices_1b(dumj,dum3,rcollsize,qr,nr) ! find index for scaled mean rain size ! if no rain, then just choose dumj = 1 and do not calculate rain-ice collection processes - if (qr.ge.qsmall .and. nr.gt.0.) then + ! DTD: should we change to nsmall instead of 0? + if (qr.ge.qsmall .and. nr.gt.0) then ! calculate scaled mean size for consistency with ice lookup table dumlr = (qr/(pi*rhow*nr))**thrd dum3 = (alog10(1.*dumlr)+5.)*10.70415 @@ -11384,12 +13006,13 @@ subroutine get_cloud_dsd2(qc_grd,nc_grd,mu_c,rho,nu,dnu,lamc,lammin,lammax,cdist qc = qc_grd*iSCF !in-cloud value - if (qc.ge.qsmall) then + if (qc.ge.qsmall .and. nc_grd*iSCF >= nsmall) then ! ERM added nc check +! if (qc.ge.qsmall) then nc = nc_grd*iSCF !in-cloud value ! set minimum nc to prevent floating point error - nc = max(nc,nsmall) + if ( log_maxnsmall ) nc = max(nc,ntiny) ! ERM added log_maxnsmall and ntiny mu_c = 0.0005714*(nc*1.e-6*rho)+0.2714 mu_c = 1./(mu_c**2)-1. mu_c = max(mu_c,2.) @@ -11433,7 +13056,7 @@ subroutine get_cloud_dsd2(qc_grd,nc_grd,mu_c,rho,nu,dnu,lamc,lammin,lammax,cdist end subroutine get_cloud_dsd2 !=========================================================================================== - subroutine get_rain_dsd2(qr_grd,nr_grd,mu_r,lamr,cdistr,logn0r,iSPF) + subroutine get_rain_dsd2(qr_grd,nr_grd,mu_r,lamr,cdistr,logn0r,iSPF,it,i_loc,j_loc,k_loc,site) !Note (BUG) need to be updated because problem when qr=qsmall ! This will change the solution @@ -11447,15 +13070,26 @@ subroutine get_rain_dsd2(qr_grd,nr_grd,mu_r,lamr,cdistr,logn0r,iSPF) real, intent(inout) :: nr_grd !grid-mean real, intent(out) :: lamr,mu_r,cdistr,logn0r real, intent(in) :: iSPF + ! optional index arguments, used only by the limiter-firing log (log_limlog); + ! read, never modified. 'site' identifies the call site and is written into + ! the iice column: 1 = main k-loop, 2 = sedimentation, 3 = final diagnostics + ! (the one whose lamr feeds ze_rain). + integer, intent(in), optional :: it,i_loc,j_loc,k_loc,site !local variables: real :: inv_dum,lammax,lammin,qr,nr + real :: nr_before ! pre-limiter nr, for the limiter-firing log + integer :: site_loc !-------------------------------------------------------------------------- qr = qr_grd*iSPF !in-cloud value - if (qr.ge.qsmall) then + ! TEMPORARY (log_nrfloor): the nr condition mirrors the nc condition already + ! present in get_cloud_dsd2. Without it this routine does not decline to act + ! on a number-less point -- it manufactures nr via the lambda limiter below, + ! pinning the distribution at the maximum mean diameter. + if (qr.ge.qsmall .and. (log_nrfloor .or. nr_grd*iSPF.ge.nsmall)) then nr = nr_grd*iSPF !in-cloud value @@ -11464,7 +13098,7 @@ subroutine get_rain_dsd2(qr_grd,nr_grd,mu_r,lamr,cdistr,logn0r,iSPF) ! find spot in lookup table ! (scaled N/q for lookup table parameter space_ - nr = max(nr,nsmall) + if ( log_maxnsmall .and. log_nrfloor ) nr = max(nr,ntiny) ! ERM added log_maxnsmall and ntiny inv_dum = (qr/(cons1*nr*6.))**thrd ! apply constant mu_r: @@ -11491,12 +13125,31 @@ subroutine get_rain_dsd2(qr_grd,nr_grd,mu_r,lamr,cdistr,logn0r,iSPF) ! apply lambda limiters for rain lammax = (mu_r+1.)*1.e+5 lammin = (mu_r+1.)*inv_Drmax + nr_before = nr + site_loc = 0 + if (present(site)) site_loc = site + if (lamr.lt.lammin) then lamr = lammin nr = 6.*lamr**3*qr/(pi*rhow*(mu_r+3.)*(mu_r+2.)*(mu_r+1.)) + ! limiter-firing log: drops were too large for the mass, so the whole + ! distribution is pinned at the maximum mean diameter (1/inv_Drmax) + ! and nr is rebuilt from qr. ze_rain then becomes the largest value + ! attainable for this qr. ratio = fraction of the final number that + ! was actually present beforehand (0 = entirely manufactured). + if (log_limlog .and. present(it) .and. present(i_loc) .and. & + present(j_loc) .and. present(k_loc)) & + call limlog_write('RLAMX ',it,i_loc,j_loc,k_loc,site_loc, & + nr_before/max(nr,1.e-30),qr,nr_before,nr,mu_r) elseif (lamr.gt.lammax) then lamr = lammax nr = 6.*lamr**3*qr/(pi*rhow*(mu_r+3.)*(mu_r+2.)*(mu_r+1.)) + ! opposite branch: drops too small for the mass, pinned at the minimum + ! mean diameter. Logged for symmetry -- this one reduces ze_rain. + if (log_limlog .and. present(it) .and. present(i_loc) .and. & + present(j_loc) .and. present(k_loc)) & + call limlog_write('RLAMN ',it,i_loc,j_loc,k_loc,site_loc, & + nr_before/max(nr,1.e-30),qr,nr_before,nr,mu_r) endif logn0r = alog10(nr)+(mu_r+1.)*alog10(lamr)-alog10(gamma(mu_r+1)) !note: logn0r is calculated as log10(n0r) @@ -11505,6 +13158,7 @@ subroutine get_rain_dsd2(qr_grd,nr_grd,mu_r,lamr,cdistr,logn0r,iSPF) else + mu_r = 0. ! was left unset here; stale on the widened else path lamr = 0. cdistr = 0. logn0r = 0. @@ -11588,6 +13242,209 @@ subroutine impose_max_total_Ni(nitot_local,max_total_Ni,inv_rho_local) end subroutine impose_max_total_Ni + !=========================================================================================== + + subroutine limlog_write(event,it,i_loc,j_loc,k_loc,iice,ratio,v1,v2,v3,v4) + +!-------------------------------------------------------------------------------- +! Limiter-firing log (see the log_limlog block near the top of this module). +! Writes one line per firing of a point-local limiter/gate in p3_main, to the +! per-rank file p3_limlog_NNNN.out. Indices written are FULL-GRID: the caller +! passes local i and j and this routine adds chksum_i0/chksum_j0 (k is not +! decomposed in CM1, so local k = global k). +! +! Diagnostic only: this routine reads its arguments and never modifies model +! state, so enabling p3_limlog cannot change the answer. +!-------------------------------------------------------------------------------- + + implicit none + +!arguments: + character(len=*), intent(in) :: event + integer, intent(in) :: it,i_loc,j_loc,k_loc,iice + real, intent(in) :: ratio,v1,v2,v3,v4 + +!local variables: + character(len=32) :: limlog_fname + + if (limlog_full) return + + if (.not. limlog_opened) then + ! newunit= assigns a NEGATIVE unit number; track opened state with a + ! separate flag, not a sign test on the unit + write(limlog_fname,'(a,i4.4,a)') 'p3_limlog_', chksum_myid, '.out' + open(newunit=limlog_unit, file=trim(limlog_fname), status='replace', & + form='formatted', action='write') + limlog_opened = .true. + write(limlog_unit,'(a)') '# event it i j k (full grid) iice ratio v1 v2 v3 v4' + endif + + write(limlog_unit,'(a6,1x,i8,3(1x,i6),1x,i3,5(1x,e14.6))') & + event, it, i_loc+chksum_i0, j_loc+chksum_j0, k_loc, iice, & + ratio, v1, v2, v3, v4 + + limlog_nrec = limlog_nrec + 1 + + ! flush periodically so the log is intact if the run is killed or aborts + if (mod(limlog_nrec,1000) == 0) flush(limlog_unit) + + if (limlog_nrec .ge. limlog_maxrec) then + write(limlog_unit,'(a,i12,a)') '# LIMLOG RECORD CAP REACHED (', limlog_maxrec, & + ') -- no further firings recorded on this rank' + flush(limlog_unit) + limlog_full = .true. + endif + + end subroutine limlog_write + +!=========================================================================================== + + subroutine dbgpt_write(it,i_loc,j_loc,k_loc,qc_l,nc_l,mu_c_l,lamc_l, & + qr_l,nr_l,mu_r_l,lamr_l,ze_ice_l,ze_rain_l,dbz_l, & + nr_entry_l,nr_posti_l,nr_postw_l,nr_posts_l, & + qr_entry_l,qr_posti_l,qr_postw_l,qr_posts_l, & + dnr_ice_l,ncautr_l,nrslf_l,nrevp_l, & + qcacc_r_l,qcacc_f_l,accbr_l,rwrad_l,xvr_l, & + qitot_l,nitot_l,qirim_l,birim_l,zitot_l,diag_di_l) + +!-------------------------------------------------------------------------------- +! Targeted single-point dump (see the dbgpt_i block near the top of this module). +! Called once per timestep for the one grid point selected by the host, after +! diag_ze has been formed, so every value written is final for that step. +! +! Diagnostic only: reads its arguments and never modifies model state. +!-------------------------------------------------------------------------------- + + implicit none + +!arguments: + integer, intent(in) :: it,i_loc,j_loc,k_loc + real, intent(in) :: qc_l,nc_l,mu_c_l,lamc_l,qr_l,nr_l,mu_r_l,lamr_l + real, intent(in) :: ze_ice_l,ze_rain_l,dbz_l + ! rain-number attribution: nr at three checkpoints through the step, the summed + ! ice-interaction increment, and the three warm-phase rates (per second). + ! (nr_posti - nr_entry) = ice interactions, (nr_postw - nr_posti) = warm phase, + ! (nr_l - nr_postw) = sedimentation + post-process clipping. + real, intent(in) :: nr_entry_l,nr_posti_l,nr_postw_l,nr_posts_l + ! qr at the same three checkpoints, so the mass and number histories can be + ! compared directly -- a bad mass/number ratio present at entry means the rain + ! arrived broken, rather than being broken by anything inside p3_main. + real, intent(in) :: qr_entry_l,qr_posti_l,qr_postw_l,qr_posts_l + real, intent(in) :: dnr_ice_l,ncautr_l,nrslf_l,nrevp_l + ! accretion trace: qcacc before and after the conservation limiters, which of + ! the Cohard-Pinty branches was taken (see the branch-code comment at the + ! accretion block), and the two quantities that select it. + real, intent(in) :: qcacc_r_l,qcacc_f_l,accbr_l,rwrad_l,xvr_l + real, dimension(:), intent(in) :: qitot_l,nitot_l,qirim_l,birim_l,zitot_l,diag_di_l + +!local variables: + character(len=32) :: dbgpt_fname + integer :: iice_d,nCat_d + + nCat_d = size(qitot_l) + + if (.not. dbgpt_opened) then + ! newunit= assigns a NEGATIVE unit number; track opened state with a + ! separate flag, not a sign test on the unit + write(dbgpt_fname,'(a,i4.4,a)') 'p3_dbgpt_', chksum_myid, '.out' + open(newunit=dbgpt_unit, file=trim(dbgpt_fname), status='replace', & + form='formatted', action='write') + dbgpt_opened = .true. + write(dbgpt_unit,'(a,3(1x,i6),a,i3)') '# targeted dump centred on full-grid (i,j,k) =', & + dbgpt_i, dbgpt_j, dbgpt_k, ' halo =', dbgpt_halo + write(dbgpt_unit,'(a)') '# it i j k (full grid) qc nc mu_c lamc qr nr mu_r lamr'// & + ' ze_ice ze_rain dbz nr_entry nr_posti nr_postw nr_posts'// & + ' qr_entry qr_posti qr_postw qr_posts'// & + ' dnr_ice ncautr nrslf nrevp'// & + ' qcacc_raw qcacc_fin accbr rwrad xvr'// & + ' then per ice category: qitot nitot qirim birim zitot diag_di' + endif + + write(dbgpt_unit,'(i8,3(1x,i6),28(1x,e13.6))',advance='no') & + it, i_loc+chksum_i0, j_loc+chksum_j0, k_loc, & + qc_l, nc_l, mu_c_l, lamc_l, qr_l, nr_l, mu_r_l, lamr_l, & + ze_ice_l, ze_rain_l, dbz_l, & + nr_entry_l, nr_posti_l, nr_postw_l, nr_posts_l, & + qr_entry_l, qr_posti_l, qr_postw_l, qr_posts_l, & + dnr_ice_l, ncautr_l, nrslf_l, nrevp_l, & + qcacc_r_l, qcacc_f_l, accbr_l, rwrad_l, xvr_l + do iice_d = 1,nCat_d + write(dbgpt_unit,'(6(1x,e13.6))',advance='no') & + qitot_l(iice_d), nitot_l(iice_d), qirim_l(iice_d), & + birim_l(iice_d), zitot_l(iice_d), diag_di_l(iice_d) + enddo + write(dbgpt_unit,'(a)') '' + flush(dbgpt_unit) + + end subroutine dbgpt_write + +!=========================================================================================== + + subroutine impose_max_Ni(nitot_local,max_Ni,i_rho_local,it,i_loc,j_loc,k_loc, & + qitot_local,zitot_local) + +!-------------------------------------------------------------------------------- +! Impose maximum ice number concentration on each ice category individually. +! Note, with this approach the maximum total concentration (sum of all categories) +! can in principle be nCat*max_Ni. +! +! The optional index/field arguments are used only by the limiter-firing log +! (log_limlog); they are read, never modified, and omitting them (or leaving +! log_limlog=.false.) leaves the clip below bit-identical. +!-------------------------------------------------------------------------------- + + implicit none + +!arguments: + real, intent(inout), dimension(:) :: nitot_local !note: dimension (nCat) + real, intent(in) :: max_Ni,i_rho_local + integer, intent(in), optional :: it,i_loc,j_loc,k_loc + real, intent(in), dimension(:), optional :: qitot_local,zitot_local + +!local variables: + real :: dum + integer :: iice + real :: nmax_local,nbefore,qdum,zdum + +!--- limiter-firing log: record which categories the clip below actually binds +! on, BEFORE it is applied (diagnostic only; does not alter the clip) + if (log_limlog .and. present(it) .and. present(i_loc) .and. present(j_loc) & + .and. present(k_loc)) then + nmax_local = max_Ni*i_rho_local + do iice = 1,size(nitot_local) + if (nitot_local(iice) .gt. nmax_local) then + nbefore = nitot_local(iice) + qdum = 0. + zdum = 0. + if (present(qitot_local)) qdum = qitot_local(iice) + if (present(zitot_local)) zdum = zitot_local(iice) + call limlog_write('MAXNI ',it,i_loc,j_loc,k_loc,iice, & + nmax_local/max(nbefore,1.e-30), & + nbefore,nmax_local,qdum,zdum) + endif + enddo + endif + + nitot_local(:) = min(nitot_local(:),max_Ni*i_rho_local) + +!--- +! Previous apporach: +! Impose maximum total ice number concentration (total of all ice categories). +! If the sum of all nitot(:) exceeds maximum allowable, each category to preserve +! ratio of number between categories. +! +! if (sum(nitot_local(:)).ge.1.e-20) then +! dum = max_total_Ni*i_rho_local/sum(nitot_local(:)) +! nitot_local(:) = nitot_local(:)*min(dum,1.) +! endif +! +! Potential problem: +! This following approach can decrease the number for a category that already has +! small number, thereby creating unrealistic mean sizes and reflectivty values. +!--- + + end subroutine impose_max_Ni + !=========================================================================================== real function qv_sat(t_atm,p_atm,i_wrt) diff --git a/src/mp_driver.F b/src/mp_driver.F index e2205e8..9824317 100644 --- a/src/mp_driver.F +++ b/src/mp_driver.F @@ -15,14 +15,14 @@ MODULE mp_driver_module subroutine mp_driver(nstep,dt,qbudget,asq,bsq,xh,ruh,xf,ruf,yh,rvh,yf,rvf, & - mh,rmh,c1,c2,zh,mf,rmf,zf,rain,prate,pi0,th0,rho0,prs0,qv0, & + mh,rmh,c1,c2,zh,mf,rmf,zf,rain,hail,prate,pi0,th0,rho0,prs0,qv0, & rho,prs,dum1,dum2,dum3,dum4,dum5,dum6,dum7,dum8, & w3d,ppi,pp3d,ppten,sten,tha,th3d,thten,qa,q3d,qten, & p3a,p3o,dum2d1,dum2d2,dum2d3,dum2d4,dum2d5, & effc,effi,effs,effr,effg,effis, & tdiag,qdiag,out2d,out3d, & dowriteout,dorad,dotdwrite,doazimwrite,dorestart, & - getdbz,getvt,dotbud,doqbud) + getdbz,getvt,dotbud,doqbud,qunit) use input use constants @@ -34,7 +34,10 @@ subroutine mp_driver(nstep,dt,qbudget,asq,bsq,xh,ruh,xf,ruf,yh,rvh,yf,rvf, & use lfoice_module, only : lfo_ice_drive,lfoice_init use module_mp_graupel , only : mp_graupel use module_mp_nssl_2mom, only : nssl_2mom_driver - use microphy_p3, only : mp_p3_wrapper_wrf + ! note: P3's qsmall (1.e-12) is a different quantity from the host's qsmall + ! in module input, which is used elsewhere in this file -- import it renamed + use microphy_p3, only : mp_p3_wrapper_wrf, limlog_write, log_limlog, & + qsmall_p3 => qsmall use module_mp_jensen_ishmael , only : mp_jensen_ishmael implicit none @@ -49,7 +52,7 @@ subroutine mp_driver(nstep,dt,qbudget,asq,bsq,xh,ruh,xf,ruf,yh,rvh,yf,rvf, & real, intent(in), dimension(jb:je+1) :: yf,rvf real, intent(in), dimension(ib:ie,jb:je,kb:ke) :: mh,rmh,c1,c2,zh real, intent(in), dimension(ib:ie,jb:je,kb:ke+1) :: mf,rmf,zf - real, intent(inout), dimension(ib:ie,jb:je,nrain) :: rain + real, intent(inout), dimension(ib:ie,jb:je,nrain) :: rain,hail real, intent(inout), dimension(ib:ie,jb:je) :: prate real, intent(in), dimension(ib:ie,jb:je,kb:ke) :: pi0,th0,rho0,prs0,qv0 real, intent(inout), dimension(ib:ie,jb:je,kb:ke) :: rho,prs @@ -69,12 +72,17 @@ subroutine mp_driver(nstep,dt,qbudget,asq,bsq,xh,ruh,xf,ruf,yh,rvh,yf,rvf, & logical, intent(in) :: dowriteout,dorad,dotdwrite,doazimwrite,dorestart logical, intent(inout) :: getdbz,getvt logical, intent(in) :: dotbud,doqbud + character(len=20), dimension(maxq), intent(in) :: qunit !........ integer :: i,j,k,n,ind_dhmax integer :: has_reqc,has_reqi,has_reqs,do_radar_ref real :: rdt + ! PREQR (limiter-firing log): mass-weighted mean rain diameter at the p3 + ! call, and the threshold above which the mass/number ratio is flagged. + real :: preqr_d + real, parameter :: preqr_dmax = 1.0e-3 if( stopit ) getdbz = .true. @@ -302,7 +310,7 @@ subroutine mp_driver(nstep,dt,qbudget,asq,bsq,xh,ruh,xf,ruf,yh,rvh,yf,rvf, & do k=1,nk do j=1,nj do i=1,ni - ! cm1r17: to make things easier to understand, use same arrays + ! cm1r17: to make things easier to understand, use same arrays ! that are used for morrison code: ! dum1 = T (this should have been calculated already) ! dum2 = pi (nondimensional pressure) @@ -781,7 +789,7 @@ subroutine mp_driver(nstep,dt,qbudget,asq,bsq,xh,ruh,xf,ruf,yh,rvh,yf,rvf, & has_reqi = 0 has_reqs = 0 endif - + IF ( ptype .eq. 26 ) THEN ! graupel only call nssl_2mom_driver( & th = dum4, & @@ -799,8 +807,8 @@ subroutine mp_driver(nstep,dt,qbudget,asq,bsq,xh,ruh,xf,ruf,yh,rvh,yf,rvf, & cci = q3d(ib,jb,kb, lni), & csw = q3d(ib,jb,kb, lns), & chw = q3d(ib,jb,kb, lnh), & - zrw = q3d(ib,jb,kb, lzr), & - zhw = q3d(ib,jb,kb, lzh), & + zrw = q3d(ib,jb,kb, max(1,lzr)), & + zhw = q3d(ib,jb,kb, max(1,lzh)), & vhw = q3d(ib,jb,kb, lvh), & pii = dum1, & p = prs, & @@ -810,6 +818,7 @@ subroutine mp_driver(nstep,dt,qbudget,asq,bsq,xh,ruh,xf,ruf,yh,rvh,yf,rvf, & dtp = dt, & itimestep = nstep, & RAIN = rain, & + hail = hail, & nrain = nrain, & prate = prate, & dbz = qdiag(ibdq,jbdq,kbdq,qd_dbz), & @@ -826,7 +835,7 @@ subroutine mp_driver(nstep,dt,qbudget,asq,bsq,xh,ruh,xf,ruf,yh,rvh,yf,rvf, & diagflag = getdbz, & ib3d=ib3d,ie3d=ie3d,jb3d=jb3d,je3d=je3d,kb3d=kb3d,ke3d=ke3d, & nout3d=nout3d,out3d=out3d, & - ims = ib ,ime = ie , jms = jb ,jme = je, kms = kb,kme = ke, & + ims = ib ,ime = ie , jms = jb ,jme = je, kms = kb,kme = ke, & its = 1 ,ite = ni, jts = 1,jte = nj, kts = 1,kte = nk) ELSEIF ( ptype .eq. 27 ) THEN call nssl_2mom_driver( & @@ -847,9 +856,9 @@ subroutine mp_driver(nstep,dt,qbudget,asq,bsq,xh,ruh,xf,ruf,yh,rvh,yf,rvf, & csw = q3d(ib,jb,kb, lns), & chw = q3d(ib,jb,kb, lnh), & chl = q3d(ib,jb,kb, lnhl), & - zrw = q3d(ib,jb,kb, lzr), & - zhw = q3d(ib,jb,kb, lzh), & - zhl = q3d(ib,jb,kb, lzhl), & + zrw = q3d(ib,jb,kb, max(1,lzr)), & + zhw = q3d(ib,jb,kb, max(1,lzh)), & + zhl = q3d(ib,jb,kb, max(1,lzhl)), & vhw = q3d(ib,jb,kb, lvh), & vhl = q3d(ib,jb,kb, lvhl), & pii = dum1, & @@ -860,6 +869,7 @@ subroutine mp_driver(nstep,dt,qbudget,asq,bsq,xh,ruh,xf,ruf,yh,rvh,yf,rvf, & dtp = dt, & itimestep = nstep, & RAIN = rain, & + hail = hail, & nrain = nrain, & prate = prate, & dbz = qdiag(ibdq,jbdq,kbdq,qd_dbz), & @@ -876,7 +886,7 @@ subroutine mp_driver(nstep,dt,qbudget,asq,bsq,xh,ruh,xf,ruf,yh,rvh,yf,rvf, & diagflag = getdbz, & ib3d=ib3d,ie3d=ie3d,jb3d=jb3d,je3d=je3d,kb3d=kb3d,ke3d=ke3d, & nout3d=nout3d,out3d=out3d, & - ims = ib ,ime = ie , jms = jb ,jme = je, kms = kb,kme = ke, & + ims = ib ,ime = ie , jms = jb ,jme = je, kms = kb,kme = ke, & its = 1 ,ite = ni, jts = 1,jte = nj, kts = 1,kte = nk) ELSEIF ( ptype .eq. 28 ) THEN ! single moment call nssl_2mom_driver( & @@ -895,6 +905,7 @@ subroutine mp_driver(nstep,dt,qbudget,asq,bsq,xh,ruh,xf,ruf,yh,rvh,yf,rvf, & dtp = dt, & itimestep = nstep, & RAIN = rain, & + hail = hail, & nrain = nrain, & prate = prate, & dbz = qdiag(ibdq,jbdq,kbdq,qd_dbz), & @@ -909,7 +920,7 @@ subroutine mp_driver(nstep,dt,qbudget,asq,bsq,xh,ruh,xf,ruf,yh,rvh,yf,rvf, & diagflag = getdbz, & ib3d=ib3d,ie3d=ie3d,jb3d=jb3d,je3d=je3d,kb3d=kb3d,ke3d=ke3d, & nout3d=nout3d,out3d=out3d, & - ims = ib ,ime = ie , jms = jb ,jme = je, kms = kb,kme = ke, & + ims = ib ,ime = ie , jms = jb ,jme = je, kms = kb,kme = ke, & its = 1 ,ite = ni, jts = 1,jte = nj, kts = 1,kte = nk) ENDIF @@ -961,6 +972,8 @@ subroutine mp_driver(nstep,dt,qbudget,asq,bsq,xh,ruh,xf,ruf,yh,rvh,yf,rvf, & ! 52 2-mom-cld, 2-mom-rain, 2-mom-ice, 2-ice-category ! 53 2-mom-cld, 2-mom-rain, 3-mom-ice, 1-ice-category ! 54 2-mom-cld, 2-mom-rain, 3-mom-ice, 2-ice-category +! 56 2-mom-cld, 2-mom-rain, 3-mom-ice, 3-ice-category +! 57 2-mom-cld, 2-mom-rain, 3-mom-ice, 4-ice-category ! 60 2-mom-cld, 2-mom-rain, 3-mom-ice, 1-ice-category, liq-frac ! 61 2-mom-cld, 2-mom-rain, 3-mom-ice, 2-ice-category, liq-frac ! 62 2-mom-cld, 2-mom-rain, 3-mom-ice, 3-ice-category, liq-frac @@ -978,11 +991,19 @@ subroutine mp_driver(nstep,dt,qbudget,asq,bsq,xh,ruh,xf,ruf,yh,rvh,yf,rvf, & ELSEIF (ptype.eq.50 .or. ptype.eq.51 .or. ptype.eq.53 .or.ptype.eq.60) THEN ! for 1-ice-category configurations + ! ERM added this, I think. If it is needed, probably should put it at front + ! of every p3 call. For now, commenting out. + ! DO i = 1,numq + ! call pdefq(0.0,asq(i),ruh,rvh,rmh,rho,q3d(ib,jb,kb,i)) + ! ENDDO + ! ERM end rdt = 1.0/dt p3_jloop1: DO j=1,nj + dum1(:,:,:) = 0.0 ! ERM added (I think) + do k=1,nk do i=1,ni p3a(i,k, 1) = th0(i,j,k)+th3d(i,j,k) @@ -1031,7 +1052,7 @@ subroutine mp_driver(nstep,dt,qbudget,asq,bsq,xh,ruh,xf,ruf,yh,rvh,yf,rvf, & rainnc = p3a(1,1,22), & rainncv = dum1(ib,jb,2), & sr = dum1(ib,jb,3), & - snownc = dum1(ib,jb,4), & + snownc = dum1(ib,jb,4), & ! ERM has dum1(1:ni,1:1,4) here. Why? (applies to all p3 calls) snowncv = dum1(ib,jb,5), & ids=1, ide=ni, jds=1, jde=1, kds=1, kde=nk , & ims=1, ime=ni, jms=1, jme=1, kms=1, kme=nk , & @@ -1052,7 +1073,9 @@ subroutine mp_driver(nstep,dt,qbudget,asq,bsq,xh,ruh,xf,ruf,yh,rvh,yf,rvf, & diag2d_02 = p3a(1,1,25), & diag3d_01 = p3a(1,1,26), & diag3d_02 = p3a(1,1,27), & - diag3d_03 = p3a(1,1,28) ) + diag3d_03 = p3a(1,1,28), & + j_index = j, & ! DTD: added j_index for debugging + diagflag = (getdbz .or. dowriteout) ) ! ERM added diagflag (applies to all p3 calls) ! user-specified diagnostic output do i=1,ni @@ -1118,7 +1141,9 @@ subroutine mp_driver(nstep,dt,qbudget,asq,bsq,xh,ruh,xf,ruf,yh,rvh,yf,rvf, & diag2d_02 = p3a(1,1,26), & diag3d_01 = p3a(1,1,27), & diag3d_02 = p3a(1,1,28), & - diag3d_03 = p3a(1,1,29) ) + diag3d_03 = p3a(1,1,29), & + j_index = j, & ! DTD: added j_index for debugging + diagflag = (getdbz .or. dowriteout) ) do k=1,nk do i=1,ni @@ -1149,6 +1174,11 @@ subroutine mp_driver(nstep,dt,qbudget,asq,bsq,xh,ruh,xf,ruf,yh,rvh,yf,rvf, & do i=1,ni p3a(i,k,23) = q3d(i,j,k,9) p3a(i,k,24) = q3d(i,j,k,10) + ! ERM begin + IF ( lccn > 0 .and. trim(qunit(max(lccn,1))) /= 'none' ) THEN + p3a(i,k,31) = q3d(i,j,k,lccn) + ENDIF + ! ERM end enddo enddo @@ -1192,19 +1222,20 @@ subroutine mp_driver(nstep,dt,qbudget,asq,bsq,xh,ruh,xf,ruf,yh,rvh,yf,rvf, & diag3d_01 = p3a(1,1,28), & diag3d_02 = p3a(1,1,29), & - diag3d_03 = p3a(1,1,30) ) -! diag3d_04 = p3a(1,1,31), & -! diag3d_05 = p3a(1,1,32), & -! diag3d_06 = p3a(1,1,33), & -! diag3d_07 = p3a(1,1,34), & -! diag3d_08 = p3a(1,1,35), & -! diag3d_09 = p3a(1,1,36), & -! diag3d_10 = p3a(1,1,37) ) + diag3d_03 = p3a(1,1,30), & + cn = p3a(1,1,31), & ! cn added by ERM (applies to other p3 calls with this) + j_index = j, & ! DTD: added j_index for debugging + diagflag = (getdbz .or. dowriteout) ) do k=1,nk do i=1,ni q3d(i,j,k, 9) = p3a(i,k,23) ! nc q3d(i,j,k,10) = p3a(i,k,24) ! qzi_1 + ! ERM begin + IF ( lccn > 0 .and. trim(qunit(max(lccn,1))) /= 'none' ) THEN + q3d(i,j,k,lccn) = p3a(i,k,31) ! ccn + ENDIF + ! ERM end enddo enddo @@ -1218,13 +1249,13 @@ subroutine mp_driver(nstep,dt,qbudget,asq,bsq,xh,ruh,xf,ruf,yh,rvh,yf,rvf, & out3d(i,j,k,1) = p3a(i,k,28) out3d(i,j,k,2) = p3a(i,k,29) out3d(i,j,k,3) = p3a(i,k,30) - out3d(i,j,k,4) = p3a(i,k,31) - out3d(i,j,k,5) = p3a(i,k,32) - out3d(i,j,k,6) = p3a(i,k,33) - out3d(i,j,k,7) = p3a(i,k,34) - out3d(i,j,k,8) = p3a(i,k,35) - out3d(i,j,k,9) = p3a(i,k,36) - out3d(i,j,k,10) = p3a(i,k,37) + ! out3d(i,j,k,4) = p3a(i,k,31) + ! out3d(i,j,k,5) = p3a(i,k,32) + ! out3d(i,j,k,6) = p3a(i,k,33) + ! out3d(i,j,k,7) = p3a(i,k,34) + ! out3d(i,j,k,8) = p3a(i,k,35) + ! out3d(i,j,k,9) = p3a(i,k,36) + ! out3d(i,j,k,10) = p3a(i,k,37) enddo enddo @@ -1284,14 +1315,9 @@ subroutine mp_driver(nstep,dt,qbudget,asq,bsq,xh,ruh,xf,ruf,yh,rvh,yf,rvf, & diag3d_01 = p3a(1,1,29), & diag3d_02 = p3a(1,1,30), & - diag3d_03 = p3a(1,1,31) ) -! diag3d_04 = p3a(1,1,32), & -! diag3d_05 = p3a(1,1,33), & -! diag3d_06 = p3a(1,1,34), & -! diag3d_07 = p3a(1,1,35), & -! diag3d_08 = p3a(1,1,36), & -! diag3d_09 = p3a(1,1,37), & -! diag3d_10 = p3a(1,1,38) ) + diag3d_03 = p3a(1,1,31), & + j_index = j, & ! DTD: added j_index for debugging + diagflag = (getdbz .or. dowriteout) ) do k=1,nk do i=1,ni @@ -1408,10 +1434,17 @@ subroutine mp_driver(nstep,dt,qbudget,asq,bsq,xh,ruh,xf,ruf,yh,rvh,yf,rvf, & ! P3 scheme -- config: 2-mom-cld, 2-mom-rain, 2-mom-ice, 2-ice-category ! !---------------------------------------------------------------------------! + ! ERM begin + ! DO i = 1,numq + ! call pdefq(0.0,asq(i),ruh,rvh,rmh,rho,q3d(ib,jb,kb,i)) + ! ENDDO + ! ERM end rdt = 1.0/dt p3_jloop2: DO j=1,nj + dum1(:,:,:) = 0.0 ! Added by ERM + do k=1,nk do i=1,ni p3a(i,k, 1) = th0(i,j,k)+th3d(i,j,k) ! th_3d @@ -1489,7 +1522,9 @@ subroutine mp_driver(nstep,dt,qbudget,asq,bsq,xh,ruh,xf,ruf,yh,rvh,yf,rvf, & diag2d_02 = p3a(1,1,34), & diag3d_01 = p3a(1,1,35), & diag3d_02 = p3a(1,1,36), & - diag3d_03 = p3a(1,1,37) ) + diag3d_03 = p3a(1,1,37), & + j_index = j, & ! DTD: added j_index for debugging + diagflag = (getdbz .or. dowriteout) ) if( axisymm.eq.1 )then do i=1,ni @@ -1590,11 +1625,17 @@ subroutine mp_driver(nstep,dt,qbudget,asq,bsq,xh,ruh,xf,ruf,yh,rvh,yf,rvf, & !---------------------------------------------------------------------------! ! P3 scheme -- config: 2-mom-cld, 2-mom-rain, 3-mom-ice, 2-ice-category ! !---------------------------------------------------------------------------! - + ! ERM begin + ! DO i = 1,numq ! nqs2 + ! call pdefq(0.0,asq(i),ruh,rvh,rmh,rho,q3d(ib,jb,kb,i)) + ! ENDDO + ! ERM end rdt = 1.0/dt p3_jloop5: DO j=1,nj + dum1(:,:,:) = 0.0 + do k=1,nk do i=1,ni p3a(i,k, 1) = th0(i,j,k)+th3d(i,j,k) ! th_3d @@ -1621,6 +1662,9 @@ subroutine mp_driver(nstep,dt,qbudget,asq,bsq,xh,ruh,xf,ruf,yh,rvh,yf,rvf, & p3a(i,k,27) = q3d(i,j,k, 6) ! nc_3d p3a(i,k,31) = q3d(i,j,k,14) ! qzi1_3d p3a(i,k,32) = q3d(i,j,k,15) ! qzi2_3d + IF ( lccn > 0 .and. trim(qunit(max(lccn,1))) /= 'none' ) THEN + p3a(i,k,40) = q3d(i,j,k,lccn) ! ccna (added by ERM) + ENDIF enddo enddo @@ -1628,6 +1672,42 @@ subroutine mp_driver(nstep,dt,qbudget,asq,bsq,xh,ruh,xf,ruf,yh,rvh,yf,rvf, & p3a(i,1,22) = 0.0 enddo + ! PRE-call state check (limiter-firing log, p3_limlog): does the host + ! hand P3 a category with ice mass but no number? P3 itself always + ! zeroes qitot and nitot together, so any such point was produced + ! outside p3_main -- host advection, sedimentation, or the tendency + ! application. Logged as PREQN into the same p3_limlog_NNNN.out, with + ! v1..v4 = qitot, nitot, qirim, zitot. Diagnostic only. + ! PREQR: does the host hand P3 rain whose mass and number are grossly + ! inconsistent? Unlike PREQN this is a ratio test, not a sign test -- + ! the mass-weighted mean diameter D = (6*qr/(pi*rhow*nr))**(1/3) is + ! compared against preqr_dmax. 1 mm is already large for the light-to- + ! moderate rain rates involved, and the scheme's own ceiling is 2 mm, + ! so anything flagged here is heading for the rain lambda limiter. + ! v1..v4 = qr, nr, qc, nc; ratio column carries D in metres. + IF ( log_limlog ) THEN + do k=1,nk + do i=1,ni + if (p3a(i,k,18).ge.qsmall_p3 .and. p3a(i,k,19).le.0.) & + call limlog_write('PREQN ',nstep,i,j,k,1,0., & + p3a(i,k,18),p3a(i,k,19),p3a(i,k,20),p3a(i,k,31)) + if (p3a(i,k,23).ge.qsmall_p3 .and. p3a(i,k,25).le.0.) & + call limlog_write('PREQN ',nstep,i,j,k,2,0., & + p3a(i,k,23),p3a(i,k,25),p3a(i,k,24),p3a(i,k,32)) + IF ( p3a(i,k,4).ge.qsmall_p3 ) THEN + if (p3a(i,k,5).le.0.) then + preqr_d = 999. ! no number at all for this mass + else + preqr_d = (6.0*p3a(i,k,4)/(3.14159265*1000.0*p3a(i,k,5)))**(1.0/3.0) + endif + if (preqr_d .gt. preqr_dmax) & + call limlog_write('PREQR ',nstep,i,j,k,0,preqr_d, & + p3a(i,k,4),p3a(i,k,5),p3a(i,k,3),p3a(i,k,27)) + ENDIF + enddo + enddo + ENDIF + call mp_p3_wrapper_wrf( th = p3a(1,1,1), & qv = p3a(1,1,2), & qc = p3a(1,1,3), & @@ -1676,7 +1756,10 @@ subroutine mp_driver(nstep,dt,qbudget,asq,bsq,xh,ruh,xf,ruf,yh,rvh,yf,rvf, & diag2d_02 = p3a(1,1,36), & diag3d_01 = p3a(1,1,37), & diag3d_02 = p3a(1,1,38), & - diag3d_03 = p3a(1,1,39) ) + diag3d_03 = p3a(1,1,39), & + cn = p3a(1,1,40), & + j_index = j, & ! DTD: added j_index for debugging + diagflag = (getdbz .or. dowriteout) ) if( axisymm.eq.1 )then do i=1,ni @@ -1721,6 +1804,9 @@ subroutine mp_driver(nstep,dt,qbudget,asq,bsq,xh,ruh,xf,ruf,yh,rvh,yf,rvf, & q3d(i,j,k, 6 ) = p3a(i,k,27) ! nc_3d q3d(i,j,k,14 ) = p3a(i,k,31) ! qzi1_3d q3d(i,j,k,15 ) = p3a(i,k,32) ! qzi2_3d + IF ( lccn > 0 .and. trim(qunit(max(lccn,1))) /= 'none' ) THEN ! Added by ERM + q3d(i,j,k,lccn) = p3a(i,k,40) ! ccna + ENDIF enddo enddo @@ -1773,16 +1859,15 @@ subroutine mp_driver(nstep,dt,qbudget,asq,bsq,xh,ruh,xf,ruf,yh,rvh,yf,rvf, & if(timestats.ge.1) time_microphy=time_microphy+mytime() - - ELSEIF (ptype.eq.61) THEN + ELSEIF (ptype.eq.56) THEN !-------------------------------------------------------------------------------------! -! P3 scheme -- config: 2-mom-cld, 2-mom-rain, 3-mom-ice, 2-ice-category, liq-frac ! +! P3 scheme -- config: 2-mom-cld, 2-mom-rain, 3-mom-ice, 3-ice-category ! !-------------------------------------------------------------------------------------! rdt = 1.0/dt - p3_jloop3: DO j=1,nj + p3_jloop7: DO j=1,nj do k=1,nk do i=1,ni @@ -1792,7 +1877,7 @@ subroutine mp_driver(nstep,dt,qbudget,asq,bsq,xh,ruh,xf,ruf,yh,rvh,yf,rvf, & qten(i,j,k,nqv) = p3a(i,k, 2) p3a(i,k, 3) = q3d(i,j,k,nqc) ! qc_3d p3a(i,k, 4) = q3d(i,j,k,nqr) ! qr_3d - p3a(i,k, 5) = q3d(i,j,k,7) ! qnr_3d + p3a(i,k, 5) = q3d(i,j,k,8) ! qnr_3d p3a(i,k, 6) = th0(i,j,k)+tha(i,j,k) ! th_old p3a(i,k, 7) = qa(i,j,k,nqv) ! qv_old p3a(i,k, 8) = pi0(i,j,k)+pp3d(i,j,k) ! pii @@ -1800,23 +1885,26 @@ subroutine mp_driver(nstep,dt,qbudget,asq,bsq,xh,ruh,xf,ruf,yh,rvh,yf,rvf, & p3a(i,k,10) = dz*rmh(i,j,k) ! dz p3a(i,k,11) = 0.5*(w3d(i,j,k)+w3d(i,j,k+1)) ! w p3a(i,k,18) = q3d(i,j,k,nqi) ! qi1_3d - p3a(i,k,19) = q3d(i,j,k,8) ! qni1_3d - p3a(i,k,20) = q3d(i,j,k,9) ! qir1_3d - p3a(i,k,21) = q3d(i,j,k,10) ! qib1_3d + p3a(i,k,19) = q3d(i,j,k,9) ! qni1_3d + p3a(i,k,20) = q3d(i,j,k,10) ! qir1_3d + p3a(i,k,21) = q3d(i,j,k,11) ! qib1_3d p3a(i,k,23) = q3d(i,j,k, 5) ! qi2_3d - p3a(i,k,24) = q3d(i,j,k,12) ! qir2_3d - p3a(i,k,25) = q3d(i,j,k,11) ! qni2_3d - p3a(i,k,26) = q3d(i,j,k,13) ! qib2_3d - p3a(i,k,27) = q3d(i,j,k, 6) ! nc_3d - p3a(i,k,31) = q3d(i,j,k,14) ! qzi1_3d - p3a(i,k,32) = q3d(i,j,k,15) ! qli1_3d - p3a(i,k,33) = q3d(i,j,k,16) ! qzi2_3d - p3a(i,k,34) = q3d(i,j,k,17) ! qli2_3d + p3a(i,k,24) = q3d(i,j,k,13) ! qir2_3d + p3a(i,k,25) = q3d(i,j,k,12) ! qni2_3d + p3a(i,k,26) = q3d(i,j,k,14) ! qib2_3d + p3a(i,k,27) = q3d(i,j,k, 7) ! nc_3d + p3a(i,k,31) = q3d(i,j,k,18) ! qzi1_3d + p3a(i,k,32) = q3d(i,j,k,19) ! qzi2_3d + p3a(i,k,33) = q3d(i,j,k, 6) ! qi3_3d + p3a(i,k,34) = q3d(i,j,k,16) ! qir3_3d + p3a(i,k,35) = q3d(i,j,k,15) ! qni3_3d + p3a(i,k,36) = q3d(i,j,k,17) ! qib3_3d + p3a(i,k,37) = q3d(i,j,k,20) ! qzi3_3d enddo enddo do i=1,ni - p3a(i,1,22) = 0.0 + p3a(i,1,22) = 0.0 enddo call mp_p3_wrapper_wrf( th = p3a(1,1,1), & @@ -1843,7 +1931,7 @@ subroutine mp_driver(nstep,dt,qbudget,asq,bsq,xh,ruh,xf,ruf,yh,rvh,yf,rvf, & diag_zdbz = p3a(1,1,12), & diag_effc = p3a(1,1,13), & diag_effi_ave = p3a(1,1,14), & - n_iceCat = 2, & + n_iceCat = 3, & qit_1 = p3a(1,1,18), & qni_1 = p3a(1,1,19), & qir_1 = p3a(1,1,20), & @@ -1852,25 +1940,33 @@ subroutine mp_driver(nstep,dt,qbudget,asq,bsq,xh,ruh,xf,ruf,yh,rvh,yf,rvf, & diag_dmi_1 = p3a(1,1,16), & diag_rhoi_1 = p3a(1,1,17), & qzi_1 = p3a(1,1,31), & - qli_1 = p3a(1,1,32), & nc = p3a(1,1,27), & qit_2 = p3a(1,1,23), & qir_2 = p3a(1,1,24), & qni_2 = p3a(1,1,25), & qib_2 = p3a(1,1,26), & - qzi_2 = p3a(1,1,33), & - qli_2 = p3a(1,1,34), & + qzi_2 = p3a(1,1,32), & diag_vmi_2 = p3a(1,1,28), & diag_dmi_2 = p3a(1,1,29), & diag_rhoi_2 = p3a(1,1,30), & - diag_dhmax_1 = p3a(1,1,35), & - diag_dhmax_2 = p3a(1,1,36), & - diag2d_01 = p3a(1,1,37), & - diag2d_02 = p3a(1,1,38), & - diag3d_01 = p3a(1,1,39), & - diag3d_02 = p3a(1,1,40), & - diag3d_03 = p3a(1,1,41) ) - + qit_3 = p3a(1,1,33), & + qir_3 = p3a(1,1,34), & + qni_3 = p3a(1,1,35), & + qib_3 = p3a(1,1,36), & + qzi_3 = p3a(1,1,37), & + diag_vmi_3 = p3a(1,1,38), & + diag_dmi_3 = p3a(1,1,39), & + diag_rhoi_3 = p3a(1,1,40), & + diag_dhmax_1 = p3a(1,1,41), & + diag_dhmax_2 = p3a(1,1,42), & + diag_dhmax_3 = p3a(1,1,43), & + diag2d_01 = p3a(1,1,44), & + diag2d_02 = p3a(1,1,45), & + diag3d_01 = p3a(1,1,46), & + diag3d_02 = p3a(1,1,47), & + diag3d_03 = p3a(1,1,48), & + j_index = j, & ! DTD: added j_index for debugging + diagflag = (getdbz .or. dowriteout) ) if( axisymm.eq.1 )then do i=1,ni prate(i,j) = p3a(i,1,22)*rdt @@ -1886,7 +1982,7 @@ subroutine mp_driver(nstep,dt,qbudget,asq,bsq,xh,ruh,xf,ruf,yh,rvh,yf,rvf, & do n=1,nrain do i=1,ni ! convert from mm to cm: - rain(i,j,n) = rain(i,j,n) + 0.1*p3a(i,1,22) + rain(i,j,n) = rain(i,j,n) + 0.1*p3a(i,1,22) enddo enddo @@ -1895,27 +1991,30 @@ subroutine mp_driver(nstep,dt,qbudget,asq,bsq,xh,ruh,xf,ruf,yh,rvh,yf,rvf, & if( abs(p3a(i,k,1)-thten(i,j,k)).ge.tsmall .or. & abs(p3a(i,k,2)-qten(i,j,k,nqv)).ge.qsmall )then pp3d(i,j,k)=(rho(i,j,k)*(rd+rv*p3a(i,k,2))*p3a(i,k,1)*rp00)**rddcv - prs(i,j,k)=p00*(pp3d(i,j,k)**cpdrd) - pp3d(i,j,k)=pp3d(i,j,k)-pi0(i,j,k) - th3d(i,j,k)=th3d(i,j,k)+(p3a(i,k,1)-thten(i,j,k)) + prs(i,j,k)=p00*(pp3d(i,j,k)**cpdrd) + pp3d(i,j,k)=pp3d(i,j,k)-pi0(i,j,k) + th3d(i,j,k)=th3d(i,j,k)+(p3a(i,k,1)-thten(i,j,k)) endif q3d(i,j,k,nqv) = p3a(i,k, 2) q3d(i,j,k,nqc) = p3a(i,k, 3) ! qc_3d q3d(i,j,k,nqr) = p3a(i,k, 4) ! qr_3d - q3d(i,j,k, 7 ) = p3a(i,k, 5) ! qnr_3d + q3d(i,j,k, 8 ) = p3a(i,k, 5) ! qnr_3d q3d(i,j,k,nqi) = p3a(i,k,18) ! qi1_3d - q3d(i,j,k, 8 ) = p3a(i,k,19) ! qni1_3d - q3d(i,j,k, 9 ) = p3a(i,k,20) ! qir1_3d - q3d(i,j,k,10 ) = p3a(i,k,21) ! qib1_3d + q3d(i,j,k, 9 ) = p3a(i,k,19) ! qni1_3d + q3d(i,j,k,10 ) = p3a(i,k,20) ! qir1_3d + q3d(i,j,k,11 ) = p3a(i,k,21) ! qib1_3d q3d(i,j,k, 5 ) = p3a(i,k,23) ! qi2_3d - q3d(i,j,k,12 ) = p3a(i,k,24) ! qir2_3d - q3d(i,j,k,11 ) = p3a(i,k,25) ! qni2_3d - q3d(i,j,k,13 ) = p3a(i,k,26) ! qib2_3d - q3d(i,j,k, 6 ) = p3a(i,k,27) ! nc_3d - q3d(i,j,k,14 ) = p3a(i,k,31) ! qzi1_3d - q3d(i,j,k,15 ) = p3a(i,k,32) ! qli1_3d - q3d(i,j,k,16 ) = p3a(i,k,33) ! qzi2_3d - q3d(i,j,k,17 ) = p3a(i,k,34) ! qli2_3d + q3d(i,j,k,13 ) = p3a(i,k,24) ! qir2_3d + q3d(i,j,k,12 ) = p3a(i,k,25) ! qni2_3d + q3d(i,j,k,14 ) = p3a(i,k,26) ! qib2_3d + q3d(i,j,k, 7 ) = p3a(i,k,27) ! nc_3d + q3d(i,j,k,18 ) = p3a(i,k,31) ! qzi1_3d + q3d(i,j,k,19 ) = p3a(i,k,32) ! qzi2_3d + q3d(i,j,k, 6 ) = p3a(i,k,33) ! qi3_3d + q3d(i,j,k,16 ) = p3a(i,k,34) ! qir3_3d + q3d(i,j,k,15 ) = p3a(i,k,35) ! qni3_3d + q3d(i,j,k,17 ) = p3a(i,k,36) ! qib3_3d + q3d(i,j,k,20 ) = p3a(i,k,37) ! qzi3_3d enddo enddo @@ -1939,83 +2038,91 @@ subroutine mp_driver(nstep,dt,qbudget,asq,bsq,xh,ruh,xf,ruf,yh,rvh,yf,rvf, & IF( dowriteout .or. getdbz )THEN do k=1,nk do i=1,ni - p3o(i,j,k,1) = p3a(i,k,15) ! vmi_1 - p3o(i,j,k,2) = p3a(i,k,16) ! dmi_1 - p3o(i,j,k,3) = p3a(i,k,17) ! rhoi_1 - p3o(i,j,k,4) = p3a(i,k,35) ! dhmax_1 - p3o(i,j,k,5) = p3a(i,k,28) ! _2 - p3o(i,j,k,6) = p3a(i,k,29) ! _2 - p3o(i,j,k,7) = p3a(i,k,30) ! _2 - p3o(i,j,k,8) = p3a(i,k,36) ! _2 - enddo - enddo + p3o(i,j,k, 1) = p3a(i,k,15) ! vmi_1 + p3o(i,j,k, 2) = p3a(i,k,16) ! dmi_1 + p3o(i,j,k, 3) = p3a(i,k,17) ! rhoi_1 + p3o(i,j,k, 4) = p3a(i,k,41) ! dhmax_1 + + p3o(i,j,k, 5) = p3a(i,k,28) ! _2 + p3o(i,j,k, 6) = p3a(i,k,29) + p3o(i,j,k, 7) = p3a(i,k,30) + p3o(i,j,k, 8) = p3a(i,k,42) + + p3o(i,j,k, 9) = p3a(i,k,38) ! _3 + p3o(i,j,k,10) = p3a(i,k,39) + p3o(i,j,k,11) = p3a(i,k,40) + p3o(i,j,k,12) = p3a(i,k,43) + enddo + enddo ENDIF ! user-specified diagnostic output do i=1,ni - out2d(i,j,1) = p3a(i,1,37) - out2d(i,j,2) = p3a(i,1,38) + out2d(i,j,1) = p3a(i,1,44) + out2d(i,j,2) = p3a(i,1,45) enddo do k=1,nk do i=1,ni - out3d(i,j,k,1) = p3a(i,k,39) - out3d(i,j,k,2) = p3a(i,k,40) - out3d(i,j,k,3) = p3a(i,k,41) + out3d(i,j,k,1) = p3a(i,k,46) + out3d(i,j,k,2) = p3a(i,k,47) + out3d(i,j,k,3) = p3a(i,k,48) enddo enddo - ENDDO p3_jloop3 - if (timestats.ge.1) time_microphy = time_microphy+mytime() + ENDDO p3_jloop7 - ELSEIF( ptype.eq.62 )THEN + if(timestats.ge.1) time_microphy=time_microphy+mytime() + ELSEIF (ptype.eq.57) THEN !-------------------------------------------------------------------------------------! -! P3 scheme -- config: 2-mom-cld, 2-mom-rain, 3-mom-ice, 3-ice-category, liq-frac ! +! P3 scheme -- config: 2-mom-cld, 2-mom-rain, 3-mom-ice, 4-ice-category, ! !-------------------------------------------------------------------------------------! rdt = 1.0/dt - p3_jloop4: DO j=1,nj + p3_jloop8: DO j=1,nj do k=1,nk do i=1,ni - p3a(i,k, 1) = th0(i,j,k)+th3d(i,j,k) ! th_3d - p3a(i,k, 2) = q3d(i,j,k,nqv) ! qv_3d + p3a(i,k, 1) = th0(i,j,k)+th3d(i,j,k) ! th + p3a(i,k, 2) = q3d(i,j,k,nqv) ! qv thten(i,j,k) = p3a(i,k, 1) qten(i,j,k,nqv) = p3a(i,k, 2) - p3a(i,k, 3) = q3d(i,j,k,nqc) ! qc_3d - p3a(i,k, 4) = q3d(i,j,k,nqr) ! qr_3d - p3a(i,k, 5) = q3d(i,j,k,8) ! qnr_3d + p3a(i,k, 3) = q3d(i,j,k,nqc) ! qc + p3a(i,k, 4) = q3d(i,j,k,nqr) ! qr + p3a(i,k, 5) = q3d(i,j,k,9) ! qnr p3a(i,k, 6) = th0(i,j,k)+tha(i,j,k) ! th_old p3a(i,k, 7) = qa(i,j,k,nqv) ! qv_old p3a(i,k, 8) = pi0(i,j,k)+pp3d(i,j,k) ! pii p3a(i,k, 9) = prs(i,j,k) ! p p3a(i,k,10) = dz*rmh(i,j,k) ! dz p3a(i,k,11) = 0.5*(w3d(i,j,k)+w3d(i,j,k+1)) ! w - p3a(i,k,18) = q3d(i,j,k,nqi) ! qi1_3d - p3a(i,k,19) = q3d(i,j,k,9) ! qni1_3d - p3a(i,k,20) = q3d(i,j,k,10) ! qir1_3d - p3a(i,k,21) = q3d(i,j,k,11) ! qib1_3d - p3a(i,k,23) = q3d(i,j,k, 5) ! qi2_3d - p3a(i,k,24) = q3d(i,j,k,13) ! qir2_3d - p3a(i,k,25) = q3d(i,j,k,12) ! qni2_3d - p3a(i,k,26) = q3d(i,j,k,14) ! qib2_3d - p3a(i,k,27) = q3d(i,j,k, 7) ! nc_3d - p3a(i,k,31) = q3d(i,j,k,15) ! qzi1_3d - p3a(i,k,32) = q3d(i,j,k,16) ! qli1_3d - p3a(i,k,33) = q3d(i,j,k,17) ! qzi2_3d - p3a(i,k,34) = q3d(i,j,k,18) ! qli2_3d - - p3a(i,k,35) = q3d(i,j,k, 6) ! qi3_3d - p3a(i,k,36) = q3d(i,j,k,20) ! qir3_3d - p3a(i,k,37) = q3d(i,j,k,19) ! qni3_3d - p3a(i,k,38) = q3d(i,j,k,21) ! qib3_3d - p3a(i,k,39) = q3d(i,j,k,22) ! qzi3_3d - p3a(i,k,40) = q3d(i,j,k,23) ! qli3_3d + p3a(i,k,18) = q3d(i,j,k,nqi) ! qit_1 + p3a(i,k,19) = q3d(i,j,k,10) ! qni_1 + p3a(i,k,20) = q3d(i,j,k,11) ! qir_1 + p3a(i,k,21) = q3d(i,j,k,12) ! qib_1 + p3a(i,k,23) = q3d(i,j,k, 5) ! qit_2 + p3a(i,k,24) = q3d(i,j,k,14) ! qir_2 + p3a(i,k,25) = q3d(i,j,k,13) ! qni_2 + p3a(i,k,26) = q3d(i,j,k,15) ! qib_2 + p3a(i,k,27) = q3d(i,j,k, 8) ! nc + p3a(i,k,31) = q3d(i,j,k,22) ! qzi_1 + p3a(i,k,32) = q3d(i,j,k,23) ! qzi_2 + p3a(i,k,33) = q3d(i,j,k, 6) ! qit_3 + p3a(i,k,34) = q3d(i,j,k,17) ! qir_3 + p3a(i,k,35) = q3d(i,j,k,16) ! qni_3 + p3a(i,k,36) = q3d(i,j,k,18) ! qib_3 + p3a(i,k,37) = q3d(i,j,k,24) ! qzi_3 + p3a(i,k,41) = q3d(i,j,k, 7) ! qit_4 + p3a(i,k,42) = q3d(i,j,k,20) ! qir_4 + p3a(i,k,43) = q3d(i,j,k,19) ! qni_4 + p3a(i,k,44) = q3d(i,j,k,21) ! qib_4 + p3a(i,k,45) = q3d(i,j,k,25) ! qzi_4 enddo enddo + do i=1,ni p3a(i,1,22) = 0.0 enddo @@ -2044,7 +2151,7 @@ subroutine mp_driver(nstep,dt,qbudget,asq,bsq,xh,ruh,xf,ruf,yh,rvh,yf,rvf, & diag_zdbz = p3a(1,1,12), & diag_effc = p3a(1,1,13), & diag_effi_ave = p3a(1,1,14), & - n_iceCat = 3, & + n_iceCat = 4, & qit_1 = p3a(1,1,18), & qni_1 = p3a(1,1,19), & qir_1 = p3a(1,1,20), & @@ -2053,35 +2160,42 @@ subroutine mp_driver(nstep,dt,qbudget,asq,bsq,xh,ruh,xf,ruf,yh,rvh,yf,rvf, & diag_dmi_1 = p3a(1,1,16), & diag_rhoi_1 = p3a(1,1,17), & qzi_1 = p3a(1,1,31), & - qli_1 = p3a(1,1,32), & nc = p3a(1,1,27), & qit_2 = p3a(1,1,23), & qir_2 = p3a(1,1,24), & qni_2 = p3a(1,1,25), & qib_2 = p3a(1,1,26), & - qzi_2 = p3a(1,1,33), & - qli_2 = p3a(1,1,34), & + qzi_2 = p3a(1,1,32), & diag_vmi_2 = p3a(1,1,28), & diag_dmi_2 = p3a(1,1,29), & diag_rhoi_2 = p3a(1,1,30), & - qit_3 = p3a(1,1,35), & - qir_3 = p3a(1,1,36), & - qni_3 = p3a(1,1,37), & - qib_3 = p3a(1,1,38), & - qzi_3 = p3a(1,1,39), & - qli_3 = p3a(1,1,40), & - diag_vmi_3 = p3a(1,1,41), & - diag_dmi_3 = p3a(1,1,42), & - diag_rhoi_3 = p3a(1,1,43), & - diag_dhmax_1 = p3a(1,1,44), & - diag_dhmax_2 = p3a(1,1,45), & - diag_dhmax_3 = p3a(1,1,46), & - diag2d_01 = p3a(1,1,47), & - diag2d_02 = p3a(1,1,48), & - diag3d_01 = p3a(1,1,49), & - diag3d_02 = p3a(1,1,50), & - diag3d_03 = p3a(1,1,51) ) - + qit_3 = p3a(1,1,33), & + qir_3 = p3a(1,1,34), & + qni_3 = p3a(1,1,35), & + qib_3 = p3a(1,1,36), & + qzi_3 = p3a(1,1,37), & + diag_vmi_3 = p3a(1,1,38), & + diag_dmi_3 = p3a(1,1,39), & + diag_rhoi_3 = p3a(1,1,40), & + qit_4 = p3a(1,1,41), & + qir_4 = p3a(1,1,42), & + qni_4 = p3a(1,1,43), & + qib_4 = p3a(1,1,44), & + qzi_4 = p3a(1,1,45), & + diag_vmi_4 = p3a(1,1,46), & + diag_dmi_4 = p3a(1,1,47), & + diag_rhoi_4 = p3a(1,1,48), & + diag_dhmax_1 = p3a(1,1,49), & + diag_dhmax_2 = p3a(1,1,50), & + diag_dhmax_3 = p3a(1,1,51), & + diag_dhmax_4 = p3a(1,1,52), & + diag2d_01 = p3a(1,1,53), & + diag2d_02 = p3a(1,1,54), & + diag3d_01 = p3a(1,1,55), & + diag3d_02 = p3a(1,1,56), & + diag3d_03 = p3a(1,1,57), & + j_index = j, & ! DTD: added j_index for debugging + diagflag = (getdbz .or. dowriteout) ) if( axisymm.eq.1 )then do i=1,ni prate(i,j) = p3a(i,1,22)*rdt @@ -2097,7 +2211,7 @@ subroutine mp_driver(nstep,dt,qbudget,asq,bsq,xh,ruh,xf,ruf,yh,rvh,yf,rvf, & do n=1,nrain do i=1,ni ! convert from mm to cm: - rain(i,j,n) = rain(i,j,n) + 0.1*p3a(i,1,22) + rain(i,j,n) = rain(i,j,n) + 0.1*p3a(i,1,22) enddo enddo @@ -2106,33 +2220,35 @@ subroutine mp_driver(nstep,dt,qbudget,asq,bsq,xh,ruh,xf,ruf,yh,rvh,yf,rvf, & if( abs(p3a(i,k,1)-thten(i,j,k)).ge.tsmall .or. & abs(p3a(i,k,2)-qten(i,j,k,nqv)).ge.qsmall )then pp3d(i,j,k)=(rho(i,j,k)*(rd+rv*p3a(i,k,2))*p3a(i,k,1)*rp00)**rddcv - prs(i,j,k)=p00*(pp3d(i,j,k)**cpdrd) - pp3d(i,j,k)=pp3d(i,j,k)-pi0(i,j,k) - th3d(i,j,k)=th3d(i,j,k)+(p3a(i,k,1)-thten(i,j,k)) + prs(i,j,k)=p00*(pp3d(i,j,k)**cpdrd) + pp3d(i,j,k)=pp3d(i,j,k)-pi0(i,j,k) + th3d(i,j,k)=th3d(i,j,k)+(p3a(i,k,1)-thten(i,j,k)) endif q3d(i,j,k,nqv) = p3a(i,k, 2) - q3d(i,j,k,nqc) = p3a(i,k, 3) ! qc_3d - q3d(i,j,k,nqr) = p3a(i,k, 4) ! qr_3d - q3d(i,j,k, 8 ) = p3a(i,k, 5) ! qnr_3d - q3d(i,j,k,nqi) = p3a(i,k,18) ! qi1_3d - q3d(i,j,k, 9 ) = p3a(i,k,19) ! qni1_3d - q3d(i,j,k,10 ) = p3a(i,k,20) ! qir1_3d - q3d(i,j,k,11 ) = p3a(i,k,21) ! qib1_3d - q3d(i,j,k, 5 ) = p3a(i,k,23) ! qi2_3d - q3d(i,j,k,13 ) = p3a(i,k,24) ! qir2_3d - q3d(i,j,k,12 ) = p3a(i,k,25) ! qni2_3d - q3d(i,j,k,14 ) = p3a(i,k,26) ! qib2_3d - q3d(i,j,k, 7 ) = p3a(i,k,27) ! nc_3d - q3d(i,j,k,15 ) = p3a(i,k,31) ! qzi1_3d - q3d(i,j,k,16 ) = p3a(i,k,32) ! qli1_3d - q3d(i,j,k,17 ) = p3a(i,k,33) ! qzi2_3d - q3d(i,j,k,18 ) = p3a(i,k,34) ! qli2_3d - q3d(i,j,k, 6 ) = p3a(i,k,35) ! qi3_3d - q3d(i,j,k,20 ) = p3a(i,k,36) ! qir3_3d - q3d(i,j,k,19 ) = p3a(i,k,37) ! qni3_3d - q3d(i,j,k,21 ) = p3a(i,k,38) ! qib3_3d - q3d(i,j,k,22 ) = p3a(i,k,39) ! qzi3_3d - q3d(i,j,k,23 ) = p3a(i,k,40) ! qli3_3d + q3d(i,j,k,nqc) = p3a(i,k, 3) ! qc + q3d(i,j,k,nqr) = p3a(i,k, 4) ! qr + q3d(i,j,k, 9 ) = p3a(i,k, 5) ! qnr_1 + q3d(i,j,k,nqi) = p3a(i,k,18) ! qit_1 + q3d(i,j,k,10 ) = p3a(i,k,19) ! qni_1 + q3d(i,j,k,11 ) = p3a(i,k,20) ! qir_1 + q3d(i,j,k,12 ) = p3a(i,k,21) ! qib_1 + q3d(i,j,k, 5 ) = p3a(i,k,23) ! qit_2 + q3d(i,j,k,14 ) = p3a(i,k,24) ! qir_2 + q3d(i,j,k,13 ) = p3a(i,k,25) ! qni_2 + q3d(i,j,k,15 ) = p3a(i,k,26) ! qib_2 + q3d(i,j,k, 8 ) = p3a(i,k,27) ! nc + q3d(i,j,k,22 ) = p3a(i,k,31) ! qzi_1 + q3d(i,j,k,23 ) = p3a(i,k,32) ! qzi_2 + q3d(i,j,k, 6 ) = p3a(i,k,33) ! qit_3 + q3d(i,j,k,17 ) = p3a(i,k,34) ! qir_3 + q3d(i,j,k,16 ) = p3a(i,k,35) ! qni_3 + q3d(i,j,k,18 ) = p3a(i,k,36) ! qib_3 + q3d(i,j,k,24 ) = p3a(i,k,37) ! qzi_3 + q3d(i,j,k, 7 ) = p3a(i,k,41) ! qit_4 + q3d(i,j,k,20 ) = p3a(i,k,42) ! qir_4 + q3d(i,j,k,19 ) = p3a(i,k,43) ! qni_4 + q3d(i,j,k,21 ) = p3a(i,k,44) ! qib_4 + q3d(i,j,k,25 ) = p3a(i,k,45) ! qzi_4 enddo enddo @@ -2159,72 +2275,517 @@ subroutine mp_driver(nstep,dt,qbudget,asq,bsq,xh,ruh,xf,ruf,yh,rvh,yf,rvf, & p3o(i,j,k, 1) = p3a(i,k,15) ! vmi_1 p3o(i,j,k, 2) = p3a(i,k,16) ! dmi_1 p3o(i,j,k, 3) = p3a(i,k,17) ! rhoi_1 - p3o(i,j,k, 4) = p3a(i,k,44) ! dhmax_1 + p3o(i,j,k, 4) = p3a(i,k,49) ! dhmax_1 p3o(i,j,k, 5) = p3a(i,k,28) ! _2 p3o(i,j,k, 6) = p3a(i,k,29) p3o(i,j,k, 7) = p3a(i,k,30) - p3o(i,j,k, 8) = p3a(i,k,45) + p3o(i,j,k, 8) = p3a(i,k,50) - p3o(i,j,k, 9) = p3a(i,k,41) ! _3 - p3o(i,j,k,10) = p3a(i,k,42) - p3o(i,j,k,11) = p3a(i,k,43) - p3o(i,j,k,12) = p3a(i,k,46) + p3o(i,j,k, 9) = p3a(i,k,38) ! _3 + p3o(i,j,k,10) = p3a(i,k,39) + p3o(i,j,k,11) = p3a(i,k,40) + p3o(i,j,k,12) = p3a(i,k,51) + + p3o(i,j,k,13) = p3a(i,k,46) ! _4 + p3o(i,j,k,14) = p3a(i,k,47) + p3o(i,j,k,15) = p3a(i,k,48) + p3o(i,j,k,16) = p3a(i,k,52) enddo enddo ENDIF ! user-specified diagnostic output do i=1,ni - out2d(i,j,1) = p3a(i,1,47) - out2d(i,j,2) = p3a(i,1,48) + out2d(i,j,1) = p3a(i,1,53) + out2d(i,j,2) = p3a(i,1,54) enddo do k=1,nk do i=1,ni - out3d(i,j,k,1) = p3a(i,k,49) - out3d(i,j,k,2) = p3a(i,k,50) - out3d(i,j,k,3) = p3a(i,k,51) + out3d(i,j,k,1) = p3a(i,k,55) + out3d(i,j,k,2) = p3a(i,k,56) + out3d(i,j,k,3) = p3a(i,k,57) enddo enddo - ENDDO p3_jloop4 - - if(timestats.ge.1) time_microphy=time_microphy+mytime() + ENDDO p3_jloop8 + if (timestats.ge.1) time_microphy = time_microphy+mytime() - ELSEIF (ptype.eq.63) THEN + ELSEIF (ptype.eq.61) THEN !-------------------------------------------------------------------------------------! -! P3 scheme -- config: 2-mom-cld, 2-mom-rain, 3-mom-ice, 4-ice-category, liq-frac ! +! P3 scheme -- config: 2-mom-cld, 2-mom-rain, 3-mom-ice, 2-ice-category, liq-frac ! !-------------------------------------------------------------------------------------! - + ! ERM begin + ! DO i = 1,numq + ! call pdefq(0.0,asq(i),ruh,rvh,rmh,rho,q3d(ib,jb,kb,i)) + ! ENDDO + ! ERM end rdt = 1.0/dt - p3_jloop6: DO j=1,nj + p3_jloop3: DO j=1,nj + + dum1(:,:,:) = 0.0 do k=1,nk do i=1,ni - p3a(i,k, 1) = th0(i,j,k)+th3d(i,j,k) ! th - p3a(i,k, 2) = q3d(i,j,k,nqv) ! qv + p3a(i,k, 1) = th0(i,j,k)+th3d(i,j,k) ! th_3d + p3a(i,k, 2) = q3d(i,j,k,nqv) ! qv_3d thten(i,j,k) = p3a(i,k, 1) qten(i,j,k,nqv) = p3a(i,k, 2) - p3a(i,k, 3) = q3d(i,j,k,nqc) ! qc - p3a(i,k, 4) = q3d(i,j,k,nqr) ! qr - p3a(i,k, 5) = q3d(i,j,k,9) ! qnr + p3a(i,k, 3) = q3d(i,j,k,nqc) ! qc_3d + p3a(i,k, 4) = q3d(i,j,k,nqr) ! qr_3d + p3a(i,k, 5) = q3d(i,j,k,7) ! qnr_3d p3a(i,k, 6) = th0(i,j,k)+tha(i,j,k) ! th_old p3a(i,k, 7) = qa(i,j,k,nqv) ! qv_old p3a(i,k, 8) = pi0(i,j,k)+pp3d(i,j,k) ! pii p3a(i,k, 9) = prs(i,j,k) ! p p3a(i,k,10) = dz*rmh(i,j,k) ! dz p3a(i,k,11) = 0.5*(w3d(i,j,k)+w3d(i,j,k+1)) ! w - p3a(i,k,18) = q3d(i,j,k,nqi) ! qit_1 - p3a(i,k,19) = q3d(i,j,k,10) ! qni_1 - p3a(i,k,20) = q3d(i,j,k,11) ! qir_1 - p3a(i,k,21) = q3d(i,j,k,12) ! qib_1 - p3a(i,k,23) = q3d(i,j,k, 5) ! qit_2 - p3a(i,k,24) = q3d(i,j,k,14) ! qir_2 - p3a(i,k,25) = q3d(i,j,k,13) ! qni_2 + p3a(i,k,18) = q3d(i,j,k,nqi) ! qi1_3d + p3a(i,k,19) = q3d(i,j,k,8) ! qni1_3d + p3a(i,k,20) = q3d(i,j,k,9) ! qir1_3d + p3a(i,k,21) = q3d(i,j,k,10) ! qib1_3d + p3a(i,k,23) = q3d(i,j,k, 5) ! qi2_3d + p3a(i,k,24) = q3d(i,j,k,12) ! qir2_3d + p3a(i,k,25) = q3d(i,j,k,11) ! qni2_3d + p3a(i,k,26) = q3d(i,j,k,13) ! qib2_3d + p3a(i,k,27) = q3d(i,j,k, 6) ! nc_3d + p3a(i,k,31) = q3d(i,j,k,14) ! qzi1_3d + p3a(i,k,32) = q3d(i,j,k,15) ! qli1_3d + p3a(i,k,33) = q3d(i,j,k,16) ! qzi2_3d + p3a(i,k,34) = q3d(i,j,k,17) ! qli2_3d + enddo + enddo + + do i=1,ni + p3a(i,1,22) = 0.0 + enddo + + call mp_p3_wrapper_wrf( th = p3a(1,1,1), & + qv = p3a(1,1,2), & + qc = p3a(1,1,3), & + qr = p3a(1,1,4), & + qnr = p3a(1,1,5), & + th_old = p3a(1,1,6), & + qv_old = p3a(1,1,7), & + pii = p3a(1,1,8), & + p = p3a(1,1,9), & + dz = p3a(1,1,10), & + w = p3a(1,1,11), & + dt = dt, & + itimestep = nstep, & + rainnc = p3a(1,1,22), & + rainncv = dum1(ib,jb,2), & + sr = dum1(ib,jb,3), & + snownc = dum1(ib,jb,4), & + snowncv = dum1(ib,jb,5), & + ids=1, ide=ni, jds=1, jde=1, kds=1, kde=nk , & + ims=1, ime=ni, jms=1, jme=1, kms=1, kme=nk , & + its=1, ite=ni, jts=1, jte=1, kts=1, kte=nk , & + diag_zdbz = p3a(1,1,12), & + diag_effc = p3a(1,1,13), & + diag_effi_ave = p3a(1,1,14), & + n_iceCat = 2, & + qit_1 = p3a(1,1,18), & + qni_1 = p3a(1,1,19), & + qir_1 = p3a(1,1,20), & + qib_1 = p3a(1,1,21), & + diag_vmi_1 = p3a(1,1,15), & + diag_dmi_1 = p3a(1,1,16), & + diag_rhoi_1 = p3a(1,1,17), & + qzi_1 = p3a(1,1,31), & + qli_1 = p3a(1,1,32), & + nc = p3a(1,1,27), & + qit_2 = p3a(1,1,23), & + qir_2 = p3a(1,1,24), & + qni_2 = p3a(1,1,25), & + qib_2 = p3a(1,1,26), & + qzi_2 = p3a(1,1,33), & + qli_2 = p3a(1,1,34), & + diag_vmi_2 = p3a(1,1,28), & + diag_dmi_2 = p3a(1,1,29), & + diag_rhoi_2 = p3a(1,1,30), & + diag_dhmax_1 = p3a(1,1,35), & + diag_dhmax_2 = p3a(1,1,36), & + diag2d_01 = p3a(1,1,37), & + diag2d_02 = p3a(1,1,38), & + diag3d_01 = p3a(1,1,39), & + diag3d_02 = p3a(1,1,40), & + diag3d_03 = p3a(1,1,41), & + j_index = j, & ! DTD: added j_index for debugging + diagflag = (getdbz .or. dowriteout) ) + + if( axisymm.eq.1 )then + do i=1,ni + prate(i,j) = p3a(i,1,22)*rdt + qbudget(6) = qbudget(6) + p3a(i,1,22)*ruh(i)*rvh(j)*dx*dy*dum3(i,j,1)/rho(i,j,1) + enddo + else + do i=1,ni + prate(i,j) = p3a(i,1,22)*rdt + qbudget(6) = qbudget(6) + p3a(i,1,22)*ruh(i)*rvh(j)*dx*dy + enddo + endif + + do n=1,nrain + do i=1,ni + ! convert from mm to cm: + rain(i,j,n) = rain(i,j,n) + 0.1*p3a(i,1,22) + enddo + enddo + + do k=1,nk + do i=1,ni + if( abs(p3a(i,k,1)-thten(i,j,k)).ge.tsmall .or. & + abs(p3a(i,k,2)-qten(i,j,k,nqv)).ge.qsmall )then + pp3d(i,j,k)=(rho(i,j,k)*(rd+rv*p3a(i,k,2))*p3a(i,k,1)*rp00)**rddcv + prs(i,j,k)=p00*(pp3d(i,j,k)**cpdrd) + pp3d(i,j,k)=pp3d(i,j,k)-pi0(i,j,k) + th3d(i,j,k)=th3d(i,j,k)+(p3a(i,k,1)-thten(i,j,k)) + endif + q3d(i,j,k,nqv) = p3a(i,k, 2) + q3d(i,j,k,nqc) = p3a(i,k, 3) ! qc_3d + q3d(i,j,k,nqr) = p3a(i,k, 4) ! qr_3d + q3d(i,j,k, 7 ) = p3a(i,k, 5) ! qnr_3d + q3d(i,j,k,nqi) = p3a(i,k,18) ! qi1_3d + q3d(i,j,k, 8 ) = p3a(i,k,19) ! qni1_3d + q3d(i,j,k, 9 ) = p3a(i,k,20) ! qir1_3d + q3d(i,j,k,10 ) = p3a(i,k,21) ! qib1_3d + q3d(i,j,k, 5 ) = p3a(i,k,23) ! qi2_3d + q3d(i,j,k,12 ) = p3a(i,k,24) ! qir2_3d + q3d(i,j,k,11 ) = p3a(i,k,25) ! qni2_3d + q3d(i,j,k,13 ) = p3a(i,k,26) ! qib2_3d + q3d(i,j,k, 6 ) = p3a(i,k,27) ! nc_3d + q3d(i,j,k,14 ) = p3a(i,k,31) ! qzi1_3d + q3d(i,j,k,15 ) = p3a(i,k,32) ! qli1_3d + q3d(i,j,k,16 ) = p3a(i,k,33) ! qzi2_3d + q3d(i,j,k,17 ) = p3a(i,k,34) ! qli2_3d + enddo + enddo + + IF( getdbz .and. qd_dbz.ge.1 )THEN + do k=1,nk + do i=1,ni + qdiag(i,j,k,qd_dbz) = p3a(i,k,12) + enddo + enddo + ENDIF + + IF( dorad )THEN + do k=1,nk + do i=1,ni + effc(i,j,k) = p3a(i,k,13) + effi(i,j,k) = p3a(i,k,14) + enddo + enddo + ENDIF + + IF( dowriteout .or. getdbz )THEN + do k=1,nk + do i=1,ni + p3o(i,j,k,1) = p3a(i,k,15) ! vmi_1 + p3o(i,j,k,2) = p3a(i,k,16) ! dmi_1 + p3o(i,j,k,3) = p3a(i,k,17) ! rhoi_1 + p3o(i,j,k,4) = p3a(i,k,35) ! dhmax_1 + p3o(i,j,k,5) = p3a(i,k,28) ! _2 + p3o(i,j,k,6) = p3a(i,k,29) ! _2 + p3o(i,j,k,7) = p3a(i,k,30) ! _2 + p3o(i,j,k,8) = p3a(i,k,36) ! _2 + enddo + enddo + ENDIF + + ! user-specified diagnostic output + do i=1,ni + out2d(i,j,1) = p3a(i,1,37) + out2d(i,j,2) = p3a(i,1,38) + enddo + do k=1,nk + do i=1,ni + out3d(i,j,k,1) = p3a(i,k,39) + out3d(i,j,k,2) = p3a(i,k,40) + out3d(i,j,k,3) = p3a(i,k,41) + enddo + enddo + + ENDDO p3_jloop3 + + if (timestats.ge.1) time_microphy = time_microphy+mytime() + + ELSEIF( ptype.eq.62 )THEN + +!-------------------------------------------------------------------------------------! +! P3 scheme -- config: 2-mom-cld, 2-mom-rain, 3-mom-ice, 3-ice-category, liq-frac ! +!-------------------------------------------------------------------------------------! + ! ERM begin + ! DO i = 1,numq + ! call pdefq(0.0,asq(i),ruh,rvh,rmh,rho,q3d(ib,jb,kb,i)) + ! ENDDO + ! ERM end + rdt = 1.0/dt + + p3_jloop4: DO j=1,nj + + dum1(:,:,:) = 0.0 + + do k=1,nk + do i=1,ni + p3a(i,k, 1) = th0(i,j,k)+th3d(i,j,k) ! th_3d + p3a(i,k, 2) = q3d(i,j,k,nqv) ! qv_3d + thten(i,j,k) = p3a(i,k, 1) + qten(i,j,k,nqv) = p3a(i,k, 2) + p3a(i,k, 3) = q3d(i,j,k,nqc) ! qc_3d + p3a(i,k, 4) = q3d(i,j,k,nqr) ! qr_3d + p3a(i,k, 5) = q3d(i,j,k,8) ! qnr_3d + p3a(i,k, 6) = th0(i,j,k)+tha(i,j,k) ! th_old + p3a(i,k, 7) = qa(i,j,k,nqv) ! qv_old + p3a(i,k, 8) = pi0(i,j,k)+pp3d(i,j,k) ! pii + p3a(i,k, 9) = prs(i,j,k) ! p + p3a(i,k,10) = dz*rmh(i,j,k) ! dz + p3a(i,k,11) = 0.5*(w3d(i,j,k)+w3d(i,j,k+1)) ! w + p3a(i,k,18) = q3d(i,j,k,nqi) ! qi1_3d + p3a(i,k,19) = q3d(i,j,k,9) ! qni1_3d + p3a(i,k,20) = q3d(i,j,k,10) ! qir1_3d + p3a(i,k,21) = q3d(i,j,k,11) ! qib1_3d + p3a(i,k,23) = q3d(i,j,k, 5) ! qi2_3d + p3a(i,k,24) = q3d(i,j,k,13) ! qir2_3d + p3a(i,k,25) = q3d(i,j,k,12) ! qni2_3d + p3a(i,k,26) = q3d(i,j,k,14) ! qib2_3d + p3a(i,k,27) = q3d(i,j,k, 7) ! nc_3d + p3a(i,k,31) = q3d(i,j,k,15) ! qzi1_3d + p3a(i,k,32) = q3d(i,j,k,16) ! qli1_3d + p3a(i,k,33) = q3d(i,j,k,17) ! qzi2_3d + p3a(i,k,34) = q3d(i,j,k,18) ! qli2_3d + + p3a(i,k,35) = q3d(i,j,k, 6) ! qi3_3d + p3a(i,k,36) = q3d(i,j,k,20) ! qir3_3d + p3a(i,k,37) = q3d(i,j,k,19) ! qni3_3d + p3a(i,k,38) = q3d(i,j,k,21) ! qib3_3d + p3a(i,k,39) = q3d(i,j,k,22) ! qzi3_3d + p3a(i,k,40) = q3d(i,j,k,23) ! qli3_3d + enddo + enddo + + do i=1,ni + p3a(i,1,22) = 0.0 + enddo + + call mp_p3_wrapper_wrf( th = p3a(1,1,1), & + qv = p3a(1,1,2), & + qc = p3a(1,1,3), & + qr = p3a(1,1,4), & + qnr = p3a(1,1,5), & + th_old = p3a(1,1,6), & + qv_old = p3a(1,1,7), & + pii = p3a(1,1,8), & + p = p3a(1,1,9), & + dz = p3a(1,1,10), & + w = p3a(1,1,11), & + dt = dt, & + itimestep = nstep, & + rainnc = p3a(1,1,22), & + rainncv = dum1(ib,jb,2), & + sr = dum1(ib,jb,3), & + snownc = dum1(ib,jb,4), & + snowncv = dum1(ib,jb,5), & + ids=1, ide=ni, jds=1, jde=1, kds=1, kde=nk , & + ims=1, ime=ni, jms=1, jme=1, kms=1, kme=nk , & + its=1, ite=ni, jts=1, jte=1, kts=1, kte=nk , & + diag_zdbz = p3a(1,1,12), & + diag_effc = p3a(1,1,13), & + diag_effi_ave = p3a(1,1,14), & + n_iceCat = 3, & + qit_1 = p3a(1,1,18), & + qni_1 = p3a(1,1,19), & + qir_1 = p3a(1,1,20), & + qib_1 = p3a(1,1,21), & + diag_vmi_1 = p3a(1,1,15), & + diag_dmi_1 = p3a(1,1,16), & + diag_rhoi_1 = p3a(1,1,17), & + qzi_1 = p3a(1,1,31), & + qli_1 = p3a(1,1,32), & + nc = p3a(1,1,27), & + qit_2 = p3a(1,1,23), & + qir_2 = p3a(1,1,24), & + qni_2 = p3a(1,1,25), & + qib_2 = p3a(1,1,26), & + qzi_2 = p3a(1,1,33), & + qli_2 = p3a(1,1,34), & + diag_vmi_2 = p3a(1,1,28), & + diag_dmi_2 = p3a(1,1,29), & + diag_rhoi_2 = p3a(1,1,30), & + qit_3 = p3a(1,1,35), & + qir_3 = p3a(1,1,36), & + qni_3 = p3a(1,1,37), & + qib_3 = p3a(1,1,38), & + qzi_3 = p3a(1,1,39), & + qli_3 = p3a(1,1,40), & + diag_vmi_3 = p3a(1,1,41), & + diag_dmi_3 = p3a(1,1,42), & + diag_rhoi_3 = p3a(1,1,43), & + diag_dhmax_1 = p3a(1,1,44), & + diag_dhmax_2 = p3a(1,1,45), & + diag_dhmax_3 = p3a(1,1,46), & + diag2d_01 = p3a(1,1,47), & + diag2d_02 = p3a(1,1,48), & + diag3d_01 = p3a(1,1,49), & + diag3d_02 = p3a(1,1,50), & + diag3d_03 = p3a(1,1,51), & + j_index = j, & ! DTD: added j_index for debugging + diagflag = (getdbz .or. dowriteout) ) + + if( axisymm.eq.1 )then + do i=1,ni + prate(i,j) = p3a(i,1,22)*rdt + qbudget(6) = qbudget(6) + p3a(i,1,22)*ruh(i)*rvh(j)*dx*dy*dum3(i,j,1)/rho(i,j,1) + enddo + else + do i=1,ni + prate(i,j) = p3a(i,1,22)*rdt + qbudget(6) = qbudget(6) + p3a(i,1,22)*ruh(i)*rvh(j)*dx*dy + enddo + endif + + do n=1,nrain + do i=1,ni + ! convert from mm to cm: + rain(i,j,n) = rain(i,j,n) + 0.1*p3a(i,1,22) + enddo + enddo + + do k=1,nk + do i=1,ni + if( abs(p3a(i,k,1)-thten(i,j,k)).ge.tsmall .or. & + abs(p3a(i,k,2)-qten(i,j,k,nqv)).ge.qsmall )then + pp3d(i,j,k)=(rho(i,j,k)*(rd+rv*p3a(i,k,2))*p3a(i,k,1)*rp00)**rddcv + prs(i,j,k)=p00*(pp3d(i,j,k)**cpdrd) + pp3d(i,j,k)=pp3d(i,j,k)-pi0(i,j,k) + th3d(i,j,k)=th3d(i,j,k)+(p3a(i,k,1)-thten(i,j,k)) + endif + q3d(i,j,k,nqv) = p3a(i,k, 2) + q3d(i,j,k,nqc) = p3a(i,k, 3) ! qc_3d + q3d(i,j,k,nqr) = p3a(i,k, 4) ! qr_3d + q3d(i,j,k, 8 ) = p3a(i,k, 5) ! qnr_3d + q3d(i,j,k,nqi) = p3a(i,k,18) ! qi1_3d + q3d(i,j,k, 9 ) = p3a(i,k,19) ! qni1_3d + q3d(i,j,k,10 ) = p3a(i,k,20) ! qir1_3d + q3d(i,j,k,11 ) = p3a(i,k,21) ! qib1_3d + q3d(i,j,k, 5 ) = p3a(i,k,23) ! qi2_3d + q3d(i,j,k,13 ) = p3a(i,k,24) ! qir2_3d + q3d(i,j,k,12 ) = p3a(i,k,25) ! qni2_3d + q3d(i,j,k,14 ) = p3a(i,k,26) ! qib2_3d + q3d(i,j,k, 7 ) = p3a(i,k,27) ! nc_3d + q3d(i,j,k,15 ) = p3a(i,k,31) ! qzi1_3d + q3d(i,j,k,16 ) = p3a(i,k,32) ! qli1_3d + q3d(i,j,k,17 ) = p3a(i,k,33) ! qzi2_3d + q3d(i,j,k,18 ) = p3a(i,k,34) ! qli2_3d + q3d(i,j,k, 6 ) = p3a(i,k,35) ! qi3_3d + q3d(i,j,k,20 ) = p3a(i,k,36) ! qir3_3d + q3d(i,j,k,19 ) = p3a(i,k,37) ! qni3_3d + q3d(i,j,k,21 ) = p3a(i,k,38) ! qib3_3d + q3d(i,j,k,22 ) = p3a(i,k,39) ! qzi3_3d + q3d(i,j,k,23 ) = p3a(i,k,40) ! qli3_3d + enddo + enddo + + IF( getdbz .and. qd_dbz.ge.1 )THEN + do k=1,nk + do i=1,ni + qdiag(i,j,k,qd_dbz) = p3a(i,k,12) + enddo + enddo + ENDIF + + IF( dorad )THEN + do k=1,nk + do i=1,ni + effc(i,j,k) = p3a(i,k,13) + effi(i,j,k) = p3a(i,k,14) + enddo + enddo + ENDIF + + IF( dowriteout .or. getdbz )THEN + do k=1,nk + do i=1,ni + p3o(i,j,k, 1) = p3a(i,k,15) ! vmi_1 + p3o(i,j,k, 2) = p3a(i,k,16) ! dmi_1 + p3o(i,j,k, 3) = p3a(i,k,17) ! rhoi_1 + p3o(i,j,k, 4) = p3a(i,k,44) ! dhmax_1 + + p3o(i,j,k, 5) = p3a(i,k,28) ! _2 + p3o(i,j,k, 6) = p3a(i,k,29) + p3o(i,j,k, 7) = p3a(i,k,30) + p3o(i,j,k, 8) = p3a(i,k,45) + + p3o(i,j,k, 9) = p3a(i,k,41) ! _3 + p3o(i,j,k,10) = p3a(i,k,42) + p3o(i,j,k,11) = p3a(i,k,43) + p3o(i,j,k,12) = p3a(i,k,46) + enddo + enddo + ENDIF + + ! user-specified diagnostic output + do i=1,ni + out2d(i,j,1) = p3a(i,1,47) + out2d(i,j,2) = p3a(i,1,48) + enddo + do k=1,nk + do i=1,ni + out3d(i,j,k,1) = p3a(i,k,49) + out3d(i,j,k,2) = p3a(i,k,50) + out3d(i,j,k,3) = p3a(i,k,51) + enddo + enddo + + + ENDDO p3_jloop4 + + if(timestats.ge.1) time_microphy=time_microphy+mytime() + + + ELSEIF (ptype.eq.63) THEN + +!-------------------------------------------------------------------------------------! +! P3 scheme -- config: 2-mom-cld, 2-mom-rain, 3-mom-ice, 4-ice-category, liq-frac ! +!-------------------------------------------------------------------------------------! + ! ERM begin + ! DO i = 1,numq + ! call pdefq(0.0,asq(i),ruh,rvh,rmh,rho,q3d(ib,jb,kb,i)) + ! ENDDO + ! ERM end + rdt = 1.0/dt + + p3_jloop6: DO j=1,nj + + dum1(:,:,:) = 0.0 + + do k=1,nk + do i=1,ni + p3a(i,k, 1) = th0(i,j,k)+th3d(i,j,k) ! th + p3a(i,k, 2) = q3d(i,j,k,nqv) ! qv + thten(i,j,k) = p3a(i,k, 1) + qten(i,j,k,nqv) = p3a(i,k, 2) + p3a(i,k, 3) = q3d(i,j,k,nqc) ! qc + p3a(i,k, 4) = q3d(i,j,k,nqr) ! qr + p3a(i,k, 5) = q3d(i,j,k,9) ! qnr + p3a(i,k, 6) = th0(i,j,k)+tha(i,j,k) ! th_old + p3a(i,k, 7) = qa(i,j,k,nqv) ! qv_old + p3a(i,k, 8) = pi0(i,j,k)+pp3d(i,j,k) ! pii + p3a(i,k, 9) = prs(i,j,k) ! p + p3a(i,k,10) = dz*rmh(i,j,k) ! dz + p3a(i,k,11) = 0.5*(w3d(i,j,k)+w3d(i,j,k+1)) ! w + p3a(i,k,18) = q3d(i,j,k,nqi) ! qit_1 + p3a(i,k,19) = q3d(i,j,k,10) ! qni_1 + p3a(i,k,20) = q3d(i,j,k,11) ! qir_1 + p3a(i,k,21) = q3d(i,j,k,12) ! qib_1 + p3a(i,k,23) = q3d(i,j,k, 5) ! qit_2 + p3a(i,k,24) = q3d(i,j,k,14) ! qir_2 + p3a(i,k,25) = q3d(i,j,k,13) ! qni_2 p3a(i,k,26) = q3d(i,j,k,15) ! qib_2 p3a(i,k,27) = q3d(i,j,k, 8) ! nc p3a(i,k,31) = q3d(i,j,k,16) ! qzi_1 @@ -2248,7 +2809,816 @@ subroutine mp_driver(nstep,dt,qbudget,asq,bsq,xh,ruh,xf,ruf,yh,rvh,yf,rvf, & do i=1,ni - p3a(i,1,22) = 0.0 + p3a(i,1,22) = 0.0 + enddo + + call mp_p3_wrapper_wrf( th = p3a(1,1,1), & + qv = p3a(1,1,2), & + qc = p3a(1,1,3), & + qr = p3a(1,1,4), & + qnr = p3a(1,1,5), & + th_old = p3a(1,1,6), & + qv_old = p3a(1,1,7), & + pii = p3a(1,1,8), & + p = p3a(1,1,9), & + dz = p3a(1,1,10), & + w = p3a(1,1,11), & + dt = dt, & + itimestep = nstep, & + rainnc = p3a(1,1,22), & + rainncv = dum1(ib,jb,2), & + sr = dum1(ib,jb,3), & + snownc = dum1(ib,jb,4), & + snowncv = dum1(ib,jb,5), & + ids=1, ide=ni, jds=1, jde=1, kds=1, kde=nk , & + ims=1, ime=ni, jms=1, jme=1, kms=1, kme=nk , & + its=1, ite=ni, jts=1, jte=1, kts=1, kte=nk , & + diag_zdbz = p3a(1,1,12), & + diag_effc = p3a(1,1,13), & + diag_effi_ave = p3a(1,1,14), & + n_iceCat = 4, & + qit_1 = p3a(1,1,18), & + qni_1 = p3a(1,1,19), & + qir_1 = p3a(1,1,20), & + qib_1 = p3a(1,1,21), & + diag_vmi_1 = p3a(1,1,15), & + diag_dmi_1 = p3a(1,1,16), & + diag_rhoi_1 = p3a(1,1,17), & + qzi_1 = p3a(1,1,31), & + qli_1 = p3a(1,1,32), & + nc = p3a(1,1,27), & + qit_2 = p3a(1,1,23), & + qir_2 = p3a(1,1,24), & + qni_2 = p3a(1,1,25), & + qib_2 = p3a(1,1,26), & + qzi_2 = p3a(1,1,33), & + qli_2 = p3a(1,1,34), & + diag_vmi_2 = p3a(1,1,28), & + diag_dmi_2 = p3a(1,1,29), & + diag_rhoi_2 = p3a(1,1,30), & + qit_3 = p3a(1,1,35), & + qir_3 = p3a(1,1,36), & + qni_3 = p3a(1,1,37), & + qib_3 = p3a(1,1,38), & + qzi_3 = p3a(1,1,39), & + qli_3 = p3a(1,1,40), & + diag_vmi_3 = p3a(1,1,41), & + diag_dmi_3 = p3a(1,1,42), & + diag_rhoi_3 = p3a(1,1,43), & + qit_4 = p3a(1,1,44), & + qir_4 = p3a(1,1,45), & + qni_4 = p3a(1,1,46), & + qib_4 = p3a(1,1,47), & + qzi_4 = p3a(1,1,48), & + qli_4 = p3a(1,1,49), & + diag_vmi_4 = p3a(1,1,50), & + diag_dmi_4 = p3a(1,1,51), & + diag_rhoi_4 = p3a(1,1,52), & + diag_dhmax_1 = p3a(1,1,53), & + diag_dhmax_2 = p3a(1,1,54), & + diag_dhmax_3 = p3a(1,1,55), & + diag_dhmax_4 = p3a(1,1,56), & + diag2d_01 = p3a(1,1,57), & + diag2d_02 = p3a(1,1,58), & + diag3d_01 = p3a(1,1,59), & + diag3d_02 = p3a(1,1,60), & + diag3d_03 = p3a(1,1,61), & + j_index = j, & ! DTD: added j_index for debugging + diagflag = (getdbz .or. dowriteout) ) + if( axisymm.eq.1 )then + do i=1,ni + prate(i,j) = p3a(i,1,22)*rdt + qbudget(6) = qbudget(6) + p3a(i,1,22)*ruh(i)*rvh(j)*dx*dy*dum3(i,j,1)/rho(i,j,1) + enddo + else + do i=1,ni + prate(i,j) = p3a(i,1,22)*rdt + qbudget(6) = qbudget(6) + p3a(i,1,22)*ruh(i)*rvh(j)*dx*dy + enddo + endif + + do n=1,nrain + do i=1,ni + ! convert from mm to cm: + rain(i,j,n) = rain(i,j,n) + 0.1*p3a(i,1,22) + enddo + enddo + + do k=1,nk + do i=1,ni + if( abs(p3a(i,k,1)-thten(i,j,k)).ge.tsmall .or. & + abs(p3a(i,k,2)-qten(i,j,k,nqv)).ge.qsmall )then + pp3d(i,j,k)=(rho(i,j,k)*(rd+rv*p3a(i,k,2))*p3a(i,k,1)*rp00)**rddcv + prs(i,j,k)=p00*(pp3d(i,j,k)**cpdrd) + pp3d(i,j,k)=pp3d(i,j,k)-pi0(i,j,k) + th3d(i,j,k)=th3d(i,j,k)+(p3a(i,k,1)-thten(i,j,k)) + endif + q3d(i,j,k,nqv) = p3a(i,k, 2) + q3d(i,j,k,nqc) = p3a(i,k, 3) ! qc + q3d(i,j,k,nqr) = p3a(i,k, 4) ! qr + q3d(i,j,k, 9 ) = p3a(i,k, 5) ! qnr_1 + q3d(i,j,k,nqi) = p3a(i,k,18) ! qit_1 + q3d(i,j,k,10 ) = p3a(i,k,19) ! qni_1 + q3d(i,j,k,11 ) = p3a(i,k,20) ! qir_1 + q3d(i,j,k,12 ) = p3a(i,k,21) ! qib_1 + q3d(i,j,k, 5 ) = p3a(i,k,23) ! qit_2 + q3d(i,j,k,14 ) = p3a(i,k,24) ! qir_2 + q3d(i,j,k,13 ) = p3a(i,k,25) ! qni_2 + q3d(i,j,k,15 ) = p3a(i,k,26) ! qib_2 + q3d(i,j,k, 8 ) = p3a(i,k,27) ! nc + q3d(i,j,k,16 ) = p3a(i,k,31) ! qzi_1 + q3d(i,j,k,17 ) = p3a(i,k,32) ! qli_1 + q3d(i,j,k,18 ) = p3a(i,k,33) ! qzi_2 + q3d(i,j,k,19 ) = p3a(i,k,34) ! qli_2 + + q3d(i,j,k, 6 ) = p3a(i,k,35) ! qit_3 + q3d(i,j,k,21 ) = p3a(i,k,36) ! qir_3 + q3d(i,j,k,20 ) = p3a(i,k,37) ! qni_3 + q3d(i,j,k,22 ) = p3a(i,k,38) ! qib_3 + q3d(i,j,k,23 ) = p3a(i,k,39) ! qzi_3 + q3d(i,j,k,24 ) = p3a(i,k,40) ! qli_3 + + q3d(i,j,k, 7 ) = p3a(i,k,44) ! qit_4 + q3d(i,j,k,26 ) = p3a(i,k,45) ! qir_4 + q3d(i,j,k,25 ) = p3a(i,k,46) ! qni_4 + q3d(i,j,k,27 ) = p3a(i,k,47) ! qib_4 + q3d(i,j,k,28 ) = p3a(i,k,48) ! qzi_4 + q3d(i,j,k,29 ) = p3a(i,k,49) ! qli_4 + enddo + enddo + + IF( getdbz .and. qd_dbz.ge.1 )THEN + do k=1,nk + do i=1,ni + qdiag(i,j,k,qd_dbz) = p3a(i,k,12) + enddo + enddo + ENDIF + + IF( dorad )THEN + do k=1,nk + do i=1,ni + effc(i,j,k) = p3a(i,k,13) + effi(i,j,k) = p3a(i,k,14) + enddo + enddo + ENDIF + + IF( dowriteout .or. getdbz )THEN + do k=1,nk + do i=1,ni + p3o(i,j,k, 1) = p3a(i,k,15) ! vmi_1 + p3o(i,j,k, 2) = p3a(i,k,16) ! dmi_1 + p3o(i,j,k, 3) = p3a(i,k,17) ! rhoi_1 + p3o(i,j,k, 4) = p3a(i,k,53) ! dhmax_1 + + p3o(i,j,k, 5) = p3a(i,k,28) ! _2 + p3o(i,j,k, 6) = p3a(i,k,29) + p3o(i,j,k, 7) = p3a(i,k,30) + p3o(i,j,k, 8) = p3a(i,k,54) + + p3o(i,j,k, 9) = p3a(i,k,41) ! _3 + p3o(i,j,k,10) = p3a(i,k,42) + p3o(i,j,k,11) = p3a(i,k,43) + p3o(i,j,k,12) = p3a(i,k,55) + + p3o(i,j,k,13) = p3a(i,k,50) ! _4 + p3o(i,j,k,14) = p3a(i,k,51) + p3o(i,j,k,15) = p3a(i,k,52) + p3o(i,j,k,16) = p3a(i,k,56) + enddo + enddo + ENDIF + + ! user-specified diagnostic output + do i=1,ni + out2d(i,j,1) = p3a(i,1,57) + out2d(i,j,2) = p3a(i,1,58) + enddo + do k=1,nk + do i=1,ni + out3d(i,j,k,1) = p3a(i,k,59) + out3d(i,j,k,2) = p3a(i,k,60) + out3d(i,j,k,3) = p3a(i,k,61) + enddo + enddo + + + ENDDO p3_jloop6 + + if (timestats.ge.1) time_microphy = time_microphy+mytime() + + ELSEIF (ptype.eq.64) THEN + +!-------------------------------------------------------------------------------------! +! P3 scheme -- config: 2-mom-cld, 2-mom-rain, 3-mom-ice, 5-ice-category ! +!-------------------------------------------------------------------------------------! + + rdt = 1.0/dt + + p3_jloop9: DO j=1,nj + + do k=1,nk + do i=1,ni + p3a(i,k, 1) = th0(i,j,k)+th3d(i,j,k) ! th + p3a(i,k, 2) = q3d(i,j,k,nqv) ! qv + thten(i,j,k) = p3a(i,k, 1) + qten(i,j,k,nqv) = p3a(i,k, 2) + p3a(i,k, 3) = q3d(i,j,k,nqc) ! qc + p3a(i,k, 4) = q3d(i,j,k,nqr) ! qr + p3a(i,k, 5) = q3d(i,j,k,10 ) ! qnr + p3a(i,k, 6) = th0(i,j,k)+tha(i,j,k) ! th_old + p3a(i,k, 7) = qa(i,j,k,nqv) ! qv_old + p3a(i,k, 8) = pi0(i,j,k)+pp3d(i,j,k) ! pii + p3a(i,k, 9) = prs(i,j,k) ! p + p3a(i,k,10) = dz*rmh(i,j,k) ! dz + p3a(i,k,11) = 0.5*(w3d(i,j,k)+w3d(i,j,k+1)) ! w + p3a(i,k,15) = q3d(i,j,k,9 ) ! nc + p3a(i,k,17) = q3d(i,j,k,nqi) ! qit_1 + p3a(i,k,18) = q3d(i,j,k,11 ) ! qni_1 + p3a(i,k,19) = q3d(i,j,k,12 ) ! qir_1 + p3a(i,k,20) = q3d(i,j,k,13 ) ! qib_1 + p3a(i,k,21) = q3d(i,j,k,26 ) ! qzi_1 + p3a(i,k,25) = q3d(i,j,k,5 ) ! qit_2 + p3a(i,k,26) = q3d(i,j,k,14 ) ! qni_2 + p3a(i,k,27) = q3d(i,j,k,15 ) ! qir_2 + p3a(i,k,28) = q3d(i,j,k,16 ) ! qib_2 + p3a(i,k,29) = q3d(i,j,k,27 ) ! qzi_2 + p3a(i,k,33) = q3d(i,j,k,6 ) ! qit_3 + p3a(i,k,34) = q3d(i,j,k,17 ) ! qni_3 + p3a(i,k,35) = q3d(i,j,k,18 ) ! qir_3 + p3a(i,k,36) = q3d(i,j,k,19 ) ! qib_3 + p3a(i,k,37) = q3d(i,j,k,28 ) ! qzi_3 + p3a(i,k,41) = q3d(i,j,k,7 ) ! qit_4 + p3a(i,k,42) = q3d(i,j,k,20 ) ! qni_4 + p3a(i,k,43) = q3d(i,j,k,21 ) ! qir_4 + p3a(i,k,44) = q3d(i,j,k,22 ) ! qib_4 + p3a(i,k,45) = q3d(i,j,k,29 ) ! qzi_4 + p3a(i,k,49) = q3d(i,j,k,8 ) ! qit_5 + p3a(i,k,50) = q3d(i,j,k,23 ) ! qni_5 + p3a(i,k,51) = q3d(i,j,k,24 ) ! qir_5 + p3a(i,k,52) = q3d(i,j,k,25 ) ! qib_5 + p3a(i,k,53) = q3d(i,j,k,30 ) ! qzi_5 + enddo + enddo + + do i=1,ni + p3a(i,1,16) = 0.0 + enddo + + call mp_p3_wrapper_wrf( th = p3a(1,1,1), & + qv = p3a(1,1,2), & + qc = p3a(1,1,3), & + qr = p3a(1,1,4), & + qnr = p3a(1,1,5), & + th_old = p3a(1,1,6), & + qv_old = p3a(1,1,7), & + pii = p3a(1,1,8), & + p = p3a(1,1,9), & + dz = p3a(1,1,10), & + w = p3a(1,1,11), & + dt = dt, & + itimestep = nstep, & + rainnc = p3a(1,1,16), & + rainncv = dum1(ib,jb,2), & + sr = dum1(ib,jb,3), & + snownc = dum1(ib,jb,4), & + snowncv = dum1(ib,jb,5), & + ids=1, ide=ni, jds=1, jde=1, kds=1, kde=nk , & + ims=1, ime=ni, jms=1, jme=1, kms=1, kme=nk , & + its=1, ite=ni, jts=1, jte=1, kts=1, kte=nk , & + diag_zdbz = p3a(1,1,12), & + diag_effc = p3a(1,1,13), & + diag_effi_ave = p3a(1,1,14), & + n_iceCat = 5, & + nc = p3a(1,1,15), & + qit_1 = p3a(1,1,17), & + qni_1 = p3a(1,1,18), & + qir_1 = p3a(1,1,19), & + qib_1 = p3a(1,1,20), & + qzi_1 = p3a(1,1,21), & + diag_vmi_1 = p3a(1,1,22), & + diag_dmi_1 = p3a(1,1,23), & + diag_rhoi_1 = p3a(1,1,24), & + qit_2 = p3a(1,1,25), & + qni_2 = p3a(1,1,26), & + qir_2 = p3a(1,1,27), & + qib_2 = p3a(1,1,28), & + qzi_2 = p3a(1,1,29), & + diag_vmi_2 = p3a(1,1,30), & + diag_dmi_2 = p3a(1,1,31), & + diag_rhoi_2 = p3a(1,1,32), & + qit_3 = p3a(1,1,33), & + qni_3 = p3a(1,1,34), & + qir_3 = p3a(1,1,35), & + qib_3 = p3a(1,1,36), & + qzi_3 = p3a(1,1,37), & + diag_vmi_3 = p3a(1,1,38), & + diag_dmi_3 = p3a(1,1,39), & + diag_rhoi_3 = p3a(1,1,40), & + qit_4 = p3a(1,1,41), & + qni_4 = p3a(1,1,42), & + qir_4 = p3a(1,1,43), & + qib_4 = p3a(1,1,44), & + qzi_4 = p3a(1,1,45), & + diag_vmi_4 = p3a(1,1,46), & + diag_dmi_4 = p3a(1,1,47), & + diag_rhoi_4 = p3a(1,1,48), & + qit_5 = p3a(1,1,49), & + qni_5 = p3a(1,1,50), & + qir_5 = p3a(1,1,51), & + qib_5 = p3a(1,1,52), & + qzi_5 = p3a(1,1,53), & + diag_vmi_5 = p3a(1,1,54), & + diag_dmi_5 = p3a(1,1,55), & + diag_rhoi_5 = p3a(1,1,56), & + diag_dhmax_1 = p3a(1,1,57), & + diag_dhmax_2 = p3a(1,1,58), & + diag_dhmax_3 = p3a(1,1,59), & + diag_dhmax_4 = p3a(1,1,60), & + diag_dhmax_5 = p3a(1,1,61), & + diag2d_01 = p3a(1,1,62), & + diag2d_02 = p3a(1,1,63), & + diag3d_01 = p3a(1,1,64), & + diag3d_02 = p3a(1,1,65), & + diag3d_03 = p3a(1,1,66), & + j_index = j, & ! DTD: added j_index for debugging + diagflag = (getdbz .or. dowriteout) ) + if( axisymm.eq.1 )then + do i=1,ni + prate(i,j) = p3a(i,1,16)*rdt + qbudget(6) = qbudget(6) + p3a(i,1,16)*ruh(i)*rvh(j)*dx*dy*dum3(i,j,1)/rho(i,j,1) + enddo + else + do i=1,ni + prate(i,j) = p3a(i,1,16)*rdt + qbudget(6) = qbudget(6) + p3a(i,1,16)*ruh(i)*rvh(j)*dx*dy + enddo + endif + + do n=1,nrain + do i=1,ni + ! convert from mm to cm: + rain(i,j,n) = rain(i,j,n) + 0.1*p3a(i,1,16) + enddo + enddo + + do k=1,nk + do i=1,ni + if( abs(p3a(i,k,1)-thten(i,j,k)).ge.tsmall .or. & + abs(p3a(i,k,2)-qten(i,j,k,nqv)).ge.qsmall )then + pp3d(i,j,k)=(rho(i,j,k)*(rd+rv*p3a(i,k,2))*p3a(i,k,1)*rp00)**rddcv + prs(i,j,k)=p00*(pp3d(i,j,k)**cpdrd) + pp3d(i,j,k)=pp3d(i,j,k)-pi0(i,j,k) + th3d(i,j,k)=th3d(i,j,k)+(p3a(i,k,1)-thten(i,j,k)) + endif + q3d(i,j,k,nqv) = p3a(i,k, 2) + q3d(i,j,k,nqc) = p3a(i,k, 3) ! qc + q3d(i,j,k,nqr) = p3a(i,k, 4) ! qr + q3d(i,j,k,10 ) = p3a(i,k, 5) ! qnr + q3d(i,j,k,9 ) = p3a(i,k,15) ! nc + q3d(i,j,k,nqi) = p3a(i,k,17) ! qit_1 + q3d(i,j,k,11 ) = p3a(i,k,18) ! qni_1 + q3d(i,j,k,12 ) = p3a(i,k,19) ! qir_1 + q3d(i,j,k,13 ) = p3a(i,k,20) ! qib_1 + q3d(i,j,k,26 ) = p3a(i,k,21) ! qzi_1 + q3d(i,j,k,5 ) = p3a(i,k,25) ! qit_2 + q3d(i,j,k,14 ) = p3a(i,k,26) ! qni_2 + q3d(i,j,k,15 ) = p3a(i,k,27) ! qir_2 + q3d(i,j,k,16 ) = p3a(i,k,28) ! qib_2 + q3d(i,j,k,27 ) = p3a(i,k,29) ! qzi_2 + q3d(i,j,k,6 ) = p3a(i,k,33) ! qit_3 + q3d(i,j,k,17 ) = p3a(i,k,34) ! qni_3 + q3d(i,j,k,18 ) = p3a(i,k,35) ! qir_3 + q3d(i,j,k,19 ) = p3a(i,k,36) ! qib_3 + q3d(i,j,k,28 ) = p3a(i,k,37) ! qzi_3 + q3d(i,j,k,7 ) = p3a(i,k,41) ! qit_4 + q3d(i,j,k,20 ) = p3a(i,k,42) ! qni_4 + q3d(i,j,k,21 ) = p3a(i,k,43) ! qir_4 + q3d(i,j,k,22 ) = p3a(i,k,44) ! qib_4 + q3d(i,j,k,29 ) = p3a(i,k,45) ! qzi_4 + q3d(i,j,k,8 ) = p3a(i,k,49) ! qit_5 + q3d(i,j,k,23 ) = p3a(i,k,50) ! qni_5 + q3d(i,j,k,24 ) = p3a(i,k,51) ! qir_5 + q3d(i,j,k,25 ) = p3a(i,k,52) ! qib_5 + q3d(i,j,k,30 ) = p3a(i,k,53) ! qzi_5 + enddo + enddo + + IF( getdbz .and. qd_dbz.ge.1 )THEN + do k=1,nk + do i=1,ni + qdiag(i,j,k,qd_dbz) = p3a(i,k,12) + enddo + enddo + ENDIF + + IF( dorad )THEN + do k=1,nk + do i=1,ni + effc(i,j,k) = p3a(i,k,13) + effi(i,j,k) = p3a(i,k,14) + enddo + enddo + ENDIF + + IF( dowriteout .or. getdbz )THEN + do k=1,nk + do i=1,ni + p3o(i,j,k, 1) = p3a(i,k,22) ! vmi_1 + p3o(i,j,k, 2) = p3a(i,k,23) ! dmi_1 + p3o(i,j,k, 3) = p3a(i,k,24) ! rhoi_1 + p3o(i,j,k, 4) = p3a(i,k,57) ! dhmax_1 + + p3o(i,j,k, 5) = p3a(i,k,30) ! vmi_2 + p3o(i,j,k, 6) = p3a(i,k,31) ! dmi_2 + p3o(i,j,k, 7) = p3a(i,k,32) ! rhoi_2 + p3o(i,j,k, 8) = p3a(i,k,58) ! dhmax_2 + + p3o(i,j,k, 9) = p3a(i,k,38) ! vmi_3 + p3o(i,j,k,10) = p3a(i,k,39) ! dmi_3 + p3o(i,j,k,11) = p3a(i,k,40) ! rhoi_3 + p3o(i,j,k,12) = p3a(i,k,59) ! dhmax_3 + + p3o(i,j,k,13) = p3a(i,k,46) ! vmi_4 + p3o(i,j,k,14) = p3a(i,k,47) ! dmi_4 + p3o(i,j,k,15) = p3a(i,k,48) ! rhoi_4 + p3o(i,j,k,16) = p3a(i,k,60) ! dhmax_4 + + p3o(i,j,k,17) = p3a(i,k,54) ! vmi_5 + p3o(i,j,k,18) = p3a(i,k,55) ! dmi_5 + p3o(i,j,k,19) = p3a(i,k,56) ! rhoi_5 + p3o(i,j,k,20) = p3a(i,k,61) ! dhmax_5 + enddo + enddo + ENDIF + + ! user-specified diagnostic output + do i=1,ni + out2d(i,j,1) = p3a(i,1,62) + out2d(i,j,2) = p3a(i,1,63) + enddo + do k=1,nk + do i=1,ni + out3d(i,j,k,1) = p3a(i,k,64) + out3d(i,j,k,2) = p3a(i,k,65) + out3d(i,j,k,3) = p3a(i,k,66) + enddo + enddo + + ENDDO p3_jloop9 + + if (timestats.ge.1) time_microphy = time_microphy+mytime() + + ELSEIF (ptype.eq.65) THEN + +!-------------------------------------------------------------------------------------! +! P3 scheme -- config: 2-mom-cld, 2-mom-rain, 3-mom-ice, 6-ice-category ! +!-------------------------------------------------------------------------------------! + + rdt = 1.0/dt + + p3_jloop10: DO j=1,nj + + do k=1,nk + do i=1,ni + p3a(i,k, 1) = th0(i,j,k)+th3d(i,j,k) ! th + p3a(i,k, 2) = q3d(i,j,k,nqv) ! qv + thten(i,j,k) = p3a(i,k, 1) + qten(i,j,k,nqv) = p3a(i,k, 2) + p3a(i,k, 3) = q3d(i,j,k,nqc) ! qc + p3a(i,k, 4) = q3d(i,j,k,nqr) ! qr + p3a(i,k, 5) = q3d(i,j,k,11 ) ! qnr + p3a(i,k, 6) = th0(i,j,k)+tha(i,j,k) ! th_old + p3a(i,k, 7) = qa(i,j,k,nqv) ! qv_old + p3a(i,k, 8) = pi0(i,j,k)+pp3d(i,j,k) ! pii + p3a(i,k, 9) = prs(i,j,k) ! p + p3a(i,k,10) = dz*rmh(i,j,k) ! dz + p3a(i,k,11) = 0.5*(w3d(i,j,k)+w3d(i,j,k+1)) ! w + p3a(i,k,15) = q3d(i,j,k,10 ) ! nc + p3a(i,k,17) = q3d(i,j,k,nqi) ! qit_1 + p3a(i,k,18) = q3d(i,j,k,12 ) ! qni_1 + p3a(i,k,19) = q3d(i,j,k,13 ) ! qir_1 + p3a(i,k,20) = q3d(i,j,k,14 ) ! qib_1 + p3a(i,k,21) = q3d(i,j,k,30 ) ! qzi_1 + p3a(i,k,25) = q3d(i,j,k,5 ) ! qit_2 + p3a(i,k,26) = q3d(i,j,k,15 ) ! qni_2 + p3a(i,k,27) = q3d(i,j,k,16 ) ! qir_2 + p3a(i,k,28) = q3d(i,j,k,17 ) ! qib_2 + p3a(i,k,29) = q3d(i,j,k,31 ) ! qzi_2 + p3a(i,k,33) = q3d(i,j,k,6 ) ! qit_3 + p3a(i,k,34) = q3d(i,j,k,18 ) ! qni_3 + p3a(i,k,35) = q3d(i,j,k,19 ) ! qir_3 + p3a(i,k,36) = q3d(i,j,k,20 ) ! qib_3 + p3a(i,k,37) = q3d(i,j,k,32 ) ! qzi_3 + p3a(i,k,41) = q3d(i,j,k,7 ) ! qit_4 + p3a(i,k,42) = q3d(i,j,k,21 ) ! qni_4 + p3a(i,k,43) = q3d(i,j,k,22 ) ! qir_4 + p3a(i,k,44) = q3d(i,j,k,23 ) ! qib_4 + p3a(i,k,45) = q3d(i,j,k,33 ) ! qzi_4 + p3a(i,k,49) = q3d(i,j,k,8 ) ! qit_5 + p3a(i,k,50) = q3d(i,j,k,24 ) ! qni_5 + p3a(i,k,51) = q3d(i,j,k,25 ) ! qir_5 + p3a(i,k,52) = q3d(i,j,k,26 ) ! qib_5 + p3a(i,k,53) = q3d(i,j,k,34 ) ! qzi_5 + p3a(i,k,57) = q3d(i,j,k,9 ) ! qit_6 + p3a(i,k,58) = q3d(i,j,k,27 ) ! qni_6 + p3a(i,k,59) = q3d(i,j,k,28 ) ! qir_6 + p3a(i,k,60) = q3d(i,j,k,29 ) ! qib_6 + p3a(i,k,61) = q3d(i,j,k,35 ) ! qzi_6 + enddo + enddo + + do i=1,ni + p3a(i,1,16) = 0.0 + enddo + + call mp_p3_wrapper_wrf( th = p3a(1,1,1), & + qv = p3a(1,1,2), & + qc = p3a(1,1,3), & + qr = p3a(1,1,4), & + qnr = p3a(1,1,5), & + th_old = p3a(1,1,6), & + qv_old = p3a(1,1,7), & + pii = p3a(1,1,8), & + p = p3a(1,1,9), & + dz = p3a(1,1,10), & + w = p3a(1,1,11), & + dt = dt, & + itimestep = nstep, & + rainnc = p3a(1,1,16), & + rainncv = dum1(ib,jb,2), & + sr = dum1(ib,jb,3), & + snownc = dum1(ib,jb,4), & + snowncv = dum1(ib,jb,5), & + ids=1, ide=ni, jds=1, jde=1, kds=1, kde=nk , & + ims=1, ime=ni, jms=1, jme=1, kms=1, kme=nk , & + its=1, ite=ni, jts=1, jte=1, kts=1, kte=nk , & + diag_zdbz = p3a(1,1,12), & + diag_effc = p3a(1,1,13), & + diag_effi_ave = p3a(1,1,14), & + n_iceCat = 6, & + nc = p3a(1,1,15), & + qit_1 = p3a(1,1,17), & + qni_1 = p3a(1,1,18), & + qir_1 = p3a(1,1,19), & + qib_1 = p3a(1,1,20), & + qzi_1 = p3a(1,1,21), & + diag_vmi_1 = p3a(1,1,22), & + diag_dmi_1 = p3a(1,1,23), & + diag_rhoi_1 = p3a(1,1,24), & + qit_2 = p3a(1,1,25), & + qni_2 = p3a(1,1,26), & + qir_2 = p3a(1,1,27), & + qib_2 = p3a(1,1,28), & + qzi_2 = p3a(1,1,29), & + diag_vmi_2 = p3a(1,1,30), & + diag_dmi_2 = p3a(1,1,31), & + diag_rhoi_2 = p3a(1,1,32), & + qit_3 = p3a(1,1,33), & + qni_3 = p3a(1,1,34), & + qir_3 = p3a(1,1,35), & + qib_3 = p3a(1,1,36), & + qzi_3 = p3a(1,1,37), & + diag_vmi_3 = p3a(1,1,38), & + diag_dmi_3 = p3a(1,1,39), & + diag_rhoi_3 = p3a(1,1,40), & + qit_4 = p3a(1,1,41), & + qni_4 = p3a(1,1,42), & + qir_4 = p3a(1,1,43), & + qib_4 = p3a(1,1,44), & + qzi_4 = p3a(1,1,45), & + diag_vmi_4 = p3a(1,1,46), & + diag_dmi_4 = p3a(1,1,47), & + diag_rhoi_4 = p3a(1,1,48), & + qit_5 = p3a(1,1,49), & + qni_5 = p3a(1,1,50), & + qir_5 = p3a(1,1,51), & + qib_5 = p3a(1,1,52), & + qzi_5 = p3a(1,1,53), & + diag_vmi_5 = p3a(1,1,54), & + diag_dmi_5 = p3a(1,1,55), & + diag_rhoi_5 = p3a(1,1,56), & + qit_6 = p3a(1,1,57), & + qni_6 = p3a(1,1,58), & + qir_6 = p3a(1,1,59), & + qib_6 = p3a(1,1,60), & + qzi_6 = p3a(1,1,61), & + diag_vmi_6 = p3a(1,1,62), & + diag_dmi_6 = p3a(1,1,63), & + diag_rhoi_6 = p3a(1,1,64), & + diag_dhmax_1 = p3a(1,1,65), & + diag_dhmax_2 = p3a(1,1,66), & + diag_dhmax_3 = p3a(1,1,67), & + diag_dhmax_4 = p3a(1,1,68), & + diag_dhmax_5 = p3a(1,1,69), & + diag_dhmax_6 = p3a(1,1,70), & + diag2d_01 = p3a(1,1,71), & + diag2d_02 = p3a(1,1,72), & + diag3d_01 = p3a(1,1,73), & + diag3d_02 = p3a(1,1,74), & + diag3d_03 = p3a(1,1,75), & + j_index = j, & ! DTD: added j_index for debugging + diagflag = (getdbz .or. dowriteout) ) + if( axisymm.eq.1 )then + do i=1,ni + prate(i,j) = p3a(i,1,16)*rdt + qbudget(6) = qbudget(6) + p3a(i,1,16)*ruh(i)*rvh(j)*dx*dy*dum3(i,j,1)/rho(i,j,1) + enddo + else + do i=1,ni + prate(i,j) = p3a(i,1,16)*rdt + qbudget(6) = qbudget(6) + p3a(i,1,16)*ruh(i)*rvh(j)*dx*dy + enddo + endif + + do n=1,nrain + do i=1,ni + ! convert from mm to cm: + rain(i,j,n) = rain(i,j,n) + 0.1*p3a(i,1,16) + enddo + enddo + + do k=1,nk + do i=1,ni + if( abs(p3a(i,k,1)-thten(i,j,k)).ge.tsmall .or. & + abs(p3a(i,k,2)-qten(i,j,k,nqv)).ge.qsmall )then + pp3d(i,j,k)=(rho(i,j,k)*(rd+rv*p3a(i,k,2))*p3a(i,k,1)*rp00)**rddcv + prs(i,j,k)=p00*(pp3d(i,j,k)**cpdrd) + pp3d(i,j,k)=pp3d(i,j,k)-pi0(i,j,k) + th3d(i,j,k)=th3d(i,j,k)+(p3a(i,k,1)-thten(i,j,k)) + endif + q3d(i,j,k,nqv) = p3a(i,k, 2) + q3d(i,j,k,nqc) = p3a(i,k, 3) ! qc + q3d(i,j,k,nqr) = p3a(i,k, 4) ! qr + q3d(i,j,k,11 ) = p3a(i,k, 5) ! qnr + q3d(i,j,k,10 ) = p3a(i,k,15) ! nc + q3d(i,j,k,nqi) = p3a(i,k,17) ! qit_1 + q3d(i,j,k,12 ) = p3a(i,k,18) ! qni_1 + q3d(i,j,k,13 ) = p3a(i,k,19) ! qir_1 + q3d(i,j,k,14 ) = p3a(i,k,20) ! qib_1 + q3d(i,j,k,30 ) = p3a(i,k,21) ! qzi_1 + q3d(i,j,k,5 ) = p3a(i,k,25) ! qit_2 + q3d(i,j,k,15 ) = p3a(i,k,26) ! qni_2 + q3d(i,j,k,16 ) = p3a(i,k,27) ! qir_2 + q3d(i,j,k,17 ) = p3a(i,k,28) ! qib_2 + q3d(i,j,k,31 ) = p3a(i,k,29) ! qzi_2 + q3d(i,j,k,6 ) = p3a(i,k,33) ! qit_3 + q3d(i,j,k,18 ) = p3a(i,k,34) ! qni_3 + q3d(i,j,k,19 ) = p3a(i,k,35) ! qir_3 + q3d(i,j,k,20 ) = p3a(i,k,36) ! qib_3 + q3d(i,j,k,32 ) = p3a(i,k,37) ! qzi_3 + q3d(i,j,k,7 ) = p3a(i,k,41) ! qit_4 + q3d(i,j,k,21 ) = p3a(i,k,42) ! qni_4 + q3d(i,j,k,22 ) = p3a(i,k,43) ! qir_4 + q3d(i,j,k,23 ) = p3a(i,k,44) ! qib_4 + q3d(i,j,k,33 ) = p3a(i,k,45) ! qzi_4 + q3d(i,j,k,8 ) = p3a(i,k,49) ! qit_5 + q3d(i,j,k,24 ) = p3a(i,k,50) ! qni_5 + q3d(i,j,k,25 ) = p3a(i,k,51) ! qir_5 + q3d(i,j,k,26 ) = p3a(i,k,52) ! qib_5 + q3d(i,j,k,34 ) = p3a(i,k,53) ! qzi_5 + q3d(i,j,k,9 ) = p3a(i,k,57) ! qit_6 + q3d(i,j,k,27 ) = p3a(i,k,58) ! qni_6 + q3d(i,j,k,28 ) = p3a(i,k,59) ! qir_6 + q3d(i,j,k,29 ) = p3a(i,k,60) ! qib_6 + q3d(i,j,k,35 ) = p3a(i,k,61) ! qzi_6 + enddo + enddo + + IF( getdbz .and. qd_dbz.ge.1 )THEN + do k=1,nk + do i=1,ni + qdiag(i,j,k,qd_dbz) = p3a(i,k,12) + enddo + enddo + ENDIF + + IF( dorad )THEN + do k=1,nk + do i=1,ni + effc(i,j,k) = p3a(i,k,13) + effi(i,j,k) = p3a(i,k,14) + enddo + enddo + ENDIF + + IF( dowriteout .or. getdbz )THEN + do k=1,nk + do i=1,ni + p3o(i,j,k, 1) = p3a(i,k,22) ! vmi_1 + p3o(i,j,k, 2) = p3a(i,k,23) ! dmi_1 + p3o(i,j,k, 3) = p3a(i,k,24) ! rhoi_1 + p3o(i,j,k, 4) = p3a(i,k,65) ! dhmax_1 + + p3o(i,j,k, 5) = p3a(i,k,30) ! vmi_2 + p3o(i,j,k, 6) = p3a(i,k,31) ! dmi_2 + p3o(i,j,k, 7) = p3a(i,k,32) ! rhoi_2 + p3o(i,j,k, 8) = p3a(i,k,66) ! dhmax_2 + + p3o(i,j,k, 9) = p3a(i,k,38) ! vmi_3 + p3o(i,j,k,10) = p3a(i,k,39) ! dmi_3 + p3o(i,j,k,11) = p3a(i,k,40) ! rhoi_3 + p3o(i,j,k,12) = p3a(i,k,67) ! dhmax_3 + + p3o(i,j,k,13) = p3a(i,k,46) ! vmi_4 + p3o(i,j,k,14) = p3a(i,k,47) ! dmi_4 + p3o(i,j,k,15) = p3a(i,k,48) ! rhoi_4 + p3o(i,j,k,16) = p3a(i,k,68) ! dhmax_4 + + p3o(i,j,k,17) = p3a(i,k,54) ! vmi_5 + p3o(i,j,k,18) = p3a(i,k,55) ! dmi_5 + p3o(i,j,k,19) = p3a(i,k,56) ! rhoi_5 + p3o(i,j,k,20) = p3a(i,k,69) ! dhmax_5 + + p3o(i,j,k,21) = p3a(i,k,62) ! vmi_6 + p3o(i,j,k,22) = p3a(i,k,63) ! dmi_6 + p3o(i,j,k,23) = p3a(i,k,64) ! rhoi_6 + p3o(i,j,k,24) = p3a(i,k,70) ! dhmax_6 + enddo + enddo + ENDIF + + ! user-specified diagnostic output + do i=1,ni + out2d(i,j,1) = p3a(i,1,71) + out2d(i,j,2) = p3a(i,1,72) + enddo + do k=1,nk + do i=1,ni + out3d(i,j,k,1) = p3a(i,k,73) + out3d(i,j,k,2) = p3a(i,k,74) + out3d(i,j,k,3) = p3a(i,k,75) + enddo + enddo + + ENDDO p3_jloop10 + + if (timestats.ge.1) time_microphy = time_microphy+mytime() + + ELSEIF (ptype.eq.66) THEN + +!-------------------------------------------------------------------------------------! +! P3 scheme -- config: 2-mom-cld, 2-mom-rain, 3-mom-ice, 5-ice-category, liq-frac ! +!-------------------------------------------------------------------------------------! + + rdt = 1.0/dt + + p3_jloop11: DO j=1,nj + + dum1(:,:,:) = 0.0 + + do k=1,nk + do i=1,ni + p3a(i,k, 1) = th0(i,j,k)+th3d(i,j,k) ! th + p3a(i,k, 2) = q3d(i,j,k,nqv) ! qv + thten(i,j,k) = p3a(i,k, 1) + qten(i,j,k,nqv) = p3a(i,k, 2) + p3a(i,k, 3) = q3d(i,j,k,nqc) ! qc + p3a(i,k, 4) = q3d(i,j,k,nqr) ! qr + p3a(i,k, 5) = q3d(i,j,k,10 ) ! qnr + p3a(i,k, 6) = th0(i,j,k)+tha(i,j,k) ! th_old + p3a(i,k, 7) = qa(i,j,k,nqv) ! qv_old + p3a(i,k, 8) = pi0(i,j,k)+pp3d(i,j,k) ! pii + p3a(i,k, 9) = prs(i,j,k) ! p + p3a(i,k,10) = dz*rmh(i,j,k) ! dz + p3a(i,k,11) = 0.5*(w3d(i,j,k)+w3d(i,j,k+1)) ! w + p3a(i,k,15) = q3d(i,j,k,9 ) ! nc + p3a(i,k,17) = q3d(i,j,k,nqi) ! qit_1 + p3a(i,k,18) = q3d(i,j,k,11 ) ! qni_1 + p3a(i,k,19) = q3d(i,j,k,12 ) ! qir_1 + p3a(i,k,20) = q3d(i,j,k,13 ) ! qib_1 + p3a(i,k,21) = q3d(i,j,k,14 ) ! qzi_1 + p3a(i,k,22) = q3d(i,j,k,15 ) ! qli_1 + p3a(i,k,26) = q3d(i,j,k,5 ) ! qit_2 + p3a(i,k,27) = q3d(i,j,k,16 ) ! qni_2 + p3a(i,k,28) = q3d(i,j,k,17 ) ! qir_2 + p3a(i,k,29) = q3d(i,j,k,18 ) ! qib_2 + p3a(i,k,30) = q3d(i,j,k,19 ) ! qzi_2 + p3a(i,k,31) = q3d(i,j,k,20 ) ! qli_2 + p3a(i,k,35) = q3d(i,j,k,6 ) ! qit_3 + p3a(i,k,36) = q3d(i,j,k,21 ) ! qni_3 + p3a(i,k,37) = q3d(i,j,k,22 ) ! qir_3 + p3a(i,k,38) = q3d(i,j,k,23 ) ! qib_3 + p3a(i,k,39) = q3d(i,j,k,24 ) ! qzi_3 + p3a(i,k,40) = q3d(i,j,k,25 ) ! qli_3 + p3a(i,k,44) = q3d(i,j,k,7 ) ! qit_4 + p3a(i,k,45) = q3d(i,j,k,26 ) ! qni_4 + p3a(i,k,46) = q3d(i,j,k,27 ) ! qir_4 + p3a(i,k,47) = q3d(i,j,k,28 ) ! qib_4 + p3a(i,k,48) = q3d(i,j,k,29 ) ! qzi_4 + p3a(i,k,49) = q3d(i,j,k,30 ) ! qli_4 + p3a(i,k,53) = q3d(i,j,k,8 ) ! qit_5 + p3a(i,k,54) = q3d(i,j,k,31 ) ! qni_5 + p3a(i,k,55) = q3d(i,j,k,32 ) ! qir_5 + p3a(i,k,56) = q3d(i,j,k,33 ) ! qib_5 + p3a(i,k,57) = q3d(i,j,k,34 ) ! qzi_5 + p3a(i,k,58) = q3d(i,j,k,35 ) ! qli_5 + enddo + enddo + + do i=1,ni + p3a(i,1,16) = 0.0 enddo call mp_p3_wrapper_wrf( th = p3a(1,1,1), & @@ -2264,7 +3634,7 @@ subroutine mp_driver(nstep,dt,qbudget,asq,bsq,xh,ruh,xf,ruf,yh,rvh,yf,rvf, & w = p3a(1,1,11), & dt = dt, & itimestep = nstep, & - rainnc = p3a(1,1,22), & + rainnc = p3a(1,1,16), & rainncv = dum1(ib,jb,2), & sr = dum1(ib,jb,3), & snownc = dum1(ib,jb,4), & @@ -2275,29 +3645,29 @@ subroutine mp_driver(nstep,dt,qbudget,asq,bsq,xh,ruh,xf,ruf,yh,rvh,yf,rvf, & diag_zdbz = p3a(1,1,12), & diag_effc = p3a(1,1,13), & diag_effi_ave = p3a(1,1,14), & - n_iceCat = 4, & - qit_1 = p3a(1,1,18), & - qni_1 = p3a(1,1,19), & - qir_1 = p3a(1,1,20), & - qib_1 = p3a(1,1,21), & - diag_vmi_1 = p3a(1,1,15), & - diag_dmi_1 = p3a(1,1,16), & - diag_rhoi_1 = p3a(1,1,17), & - qzi_1 = p3a(1,1,31), & - qli_1 = p3a(1,1,32), & - nc = p3a(1,1,27), & - qit_2 = p3a(1,1,23), & - qir_2 = p3a(1,1,24), & - qni_2 = p3a(1,1,25), & - qib_2 = p3a(1,1,26), & - qzi_2 = p3a(1,1,33), & - qli_2 = p3a(1,1,34), & - diag_vmi_2 = p3a(1,1,28), & - diag_dmi_2 = p3a(1,1,29), & - diag_rhoi_2 = p3a(1,1,30), & + n_iceCat = 5, & + nc = p3a(1,1,15), & + qit_1 = p3a(1,1,17), & + qni_1 = p3a(1,1,18), & + qir_1 = p3a(1,1,19), & + qib_1 = p3a(1,1,20), & + qzi_1 = p3a(1,1,21), & + qli_1 = p3a(1,1,22), & + diag_vmi_1 = p3a(1,1,23), & + diag_dmi_1 = p3a(1,1,24), & + diag_rhoi_1 = p3a(1,1,25), & + qit_2 = p3a(1,1,26), & + qni_2 = p3a(1,1,27), & + qir_2 = p3a(1,1,28), & + qib_2 = p3a(1,1,29), & + qzi_2 = p3a(1,1,30), & + qli_2 = p3a(1,1,31), & + diag_vmi_2 = p3a(1,1,32), & + diag_dmi_2 = p3a(1,1,33), & + diag_rhoi_2 = p3a(1,1,34), & qit_3 = p3a(1,1,35), & - qir_3 = p3a(1,1,36), & - qni_3 = p3a(1,1,37), & + qni_3 = p3a(1,1,36), & + qir_3 = p3a(1,1,37), & qib_3 = p3a(1,1,38), & qzi_3 = p3a(1,1,39), & qli_3 = p3a(1,1,40), & @@ -2305,40 +3675,51 @@ subroutine mp_driver(nstep,dt,qbudget,asq,bsq,xh,ruh,xf,ruf,yh,rvh,yf,rvf, & diag_dmi_3 = p3a(1,1,42), & diag_rhoi_3 = p3a(1,1,43), & qit_4 = p3a(1,1,44), & - qir_4 = p3a(1,1,45), & - qni_4 = p3a(1,1,46), & + qni_4 = p3a(1,1,45), & + qir_4 = p3a(1,1,46), & qib_4 = p3a(1,1,47), & qzi_4 = p3a(1,1,48), & qli_4 = p3a(1,1,49), & diag_vmi_4 = p3a(1,1,50), & diag_dmi_4 = p3a(1,1,51), & diag_rhoi_4 = p3a(1,1,52), & - diag_dhmax_1 = p3a(1,1,53), & - diag_dhmax_2 = p3a(1,1,54), & - diag_dhmax_3 = p3a(1,1,55), & - diag_dhmax_4 = p3a(1,1,56), & - diag2d_01 = p3a(1,1,57), & - diag2d_02 = p3a(1,1,58), & - diag3d_01 = p3a(1,1,59), & - diag3d_02 = p3a(1,1,60), & - diag3d_03 = p3a(1,1,61) ) - + qit_5 = p3a(1,1,53), & + qni_5 = p3a(1,1,54), & + qir_5 = p3a(1,1,55), & + qib_5 = p3a(1,1,56), & + qzi_5 = p3a(1,1,57), & + qli_5 = p3a(1,1,58), & + diag_vmi_5 = p3a(1,1,59), & + diag_dmi_5 = p3a(1,1,60), & + diag_rhoi_5 = p3a(1,1,61), & + diag_dhmax_1 = p3a(1,1,62), & + diag_dhmax_2 = p3a(1,1,63), & + diag_dhmax_3 = p3a(1,1,64), & + diag_dhmax_4 = p3a(1,1,65), & + diag_dhmax_5 = p3a(1,1,66), & + diag2d_01 = p3a(1,1,67), & + diag2d_02 = p3a(1,1,68), & + diag3d_01 = p3a(1,1,69), & + diag3d_02 = p3a(1,1,70), & + diag3d_03 = p3a(1,1,71), & + j_index = j, & ! DTD: added j_index for debugging + diagflag = (getdbz .or. dowriteout) ) if( axisymm.eq.1 )then do i=1,ni - prate(i,j) = p3a(i,1,22)*rdt - qbudget(6) = qbudget(6) + p3a(i,1,22)*ruh(i)*rvh(j)*dx*dy*dum3(i,j,1)/rho(i,j,1) + prate(i,j) = p3a(i,1,16)*rdt + qbudget(6) = qbudget(6) + p3a(i,1,16)*ruh(i)*rvh(j)*dx*dy*dum3(i,j,1)/rho(i,j,1) enddo else do i=1,ni - prate(i,j) = p3a(i,1,22)*rdt - qbudget(6) = qbudget(6) + p3a(i,1,22)*ruh(i)*rvh(j)*dx*dy + prate(i,j) = p3a(i,1,16)*rdt + qbudget(6) = qbudget(6) + p3a(i,1,16)*ruh(i)*rvh(j)*dx*dy enddo endif do n=1,nrain do i=1,ni ! convert from mm to cm: - rain(i,j,n) = rain(i,j,n) + 0.1*p3a(i,1,22) + rain(i,j,n) = rain(i,j,n) + 0.1*p3a(i,1,16) enddo enddo @@ -2354,34 +3735,38 @@ subroutine mp_driver(nstep,dt,qbudget,asq,bsq,xh,ruh,xf,ruf,yh,rvh,yf,rvf, & q3d(i,j,k,nqv) = p3a(i,k, 2) q3d(i,j,k,nqc) = p3a(i,k, 3) ! qc q3d(i,j,k,nqr) = p3a(i,k, 4) ! qr - q3d(i,j,k, 9 ) = p3a(i,k, 5) ! qnr_1 - q3d(i,j,k,nqi) = p3a(i,k,18) ! qit_1 - q3d(i,j,k,10 ) = p3a(i,k,19) ! qni_1 - q3d(i,j,k,11 ) = p3a(i,k,20) ! qir_1 - q3d(i,j,k,12 ) = p3a(i,k,21) ! qib_1 - q3d(i,j,k, 5 ) = p3a(i,k,23) ! qit_2 - q3d(i,j,k,14 ) = p3a(i,k,24) ! qir_2 - q3d(i,j,k,13 ) = p3a(i,k,25) ! qni_2 - q3d(i,j,k,15 ) = p3a(i,k,26) ! qib_2 - q3d(i,j,k, 8 ) = p3a(i,k,27) ! nc - q3d(i,j,k,16 ) = p3a(i,k,31) ! qzi_1 - q3d(i,j,k,17 ) = p3a(i,k,32) ! qli_1 - q3d(i,j,k,18 ) = p3a(i,k,33) ! qzi_2 - q3d(i,j,k,19 ) = p3a(i,k,34) ! qli_2 - - q3d(i,j,k, 6 ) = p3a(i,k,35) ! qit_3 - q3d(i,j,k,21 ) = p3a(i,k,36) ! qir_3 - q3d(i,j,k,20 ) = p3a(i,k,37) ! qni_3 - q3d(i,j,k,22 ) = p3a(i,k,38) ! qib_3 - q3d(i,j,k,23 ) = p3a(i,k,39) ! qzi_3 - q3d(i,j,k,24 ) = p3a(i,k,40) ! qli_3 - - q3d(i,j,k, 7 ) = p3a(i,k,44) ! qit_4 - q3d(i,j,k,26 ) = p3a(i,k,45) ! qir_4 - q3d(i,j,k,25 ) = p3a(i,k,46) ! qni_4 - q3d(i,j,k,27 ) = p3a(i,k,47) ! qib_4 - q3d(i,j,k,28 ) = p3a(i,k,48) ! qzi_4 - q3d(i,j,k,29 ) = p3a(i,k,49) ! qli_4 + q3d(i,j,k,10 ) = p3a(i,k, 5) ! qnr + q3d(i,j,k,9 ) = p3a(i,k,15) ! nc + q3d(i,j,k,nqi) = p3a(i,k,17) ! qit_1 + q3d(i,j,k,11 ) = p3a(i,k,18) ! qni_1 + q3d(i,j,k,12 ) = p3a(i,k,19) ! qir_1 + q3d(i,j,k,13 ) = p3a(i,k,20) ! qib_1 + q3d(i,j,k,14 ) = p3a(i,k,21) ! qzi_1 + q3d(i,j,k,15 ) = p3a(i,k,22) ! qli_1 + q3d(i,j,k,5 ) = p3a(i,k,26) ! qit_2 + q3d(i,j,k,16 ) = p3a(i,k,27) ! qni_2 + q3d(i,j,k,17 ) = p3a(i,k,28) ! qir_2 + q3d(i,j,k,18 ) = p3a(i,k,29) ! qib_2 + q3d(i,j,k,19 ) = p3a(i,k,30) ! qzi_2 + q3d(i,j,k,20 ) = p3a(i,k,31) ! qli_2 + q3d(i,j,k,6 ) = p3a(i,k,35) ! qit_3 + q3d(i,j,k,21 ) = p3a(i,k,36) ! qni_3 + q3d(i,j,k,22 ) = p3a(i,k,37) ! qir_3 + q3d(i,j,k,23 ) = p3a(i,k,38) ! qib_3 + q3d(i,j,k,24 ) = p3a(i,k,39) ! qzi_3 + q3d(i,j,k,25 ) = p3a(i,k,40) ! qli_3 + q3d(i,j,k,7 ) = p3a(i,k,44) ! qit_4 + q3d(i,j,k,26 ) = p3a(i,k,45) ! qni_4 + q3d(i,j,k,27 ) = p3a(i,k,46) ! qir_4 + q3d(i,j,k,28 ) = p3a(i,k,47) ! qib_4 + q3d(i,j,k,29 ) = p3a(i,k,48) ! qzi_4 + q3d(i,j,k,30 ) = p3a(i,k,49) ! qli_4 + q3d(i,j,k,8 ) = p3a(i,k,53) ! qit_5 + q3d(i,j,k,31 ) = p3a(i,k,54) ! qni_5 + q3d(i,j,k,32 ) = p3a(i,k,55) ! qir_5 + q3d(i,j,k,33 ) = p3a(i,k,56) ! qib_5 + q3d(i,j,k,34 ) = p3a(i,k,57) ! qzi_5 + q3d(i,j,k,35 ) = p3a(i,k,58) ! qli_5 enddo enddo @@ -2405,48 +3790,357 @@ subroutine mp_driver(nstep,dt,qbudget,asq,bsq,xh,ruh,xf,ruf,yh,rvh,yf,rvf, & IF( dowriteout .or. getdbz )THEN do k=1,nk do i=1,ni - p3o(i,j,k, 1) = p3a(i,k,15) ! vmi_1 - p3o(i,j,k, 2) = p3a(i,k,16) ! dmi_1 - p3o(i,j,k, 3) = p3a(i,k,17) ! rhoi_1 - p3o(i,j,k, 4) = p3a(i,k,53) ! dhmax_1 + p3o(i,j,k, 1) = p3a(i,k,23) ! vmi_1 + p3o(i,j,k, 2) = p3a(i,k,24) ! dmi_1 + p3o(i,j,k, 3) = p3a(i,k,25) ! rhoi_1 + p3o(i,j,k, 4) = p3a(i,k,62) ! dhmax_1 + + p3o(i,j,k, 5) = p3a(i,k,32) ! vmi_2 + p3o(i,j,k, 6) = p3a(i,k,33) ! dmi_2 + p3o(i,j,k, 7) = p3a(i,k,34) ! rhoi_2 + p3o(i,j,k, 8) = p3a(i,k,63) ! dhmax_2 + + p3o(i,j,k, 9) = p3a(i,k,41) ! vmi_3 + p3o(i,j,k,10) = p3a(i,k,42) ! dmi_3 + p3o(i,j,k,11) = p3a(i,k,43) ! rhoi_3 + p3o(i,j,k,12) = p3a(i,k,64) ! dhmax_3 + + p3o(i,j,k,13) = p3a(i,k,50) ! vmi_4 + p3o(i,j,k,14) = p3a(i,k,51) ! dmi_4 + p3o(i,j,k,15) = p3a(i,k,52) ! rhoi_4 + p3o(i,j,k,16) = p3a(i,k,65) ! dhmax_4 + + p3o(i,j,k,17) = p3a(i,k,59) ! vmi_5 + p3o(i,j,k,18) = p3a(i,k,60) ! dmi_5 + p3o(i,j,k,19) = p3a(i,k,61) ! rhoi_5 + p3o(i,j,k,20) = p3a(i,k,66) ! dhmax_5 + enddo + enddo + ENDIF - p3o(i,j,k, 5) = p3a(i,k,28) ! _2 - p3o(i,j,k, 6) = p3a(i,k,29) - p3o(i,j,k, 7) = p3a(i,k,30) - p3o(i,j,k, 8) = p3a(i,k,54) + ! user-specified diagnostic output + do i=1,ni + out2d(i,j,1) = p3a(i,1,67) + out2d(i,j,2) = p3a(i,1,68) + enddo + do k=1,nk + do i=1,ni + out3d(i,j,k,1) = p3a(i,k,69) + out3d(i,j,k,2) = p3a(i,k,70) + out3d(i,j,k,3) = p3a(i,k,71) + enddo + enddo - p3o(i,j,k, 9) = p3a(i,k,41) ! _3 - p3o(i,j,k,10) = p3a(i,k,42) - p3o(i,j,k,11) = p3a(i,k,43) - p3o(i,j,k,12) = p3a(i,k,55) + ENDDO p3_jloop11 - p3o(i,j,k,13) = p3a(i,k,50) ! _4 - p3o(i,j,k,14) = p3a(i,k,51) - p3o(i,j,k,15) = p3a(i,k,52) - p3o(i,j,k,16) = p3a(i,k,56) + if (timestats.ge.1) time_microphy = time_microphy+mytime() + + ELSEIF (ptype.eq.67) THEN + +!-------------------------------------------------------------------------------------! +! P3 scheme -- config: 2-mom-cld, 2-mom-rain, 3-mom-ice, 6-ice-category, liq-frac ! +!-------------------------------------------------------------------------------------! + + rdt = 1.0/dt + + p3_jloop12: DO j=1,nj + + dum1(:,:,:) = 0.0 + + do k=1,nk + do i=1,ni + p3a(i,k, 1) = th0(i,j,k)+th3d(i,j,k) ! th + p3a(i,k, 2) = q3d(i,j,k,nqv) ! qv + thten(i,j,k) = p3a(i,k, 1) + qten(i,j,k,nqv) = p3a(i,k, 2) + p3a(i,k, 3) = q3d(i,j,k,nqc) ! qc + p3a(i,k, 4) = q3d(i,j,k,nqr) ! qr + p3a(i,k, 5) = q3d(i,j,k,11 ) ! qnr + p3a(i,k, 6) = th0(i,j,k)+tha(i,j,k) ! th_old + p3a(i,k, 7) = qa(i,j,k,nqv) ! qv_old + p3a(i,k, 8) = pi0(i,j,k)+pp3d(i,j,k) ! pii + p3a(i,k, 9) = prs(i,j,k) ! p + p3a(i,k,10) = dz*rmh(i,j,k) ! dz + p3a(i,k,11) = 0.5*(w3d(i,j,k)+w3d(i,j,k+1)) ! w + p3a(i,k,15) = q3d(i,j,k,10 ) ! nc + p3a(i,k,17) = q3d(i,j,k,nqi) ! qit_1 + p3a(i,k,18) = q3d(i,j,k,12 ) ! qni_1 + p3a(i,k,19) = q3d(i,j,k,13 ) ! qir_1 + p3a(i,k,20) = q3d(i,j,k,14 ) ! qib_1 + p3a(i,k,21) = q3d(i,j,k,15 ) ! qzi_1 + p3a(i,k,22) = q3d(i,j,k,16 ) ! qli_1 + p3a(i,k,26) = q3d(i,j,k,5 ) ! qit_2 + p3a(i,k,27) = q3d(i,j,k,17 ) ! qni_2 + p3a(i,k,28) = q3d(i,j,k,18 ) ! qir_2 + p3a(i,k,29) = q3d(i,j,k,19 ) ! qib_2 + p3a(i,k,30) = q3d(i,j,k,20 ) ! qzi_2 + p3a(i,k,31) = q3d(i,j,k,21 ) ! qli_2 + p3a(i,k,35) = q3d(i,j,k,6 ) ! qit_3 + p3a(i,k,36) = q3d(i,j,k,22 ) ! qni_3 + p3a(i,k,37) = q3d(i,j,k,23 ) ! qir_3 + p3a(i,k,38) = q3d(i,j,k,24 ) ! qib_3 + p3a(i,k,39) = q3d(i,j,k,25 ) ! qzi_3 + p3a(i,k,40) = q3d(i,j,k,26 ) ! qli_3 + p3a(i,k,44) = q3d(i,j,k,7 ) ! qit_4 + p3a(i,k,45) = q3d(i,j,k,27 ) ! qni_4 + p3a(i,k,46) = q3d(i,j,k,28 ) ! qir_4 + p3a(i,k,47) = q3d(i,j,k,29 ) ! qib_4 + p3a(i,k,48) = q3d(i,j,k,30 ) ! qzi_4 + p3a(i,k,49) = q3d(i,j,k,31 ) ! qli_4 + p3a(i,k,53) = q3d(i,j,k,8 ) ! qit_5 + p3a(i,k,54) = q3d(i,j,k,32 ) ! qni_5 + p3a(i,k,55) = q3d(i,j,k,33 ) ! qir_5 + p3a(i,k,56) = q3d(i,j,k,34 ) ! qib_5 + p3a(i,k,57) = q3d(i,j,k,35 ) ! qzi_5 + p3a(i,k,58) = q3d(i,j,k,36 ) ! qli_5 + p3a(i,k,62) = q3d(i,j,k,9 ) ! qit_6 + p3a(i,k,63) = q3d(i,j,k,37 ) ! qni_6 + p3a(i,k,64) = q3d(i,j,k,38 ) ! qir_6 + p3a(i,k,65) = q3d(i,j,k,39 ) ! qib_6 + p3a(i,k,66) = q3d(i,j,k,40 ) ! qzi_6 + p3a(i,k,67) = q3d(i,j,k,41 ) ! qli_6 + enddo + enddo + + do i=1,ni + p3a(i,1,16) = 0.0 + enddo + + call mp_p3_wrapper_wrf( th = p3a(1,1,1), & + qv = p3a(1,1,2), & + qc = p3a(1,1,3), & + qr = p3a(1,1,4), & + qnr = p3a(1,1,5), & + th_old = p3a(1,1,6), & + qv_old = p3a(1,1,7), & + pii = p3a(1,1,8), & + p = p3a(1,1,9), & + dz = p3a(1,1,10), & + w = p3a(1,1,11), & + dt = dt, & + itimestep = nstep, & + rainnc = p3a(1,1,16), & + rainncv = dum1(ib,jb,2), & + sr = dum1(ib,jb,3), & + snownc = dum1(ib,jb,4), & + snowncv = dum1(ib,jb,5), & + ids=1, ide=ni, jds=1, jde=1, kds=1, kde=nk , & + ims=1, ime=ni, jms=1, jme=1, kms=1, kme=nk , & + its=1, ite=ni, jts=1, jte=1, kts=1, kte=nk , & + diag_zdbz = p3a(1,1,12), & + diag_effc = p3a(1,1,13), & + diag_effi_ave = p3a(1,1,14), & + n_iceCat = 6, & + nc = p3a(1,1,15), & + qit_1 = p3a(1,1,17), & + qni_1 = p3a(1,1,18), & + qir_1 = p3a(1,1,19), & + qib_1 = p3a(1,1,20), & + qzi_1 = p3a(1,1,21), & + qli_1 = p3a(1,1,22), & + diag_vmi_1 = p3a(1,1,23), & + diag_dmi_1 = p3a(1,1,24), & + diag_rhoi_1 = p3a(1,1,25), & + qit_2 = p3a(1,1,26), & + qni_2 = p3a(1,1,27), & + qir_2 = p3a(1,1,28), & + qib_2 = p3a(1,1,29), & + qzi_2 = p3a(1,1,30), & + qli_2 = p3a(1,1,31), & + diag_vmi_2 = p3a(1,1,32), & + diag_dmi_2 = p3a(1,1,33), & + diag_rhoi_2 = p3a(1,1,34), & + qit_3 = p3a(1,1,35), & + qni_3 = p3a(1,1,36), & + qir_3 = p3a(1,1,37), & + qib_3 = p3a(1,1,38), & + qzi_3 = p3a(1,1,39), & + qli_3 = p3a(1,1,40), & + diag_vmi_3 = p3a(1,1,41), & + diag_dmi_3 = p3a(1,1,42), & + diag_rhoi_3 = p3a(1,1,43), & + qit_4 = p3a(1,1,44), & + qni_4 = p3a(1,1,45), & + qir_4 = p3a(1,1,46), & + qib_4 = p3a(1,1,47), & + qzi_4 = p3a(1,1,48), & + qli_4 = p3a(1,1,49), & + diag_vmi_4 = p3a(1,1,50), & + diag_dmi_4 = p3a(1,1,51), & + diag_rhoi_4 = p3a(1,1,52), & + qit_5 = p3a(1,1,53), & + qni_5 = p3a(1,1,54), & + qir_5 = p3a(1,1,55), & + qib_5 = p3a(1,1,56), & + qzi_5 = p3a(1,1,57), & + qli_5 = p3a(1,1,58), & + diag_vmi_5 = p3a(1,1,59), & + diag_dmi_5 = p3a(1,1,60), & + diag_rhoi_5 = p3a(1,1,61), & + qit_6 = p3a(1,1,62), & + qni_6 = p3a(1,1,63), & + qir_6 = p3a(1,1,64), & + qib_6 = p3a(1,1,65), & + qzi_6 = p3a(1,1,66), & + qli_6 = p3a(1,1,67), & + diag_vmi_6 = p3a(1,1,68), & + diag_dmi_6 = p3a(1,1,69), & + diag_rhoi_6 = p3a(1,1,70), & + diag_dhmax_1 = p3a(1,1,71), & + diag_dhmax_2 = p3a(1,1,72), & + diag_dhmax_3 = p3a(1,1,73), & + diag_dhmax_4 = p3a(1,1,74), & + diag_dhmax_5 = p3a(1,1,75), & + diag_dhmax_6 = p3a(1,1,76), & + diag2d_01 = p3a(1,1,77), & + diag2d_02 = p3a(1,1,78), & + diag3d_01 = p3a(1,1,79), & + diag3d_02 = p3a(1,1,80), & + diag3d_03 = p3a(1,1,81), & + j_index = j, & ! DTD: added j_index for debugging + diagflag = (getdbz .or. dowriteout) ) + if( axisymm.eq.1 )then + do i=1,ni + prate(i,j) = p3a(i,1,16)*rdt + qbudget(6) = qbudget(6) + p3a(i,1,16)*ruh(i)*rvh(j)*dx*dy*dum3(i,j,1)/rho(i,j,1) + enddo + else + do i=1,ni + prate(i,j) = p3a(i,1,16)*rdt + qbudget(6) = qbudget(6) + p3a(i,1,16)*ruh(i)*rvh(j)*dx*dy + enddo + endif + + do n=1,nrain + do i=1,ni + ! convert from mm to cm: + rain(i,j,n) = rain(i,j,n) + 0.1*p3a(i,1,16) + enddo + enddo + + do k=1,nk + do i=1,ni + if( abs(p3a(i,k,1)-thten(i,j,k)).ge.tsmall .or. & + abs(p3a(i,k,2)-qten(i,j,k,nqv)).ge.qsmall )then + pp3d(i,j,k)=(rho(i,j,k)*(rd+rv*p3a(i,k,2))*p3a(i,k,1)*rp00)**rddcv + prs(i,j,k)=p00*(pp3d(i,j,k)**cpdrd) + pp3d(i,j,k)=pp3d(i,j,k)-pi0(i,j,k) + th3d(i,j,k)=th3d(i,j,k)+(p3a(i,k,1)-thten(i,j,k)) + endif + q3d(i,j,k,nqv) = p3a(i,k, 2) + q3d(i,j,k,nqc) = p3a(i,k, 3) ! qc + q3d(i,j,k,nqr) = p3a(i,k, 4) ! qr + q3d(i,j,k,11 ) = p3a(i,k, 5) ! qnr + q3d(i,j,k,10 ) = p3a(i,k,15) ! nc + q3d(i,j,k,nqi) = p3a(i,k,17) ! qit_1 + q3d(i,j,k,12 ) = p3a(i,k,18) ! qni_1 + q3d(i,j,k,13 ) = p3a(i,k,19) ! qir_1 + q3d(i,j,k,14 ) = p3a(i,k,20) ! qib_1 + q3d(i,j,k,15 ) = p3a(i,k,21) ! qzi_1 + q3d(i,j,k,16 ) = p3a(i,k,22) ! qli_1 + q3d(i,j,k,5 ) = p3a(i,k,26) ! qit_2 + q3d(i,j,k,17 ) = p3a(i,k,27) ! qni_2 + q3d(i,j,k,18 ) = p3a(i,k,28) ! qir_2 + q3d(i,j,k,19 ) = p3a(i,k,29) ! qib_2 + q3d(i,j,k,20 ) = p3a(i,k,30) ! qzi_2 + q3d(i,j,k,21 ) = p3a(i,k,31) ! qli_2 + q3d(i,j,k,6 ) = p3a(i,k,35) ! qit_3 + q3d(i,j,k,22 ) = p3a(i,k,36) ! qni_3 + q3d(i,j,k,23 ) = p3a(i,k,37) ! qir_3 + q3d(i,j,k,24 ) = p3a(i,k,38) ! qib_3 + q3d(i,j,k,25 ) = p3a(i,k,39) ! qzi_3 + q3d(i,j,k,26 ) = p3a(i,k,40) ! qli_3 + q3d(i,j,k,7 ) = p3a(i,k,44) ! qit_4 + q3d(i,j,k,27 ) = p3a(i,k,45) ! qni_4 + q3d(i,j,k,28 ) = p3a(i,k,46) ! qir_4 + q3d(i,j,k,29 ) = p3a(i,k,47) ! qib_4 + q3d(i,j,k,30 ) = p3a(i,k,48) ! qzi_4 + q3d(i,j,k,31 ) = p3a(i,k,49) ! qli_4 + q3d(i,j,k,8 ) = p3a(i,k,53) ! qit_5 + q3d(i,j,k,32 ) = p3a(i,k,54) ! qni_5 + q3d(i,j,k,33 ) = p3a(i,k,55) ! qir_5 + q3d(i,j,k,34 ) = p3a(i,k,56) ! qib_5 + q3d(i,j,k,35 ) = p3a(i,k,57) ! qzi_5 + q3d(i,j,k,36 ) = p3a(i,k,58) ! qli_5 + q3d(i,j,k,9 ) = p3a(i,k,62) ! qit_6 + q3d(i,j,k,37 ) = p3a(i,k,63) ! qni_6 + q3d(i,j,k,38 ) = p3a(i,k,64) ! qir_6 + q3d(i,j,k,39 ) = p3a(i,k,65) ! qib_6 + q3d(i,j,k,40 ) = p3a(i,k,66) ! qzi_6 + q3d(i,j,k,41 ) = p3a(i,k,67) ! qli_6 + enddo + enddo + + IF( getdbz .and. qd_dbz.ge.1 )THEN + do k=1,nk + do i=1,ni + qdiag(i,j,k,qd_dbz) = p3a(i,k,12) + enddo + enddo + ENDIF + + IF( dorad )THEN + do k=1,nk + do i=1,ni + effc(i,j,k) = p3a(i,k,13) + effi(i,j,k) = p3a(i,k,14) + enddo + enddo + ENDIF + + IF( dowriteout .or. getdbz )THEN + do k=1,nk + do i=1,ni + p3o(i,j,k, 1) = p3a(i,k,23) ! vmi_1 + p3o(i,j,k, 2) = p3a(i,k,24) ! dmi_1 + p3o(i,j,k, 3) = p3a(i,k,25) ! rhoi_1 + p3o(i,j,k, 4) = p3a(i,k,71) ! dhmax_1 + + p3o(i,j,k, 5) = p3a(i,k,32) ! vmi_2 + p3o(i,j,k, 6) = p3a(i,k,33) ! dmi_2 + p3o(i,j,k, 7) = p3a(i,k,34) ! rhoi_2 + p3o(i,j,k, 8) = p3a(i,k,72) ! dhmax_2 + + p3o(i,j,k, 9) = p3a(i,k,41) ! vmi_3 + p3o(i,j,k,10) = p3a(i,k,42) ! dmi_3 + p3o(i,j,k,11) = p3a(i,k,43) ! rhoi_3 + p3o(i,j,k,12) = p3a(i,k,73) ! dhmax_3 + + p3o(i,j,k,13) = p3a(i,k,50) ! vmi_4 + p3o(i,j,k,14) = p3a(i,k,51) ! dmi_4 + p3o(i,j,k,15) = p3a(i,k,52) ! rhoi_4 + p3o(i,j,k,16) = p3a(i,k,74) ! dhmax_4 + + p3o(i,j,k,17) = p3a(i,k,59) ! vmi_5 + p3o(i,j,k,18) = p3a(i,k,60) ! dmi_5 + p3o(i,j,k,19) = p3a(i,k,61) ! rhoi_5 + p3o(i,j,k,20) = p3a(i,k,75) ! dhmax_5 + + p3o(i,j,k,21) = p3a(i,k,68) ! vmi_6 + p3o(i,j,k,22) = p3a(i,k,69) ! dmi_6 + p3o(i,j,k,23) = p3a(i,k,70) ! rhoi_6 + p3o(i,j,k,24) = p3a(i,k,76) ! dhmax_6 enddo enddo ENDIF ! user-specified diagnostic output do i=1,ni - out2d(i,j,1) = p3a(i,1,57) - out2d(i,j,2) = p3a(i,1,58) + out2d(i,j,1) = p3a(i,1,77) + out2d(i,j,2) = p3a(i,1,78) enddo do k=1,nk do i=1,ni - out3d(i,j,k,1) = p3a(i,k,59) - out3d(i,j,k,2) = p3a(i,k,60) - out3d(i,j,k,3) = p3a(i,k,61) + out3d(i,j,k,1) = p3a(i,k,79) + out3d(i,j,k,2) = p3a(i,k,80) + out3d(i,j,k,3) = p3a(i,k,81) enddo enddo - - ENDDO p3_jloop6 + ENDDO p3_jloop12 if (timestats.ge.1) time_microphy = time_microphy+mytime() - ! --- END OF CODE FOR P3 SCHEME --- !ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc @@ -2465,7 +4159,7 @@ subroutine mp_driver(nstep,dt,qbudget,asq,bsq,xh,ruh,xf,ruf,yh,rvh,yf,rvf, & do k=1,nk do j=1,nj do i=1,ni - ! cm1r17: to make things easier to understand, use same arrays + ! cm1r17: to make things easier to understand, use same arrays ! that are used for morrison code: ! dum1 = T (this should have been calculated already) ! dum2 = pi (nondimensional pressure) @@ -2490,7 +4184,7 @@ subroutine mp_driver(nstep,dt,qbudget,asq,bsq,xh,ruh,xf,ruf,yh,rvh,yf,rvf, & ! ib3d=ib3d,ie3d=ie3d,jb3d=jb3d,je3d=je3d,kb3d=kb3d,ke3d=ke3d, & ! nout3d=nout3d,out3d=out3d,eqtset=eqtset) - + call mp_jensen_ishmael( & itimestep=nstep, dt_in=dt, p=prs, dz=dum4, t3d=dum1, & qv=q3d(ib,jb,kb,1), & @@ -2536,7 +4230,7 @@ subroutine mp_driver(nstep,dt,qbudget,asq,bsq,xh,ruh,xf,ruf,yh,rvh,yf,rvf, & enddo enddo - if( getdbz )then + if( getdbz .and. qd_dbz.ge.1 )then do k=1,nk do j=1,nj do i=1,ni diff --git a/src/param.F b/src/param.F index f75afbd..f6c903d 100644 --- a/src/param.F +++ b/src/param.F @@ -73,7 +73,10 @@ subroutine param(dt,dtlast,stattim,taptim,rsttim,radtim,prcltim, & #endif use module_mp_thompson , only : thompson_init use module_mp_graupel - use microphy_p3, only : p3_init + use microphy_p3, only : p3_init, log_chksum, chksum_myid, & + log_chkpts, chksum_i0, chksum_j0, & + log_limlog, limlog_ratmin, log_nifloor, log_nrfloor, & + dbgpt_i, dbgpt_j, dbgpt_k, dbgpt_halo use module_mp_jensen_ishmael, only : jensen_ishmael_init use module_mp_nssl_2mom, only: nssl_2mom_init, rho_qr, cnor, rho_qs, & cnos, rho_qh, rho_qhl, cnoh, ccn, irenuc, infall, alphah, alphahl, & @@ -150,6 +153,68 @@ subroutine param(dt,dtlast,stattim,taptim,rsttim,radtim,prcltim, & logical :: doit,getfall logical :: nssl_hail_on = .false. + ! ERM/DTD begin for p3 parameters + real :: p3_cccn = 300.e6 + real :: p3_nimax = 2000.e3 + integer :: p3_iparam = 3 + integer :: p3_ccn_on = 0 + integer :: p3_merge_opt = 1 ! 0 = no merging; 1 = diameter-difference merge (original); 2 = percent difference in diam. (Cholette 2024) + integer :: p3_qrcol_opt = 0 ! 0 = no size check on qrcol; 1 = only allow qrcol for ice larger than rain + ! for p3_merge_opt=0 with p3_qrcol_opt=2 and ncat=2, this disables qrcol for iice=2 + integer :: p3_hm_opt = 1 ! P3: Hallett-Mossop rime-splintering source: 0 = off, 1 = riming of cloud droplets only, + ! 2 = riming of rain only (original P3 behaviour), 3 = both + integer :: rssflg = 1 ! P3: Rain size-sorting allowed (1, default), or disallowed (0). If 0, sets N and Z-weighted fall speeds to q-weighted value + integer :: sssflg = 1 ! P3: As for rain but for ice (all ice) + logical :: p3_cat_init_new = .true. ! switch for mechanism-based ice category initialization + logical :: p3_chksum = .false. ! P3: write per-timestep bitwise field checksums to p3_chksum_NNNN.out (divergence diagnosis) + logical :: p3_chkpts = .false. ! P3: write per-point raw bit patterns to p3_chkpts_NNNN.out (LARGE; short bracketing runs only) + logical :: p3_limlog = .false. ! P3: log every point-local limiter/gate firing to p3_limlog_NNNN.out (grid-point noise diagnosis) + real :: p3_limlog_rat = 0.9 ! P3: with p3_limlog, record conservation-limiter firings only when the applied ratio is below this + ! P3: targeted single-point dump to p3_dbgpt_NNNN.out (full-grid indices; p3_dbg_i<=0 disables) + integer :: p3_dbg_i = 0 + integer :: p3_dbg_j = 0 + integer :: p3_dbg_k = 0 + integer :: p3_dbg_halo = 1 ! P3: half-width of the block dumped around (p3_dbg_i,j,k); 0 = single point + ! TEMPORARY diagnostic switch -- remove after the grid-point-noise A/B concludes: + logical :: p3_nifloor = .true. ! P3: .false. disables every nitot/nc floor; ice or cloud with mass but no number keeps its mass and is rejected by nitot/nc conditions on the gates instead of running at an absurd mean size. NOTE: with .false. the exit clip no longer clears number-less ice, so that mass persists + logical :: p3_nrfloor = .true. ! P3: .false. disables every nr floor; rain with mass but no number keeps its mass and is rejected by nr conditions on the rain paths (get_rain_dsd2, ice collection, evaporation, sedimentation, ze_rain) instead of being given nr=nsmall, which would pin the drop spectrum at the maximum diameter and maximise ze_rain + logical :: log_nislf = .true. ! switch to allow ice self-aggregation + logical :: log_iceice_interaction = .true. ! switch to allow ice categories to interact + integer :: p3_catdest_contact_n2 = 1 + integer :: p3_catdest_contact_n3 = 3 + integer :: p3_catdest_contact_n4 = 4 + integer :: p3_catdest_rainimm_n2 = 2 + integer :: p3_catdest_rainimm_n3 = 2 + integer :: p3_catdest_rainimm_n4 = 2 + integer :: p3_catdest_rimesplinter_n2 = 1 + integer :: p3_catdest_rimesplinter_n3 = 3 + integer :: p3_catdest_rimesplinter_n4 = 3 + integer :: p3_catdest_depnuc_n2 = 1 + integer :: p3_catdest_depnuc_n3 = 3 + integer :: p3_catdest_depnuc_n4 = 4 + integer :: p3_catdest_homocloud_n2 = 1 + integer :: p3_catdest_homocloud_n3 = 1 + integer :: p3_catdest_homocloud_n4 = 1 + integer :: p3_catdest_homorain_n2 = 2 + integer :: p3_catdest_homorain_n3 = 2 + integer :: p3_catdest_homorain_n4 = 2 + ! DTD: destinations for the 5- and 6-category configurations (ptype 64-67). + ! Defaults continue the progressive split of the _n2..._n4 series: with 5 + ! categories deposition nucleation gets its own category, and with 6 + ! homogeneous freezing of rain gets its own as well. + integer :: p3_catdest_contact_n5 = 4 + integer :: p3_catdest_contact_n6 = 4 + integer :: p3_catdest_rainimm_n5 = 2 + integer :: p3_catdest_rainimm_n6 = 2 + integer :: p3_catdest_rimesplinter_n5 = 3 + integer :: p3_catdest_rimesplinter_n6 = 3 + integer :: p3_catdest_depnuc_n5 = 5 + integer :: p3_catdest_depnuc_n6 = 5 + integer :: p3_catdest_homocloud_n5 = 1 + integer :: p3_catdest_homocloud_n6 = 1 + integer :: p3_catdest_homorain_n5 = 2 + integer :: p3_catdest_homorain_n6 = 6 + ! ERM/DTD end #ifdef MPI integer :: ntmp1,ntmp2,ntmp3,ntmp4,reqs,reqs1,reqs2,reqs3,reqs4 integer, dimension(MPI_STATUS_SIZE) :: status @@ -182,6 +247,60 @@ subroutine param(dt,dtlast,stattim,taptim,rsttim,radtim,prcltim, & dmrauto, & ioldlimiter, & ihlcnh + NAMELIST /p3_params/ & ! ERM/DTD add p3_params namelist + p3_cccn, & + p3_nimax, & + p3_iparam, & + p3_ccn_on, & + p3_merge_opt, & + p3_qrcol_opt, & + p3_hm_opt, & + rssflg, & + sssflg, & + p3_cat_init_new,& + p3_chksum, & + p3_chkpts, & + p3_limlog, & + p3_limlog_rat, & + p3_nifloor, & + p3_nrfloor, & + p3_dbg_i, & + p3_dbg_j, & + p3_dbg_k, & + p3_dbg_halo, & + qsum_invariant, & + log_nislf, & + log_iceice_interaction, & + p3_catdest_contact_n2, & + p3_catdest_contact_n3, & + p3_catdest_contact_n4, & + p3_catdest_rainimm_n2, & + p3_catdest_rainimm_n3, & + p3_catdest_rainimm_n4, & + p3_catdest_rimesplinter_n2, & + p3_catdest_rimesplinter_n3, & + p3_catdest_rimesplinter_n4, & + p3_catdest_depnuc_n2, & + p3_catdest_depnuc_n3, & + p3_catdest_depnuc_n4, & + p3_catdest_homocloud_n2, & + p3_catdest_homocloud_n3, & + p3_catdest_homocloud_n4, & + p3_catdest_homorain_n2, & + p3_catdest_homorain_n3, & + p3_catdest_homorain_n4, & + p3_catdest_contact_n5, & + p3_catdest_contact_n6, & + p3_catdest_rainimm_n5, & + p3_catdest_rainimm_n6, & + p3_catdest_rimesplinter_n5, & + p3_catdest_rimesplinter_n6, & + p3_catdest_depnuc_n5, & + p3_catdest_depnuc_n6, & + p3_catdest_homocloud_n5, & + p3_catdest_homocloud_n6, & + p3_catdest_homorain_n5, & + p3_catdest_homorain_n6 NAMELIST /forcing/ & iforce, & @@ -342,7 +461,12 @@ subroutine param(dt,dtlast,stattim,taptim,rsttim,radtim,prcltim, & 751 continue rewind(20) ENDIF - + ! ERM/DTD for p3_params + IF ( (ptype.ge.50 .and. ptype.le.54) .or. (ptype.ge.56 .and. ptype.le.67) ) THEN + read(20,nml=p3_params,end=752) +752 continue + rewind(20) + ENDIF read(20,nml=param17,end=717) 717 continue rewind(20) @@ -523,6 +647,7 @@ subroutine param(dt,dtlast,stattim,taptim,rsttim,radtim,prcltim, & call MPI_BCAST(output_filetype,1,MPI_INTEGER,0,MPI_COMM_WORLD,ierr) call MPI_BCAST(output_interp ,1,MPI_INTEGER,0,MPI_COMM_WORLD,ierr) call MPI_BCAST(output_rain ,1,MPI_INTEGER,0,MPI_COMM_WORLD,ierr) + call MPI_BCAST(output_hail ,1,MPI_INTEGER,0,MPI_COMM_WORLD,ierr) call MPI_BCAST(output_sws ,1,MPI_INTEGER,0,MPI_COMM_WORLD,ierr) call MPI_BCAST(output_svs ,1,MPI_INTEGER,0,MPI_COMM_WORLD,ierr) call MPI_BCAST(output_sps ,1,MPI_INTEGER,0,MPI_COMM_WORLD,ierr) @@ -764,6 +889,61 @@ subroutine param(dt,dtlast,stattim,taptim,rsttim,radtim,prcltim, & call MPI_BCAST(nssl_3moment,1,MPI_LOGICAL,0,MPI_COMM_WORLD,ierr) call MPI_BCAST(nssl_density_on,1,MPI_LOGICAL,0,MPI_COMM_WORLD,ierr) ENDIF + ! ERM/DTD begin + call MPI_BCAST(p3_cccn ,1,MPI_REAL,0,MPI_COMM_WORLD,ierr) + call MPI_BCAST(p3_nimax ,1,MPI_REAL,0,MPI_COMM_WORLD,ierr) + call MPI_BCAST(p3_iparam ,1,MPI_INTEGER,0,MPI_COMM_WORLD,ierr) + call MPI_BCAST(p3_ccn_on ,1,MPI_INTEGER,0,MPI_COMM_WORLD,ierr) + call MPI_BCAST(p3_merge_opt,1,MPI_INTEGER,0,MPI_COMM_WORLD,ierr) + call MPI_BCAST(p3_qrcol_opt,1,MPI_INTEGER,0,MPI_COMM_WORLD,ierr) + call MPI_BCAST(p3_hm_opt,1,MPI_INTEGER,0,MPI_COMM_WORLD,ierr) + call MPI_BCAST(rssflg ,1,MPI_INTEGER,0,MPI_COMM_WORLD,ierr) + call MPI_BCAST(sssflg ,1,MPI_INTEGER,0,MPI_COMM_WORLD,ierr) + call MPI_BCAST(p3_cat_init_new,1,MPI_LOGICAL,0,MPI_COMM_WORLD,ierr) + call MPI_BCAST(p3_chksum,1,MPI_LOGICAL,0,MPI_COMM_WORLD,ierr) + call MPI_BCAST(p3_chkpts,1,MPI_LOGICAL,0,MPI_COMM_WORLD,ierr) + call MPI_BCAST(p3_limlog,1,MPI_LOGICAL,0,MPI_COMM_WORLD,ierr) + call MPI_BCAST(p3_limlog_rat,1,MPI_REAL,0,MPI_COMM_WORLD,ierr) + call MPI_BCAST(p3_nifloor,1,MPI_LOGICAL,0,MPI_COMM_WORLD,ierr) + call MPI_BCAST(p3_nrfloor,1,MPI_LOGICAL,0,MPI_COMM_WORLD,ierr) + call MPI_BCAST(p3_dbg_i,1,MPI_INTEGER,0,MPI_COMM_WORLD,ierr) + call MPI_BCAST(p3_dbg_j,1,MPI_INTEGER,0,MPI_COMM_WORLD,ierr) + call MPI_BCAST(p3_dbg_k,1,MPI_INTEGER,0,MPI_COMM_WORLD,ierr) + call MPI_BCAST(p3_dbg_halo,1,MPI_INTEGER,0,MPI_COMM_WORLD,ierr) + call MPI_BCAST(qsum_invariant,1,MPI_LOGICAL,0,MPI_COMM_WORLD,ierr) + call MPI_BCAST(log_nislf,1,MPI_LOGICAL,0,MPI_COMM_WORLD,ierr) + call MPI_BCAST(log_iceice_interaction,1,MPI_LOGICAL,0,MPI_COMM_WORLD,ierr) + call MPI_BCAST(p3_catdest_contact_n2,1,MPI_INTEGER,0,MPI_COMM_WORLD,ierr) + call MPI_BCAST(p3_catdest_contact_n3,1,MPI_INTEGER,0,MPI_COMM_WORLD,ierr) + call MPI_BCAST(p3_catdest_contact_n4,1,MPI_INTEGER,0,MPI_COMM_WORLD,ierr) + call MPI_BCAST(p3_catdest_rainimm_n2,1,MPI_INTEGER,0,MPI_COMM_WORLD,ierr) + call MPI_BCAST(p3_catdest_rainimm_n3,1,MPI_INTEGER,0,MPI_COMM_WORLD,ierr) + call MPI_BCAST(p3_catdest_rainimm_n4,1,MPI_INTEGER,0,MPI_COMM_WORLD,ierr) + call MPI_BCAST(p3_catdest_rimesplinter_n2,1,MPI_INTEGER,0,MPI_COMM_WORLD,ierr) + call MPI_BCAST(p3_catdest_rimesplinter_n3,1,MPI_INTEGER,0,MPI_COMM_WORLD,ierr) + call MPI_BCAST(p3_catdest_rimesplinter_n4,1,MPI_INTEGER,0,MPI_COMM_WORLD,ierr) + call MPI_BCAST(p3_catdest_depnuc_n2,1,MPI_INTEGER,0,MPI_COMM_WORLD,ierr) + call MPI_BCAST(p3_catdest_depnuc_n3,1,MPI_INTEGER,0,MPI_COMM_WORLD,ierr) + call MPI_BCAST(p3_catdest_depnuc_n4,1,MPI_INTEGER,0,MPI_COMM_WORLD,ierr) + call MPI_BCAST(p3_catdest_homocloud_n2,1,MPI_INTEGER,0,MPI_COMM_WORLD,ierr) + call MPI_BCAST(p3_catdest_homocloud_n3,1,MPI_INTEGER,0,MPI_COMM_WORLD,ierr) + call MPI_BCAST(p3_catdest_homocloud_n4,1,MPI_INTEGER,0,MPI_COMM_WORLD,ierr) + call MPI_BCAST(p3_catdest_homorain_n2,1,MPI_INTEGER,0,MPI_COMM_WORLD,ierr) + call MPI_BCAST(p3_catdest_homorain_n3,1,MPI_INTEGER,0,MPI_COMM_WORLD,ierr) + call MPI_BCAST(p3_catdest_homorain_n4,1,MPI_INTEGER,0,MPI_COMM_WORLD,ierr) + call MPI_BCAST(p3_catdest_contact_n5,1,MPI_INTEGER,0,MPI_COMM_WORLD,ierr) + call MPI_BCAST(p3_catdest_contact_n6,1,MPI_INTEGER,0,MPI_COMM_WORLD,ierr) + call MPI_BCAST(p3_catdest_rainimm_n5,1,MPI_INTEGER,0,MPI_COMM_WORLD,ierr) + call MPI_BCAST(p3_catdest_rainimm_n6,1,MPI_INTEGER,0,MPI_COMM_WORLD,ierr) + call MPI_BCAST(p3_catdest_rimesplinter_n5,1,MPI_INTEGER,0,MPI_COMM_WORLD,ierr) + call MPI_BCAST(p3_catdest_rimesplinter_n6,1,MPI_INTEGER,0,MPI_COMM_WORLD,ierr) + call MPI_BCAST(p3_catdest_depnuc_n5,1,MPI_INTEGER,0,MPI_COMM_WORLD,ierr) + call MPI_BCAST(p3_catdest_depnuc_n6,1,MPI_INTEGER,0,MPI_COMM_WORLD,ierr) + call MPI_BCAST(p3_catdest_homocloud_n5,1,MPI_INTEGER,0,MPI_COMM_WORLD,ierr) + call MPI_BCAST(p3_catdest_homocloud_n6,1,MPI_INTEGER,0,MPI_COMM_WORLD,ierr) + call MPI_BCAST(p3_catdest_homorain_n5,1,MPI_INTEGER,0,MPI_COMM_WORLD,ierr) + call MPI_BCAST(p3_catdest_homorain_n6,1,MPI_INTEGER,0,MPI_COMM_WORLD,ierr) + ! ERM/DTD end #endif open(unit=20,file='namelist.input',form='formatted',status='old', & @@ -1036,15 +1216,16 @@ subroutine param(dt,dtlast,stattim,taptim,rsttim,radtim,prcltim, & eqtset = 1 ENDIF !----- - IF( (ptype.eq.4.or.ptype.eq.50.or.ptype.eq.51.or.ptype.eq.52.or.ptype.eq.53.or.ptype.eq.54.or.ptype.eq.55.or.ptype.eq.60 & - .or.ptype.eq.61 .or. ptype.eq.62 .or. ptype.eq.63) .and. eqtset.eq.2 )THEN + IF( (ptype.eq.4.or.ptype.eq.50.or.ptype.eq.51.or.ptype.eq.52.or.ptype.eq.53.or.ptype.eq.54.or.ptype.eq.55.or.ptype.eq.56 & + .or.ptype.eq.57 .or.ptype.eq.60.or.ptype.eq.61 .or. ptype.eq.62 .or. ptype.eq.63 & + .or.ptype.eq.64 .or.ptype.eq.65 .or. ptype.eq.66 .or. ptype.eq.67) .and. eqtset.eq.2 )THEN if(myid.eq.0)then print *,' -------------------------------- ' print * print *,' ptype = ',ptype print *,' eqtset = ',eqtset print * - print *,' ptype=4,50,51,52,53,54,55,60,61,62,63 requires eqtset=1 ' + print *,' ptype=4,50,51,52,53,54,55,56,57,60,61,62,63 requires eqtset=1 ' print * print *,' ... setting eqtset to 1 ... ' print * @@ -2382,14 +2563,15 @@ subroutine param(dt,dtlast,stattim,taptim,rsttim,radtim,prcltim, & ENDIF !----- IF( radopt.eq.2 .and. ( ptype.ne.3 .and. ptype.ne.5 .and. ptype.ne.50 .and. ptype.ne.51 .and. & - ptype.ne.52 .and. ptype.ne.53 .and. ptype.ne.54 .and. ptype.ne.55 .and. ptype.ne.60 .and. & + ptype.ne.52 .and. ptype.ne.53 .and. ptype.ne.54 .and. ptype.ne.55 .and. & + ptype.ne.56 .and. ptype.ne.57 .and. ptype.ne.60 .and. & ptype.ne.61 .and. ptype.ne.62 .and. ptype.ne.63) )THEN if(myid.eq.0)then print * print *,' radopt = ',radopt print *,' ptype = ',ptype print * - print *,' radopt=2 requires ptype=3,5,26,27,50,51,52,53,54,55,60,61,62,63 (for now) ' + print *,' radopt=2 requires ptype=3,5,26,27,50,51,52,53,54,55,56,57,60,61,62,63 (for now) ' print * print *,' stopping model .... ' print * @@ -2817,10 +2999,16 @@ subroutine param(dt,dtlast,stattim,taptim,rsttim,radtim,prcltim, & if( ptype.eq.53 ) param_mp = 'Predicted Particle Property (P3)' if( ptype.eq.54 ) param_mp = 'Predicted Particle Property (P3)' if( ptype.eq.55 ) param_mp = 'Jensen_ISHMAEL' + if( ptype.eq.56 ) param_mp = 'Predicted Particle Property (P3)' + if( ptype.eq.57 ) param_mp = 'Predicted Particle Property (P3)' if( ptype.eq.60 ) param_mp = 'Predicted Particle Property (P3)' if( ptype.eq.61 ) param_mp = 'Predicted Particle Property (P3)' if( ptype.eq.62 ) param_mp = 'Predicted Particle Property (P3)' if( ptype.eq.63 ) param_mp = 'Predicted Particle Property (P3)' + if( ptype.eq.64 ) param_mp = 'Predicted Particle Property (P3)' + if( ptype.eq.65 ) param_mp = 'Predicted Particle Property (P3)' + if( ptype.eq.66 ) param_mp = 'Predicted Particle Property (P3)' + if( ptype.eq.67 ) param_mp = 'Predicted Particle Property (P3)' endif if( idoles )then ! LES subgrid: @@ -3103,7 +3291,7 @@ subroutine param(dt,dtlast,stattim,taptim,rsttim,radtim,prcltim, & if(dowr) write(outfile,*) - IF ( ptype >= 26 .and. dowr ) THEN + IF ( ptype >= 26 .and. ptype <= 28 .and. dowr ) THEN write(outfile,NML=nssl2mom_params) ! write(outfile,*) 'alphah =',alphah ! write(outfile,*) 'alphahl =',alphahl @@ -3121,7 +3309,10 @@ subroutine param(dt,dtlast,stattim,taptim,rsttim,radtim,prcltim, & ! write(outfile,*) 'dmrauto =',dmrauto ! write(outfile,*) 'ioldlimiter=',ioldlimiter ENDIF - + ! ERM/DTD for p3 + IF ( (ptype.ge.50 .and. ptype.le.54) .or. (ptype.ge.56 .and. ptype.le.67) ) THEN + write(outfile,NML=p3_params) + ENDIF !-------------------------------------------------------------- if(dowr) write(outfile,*) @@ -3860,7 +4051,7 @@ subroutine param(dt,dtlast,stattim,taptim,rsttim,radtim,prcltim, & qunit(nvl1:nvl2) = 'm^3/kg' ENDIF IF ( nssl_3moment ) THEN - qunit(nzl1:nzl2) = 'Z/m^3/kg' + qunit(nzl1:nzl2) = 'Z/kg' ENDIF rhovar(lv:lhab) = .false. @@ -4017,7 +4208,8 @@ subroutine param(dt,dtlast,stattim,taptim,rsttim,radtim,prcltim, & ! if(dowr) write(outfile,*) 'Calling graupel_init' ! if(dowr) write(outfile,*) - CALL nssl_2mom_init(ipctmp=0,mixphase=0,ihvol=-1,eqtset_tmp=eqtset) + CALL nssl_2mom_init(ipctmp=0,mixphase=0,nssl_hail_on=.false.,nssl_density_on=.false., & + eqtset_tmp=eqtset,myrank=myid,mpiroot=0) ! if(dowr) write(outfile,*) @@ -4036,8 +4228,9 @@ subroutine param(dt,dtlast,stattim,taptim,rsttim,radtim,prcltim, & !----------------------------------------------------------------------- - ELSEIF( ptype.eq.50 .or. ptype.eq.51 .or. ptype.eq.52 .or. ptype.eq.53 .or. ptype.eq.54 .or. ptype.eq.60 & - .or. ptype.eq.61 .or. ptype.eq.62 .or. ptype.eq.63) THEN ! P3 + ELSEIF( ptype.eq.50 .or. ptype.eq.51 .or. ptype.eq.52 .or. ptype.eq.53 .or. ptype.eq.54 .or. ptype.eq.56 & + .or. ptype.eq.57 .or. ptype.eq.60 .or. ptype.eq.61 .or. ptype.eq.62 .or. ptype.eq.63 & + .or. ptype.eq.64 .or. ptype.eq.65 .or. ptype.eq.66 .or. ptype.eq.67) THEN ! P3 !----- initialize the P3 scheme ----- @@ -4052,7 +4245,22 @@ subroutine param(dt,dtlast,stattim,taptim,rsttim,radtim,prcltim, & model='WRF', & stat=p3stat, & abort_on_err=.false., & - dowr=dowr) + dowr=dowr, nanew1_in=p3_cccn,iparam_in=p3_iparam, & ! ERM added new p3 options (all calls) + p3_ccn_on=p3_ccn_on,p3_merge_opt=p3_merge_opt,p3_qrcol_opt=p3_qrcol_opt,p3_hm_opt=p3_hm_opt, & + rssflg_in=rssflg, sssflg_in=sssflg, max_Ni_in=p3_nimax, & + cat_init_new_in=p3_cat_init_new, & + log_nislf_in=log_nislf, & + log_iceice_interaction_in=log_iceice_interaction, & + catdest_contact_n2_in=p3_catdest_contact_n2,catdest_contact_n3_in=p3_catdest_contact_n3, & + catdest_contact_n4_in=p3_catdest_contact_n4,catdest_rainimm_n2_in=p3_catdest_rainimm_n2, & + catdest_rainimm_n3_in=p3_catdest_rainimm_n3,catdest_rainimm_n4_in=p3_catdest_rainimm_n4, & + catdest_rimesplinter_n2_in=p3_catdest_rimesplinter_n2, & + catdest_rimesplinter_n3_in=p3_catdest_rimesplinter_n3, & + catdest_rimesplinter_n4_in=p3_catdest_rimesplinter_n4,catdest_depnuc_n2_in=p3_catdest_depnuc_n2, & + catdest_depnuc_n3_in=p3_catdest_depnuc_n3,catdest_depnuc_n4_in=p3_catdest_depnuc_n4, & + catdest_homocloud_n2_in=p3_catdest_homocloud_n2,catdest_homocloud_n3_in=p3_catdest_homocloud_n3, & + catdest_homocloud_n4_in=p3_catdest_homocloud_n4,catdest_homorain_n2_in=p3_catdest_homorain_n2, & + catdest_homorain_n3_in=p3_catdest_homorain_n3,catdest_homorain_n4_in=p3_catdest_homorain_n4 ) elseif( ptype.eq.51 )then call p3_init(lookup_file_dir='.', & nCat=1, & @@ -4061,7 +4269,22 @@ subroutine param(dt,dtlast,stattim,taptim,rsttim,radtim,prcltim, & model='WRF', & stat=p3stat, & abort_on_err=.false., & - dowr=dowr) + dowr=dowr, nanew1_in=p3_cccn,iparam_in=p3_iparam, & + p3_ccn_on=p3_ccn_on,p3_merge_opt=p3_merge_opt,p3_qrcol_opt=p3_qrcol_opt,p3_hm_opt=p3_hm_opt, & + rssflg_in=rssflg, sssflg_in=sssflg, max_Ni_in=p3_nimax, & + cat_init_new_in=p3_cat_init_new, & + log_nislf_in=log_nislf, & + log_iceice_interaction_in=log_iceice_interaction, & + catdest_contact_n2_in=p3_catdest_contact_n2,catdest_contact_n3_in=p3_catdest_contact_n3, & + catdest_contact_n4_in=p3_catdest_contact_n4,catdest_rainimm_n2_in=p3_catdest_rainimm_n2, & + catdest_rainimm_n3_in=p3_catdest_rainimm_n3,catdest_rainimm_n4_in=p3_catdest_rainimm_n4, & + catdest_rimesplinter_n2_in=p3_catdest_rimesplinter_n2, & + catdest_rimesplinter_n3_in=p3_catdest_rimesplinter_n3, & + catdest_rimesplinter_n4_in=p3_catdest_rimesplinter_n4,catdest_depnuc_n2_in=p3_catdest_depnuc_n2, & + catdest_depnuc_n3_in=p3_catdest_depnuc_n3,catdest_depnuc_n4_in=p3_catdest_depnuc_n4, & + catdest_homocloud_n2_in=p3_catdest_homocloud_n2,catdest_homocloud_n3_in=p3_catdest_homocloud_n3, & + catdest_homocloud_n4_in=p3_catdest_homocloud_n4,catdest_homorain_n2_in=p3_catdest_homorain_n2, & + catdest_homorain_n3_in=p3_catdest_homorain_n3,catdest_homorain_n4_in=p3_catdest_homorain_n4 ) elseif( ptype.eq.52 )then call p3_init(lookup_file_dir='.', & nCat=2, & @@ -4070,7 +4293,22 @@ subroutine param(dt,dtlast,stattim,taptim,rsttim,radtim,prcltim, & model='WRF', & stat=p3stat, & abort_on_err=.false., & - dowr=dowr) + dowr=dowr, nanew1_in=p3_cccn,iparam_in=p3_iparam, & + p3_ccn_on=p3_ccn_on,p3_merge_opt=p3_merge_opt,p3_qrcol_opt=p3_qrcol_opt,p3_hm_opt=p3_hm_opt, & + rssflg_in=rssflg, sssflg_in=sssflg, max_Ni_in=p3_nimax, & + cat_init_new_in=p3_cat_init_new, & + log_nislf_in=log_nislf, & + log_iceice_interaction_in=log_iceice_interaction, & + catdest_contact_n2_in=p3_catdest_contact_n2,catdest_contact_n3_in=p3_catdest_contact_n3, & + catdest_contact_n4_in=p3_catdest_contact_n4,catdest_rainimm_n2_in=p3_catdest_rainimm_n2, & + catdest_rainimm_n3_in=p3_catdest_rainimm_n3,catdest_rainimm_n4_in=p3_catdest_rainimm_n4, & + catdest_rimesplinter_n2_in=p3_catdest_rimesplinter_n2, & + catdest_rimesplinter_n3_in=p3_catdest_rimesplinter_n3, & + catdest_rimesplinter_n4_in=p3_catdest_rimesplinter_n4,catdest_depnuc_n2_in=p3_catdest_depnuc_n2, & + catdest_depnuc_n3_in=p3_catdest_depnuc_n3,catdest_depnuc_n4_in=p3_catdest_depnuc_n4, & + catdest_homocloud_n2_in=p3_catdest_homocloud_n2,catdest_homocloud_n3_in=p3_catdest_homocloud_n3, & + catdest_homocloud_n4_in=p3_catdest_homocloud_n4,catdest_homorain_n2_in=p3_catdest_homorain_n2, & + catdest_homorain_n3_in=p3_catdest_homorain_n3,catdest_homorain_n4_in=p3_catdest_homorain_n4 ) elseif( ptype.eq.53 )then call p3_init(lookup_file_dir='.', & nCat=1, & @@ -4079,7 +4317,22 @@ subroutine param(dt,dtlast,stattim,taptim,rsttim,radtim,prcltim, & model='WRF', & stat=p3stat, & abort_on_err=.false., & - dowr=dowr) + dowr=dowr, nanew1_in=p3_cccn,iparam_in=p3_iparam, & + p3_ccn_on=p3_ccn_on,p3_merge_opt=p3_merge_opt,p3_qrcol_opt=p3_qrcol_opt,p3_hm_opt=p3_hm_opt, & + rssflg_in=rssflg, sssflg_in=sssflg, max_Ni_in=p3_nimax, & + cat_init_new_in=p3_cat_init_new, & + log_nislf_in=log_nislf, & + log_iceice_interaction_in=log_iceice_interaction, & + catdest_contact_n2_in=p3_catdest_contact_n2,catdest_contact_n3_in=p3_catdest_contact_n3, & + catdest_contact_n4_in=p3_catdest_contact_n4,catdest_rainimm_n2_in=p3_catdest_rainimm_n2, & + catdest_rainimm_n3_in=p3_catdest_rainimm_n3,catdest_rainimm_n4_in=p3_catdest_rainimm_n4, & + catdest_rimesplinter_n2_in=p3_catdest_rimesplinter_n2, & + catdest_rimesplinter_n3_in=p3_catdest_rimesplinter_n3, & + catdest_rimesplinter_n4_in=p3_catdest_rimesplinter_n4,catdest_depnuc_n2_in=p3_catdest_depnuc_n2, & + catdest_depnuc_n3_in=p3_catdest_depnuc_n3,catdest_depnuc_n4_in=p3_catdest_depnuc_n4, & + catdest_homocloud_n2_in=p3_catdest_homocloud_n2,catdest_homocloud_n3_in=p3_catdest_homocloud_n3, & + catdest_homocloud_n4_in=p3_catdest_homocloud_n4,catdest_homorain_n2_in=p3_catdest_homorain_n2, & + catdest_homorain_n3_in=p3_catdest_homorain_n3,catdest_homorain_n4_in=p3_catdest_homorain_n4 ) elseif( ptype.eq.54 )then call p3_init(lookup_file_dir='.', & nCat=2, & @@ -4088,7 +4341,70 @@ subroutine param(dt,dtlast,stattim,taptim,rsttim,radtim,prcltim, & model='WRF', & stat=p3stat, & abort_on_err=.false., & - dowr=dowr) + dowr=dowr, nanew1_in=p3_cccn,iparam_in=p3_iparam, & + p3_ccn_on=p3_ccn_on,p3_merge_opt=p3_merge_opt,p3_qrcol_opt=p3_qrcol_opt,p3_hm_opt=p3_hm_opt, & + rssflg_in=rssflg, sssflg_in=sssflg, max_Ni_in=p3_nimax, & + cat_init_new_in=p3_cat_init_new, & + log_nislf_in=log_nislf, & + log_iceice_interaction_in=log_iceice_interaction, & + catdest_contact_n2_in=p3_catdest_contact_n2,catdest_contact_n3_in=p3_catdest_contact_n3, & + catdest_contact_n4_in=p3_catdest_contact_n4,catdest_rainimm_n2_in=p3_catdest_rainimm_n2, & + catdest_rainimm_n3_in=p3_catdest_rainimm_n3,catdest_rainimm_n4_in=p3_catdest_rainimm_n4, & + catdest_rimesplinter_n2_in=p3_catdest_rimesplinter_n2, & + catdest_rimesplinter_n3_in=p3_catdest_rimesplinter_n3, & + catdest_rimesplinter_n4_in=p3_catdest_rimesplinter_n4,catdest_depnuc_n2_in=p3_catdest_depnuc_n2, & + catdest_depnuc_n3_in=p3_catdest_depnuc_n3,catdest_depnuc_n4_in=p3_catdest_depnuc_n4, & + catdest_homocloud_n2_in=p3_catdest_homocloud_n2,catdest_homocloud_n3_in=p3_catdest_homocloud_n3, & + catdest_homocloud_n4_in=p3_catdest_homocloud_n4,catdest_homorain_n2_in=p3_catdest_homorain_n2, & + catdest_homorain_n3_in=p3_catdest_homorain_n3,catdest_homorain_n4_in=p3_catdest_homorain_n4 ) + elseif( ptype.eq.56 )then + call p3_init(lookup_file_dir='.', & + nCat=3, & + trplMomI=.true., & + liqFrac=.false., & + model='WRF', & + stat=p3stat, & + abort_on_err=.false., & + dowr=dowr, nanew1_in=p3_cccn,iparam_in=p3_iparam, & + p3_ccn_on=p3_ccn_on,p3_merge_opt=p3_merge_opt,p3_qrcol_opt=p3_qrcol_opt,p3_hm_opt=p3_hm_opt, & + rssflg_in=rssflg, sssflg_in=sssflg, max_Ni_in=p3_nimax, & + cat_init_new_in=p3_cat_init_new, & + log_nislf_in=log_nislf, & + log_iceice_interaction_in=log_iceice_interaction, & + catdest_contact_n2_in=p3_catdest_contact_n2,catdest_contact_n3_in=p3_catdest_contact_n3, & + catdest_contact_n4_in=p3_catdest_contact_n4,catdest_rainimm_n2_in=p3_catdest_rainimm_n2, & + catdest_rainimm_n3_in=p3_catdest_rainimm_n3,catdest_rainimm_n4_in=p3_catdest_rainimm_n4, & + catdest_rimesplinter_n2_in=p3_catdest_rimesplinter_n2, & + catdest_rimesplinter_n3_in=p3_catdest_rimesplinter_n3, & + catdest_rimesplinter_n4_in=p3_catdest_rimesplinter_n4,catdest_depnuc_n2_in=p3_catdest_depnuc_n2, & + catdest_depnuc_n3_in=p3_catdest_depnuc_n3,catdest_depnuc_n4_in=p3_catdest_depnuc_n4, & + catdest_homocloud_n2_in=p3_catdest_homocloud_n2,catdest_homocloud_n3_in=p3_catdest_homocloud_n3, & + catdest_homocloud_n4_in=p3_catdest_homocloud_n4,catdest_homorain_n2_in=p3_catdest_homorain_n2, & + catdest_homorain_n3_in=p3_catdest_homorain_n3,catdest_homorain_n4_in=p3_catdest_homorain_n4 ) + elseif( ptype.eq.57 )then + call p3_init(lookup_file_dir='.', & + nCat=4, & + trplMomI=.true., & + liqFrac=.false., & + model='WRF', & + stat=p3stat, & + abort_on_err=.false., & + dowr=dowr, nanew1_in=p3_cccn,iparam_in=p3_iparam, & + p3_ccn_on=p3_ccn_on,p3_merge_opt=p3_merge_opt,p3_qrcol_opt=p3_qrcol_opt,p3_hm_opt=p3_hm_opt, & + rssflg_in=rssflg, sssflg_in=sssflg, max_Ni_in=p3_nimax, & + cat_init_new_in=p3_cat_init_new, & + log_nislf_in=log_nislf, & + log_iceice_interaction_in=log_iceice_interaction, & + catdest_contact_n2_in=p3_catdest_contact_n2,catdest_contact_n3_in=p3_catdest_contact_n3, & + catdest_contact_n4_in=p3_catdest_contact_n4,catdest_rainimm_n2_in=p3_catdest_rainimm_n2, & + catdest_rainimm_n3_in=p3_catdest_rainimm_n3,catdest_rainimm_n4_in=p3_catdest_rainimm_n4, & + catdest_rimesplinter_n2_in=p3_catdest_rimesplinter_n2, & + catdest_rimesplinter_n3_in=p3_catdest_rimesplinter_n3, & + catdest_rimesplinter_n4_in=p3_catdest_rimesplinter_n4,catdest_depnuc_n2_in=p3_catdest_depnuc_n2, & + catdest_depnuc_n3_in=p3_catdest_depnuc_n3,catdest_depnuc_n4_in=p3_catdest_depnuc_n4, & + catdest_homocloud_n2_in=p3_catdest_homocloud_n2,catdest_homocloud_n3_in=p3_catdest_homocloud_n3, & + catdest_homocloud_n4_in=p3_catdest_homocloud_n4,catdest_homorain_n2_in=p3_catdest_homorain_n2, & + catdest_homorain_n3_in=p3_catdest_homorain_n3,catdest_homorain_n4_in=p3_catdest_homorain_n4 ) elseif( ptype.eq.60 )then call p3_init(lookup_file_dir='.', & nCat=1, & @@ -4097,7 +4413,22 @@ subroutine param(dt,dtlast,stattim,taptim,rsttim,radtim,prcltim, & model='WRF', & stat=p3stat, & abort_on_err=.false., & - dowr=dowr) + dowr=dowr, nanew1_in=p3_cccn,iparam_in=p3_iparam, & + p3_ccn_on=p3_ccn_on,p3_merge_opt=p3_merge_opt,p3_qrcol_opt=p3_qrcol_opt,p3_hm_opt=p3_hm_opt, & + rssflg_in=rssflg, sssflg_in=sssflg, max_Ni_in=p3_nimax, & + cat_init_new_in=p3_cat_init_new, & + log_nislf_in=log_nislf, & + log_iceice_interaction_in=log_iceice_interaction, & + catdest_contact_n2_in=p3_catdest_contact_n2,catdest_contact_n3_in=p3_catdest_contact_n3, & + catdest_contact_n4_in=p3_catdest_contact_n4,catdest_rainimm_n2_in=p3_catdest_rainimm_n2, & + catdest_rainimm_n3_in=p3_catdest_rainimm_n3,catdest_rainimm_n4_in=p3_catdest_rainimm_n4, & + catdest_rimesplinter_n2_in=p3_catdest_rimesplinter_n2, & + catdest_rimesplinter_n3_in=p3_catdest_rimesplinter_n3, & + catdest_rimesplinter_n4_in=p3_catdest_rimesplinter_n4,catdest_depnuc_n2_in=p3_catdest_depnuc_n2, & + catdest_depnuc_n3_in=p3_catdest_depnuc_n3,catdest_depnuc_n4_in=p3_catdest_depnuc_n4, & + catdest_homocloud_n2_in=p3_catdest_homocloud_n2,catdest_homocloud_n3_in=p3_catdest_homocloud_n3, & + catdest_homocloud_n4_in=p3_catdest_homocloud_n4,catdest_homorain_n2_in=p3_catdest_homorain_n2, & + catdest_homorain_n3_in=p3_catdest_homorain_n3,catdest_homorain_n4_in=p3_catdest_homorain_n4 ) elseif( ptype.eq.61 )then call p3_init(lookup_file_dir='.', & nCat=2, & @@ -4106,7 +4437,22 @@ subroutine param(dt,dtlast,stattim,taptim,rsttim,radtim,prcltim, & model='WRF', & stat=p3stat, & abort_on_err=.false., & - dowr=dowr) + dowr=dowr, nanew1_in=p3_cccn,iparam_in=p3_iparam, & + p3_ccn_on=p3_ccn_on,p3_merge_opt=p3_merge_opt,p3_qrcol_opt=p3_qrcol_opt,p3_hm_opt=p3_hm_opt, & + rssflg_in=rssflg, sssflg_in=sssflg, max_Ni_in=p3_nimax, & + cat_init_new_in=p3_cat_init_new, & + log_nislf_in=log_nislf, & + log_iceice_interaction_in=log_iceice_interaction, & + catdest_contact_n2_in=p3_catdest_contact_n2,catdest_contact_n3_in=p3_catdest_contact_n3, & + catdest_contact_n4_in=p3_catdest_contact_n4,catdest_rainimm_n2_in=p3_catdest_rainimm_n2, & + catdest_rainimm_n3_in=p3_catdest_rainimm_n3,catdest_rainimm_n4_in=p3_catdest_rainimm_n4, & + catdest_rimesplinter_n2_in=p3_catdest_rimesplinter_n2, & + catdest_rimesplinter_n3_in=p3_catdest_rimesplinter_n3, & + catdest_rimesplinter_n4_in=p3_catdest_rimesplinter_n4,catdest_depnuc_n2_in=p3_catdest_depnuc_n2, & + catdest_depnuc_n3_in=p3_catdest_depnuc_n3,catdest_depnuc_n4_in=p3_catdest_depnuc_n4, & + catdest_homocloud_n2_in=p3_catdest_homocloud_n2,catdest_homocloud_n3_in=p3_catdest_homocloud_n3, & + catdest_homocloud_n4_in=p3_catdest_homocloud_n4,catdest_homorain_n2_in=p3_catdest_homorain_n2, & + catdest_homorain_n3_in=p3_catdest_homorain_n3,catdest_homorain_n4_in=p3_catdest_homorain_n4 ) elseif( ptype.eq.62 )then call p3_init(lookup_file_dir='.', & nCat=3, & @@ -4115,7 +4461,22 @@ subroutine param(dt,dtlast,stattim,taptim,rsttim,radtim,prcltim, & model='WRF', & stat=p3stat, & abort_on_err=.false., & - dowr=dowr) + dowr=dowr, nanew1_in=p3_cccn,iparam_in=p3_iparam, & + p3_ccn_on=p3_ccn_on,p3_merge_opt=p3_merge_opt,p3_qrcol_opt=p3_qrcol_opt,p3_hm_opt=p3_hm_opt, & + rssflg_in=rssflg, sssflg_in=sssflg, max_Ni_in=p3_nimax, & + cat_init_new_in=p3_cat_init_new, & + log_nislf_in=log_nislf, & + log_iceice_interaction_in=log_iceice_interaction, & + catdest_contact_n2_in=p3_catdest_contact_n2,catdest_contact_n3_in=p3_catdest_contact_n3, & + catdest_contact_n4_in=p3_catdest_contact_n4,catdest_rainimm_n2_in=p3_catdest_rainimm_n2, & + catdest_rainimm_n3_in=p3_catdest_rainimm_n3,catdest_rainimm_n4_in=p3_catdest_rainimm_n4, & + catdest_rimesplinter_n2_in=p3_catdest_rimesplinter_n2, & + catdest_rimesplinter_n3_in=p3_catdest_rimesplinter_n3, & + catdest_rimesplinter_n4_in=p3_catdest_rimesplinter_n4,catdest_depnuc_n2_in=p3_catdest_depnuc_n2, & + catdest_depnuc_n3_in=p3_catdest_depnuc_n3,catdest_depnuc_n4_in=p3_catdest_depnuc_n4, & + catdest_homocloud_n2_in=p3_catdest_homocloud_n2,catdest_homocloud_n3_in=p3_catdest_homocloud_n3, & + catdest_homocloud_n4_in=p3_catdest_homocloud_n4,catdest_homorain_n2_in=p3_catdest_homorain_n2, & + catdest_homorain_n3_in=p3_catdest_homorain_n3,catdest_homorain_n4_in=p3_catdest_homorain_n4 ) elseif( ptype.eq.63 )then call p3_init(lookup_file_dir='.', & nCat=4, & @@ -4124,12 +4485,170 @@ subroutine param(dt,dtlast,stattim,taptim,rsttim,radtim,prcltim, & model='WRF', & stat=p3stat, & abort_on_err=.false., & - dowr=dowr) + dowr=dowr, nanew1_in=p3_cccn,iparam_in=p3_iparam, & + p3_ccn_on=p3_ccn_on,p3_merge_opt=p3_merge_opt,p3_qrcol_opt=p3_qrcol_opt,p3_hm_opt=p3_hm_opt, & + rssflg_in=rssflg, sssflg_in=sssflg, max_Ni_in=p3_nimax, & + cat_init_new_in=p3_cat_init_new, & + log_nislf_in=log_nislf, & + log_iceice_interaction_in=log_iceice_interaction, & + catdest_contact_n2_in=p3_catdest_contact_n2,catdest_contact_n3_in=p3_catdest_contact_n3, & + catdest_contact_n4_in=p3_catdest_contact_n4,catdest_rainimm_n2_in=p3_catdest_rainimm_n2, & + catdest_rainimm_n3_in=p3_catdest_rainimm_n3,catdest_rainimm_n4_in=p3_catdest_rainimm_n4, & + catdest_rimesplinter_n2_in=p3_catdest_rimesplinter_n2, & + catdest_rimesplinter_n3_in=p3_catdest_rimesplinter_n3, & + catdest_rimesplinter_n4_in=p3_catdest_rimesplinter_n4,catdest_depnuc_n2_in=p3_catdest_depnuc_n2, & + catdest_depnuc_n3_in=p3_catdest_depnuc_n3,catdest_depnuc_n4_in=p3_catdest_depnuc_n4, & + catdest_homocloud_n2_in=p3_catdest_homocloud_n2,catdest_homocloud_n3_in=p3_catdest_homocloud_n3, & + catdest_homocloud_n4_in=p3_catdest_homocloud_n4,catdest_homorain_n2_in=p3_catdest_homorain_n2, & + catdest_homorain_n3_in=p3_catdest_homorain_n3,catdest_homorain_n4_in=p3_catdest_homorain_n4 ) + elseif( ptype.eq.64 )then + call p3_init(lookup_file_dir='.', & + nCat=5, & + trplMomI=.true., & + liqFrac=.false., & + model='WRF', & + stat=p3stat, & + abort_on_err=.false., & + dowr=dowr, nanew1_in=p3_cccn,iparam_in=p3_iparam, & + p3_ccn_on=p3_ccn_on,p3_merge_opt=p3_merge_opt,p3_qrcol_opt=p3_qrcol_opt,p3_hm_opt=p3_hm_opt, & + rssflg_in=rssflg, sssflg_in=sssflg, max_Ni_in=p3_nimax, & + cat_init_new_in=p3_cat_init_new, & + log_nislf_in=log_nislf, & + log_iceice_interaction_in=log_iceice_interaction, & + catdest_contact_n2_in=p3_catdest_contact_n2,catdest_contact_n3_in=p3_catdest_contact_n3, & + catdest_contact_n4_in=p3_catdest_contact_n4,catdest_rainimm_n2_in=p3_catdest_rainimm_n2, & + catdest_rainimm_n3_in=p3_catdest_rainimm_n3,catdest_rainimm_n4_in=p3_catdest_rainimm_n4, & + catdest_rimesplinter_n2_in=p3_catdest_rimesplinter_n2, & + catdest_rimesplinter_n3_in=p3_catdest_rimesplinter_n3, & + catdest_rimesplinter_n4_in=p3_catdest_rimesplinter_n4,catdest_depnuc_n2_in=p3_catdest_depnuc_n2, & + catdest_depnuc_n3_in=p3_catdest_depnuc_n3,catdest_depnuc_n4_in=p3_catdest_depnuc_n4, & + catdest_homocloud_n2_in=p3_catdest_homocloud_n2,catdest_homocloud_n3_in=p3_catdest_homocloud_n3, & + catdest_homocloud_n4_in=p3_catdest_homocloud_n4,catdest_homorain_n2_in=p3_catdest_homorain_n2, & + catdest_homorain_n3_in=p3_catdest_homorain_n3,catdest_homorain_n4_in=p3_catdest_homorain_n4, & + catdest_contact_n5_in=p3_catdest_contact_n5,catdest_contact_n6_in=p3_catdest_contact_n6, & + catdest_rainimm_n5_in=p3_catdest_rainimm_n5,catdest_rainimm_n6_in=p3_catdest_rainimm_n6, & + catdest_rimesplinter_n5_in=p3_catdest_rimesplinter_n5, & + catdest_rimesplinter_n6_in=p3_catdest_rimesplinter_n6, & + catdest_depnuc_n5_in=p3_catdest_depnuc_n5,catdest_depnuc_n6_in=p3_catdest_depnuc_n6, & + catdest_homocloud_n5_in=p3_catdest_homocloud_n5,catdest_homocloud_n6_in=p3_catdest_homocloud_n6, & + catdest_homorain_n5_in=p3_catdest_homorain_n5,catdest_homorain_n6_in=p3_catdest_homorain_n6 ) + elseif( ptype.eq.65 )then + call p3_init(lookup_file_dir='.', & + nCat=6, & + trplMomI=.true., & + liqFrac=.false., & + model='WRF', & + stat=p3stat, & + abort_on_err=.false., & + dowr=dowr, nanew1_in=p3_cccn,iparam_in=p3_iparam, & + p3_ccn_on=p3_ccn_on,p3_merge_opt=p3_merge_opt,p3_qrcol_opt=p3_qrcol_opt,p3_hm_opt=p3_hm_opt, & + rssflg_in=rssflg, sssflg_in=sssflg, max_Ni_in=p3_nimax, & + cat_init_new_in=p3_cat_init_new, & + log_nislf_in=log_nislf, & + log_iceice_interaction_in=log_iceice_interaction, & + catdest_contact_n2_in=p3_catdest_contact_n2,catdest_contact_n3_in=p3_catdest_contact_n3, & + catdest_contact_n4_in=p3_catdest_contact_n4,catdest_rainimm_n2_in=p3_catdest_rainimm_n2, & + catdest_rainimm_n3_in=p3_catdest_rainimm_n3,catdest_rainimm_n4_in=p3_catdest_rainimm_n4, & + catdest_rimesplinter_n2_in=p3_catdest_rimesplinter_n2, & + catdest_rimesplinter_n3_in=p3_catdest_rimesplinter_n3, & + catdest_rimesplinter_n4_in=p3_catdest_rimesplinter_n4,catdest_depnuc_n2_in=p3_catdest_depnuc_n2, & + catdest_depnuc_n3_in=p3_catdest_depnuc_n3,catdest_depnuc_n4_in=p3_catdest_depnuc_n4, & + catdest_homocloud_n2_in=p3_catdest_homocloud_n2,catdest_homocloud_n3_in=p3_catdest_homocloud_n3, & + catdest_homocloud_n4_in=p3_catdest_homocloud_n4,catdest_homorain_n2_in=p3_catdest_homorain_n2, & + catdest_homorain_n3_in=p3_catdest_homorain_n3,catdest_homorain_n4_in=p3_catdest_homorain_n4, & + catdest_contact_n5_in=p3_catdest_contact_n5,catdest_contact_n6_in=p3_catdest_contact_n6, & + catdest_rainimm_n5_in=p3_catdest_rainimm_n5,catdest_rainimm_n6_in=p3_catdest_rainimm_n6, & + catdest_rimesplinter_n5_in=p3_catdest_rimesplinter_n5, & + catdest_rimesplinter_n6_in=p3_catdest_rimesplinter_n6, & + catdest_depnuc_n5_in=p3_catdest_depnuc_n5,catdest_depnuc_n6_in=p3_catdest_depnuc_n6, & + catdest_homocloud_n5_in=p3_catdest_homocloud_n5,catdest_homocloud_n6_in=p3_catdest_homocloud_n6, & + catdest_homorain_n5_in=p3_catdest_homorain_n5,catdest_homorain_n6_in=p3_catdest_homorain_n6 ) + elseif( ptype.eq.66 )then + call p3_init(lookup_file_dir='.', & + nCat=5, & + trplMomI=.true., & + liqFrac=.true., & + model='WRF', & + stat=p3stat, & + abort_on_err=.false., & + dowr=dowr, nanew1_in=p3_cccn,iparam_in=p3_iparam, & + p3_ccn_on=p3_ccn_on,p3_merge_opt=p3_merge_opt,p3_qrcol_opt=p3_qrcol_opt,p3_hm_opt=p3_hm_opt, & + rssflg_in=rssflg, sssflg_in=sssflg, max_Ni_in=p3_nimax, & + cat_init_new_in=p3_cat_init_new, & + log_nislf_in=log_nislf, & + log_iceice_interaction_in=log_iceice_interaction, & + catdest_contact_n2_in=p3_catdest_contact_n2,catdest_contact_n3_in=p3_catdest_contact_n3, & + catdest_contact_n4_in=p3_catdest_contact_n4,catdest_rainimm_n2_in=p3_catdest_rainimm_n2, & + catdest_rainimm_n3_in=p3_catdest_rainimm_n3,catdest_rainimm_n4_in=p3_catdest_rainimm_n4, & + catdest_rimesplinter_n2_in=p3_catdest_rimesplinter_n2, & + catdest_rimesplinter_n3_in=p3_catdest_rimesplinter_n3, & + catdest_rimesplinter_n4_in=p3_catdest_rimesplinter_n4,catdest_depnuc_n2_in=p3_catdest_depnuc_n2, & + catdest_depnuc_n3_in=p3_catdest_depnuc_n3,catdest_depnuc_n4_in=p3_catdest_depnuc_n4, & + catdest_homocloud_n2_in=p3_catdest_homocloud_n2,catdest_homocloud_n3_in=p3_catdest_homocloud_n3, & + catdest_homocloud_n4_in=p3_catdest_homocloud_n4,catdest_homorain_n2_in=p3_catdest_homorain_n2, & + catdest_homorain_n3_in=p3_catdest_homorain_n3,catdest_homorain_n4_in=p3_catdest_homorain_n4, & + catdest_contact_n5_in=p3_catdest_contact_n5,catdest_contact_n6_in=p3_catdest_contact_n6, & + catdest_rainimm_n5_in=p3_catdest_rainimm_n5,catdest_rainimm_n6_in=p3_catdest_rainimm_n6, & + catdest_rimesplinter_n5_in=p3_catdest_rimesplinter_n5, & + catdest_rimesplinter_n6_in=p3_catdest_rimesplinter_n6, & + catdest_depnuc_n5_in=p3_catdest_depnuc_n5,catdest_depnuc_n6_in=p3_catdest_depnuc_n6, & + catdest_homocloud_n5_in=p3_catdest_homocloud_n5,catdest_homocloud_n6_in=p3_catdest_homocloud_n6, & + catdest_homorain_n5_in=p3_catdest_homorain_n5,catdest_homorain_n6_in=p3_catdest_homorain_n6 ) + elseif( ptype.eq.67 )then + call p3_init(lookup_file_dir='.', & + nCat=6, & + trplMomI=.true., & + liqFrac=.true., & + model='WRF', & + stat=p3stat, & + abort_on_err=.false., & + dowr=dowr, nanew1_in=p3_cccn,iparam_in=p3_iparam, & + p3_ccn_on=p3_ccn_on,p3_merge_opt=p3_merge_opt,p3_qrcol_opt=p3_qrcol_opt,p3_hm_opt=p3_hm_opt, & + rssflg_in=rssflg, sssflg_in=sssflg, max_Ni_in=p3_nimax, & + cat_init_new_in=p3_cat_init_new, & + log_nislf_in=log_nislf, & + log_iceice_interaction_in=log_iceice_interaction, & + catdest_contact_n2_in=p3_catdest_contact_n2,catdest_contact_n3_in=p3_catdest_contact_n3, & + catdest_contact_n4_in=p3_catdest_contact_n4,catdest_rainimm_n2_in=p3_catdest_rainimm_n2, & + catdest_rainimm_n3_in=p3_catdest_rainimm_n3,catdest_rainimm_n4_in=p3_catdest_rainimm_n4, & + catdest_rimesplinter_n2_in=p3_catdest_rimesplinter_n2, & + catdest_rimesplinter_n3_in=p3_catdest_rimesplinter_n3, & + catdest_rimesplinter_n4_in=p3_catdest_rimesplinter_n4,catdest_depnuc_n2_in=p3_catdest_depnuc_n2, & + catdest_depnuc_n3_in=p3_catdest_depnuc_n3,catdest_depnuc_n4_in=p3_catdest_depnuc_n4, & + catdest_homocloud_n2_in=p3_catdest_homocloud_n2,catdest_homocloud_n3_in=p3_catdest_homocloud_n3, & + catdest_homocloud_n4_in=p3_catdest_homocloud_n4,catdest_homorain_n2_in=p3_catdest_homorain_n2, & + catdest_homorain_n3_in=p3_catdest_homorain_n3,catdest_homorain_n4_in=p3_catdest_homorain_n4, & + catdest_contact_n5_in=p3_catdest_contact_n5,catdest_contact_n6_in=p3_catdest_contact_n6, & + catdest_rainimm_n5_in=p3_catdest_rainimm_n5,catdest_rainimm_n6_in=p3_catdest_rainimm_n6, & + catdest_rimesplinter_n5_in=p3_catdest_rimesplinter_n5, & + catdest_rimesplinter_n6_in=p3_catdest_rimesplinter_n6, & + catdest_depnuc_n5_in=p3_catdest_depnuc_n5,catdest_depnuc_n6_in=p3_catdest_depnuc_n6, & + catdest_homocloud_n5_in=p3_catdest_homocloud_n5,catdest_homocloud_n6_in=p3_catdest_homocloud_n6, & + catdest_homorain_n5_in=p3_catdest_homorain_n5,catdest_homorain_n6_in=p3_catdest_homorain_n6 ) endif if(dowr) write(outfile,*) 'Returned from P3_INIT' if(dowr) write(outfile,*) + ! Phase-1/2 checksum instrumentation (category-swap divergence diagnosis): + log_chksum = p3_chksum + log_chkpts = p3_chkpts + ! limiter-firing log (grid-point noise diagnosis) + log_limlog = p3_limlog + limlog_ratmin = p3_limlog_rat + ! TEMPORARY -- remove with p3_nifloor + log_nifloor = p3_nifloor + log_nrfloor = p3_nrfloor + ! targeted single-point dump + dbgpt_i = p3_dbg_i + dbgpt_j = p3_dbg_j + dbgpt_k = p3_dbg_k + dbgpt_halo = p3_dbg_halo + chksum_myid = myid + ! global index = local index + offset (k is not decomposed): + chksum_i0 = myi1-1 + chksum_j0 = myj1-1 + if( p3stat.ne.0 )then print *,' there was an error in p3_init ' call stopcm1 @@ -4140,6 +4659,12 @@ subroutine param(dt,dtlast,stattim,taptim,rsttim,radtim,prcltim, & iice = 1 ! this scheme has ice microphysics idm = 1 ! this scheme has at least one double moment + ! ERM begin + ltmp = 0 + lccn = 0 + IF ( p3_ccn_on > 0 ) ltmp = 1 + ! ERM end + !cccccccccccccccccccccccccccccccccccccccccccccccccccc! IF( ptype.eq.50 )THEN @@ -4331,7 +4856,7 @@ subroutine param(dt,dtlast,stattim,taptim,rsttim,radtim,prcltim, & ELSEIF( ptype.eq.53 )THEN - numq = 10 ! there are 9 q variables + numq = 10+ltmp ! there are 10 q variables (11 with CCN added by ERM) nqv = 1 ! qv nql1 = 2 ! the first liquid variable @@ -4349,17 +4874,19 @@ subroutine param(dt,dtlast,stattim,taptim,rsttim,radtim,prcltim, & cloudvar(8) = .false. cloudvar(9) = .false. cloudvar(10) = .false. + cloudvar(11) = .false. ! ERM qname(1) = 'qv ' qname(2) = 'qc ' qname(3) = 'qr ' qname(4) = 'qi1' qname(5) = 'ni1' - qname(6) = 'qnr' + qname(6) = 'qnr' ! ERM has these named just "nr", "nc". Does it matter? qname(7) = 'ri1' qname(8) = 'bi1' qname(9) = 'qnc' qname(10) = 'zi1' + qname(11) = 'ccn' ! ERM qunit(1) = 'kg/kg' qunit(2) = 'kg/kg' @@ -4371,6 +4898,12 @@ subroutine param(dt,dtlast,stattim,taptim,rsttim,radtim,prcltim, & qunit(8) = 'm^3 kg^-1' qunit(9) = '#/kg' qunit(10) = 'm(6) kg(-1)' + IF ( p3_ccn_on > 0 ) THEN ! Added by ERM + lccn = 11 + qunit(11) = '#/kg' + ELSE + qunit(11) = 'none' + ENDIF ! likely maximum value (order-of-magnitude) ! (needed for monotonic advection schemes) @@ -4384,6 +4917,7 @@ subroutine param(dt,dtlast,stattim,taptim,rsttim,radtim,prcltim, & qmag(8) = 1.0e-5 qmag(9) = 1.0e8 qmag(10) = 1.0e-3 + qmag(11) = 1.0e8 ! Added by ERM ! for p3 arrays: !--v00: @@ -4391,8 +4925,8 @@ subroutine param(dt,dtlast,stattim,taptim,rsttim,radtim,prcltim, & ! np3a = 29 ! for 3 + 2 (nout3d = 3, nout2d = 2) additional output variables ! np3o = 3 !-- - np3a = 24 ! 3-mom, no_liqfrac, 1-cat (incl. vmi_1, dmi_1, rhoi_1) - np3a = np3a + nout2d + nout3d + 1 !(1 for dhmax_x) + np3a = 24 + ltmp ! 3-mom, no_liqfrac, 1-cat (incl. vmi_1, dmi_1, rhoi_1) ltmp added by ERM + np3a = np3a + nout2d + nout3d + 1 + ltmp !(1 for dhmax_x) ! ltmp added by ERM np3o = 4 ! 1 x nCat; for vmi_(x), dmi_(x), rhoi_(x), dhmax_(x) np3a = np3a + 7 ! adding 7 additional 3d output fields @@ -4400,7 +4934,7 @@ subroutine param(dt,dtlast,stattim,taptim,rsttim,radtim,prcltim, & ELSEIF( ptype.eq.54 )THEN - numq = 15 ! there are 13 q variables + numq = 15 + ltmp ! there are 15 q variables (16 with CCN added by ERM) nqv = 1 ! qv nql1 = 2 ! the first liquid variable @@ -4423,6 +4957,7 @@ subroutine param(dt,dtlast,stattim,taptim,rsttim,radtim,prcltim, & cloudvar(13) = .false. cloudvar(14) = .false. cloudvar(15) = .false. + cloudvar(16) = .false. ! ERM qname( 1) = 'qv ' qname( 2) = 'qc ' @@ -4439,6 +4974,7 @@ subroutine param(dt,dtlast,stattim,taptim,rsttim,radtim,prcltim, & qname(13) = 'bi2' qname(14) = 'zi1' qname(15) = 'zi2' + qname(16) = 'ccn' ! ERM qunit( 1) = 'kg/kg' qunit( 2) = 'kg/kg' @@ -4455,6 +4991,14 @@ subroutine param(dt,dtlast,stattim,taptim,rsttim,radtim,prcltim, & qunit(13) = 'm^-3 kg^-1' qunit(14) = 'm^6/kg' qunit(15) = 'm^6/kg' + ! ERM begin + IF ( p3_ccn_on > 0 ) THEN + lccn = 16 + qunit(16) = '#/kg' + ELSE + qunit(16) = 'none' + ENDIF + ! ERM end ! likely maximum value (order-of-magnitude) ! (needed for monotonic advection schemes) @@ -4473,6 +5017,7 @@ subroutine param(dt,dtlast,stattim,taptim,rsttim,radtim,prcltim, & qmag(13) = 1.0e-5 qmag(14) = 1.0e-3 qmag(15) = 1.0e-3 + qmag(16) = 1.e8 ! ERM ! for p3 arrays: !--v00: @@ -4486,6 +5031,227 @@ subroutine param(dt,dtlast,stattim,taptim,rsttim,radtim,prcltim, & !cccccccccccccccccccccccccccccccccccccccccccccccccccc! + ELSEIF( ptype.eq.56 )THEN + + numq = 20 ! there are 20 q variables + + nqv = 1 ! qv + nql1 = 2 ! the first liquid variable + nql2 = 3 ! the last liquid variable + nqs1 = 4 ! the first solid variable + nqs2 = 6 ! the last solid variable + + cloudvar( 1) = .false. + cloudvar( 2) = .true. + cloudvar( 3) = .false. + cloudvar( 4) = .true. + cloudvar( 5) = .true. + cloudvar( 6) = .true. + cloudvar( 7) = .false. + cloudvar( 8) = .false. + cloudvar( 9) = .false. + cloudvar(10) = .false. + cloudvar(11) = .false. + cloudvar(12) = .false. + cloudvar(13) = .false. + cloudvar(14) = .false. + cloudvar(15) = .false. + cloudvar(16) = .false. + cloudvar(17) = .false. + cloudvar(18) = .false. + cloudvar(19) = .false. + cloudvar(20) = .false. + + qname( 1) = 'qv ' + qname( 2) = 'qc ' + qname( 3) = 'qr ' + qname( 4) = 'qi1' + qname( 5) = 'qi2' + qname( 6) = 'qi3' + qname( 7) = 'nc ' + qname( 8) = 'nr ' + qname( 9) = 'ni1' + qname(10) = 'ri1' + qname(11) = 'bi1' + qname(12) = 'ni2' + qname(13) = 'ri2' + qname(14) = 'bi2' + qname(15) = 'ni3' + qname(16) = 'ri3' + qname(17) = 'bi3' + qname(18) = 'zi1' + qname(19) = 'zi2' + qname(20) = 'zi3' + + qunit( 1) = 'kg/kg' + qunit( 2) = 'kg/kg' + qunit( 3) = 'kg/kg' + qunit( 4) = 'kg/kg' + qunit( 5) = 'kg/kg' + qunit( 6) = 'kg/kg' + qunit( 7) = '#/kg' + qunit( 8) = '#/kg' + qunit( 9) = '#/kg' + qunit(10) = 'kg/kg' + qunit(11) = 'm^-3 kg^-1' + qunit(12) = '#/kg' + qunit(13) = 'kg/kg' + qunit(14) = 'm^-3 kg^-1' + qunit(15) = '#/kg' + qunit(16) = 'kg/kg' + qunit(17) = 'm^-3 kg^-1' + qunit(18) = 'm^6/kg' + qunit(19) = 'm^6/kg' + qunit(20) = 'm^6/kg' + + ! likely maximum value (order-of-magnitude) + ! (needed for monotonic advection schemes) + qmag( 1) = 0.01 + qmag( 2) = 0.01 + qmag( 3) = 0.01 + qmag( 4) = 0.01 + qmag( 5) = 0.01 + qmag( 6) = 0.01 + qmag( 7) = 1.0e5 + qmag( 8) = 1.0e5 + qmag( 9) = 1.0e5 + qmag(10) = 0.01 + qmag(11) = 1.0e-5 + qmag(12) = 1.0e5 + qmag(13) = 0.01 + qmag(14) = 1.0e-5 + qmag(15) = 1.0e5 + qmag(16) = 0.01 + qmag(17) = 1.0e-5 + qmag(18) = 1.0e-3 + qmag(19) = 1.0e-3 + qmag(20) = 1.0e-3 + + ! for p3 arrays: + np3a = 40 ! 3-mom, no_liqfrac, 3-cat (no extra output) + np3a = np3a + nout2d + nout3d + 3 !(3 for dhmax_x) + np3o = 12 ! 3 x nCat; for vmi_(x), dmi_(x), rhoi_(x), dhmax_(x) + + ELSEIF( ptype.eq.57 )THEN + + numq = 25 ! there are 25 q variables + + nqv = 1 ! qv + nql1 = 2 ! the first liquid variable + nql2 = 3 ! the last liquid variable + nqs1 = 4 ! the first solid variable + nqs2 = 7 ! the last solid variable + + cloudvar( 1) = .false. + cloudvar( 2) = .true. + cloudvar( 3) = .false. + cloudvar( 4) = .true. + cloudvar( 5) = .true. + cloudvar( 6) = .true. + cloudvar( 7) = .true. + cloudvar( 8) = .false. + cloudvar( 9) = .false. + cloudvar(10) = .false. + cloudvar(11) = .false. + cloudvar(12) = .false. + cloudvar(13) = .false. + cloudvar(14) = .false. + cloudvar(15) = .false. + cloudvar(16) = .false. + cloudvar(17) = .false. + cloudvar(18) = .false. + cloudvar(19) = .false. + cloudvar(20) = .false. + cloudvar(21) = .false. + cloudvar(22) = .false. + cloudvar(23) = .false. + cloudvar(24) = .false. + cloudvar(25) = .false. + + qname( 1) = 'qv ' + qname( 2) = 'qc ' + qname( 3) = 'qr ' + qname( 4) = 'qi1' + qname( 5) = 'qi2' + qname( 6) = 'qi3' + qname( 7) = 'qi4' + qname( 8) = 'nc ' + qname( 9) = 'nr ' + qname(10) = 'ni1' + qname(11) = 'ri1' + qname(12) = 'bi1' + qname(13) = 'ni2' + qname(14) = 'ri2' + qname(15) = 'bi2' + qname(16) = 'ni3' + qname(17) = 'ri3' + qname(18) = 'bi3' + qname(19) = 'ni4' + qname(20) = 'ri4' + qname(21) = 'bi4' + qname(22) = 'zi1' + qname(23) = 'zi2' + qname(24) = 'zi3' + qname(25) = 'zi4' + + qunit( 1) = 'kg/kg' + qunit( 2) = 'kg/kg' + qunit( 3) = 'kg/kg' + qunit( 4) = 'kg/kg' + qunit( 5) = 'kg/kg' + qunit( 6) = 'kg/kg' + qunit( 7) = 'kg/kg' + qunit( 8) = '#/kg' + qunit( 9) = '#/kg' + qunit(10) = '#/kg' + qunit(11) = 'kg/kg' + qunit(12) = 'm^-3 kg^-1' + qunit(13) = '#/kg' + qunit(14) = 'kg/kg' + qunit(15) = 'm^-3 kg^-1' + qunit(16) = '#/kg' + qunit(17) = 'kg/kg' + qunit(18) = 'm^-3 kg^-1' + qunit(19) = '#/kg' + qunit(20) = 'kg/kg' + qunit(21) = 'm^-3 kg^-1' + qunit(22) = 'm^6/kg' + qunit(23) = 'm^6/kg' + qunit(24) = 'm^6/kg' + qunit(25) = 'm^6/kg' + + ! likely maximum value (order-of-magnitude) + ! (needed for monotonic advection schemes) + qmag( 1) = 0.01 + qmag( 2) = 0.01 + qmag( 3) = 0.01 + qmag( 4) = 0.01 + qmag( 5) = 0.01 + qmag( 6) = 0.01 + qmag( 7) = 0.01 + qmag( 8) = 1.0e5 + qmag( 9) = 1.0e5 + qmag(10) = 1.0e5 + qmag(11) = 0.01 + qmag(12) = 1.0e-5 + qmag(13) = 1.0e5 + qmag(14) = 0.01 + qmag(15) = 1.0e-5 + qmag(16) = 1.0e5 + qmag(17) = 0.01 + qmag(18) = 1.0e-5 + qmag(19) = 1.0e5 + qmag(20) = 0.01 + qmag(21) = 1.0e-5 + qmag(22) = 1.0e-3 + qmag(23) = 1.0e-3 + qmag(24) = 1.0e-3 + qmag(25) = 1.0e-3 + + ! for p3 arrays: + np3a = 48 ! 3-mom, no_liqfrac, 4-cat (no extra output) + np3a = np3a + nout2d + nout3d + 4 !(4 for dhmax_x) + np3o = 16 ! 4 x nCat; for vmi_(x), dmi_(x), rhoi_(x), dhmax_(x) ELSEIF( ptype.eq.60 )THEN @@ -4593,36 +5359,590 @@ subroutine param(dt,dtlast,stattim,taptim,rsttim,radtim,prcltim, & qname( 3) = 'qr ' qname( 4) = 'qi1' qname( 5) = 'qi2' - qname( 6) = 'nc ' - qname( 7) = 'nr ' - qname( 8) = 'ni1' - qname( 9) = 'ri1' - qname(10) = 'bi1' - qname(11) = 'ni2' - qname(12) = 'ri2' - qname(13) = 'bi2' - qname(14) = 'zi1' - qname(15) = 'li1' - qname(16) = 'zi2' - qname(17) = 'li2' + qname( 6) = 'nc ' + qname( 7) = 'nr ' + qname( 8) = 'ni1' + qname( 9) = 'ri1' + qname(10) = 'bi1' + qname(11) = 'ni2' + qname(12) = 'ri2' + qname(13) = 'bi2' + qname(14) = 'zi1' + qname(15) = 'li1' + qname(16) = 'zi2' + qname(17) = 'li2' + + qunit( 1) = 'kg/kg' + qunit( 2) = 'kg/kg' + qunit( 3) = 'kg/kg' + qunit( 4) = 'kg/kg' + qunit( 5) = 'kg/kg' + qunit( 6) = '#/kg' + qunit( 7) = '#/kg' + qunit( 8) = '#/kg' + qunit( 9) = 'kg/kg' + qunit(10) = 'm^-3 kg^-1' + qunit(11) = '#/kg' + qunit(12) = 'kg/kg' + qunit(13) = 'm^-3 kg^-1' + qunit(14) = 'm^6 kg^-1' + qunit(15) = 'kg/kg' + qunit(16) = 'm^6 kg^-1' + qunit(17) = 'kg/kg' + + ! likely maximum value (order-of-magnitude) + ! (needed for monotonic advection schemes) + qmag( 1) = 0.01 + qmag( 2) = 0.01 + qmag( 3) = 0.01 + qmag( 4) = 0.01 + qmag( 5) = 0.01 + qmag( 6) = 1.0e5 + qmag( 7) = 1.0e5 + qmag( 8) = 1.0e5 + qmag( 9) = 0.01 + qmag(10) = 1.0e-5 + qmag(11) = 1.0e5 + qmag(12) = 0.01 + qmag(13) = 1.0e-5 + qmag(14) = 1.0e-3 + qmag(15) = 0.01 + qmag(16) = 1.0e-3 + qmag(17) = 0.01 + + ! for p3 arrays: +!--v00: +!! np3a = 34 +! np3a = 39 ! for 3+2 additional output variables +! np3o = 6 +!-- + np3a = 34 ! 3-mom, liqfrac, 2-cat (no extra output) + np3a = np3a + nout2d + nout3d + 2 !(2 for dhmax_x) + np3o = 8 ! 2 x nCat; for vmi_(x), dmi_(x), rhoi_(x), dhmax_(x) + + !cccccccccccccccccccccccccccccccccccccccccccccccccccc! + + ELSEIF( ptype.eq.62 )THEN + + numq = 23 ! there are 23 q variables + + nqv = 1 ! qv + nql1 = 2 ! the first liquid variable + nql2 = 3 ! the last liquid variable + nqs1 = 4 ! the first solid variable + nqs2 = 6 ! the last solid variable + + cloudvar( 1) = .false. + cloudvar( 2) = .true. + cloudvar( 3) = .false. + cloudvar( 4) = .true. + cloudvar( 5) = .true. + cloudvar( 6) = .true. + cloudvar( 7) = .false. + cloudvar( 8) = .false. + cloudvar( 9) = .false. + cloudvar(10) = .false. + cloudvar(11) = .false. + cloudvar(12) = .false. + cloudvar(13) = .false. + cloudvar(14) = .false. + cloudvar(15) = .false. + cloudvar(16) = .false. + cloudvar(17) = .false. + cloudvar(18) = .false. + cloudvar(19) = .false. + cloudvar(20) = .false. + cloudvar(21) = .false. + cloudvar(22) = .false. + cloudvar(23) = .false. + + qname( 1) = 'qv ' + qname( 2) = 'qc ' + qname( 3) = 'qr ' + qname( 4) = 'qi1' + qname( 5) = 'qi2' + qname( 6) = 'qi3' + qname( 7) = 'nc ' + qname( 8) = 'nr ' + qname( 9) = 'ni1' + qname(10) = 'ri1' + qname(11) = 'bi1' + qname(12) = 'ni2' + qname(13) = 'ri2' + qname(14) = 'bi2' + qname(15) = 'zi1' + qname(16) = 'li1' + qname(17) = 'zi2' + qname(18) = 'li2' + qname(19) = 'ni3' + qname(20) = 'ri3' + qname(21) = 'bi3' + qname(22) = 'zi3' + qname(23) = 'li3' + + qunit( 1) = 'kg/kg' + qunit( 2) = 'kg/kg' + qunit( 3) = 'kg/kg' + qunit( 4) = 'kg/kg' + qunit( 5) = 'kg/kg' + qunit( 6) = 'kg/kg' + qunit( 7) = '#/kg' + qunit( 8) = '#/kg' + qunit( 9) = '#/kg' + qunit(10) = 'kg/kg' + qunit(11) = 'm^-3 kg^-1' + qunit(12) = '#/kg' + qunit(13) = 'kg/kg' + qunit(14) = 'm^-3 kg^-1' + qunit(15) = 'm^6 kg^-1' + qunit(16) = 'kg/kg' + qunit(17) = 'm^6 kg^-1' + qunit(18) = 'kg/kg' + qunit(19) = '#/kg' + qunit(20) = 'kg/kg' + qunit(21) = 'm^-3 kg^-1' + qunit(22) = 'm^6 kg^-1' + qunit(23) = 'kg/kg' + + ! likely maximum value (order-of-magnitude) + ! (needed for monotonic advection schemes) + qmag( 1) = 0.01 + qmag( 2) = 0.01 + qmag( 3) = 0.01 + qmag( 4) = 0.01 + qmag( 5) = 0.01 + qmag( 6) = 0.01 + qmag( 7) = 1.0e5 + qmag( 8) = 1.0e5 + qmag( 9) = 1.0e5 + qmag(10) = 0.01 + qmag(11) = 1.0e-5 + qmag(12) = 1.0e5 + qmag(13) = 0.01 + qmag(14) = 1.0e-5 + qmag(15) = 1.0e-3 + qmag(16) = 0.01 + qmag(17) = 1.0e-3 + qmag(18) = 0.01 + qmag(19) = 1.0e5 + qmag(20) = 0.01 + qmag(21) = 1.0e-5 + qmag(22) = 1.0e-3 + qmag(23) = 0.01 + + ! for p3 arrays: +!--v00: +!! np3a = 43 +! np3a = 48 ! for 3+2 additional output variables +! np3o = 9 +!-- + np3a = 43 ! 3-mom, liqfrac, 3-cat (no extra output) + np3a = np3a + nout2d + nout3d + 3 !(3 for dhmax_x) + np3o = 12 ! 3 x nCat; for vmi_(x), dmi_(x), rhoi_(x), dhmax_(x) + + !cccccccccccccccccccccccccccccccccccccccccccccccccccc! + + ELSEIF( ptype.eq.63 )THEN + + numq = 29 ! there are 29 q variables + + nqv = 1 ! qv + nql1 = 2 ! the first liquid variable + nql2 = 3 ! the last liquid variable + nqs1 = 4 ! the first solid variable + nqs2 = 7 ! the last solid variable + + cloudvar( 1) = .false. + cloudvar( 2) = .true. + cloudvar( 3) = .false. + cloudvar( 4) = .true. + cloudvar( 5) = .true. + cloudvar( 6) = .true. + cloudvar( 7) = .true. + cloudvar( 8) = .false. + cloudvar( 9) = .false. + cloudvar(10) = .false. + cloudvar(11) = .false. + cloudvar(12) = .false. + cloudvar(13) = .false. + cloudvar(14) = .false. + cloudvar(15) = .false. + cloudvar(16) = .false. + cloudvar(17) = .false. + cloudvar(18) = .false. + cloudvar(19) = .false. + cloudvar(20) = .false. + cloudvar(21) = .false. + cloudvar(22) = .false. + cloudvar(23) = .false. + cloudvar(24) = .false. + cloudvar(25) = .false. + cloudvar(26) = .false. + cloudvar(27) = .false. + cloudvar(28) = .false. + cloudvar(29) = .false. + + qname( 1) = 'qv ' + qname( 2) = 'qc ' + qname( 3) = 'qr ' + qname( 4) = 'qi1' + qname( 5) = 'qi2' + qname( 6) = 'qi3' + qname( 7) = 'qi4' + qname( 8) = 'nc ' + qname( 9) = 'nr ' + qname(10) = 'ni1' + qname(11) = 'ri1' + qname(12) = 'bi1' + qname(13) = 'ni2' + qname(14) = 'ri2' + qname(15) = 'bi2' + qname(16) = 'zi1' + qname(17) = 'li1' + qname(18) = 'zi2' + qname(19) = 'li2' + qname(20) = 'ni3' + qname(21) = 'ri3' + qname(22) = 'bi3' + qname(23) = 'zi3' + qname(24) = 'li3' + qname(25) = 'ni4' + qname(26) = 'ri4' + qname(27) = 'bi4' + qname(28) = 'zi4' + qname(29) = 'li4' + + + qunit( 1) = 'kg/kg' + qunit( 2) = 'kg/kg' + qunit( 3) = 'kg/kg' + qunit( 4) = 'kg/kg' + qunit( 5) = 'kg/kg' + qunit( 6) = 'kg/kg' + qunit( 7) = 'kg/kg' + qunit( 8) = '#/kg' + qunit( 9) = '#/kg' + qunit(10) = '#/kg' + qunit(11) = 'kg/kg' + qunit(12) = 'm^-3 kg^-1' + qunit(13) = '#/kg' + qunit(14) = 'kg/kg' + qunit(15) = 'm^-3 kg^-1' + qunit(16) = 'm^6 kg^-1' + qunit(17) = 'kg/kg' + qunit(18) = 'm^6 kg^-1' + qunit(19) = 'kg/kg' + qunit(20) = '#/kg' + qunit(21) = 'kg/kg' + qunit(22) = 'm^-3 kg^-1' + qunit(23) = 'm^6 kg^-1' + qunit(24) = 'kg/kg' + qunit(25) = '#/kg' + qunit(26) = 'kg/kg' + qunit(27) = 'm^-3 kg^-1' + qunit(28) = 'm^6 kg^-1' + qunit(29) = 'kg/kg' + + ! likely maximum value (order-of-magnitude) + ! (needed for monotonic advection schemes) + qmag( 1) = 0.01 + qmag( 2) = 0.01 + qmag( 3) = 0.01 + qmag( 4) = 0.01 + qmag( 5) = 0.01 + qmag( 6) = 0.01 + qmag( 7) = 0.01 + qmag( 8) = 1.0e5 + qmag( 9) = 1.0e5 + qmag(10) = 1.0e5 + qmag(11) = 0.01 + qmag(12) = 1.0e-5 + qmag(13) = 1.0e5 + qmag(14) = 0.01 + qmag(15) = 1.0e-5 + qmag(16) = 1.0e-3 + qmag(17) = 0.01 + qmag(18) = 1.0e-3 + qmag(19) = 0.01 + qmag(20) = 1.0e5 + qmag(21) = 0.01 + qmag(22) = 1.0e-5 + qmag(23) = 1.0e-3 + qmag(24) = 0.01 + qmag(25) = 1.0e5 + qmag(26) = 0.01 + qmag(27) = 1.0e-5 + qmag(28) = 1.0e-3 + qmag(29) = 0.01 + + ! for p3 arrays: +!--v00: +!! np3a = 52 +! np3a = 57 ! for 3+2 additional output variables +! np3o = 12 +!-- + np3a = 52 ! 3-mom, liqfrac, 4-cat (no extra output) + np3a = np3a + nout2d + nout3d + 4 !(4 for dhmax_x) + np3o = 16 ! 4 x nCat for vmi_(x), dmi_(x), rhoi_(x), dhmax_(x) + + ELSEIF( ptype.eq.64 )THEN + + numq = 30 ! there are 30 q variables + + nqv = 1 ! qv + nql1 = 2 ! the first liquid variable + nql2 = 3 ! the last liquid variable + nqs1 = 4 ! the first solid variable + nqs2 = 8 ! the last solid variable + + cloudvar( 1) = .false. + cloudvar( 2) = .true. + cloudvar( 3) = .false. + cloudvar( 4) = .true. + cloudvar( 5) = .true. + cloudvar( 6) = .true. + cloudvar( 7) = .true. + cloudvar( 8) = .true. + cloudvar( 9) = .false. + cloudvar(10) = .false. + cloudvar(11) = .false. + cloudvar(12) = .false. + cloudvar(13) = .false. + cloudvar(14) = .false. + cloudvar(15) = .false. + cloudvar(16) = .false. + cloudvar(17) = .false. + cloudvar(18) = .false. + cloudvar(19) = .false. + cloudvar(20) = .false. + cloudvar(21) = .false. + cloudvar(22) = .false. + cloudvar(23) = .false. + cloudvar(24) = .false. + cloudvar(25) = .false. + cloudvar(26) = .false. + cloudvar(27) = .false. + cloudvar(28) = .false. + cloudvar(29) = .false. + cloudvar(30) = .false. + + qname( 1) = 'qv ' + qname( 2) = 'qc ' + qname( 3) = 'qr ' + qname( 4) = 'qi1' + qname( 5) = 'qi2' + qname( 6) = 'qi3' + qname( 7) = 'qi4' + qname( 8) = 'qi5' + qname( 9) = 'nc ' + qname(10) = 'nr ' + qname(11) = 'ni1' + qname(12) = 'ri1' + qname(13) = 'bi1' + qname(14) = 'ni2' + qname(15) = 'ri2' + qname(16) = 'bi2' + qname(17) = 'ni3' + qname(18) = 'ri3' + qname(19) = 'bi3' + qname(20) = 'ni4' + qname(21) = 'ri4' + qname(22) = 'bi4' + qname(23) = 'ni5' + qname(24) = 'ri5' + qname(25) = 'bi5' + qname(26) = 'zi1' + qname(27) = 'zi2' + qname(28) = 'zi3' + qname(29) = 'zi4' + qname(30) = 'zi5' + + qunit( 1) = 'kg/kg' + qunit( 2) = 'kg/kg' + qunit( 3) = 'kg/kg' + qunit( 4) = 'kg/kg' + qunit( 5) = 'kg/kg' + qunit( 6) = 'kg/kg' + qunit( 7) = 'kg/kg' + qunit( 8) = 'kg/kg' + qunit( 9) = '#/kg' + qunit(10) = '#/kg' + qunit(11) = '#/kg' + qunit(12) = 'kg/kg' + qunit(13) = 'm^-3 kg^-1' + qunit(14) = '#/kg' + qunit(15) = 'kg/kg' + qunit(16) = 'm^-3 kg^-1' + qunit(17) = '#/kg' + qunit(18) = 'kg/kg' + qunit(19) = 'm^-3 kg^-1' + qunit(20) = '#/kg' + qunit(21) = 'kg/kg' + qunit(22) = 'm^-3 kg^-1' + qunit(23) = '#/kg' + qunit(24) = 'kg/kg' + qunit(25) = 'm^-3 kg^-1' + qunit(26) = 'm^6/kg' + qunit(27) = 'm^6/kg' + qunit(28) = 'm^6/kg' + qunit(29) = 'm^6/kg' + qunit(30) = 'm^6/kg' + + ! likely maximum value (order-of-magnitude) + ! (needed for monotonic advection schemes) + qmag( 1) = 0.01 + qmag( 2) = 0.01 + qmag( 3) = 0.01 + qmag( 4) = 0.01 + qmag( 5) = 0.01 + qmag( 6) = 0.01 + qmag( 7) = 0.01 + qmag( 8) = 0.01 + qmag( 9) = 1.0e5 + qmag(10) = 1.0e5 + qmag(11) = 1.0e5 + qmag(12) = 0.01 + qmag(13) = 1.0e-5 + qmag(14) = 1.0e5 + qmag(15) = 0.01 + qmag(16) = 1.0e-5 + qmag(17) = 1.0e5 + qmag(18) = 0.01 + qmag(19) = 1.0e-5 + qmag(20) = 1.0e5 + qmag(21) = 0.01 + qmag(22) = 1.0e-5 + qmag(23) = 1.0e5 + qmag(24) = 0.01 + qmag(25) = 1.0e-5 + qmag(26) = 1.0e-3 + qmag(27) = 1.0e-3 + qmag(28) = 1.0e-3 + qmag(29) = 1.0e-3 + qmag(30) = 1.0e-3 + + ! for p3 arrays: + np3a = 56 ! 3-mom, no_liqfrac, 5-cat (no extra output) + np3a = np3a + nout2d + nout3d + 5 !(5 for dhmax_x) + np3o = 20 ! 4 x nCat; for vmi_(x), dmi_(x), rhoi_(x), dhmax_(x) + + ELSEIF( ptype.eq.65 )THEN + + numq = 35 ! there are 35 q variables + + nqv = 1 ! qv + nql1 = 2 ! the first liquid variable + nql2 = 3 ! the last liquid variable + nqs1 = 4 ! the first solid variable + nqs2 = 9 ! the last solid variable + + cloudvar( 1) = .false. + cloudvar( 2) = .true. + cloudvar( 3) = .false. + cloudvar( 4) = .true. + cloudvar( 5) = .true. + cloudvar( 6) = .true. + cloudvar( 7) = .true. + cloudvar( 8) = .true. + cloudvar( 9) = .true. + cloudvar(10) = .false. + cloudvar(11) = .false. + cloudvar(12) = .false. + cloudvar(13) = .false. + cloudvar(14) = .false. + cloudvar(15) = .false. + cloudvar(16) = .false. + cloudvar(17) = .false. + cloudvar(18) = .false. + cloudvar(19) = .false. + cloudvar(20) = .false. + cloudvar(21) = .false. + cloudvar(22) = .false. + cloudvar(23) = .false. + cloudvar(24) = .false. + cloudvar(25) = .false. + cloudvar(26) = .false. + cloudvar(27) = .false. + cloudvar(28) = .false. + cloudvar(29) = .false. + cloudvar(30) = .false. + cloudvar(31) = .false. + cloudvar(32) = .false. + cloudvar(33) = .false. + cloudvar(34) = .false. + cloudvar(35) = .false. + + qname( 1) = 'qv ' + qname( 2) = 'qc ' + qname( 3) = 'qr ' + qname( 4) = 'qi1' + qname( 5) = 'qi2' + qname( 6) = 'qi3' + qname( 7) = 'qi4' + qname( 8) = 'qi5' + qname( 9) = 'qi6' + qname(10) = 'nc ' + qname(11) = 'nr ' + qname(12) = 'ni1' + qname(13) = 'ri1' + qname(14) = 'bi1' + qname(15) = 'ni2' + qname(16) = 'ri2' + qname(17) = 'bi2' + qname(18) = 'ni3' + qname(19) = 'ri3' + qname(20) = 'bi3' + qname(21) = 'ni4' + qname(22) = 'ri4' + qname(23) = 'bi4' + qname(24) = 'ni5' + qname(25) = 'ri5' + qname(26) = 'bi5' + qname(27) = 'ni6' + qname(28) = 'ri6' + qname(29) = 'bi6' + qname(30) = 'zi1' + qname(31) = 'zi2' + qname(32) = 'zi3' + qname(33) = 'zi4' + qname(34) = 'zi5' + qname(35) = 'zi6' qunit( 1) = 'kg/kg' qunit( 2) = 'kg/kg' qunit( 3) = 'kg/kg' qunit( 4) = 'kg/kg' qunit( 5) = 'kg/kg' - qunit( 6) = '#/kg' - qunit( 7) = '#/kg' - qunit( 8) = '#/kg' + qunit( 6) = 'kg/kg' + qunit( 7) = 'kg/kg' + qunit( 8) = 'kg/kg' qunit( 9) = 'kg/kg' - qunit(10) = 'm^-3 kg^-1' + qunit(10) = '#/kg' qunit(11) = '#/kg' - qunit(12) = 'kg/kg' - qunit(13) = 'm^-3 kg^-1' - qunit(14) = 'm^6 kg^-1' - qunit(15) = 'kg/kg' - qunit(16) = 'm^6 kg^-1' - qunit(17) = 'kg/kg' + qunit(12) = '#/kg' + qunit(13) = 'kg/kg' + qunit(14) = 'm^-3 kg^-1' + qunit(15) = '#/kg' + qunit(16) = 'kg/kg' + qunit(17) = 'm^-3 kg^-1' + qunit(18) = '#/kg' + qunit(19) = 'kg/kg' + qunit(20) = 'm^-3 kg^-1' + qunit(21) = '#/kg' + qunit(22) = 'kg/kg' + qunit(23) = 'm^-3 kg^-1' + qunit(24) = '#/kg' + qunit(25) = 'kg/kg' + qunit(26) = 'm^-3 kg^-1' + qunit(27) = '#/kg' + qunit(28) = 'kg/kg' + qunit(29) = 'm^-3 kg^-1' + qunit(30) = 'm^6/kg' + qunit(31) = 'm^6/kg' + qunit(32) = 'm^6/kg' + qunit(33) = 'm^6/kg' + qunit(34) = 'm^6/kg' + qunit(35) = 'm^6/kg' ! likely maximum value (order-of-magnitude) ! (needed for monotonic advection schemes) @@ -4631,40 +5951,51 @@ subroutine param(dt,dtlast,stattim,taptim,rsttim,radtim,prcltim, & qmag( 3) = 0.01 qmag( 4) = 0.01 qmag( 5) = 0.01 - qmag( 6) = 1.0e5 - qmag( 7) = 1.0e5 - qmag( 8) = 1.0e5 + qmag( 6) = 0.01 + qmag( 7) = 0.01 + qmag( 8) = 0.01 qmag( 9) = 0.01 - qmag(10) = 1.0e-5 + qmag(10) = 1.0e5 qmag(11) = 1.0e5 - qmag(12) = 0.01 - qmag(13) = 1.0e-5 - qmag(14) = 1.0e-3 - qmag(15) = 0.01 - qmag(16) = 1.0e-3 - qmag(17) = 0.01 + qmag(12) = 1.0e5 + qmag(13) = 0.01 + qmag(14) = 1.0e-5 + qmag(15) = 1.0e5 + qmag(16) = 0.01 + qmag(17) = 1.0e-5 + qmag(18) = 1.0e5 + qmag(19) = 0.01 + qmag(20) = 1.0e-5 + qmag(21) = 1.0e5 + qmag(22) = 0.01 + qmag(23) = 1.0e-5 + qmag(24) = 1.0e5 + qmag(25) = 0.01 + qmag(26) = 1.0e-5 + qmag(27) = 1.0e5 + qmag(28) = 0.01 + qmag(29) = 1.0e-5 + qmag(30) = 1.0e-3 + qmag(31) = 1.0e-3 + qmag(32) = 1.0e-3 + qmag(33) = 1.0e-3 + qmag(34) = 1.0e-3 + qmag(35) = 1.0e-3 ! for p3 arrays: -!--v00: -!! np3a = 34 -! np3a = 39 ! for 3+2 additional output variables -! np3o = 6 -!-- - np3a = 34 ! 3-mom, liqfrac, 2-cat (no extra output) - np3a = np3a + nout2d + nout3d + 2 !(2 for dhmax_x) - np3o = 8 ! 2 x nCat; for vmi_(x), dmi_(x), rhoi_(x), dhmax_(x) - - !cccccccccccccccccccccccccccccccccccccccccccccccccccc! + np3a = 64 ! 3-mom, no_liqfrac, 6-cat (no extra output) + np3a = np3a + nout2d + nout3d + 6 !(6 for dhmax_x) + np3o = 24 ! 4 x nCat; for vmi_(x), dmi_(x), rhoi_(x), dhmax_(x) - ELSEIF( ptype.eq.62 )THEN + ELSEIF( ptype.eq.66 )THEN - numq = 23 ! there are 17 q variables + numq = 35 ! there are 35 q variables nqv = 1 ! qv nql1 = 2 ! the first liquid variable nql2 = 3 ! the last liquid variable nqs1 = 4 ! the first solid variable - nqs2 = 6 ! the last solid variable + nqs2 = 8 ! the last solid variable cloudvar( 1) = .false. cloudvar( 2) = .true. @@ -4672,8 +6003,8 @@ subroutine param(dt,dtlast,stattim,taptim,rsttim,radtim,prcltim, & cloudvar( 4) = .true. cloudvar( 5) = .true. cloudvar( 6) = .true. - cloudvar( 7) = .false. - cloudvar( 8) = .false. + cloudvar( 7) = .true. + cloudvar( 8) = .true. cloudvar( 9) = .false. cloudvar(10) = .false. cloudvar(11) = .false. @@ -4689,6 +6020,18 @@ subroutine param(dt,dtlast,stattim,taptim,rsttim,radtim,prcltim, & cloudvar(21) = .false. cloudvar(22) = .false. cloudvar(23) = .false. + cloudvar(24) = .false. + cloudvar(25) = .false. + cloudvar(26) = .false. + cloudvar(27) = .false. + cloudvar(28) = .false. + cloudvar(29) = .false. + cloudvar(30) = .false. + cloudvar(31) = .false. + cloudvar(32) = .false. + cloudvar(33) = .false. + cloudvar(34) = .false. + cloudvar(35) = .false. qname( 1) = 'qv ' qname( 2) = 'qc ' @@ -4696,23 +6039,35 @@ subroutine param(dt,dtlast,stattim,taptim,rsttim,radtim,prcltim, & qname( 4) = 'qi1' qname( 5) = 'qi2' qname( 6) = 'qi3' - qname( 7) = 'nc ' - qname( 8) = 'nr ' - qname( 9) = 'ni1' - qname(10) = 'ri1' - qname(11) = 'bi1' - qname(12) = 'ni2' - qname(13) = 'ri2' - qname(14) = 'bi2' - qname(15) = 'zi1' - qname(16) = 'li1' - qname(17) = 'zi2' - qname(18) = 'li2' - qname(19) = 'ni3' - qname(20) = 'ri3' - qname(21) = 'bi3' - qname(22) = 'zi3' - qname(23) = 'li3' + qname( 7) = 'qi4' + qname( 8) = 'qi5' + qname( 9) = 'nc ' + qname(10) = 'nr ' + qname(11) = 'ni1' + qname(12) = 'ri1' + qname(13) = 'bi1' + qname(14) = 'zi1' + qname(15) = 'li1' + qname(16) = 'ni2' + qname(17) = 'ri2' + qname(18) = 'bi2' + qname(19) = 'zi2' + qname(20) = 'li2' + qname(21) = 'ni3' + qname(22) = 'ri3' + qname(23) = 'bi3' + qname(24) = 'zi3' + qname(25) = 'li3' + qname(26) = 'ni4' + qname(27) = 'ri4' + qname(28) = 'bi4' + qname(29) = 'zi4' + qname(30) = 'li4' + qname(31) = 'ni5' + qname(32) = 'ri5' + qname(33) = 'bi5' + qname(34) = 'zi5' + qname(35) = 'li5' qunit( 1) = 'kg/kg' qunit( 2) = 'kg/kg' @@ -4720,23 +6075,35 @@ subroutine param(dt,dtlast,stattim,taptim,rsttim,radtim,prcltim, & qunit( 4) = 'kg/kg' qunit( 5) = 'kg/kg' qunit( 6) = 'kg/kg' - qunit( 7) = '#/kg' - qunit( 8) = '#/kg' + qunit( 7) = 'kg/kg' + qunit( 8) = 'kg/kg' qunit( 9) = '#/kg' - qunit(10) = 'kg/kg' - qunit(11) = 'm^-3 kg^-1' - qunit(12) = '#/kg' - qunit(13) = 'kg/kg' - qunit(14) = 'm^-3 kg^-1' - qunit(15) = 'm^6 kg^-1' - qunit(16) = 'kg/kg' - qunit(17) = 'm^6 kg^-1' - qunit(18) = 'kg/kg' - qunit(19) = '#/kg' + qunit(10) = '#/kg' + qunit(11) = '#/kg' + qunit(12) = 'kg/kg' + qunit(13) = 'm^-3 kg^-1' + qunit(14) = 'm^6 kg^-1' + qunit(15) = 'kg/kg' + qunit(16) = '#/kg' + qunit(17) = 'kg/kg' + qunit(18) = 'm^-3 kg^-1' + qunit(19) = 'm^6 kg^-1' qunit(20) = 'kg/kg' - qunit(21) = 'm^-3 kg^-1' - qunit(22) = 'm^6 kg^-1' - qunit(23) = 'kg/kg' + qunit(21) = '#/kg' + qunit(22) = 'kg/kg' + qunit(23) = 'm^-3 kg^-1' + qunit(24) = 'm^6 kg^-1' + qunit(25) = 'kg/kg' + qunit(26) = '#/kg' + qunit(27) = 'kg/kg' + qunit(28) = 'm^-3 kg^-1' + qunit(29) = 'm^6 kg^-1' + qunit(30) = 'kg/kg' + qunit(31) = '#/kg' + qunit(32) = 'kg/kg' + qunit(33) = 'm^-3 kg^-1' + qunit(34) = 'm^6 kg^-1' + qunit(35) = 'kg/kg' ! likely maximum value (order-of-magnitude) ! (needed for monotonic advection schemes) @@ -4746,45 +6113,50 @@ subroutine param(dt,dtlast,stattim,taptim,rsttim,radtim,prcltim, & qmag( 4) = 0.01 qmag( 5) = 0.01 qmag( 6) = 0.01 - qmag( 7) = 1.0e5 - qmag( 8) = 1.0e5 + qmag( 7) = 0.01 + qmag( 8) = 0.01 qmag( 9) = 1.0e5 - qmag(10) = 0.01 - qmag(11) = 1.0e-5 - qmag(12) = 1.0e5 - qmag(13) = 0.01 - qmag(14) = 1.0e-5 - qmag(15) = 1.0e-3 - qmag(16) = 0.01 - qmag(17) = 1.0e-3 - qmag(18) = 0.01 - qmag(19) = 1.0e5 + qmag(10) = 1.0e5 + qmag(11) = 1.0e5 + qmag(12) = 0.01 + qmag(13) = 1.0e-5 + qmag(14) = 1.0e-3 + qmag(15) = 0.01 + qmag(16) = 1.0e5 + qmag(17) = 0.01 + qmag(18) = 1.0e-5 + qmag(19) = 1.0e-3 qmag(20) = 0.01 - qmag(21) = 1.0e-5 - qmag(22) = 1.0e-3 - qmag(23) = 0.01 + qmag(21) = 1.0e5 + qmag(22) = 0.01 + qmag(23) = 1.0e-5 + qmag(24) = 1.0e-3 + qmag(25) = 0.01 + qmag(26) = 1.0e5 + qmag(27) = 0.01 + qmag(28) = 1.0e-5 + qmag(29) = 1.0e-3 + qmag(30) = 0.01 + qmag(31) = 1.0e5 + qmag(32) = 0.01 + qmag(33) = 1.0e-5 + qmag(34) = 1.0e-3 + qmag(35) = 0.01 ! for p3 arrays: -!--v00: -!! np3a = 43 -! np3a = 48 ! for 3+2 additional output variables -! np3o = 9 -!-- - np3a = 43 ! 3-mom, liqfrac, 3-cat (no extra output) - np3a = np3a + nout2d + nout3d + 3 !(3 for dhmax_x) - np3o = 12 ! 3 x nCat; for vmi_(x), dmi_(x), rhoi_(x), dhmax_(x) - - !cccccccccccccccccccccccccccccccccccccccccccccccccccc! + np3a = 61 ! 3-mom, liqfrac, 5-cat (no extra output) + np3a = np3a + nout2d + nout3d + 5 !(5 for dhmax_x) + np3o = 20 ! 4 x nCat; for vmi_(x), dmi_(x), rhoi_(x), dhmax_(x) - ELSEIF( ptype.eq.63 )THEN + ELSEIF( ptype.eq.67 )THEN - numq = 29 ! there are 29 q variables + numq = 41 ! there are 41 q variables nqv = 1 ! qv nql1 = 2 ! the first liquid variable nql2 = 3 ! the last liquid variable nqs1 = 4 ! the first solid variable - nqs2 = 7 ! the last solid variable + nqs2 = 9 ! the last solid variable cloudvar( 1) = .false. cloudvar( 2) = .true. @@ -4793,8 +6165,8 @@ subroutine param(dt,dtlast,stattim,taptim,rsttim,radtim,prcltim, & cloudvar( 5) = .true. cloudvar( 6) = .true. cloudvar( 7) = .true. - cloudvar( 8) = .false. - cloudvar( 9) = .false. + cloudvar( 8) = .true. + cloudvar( 9) = .true. cloudvar(10) = .false. cloudvar(11) = .false. cloudvar(12) = .false. @@ -4815,6 +6187,18 @@ subroutine param(dt,dtlast,stattim,taptim,rsttim,radtim,prcltim, & cloudvar(27) = .false. cloudvar(28) = .false. cloudvar(29) = .false. + cloudvar(30) = .false. + cloudvar(31) = .false. + cloudvar(32) = .false. + cloudvar(33) = .false. + cloudvar(34) = .false. + cloudvar(35) = .false. + cloudvar(36) = .false. + cloudvar(37) = .false. + cloudvar(38) = .false. + cloudvar(39) = .false. + cloudvar(40) = .false. + cloudvar(41) = .false. qname( 1) = 'qv ' qname( 2) = 'qc ' @@ -4823,29 +6207,40 @@ subroutine param(dt,dtlast,stattim,taptim,rsttim,radtim,prcltim, & qname( 5) = 'qi2' qname( 6) = 'qi3' qname( 7) = 'qi4' - qname( 8) = 'nc ' - qname( 9) = 'nr ' - qname(10) = 'ni1' - qname(11) = 'ri1' - qname(12) = 'bi1' - qname(13) = 'ni2' - qname(14) = 'ri2' - qname(15) = 'bi2' - qname(16) = 'zi1' - qname(17) = 'li1' - qname(18) = 'zi2' - qname(19) = 'li2' - qname(20) = 'ni3' - qname(21) = 'ri3' - qname(22) = 'bi3' - qname(23) = 'zi3' - qname(24) = 'li3' - qname(25) = 'ni4' - qname(26) = 'ri4' - qname(27) = 'bi4' - qname(28) = 'zi4' - qname(29) = 'li4' - + qname( 8) = 'qi5' + qname( 9) = 'qi6' + qname(10) = 'nc ' + qname(11) = 'nr ' + qname(12) = 'ni1' + qname(13) = 'ri1' + qname(14) = 'bi1' + qname(15) = 'zi1' + qname(16) = 'li1' + qname(17) = 'ni2' + qname(18) = 'ri2' + qname(19) = 'bi2' + qname(20) = 'zi2' + qname(21) = 'li2' + qname(22) = 'ni3' + qname(23) = 'ri3' + qname(24) = 'bi3' + qname(25) = 'zi3' + qname(26) = 'li3' + qname(27) = 'ni4' + qname(28) = 'ri4' + qname(29) = 'bi4' + qname(30) = 'zi4' + qname(31) = 'li4' + qname(32) = 'ni5' + qname(33) = 'ri5' + qname(34) = 'bi5' + qname(35) = 'zi5' + qname(36) = 'li5' + qname(37) = 'ni6' + qname(38) = 'ri6' + qname(39) = 'bi6' + qname(40) = 'zi6' + qname(41) = 'li6' qunit( 1) = 'kg/kg' qunit( 2) = 'kg/kg' @@ -4854,28 +6249,40 @@ subroutine param(dt,dtlast,stattim,taptim,rsttim,radtim,prcltim, & qunit( 5) = 'kg/kg' qunit( 6) = 'kg/kg' qunit( 7) = 'kg/kg' - qunit( 8) = '#/kg' - qunit( 9) = '#/kg' + qunit( 8) = 'kg/kg' + qunit( 9) = 'kg/kg' qunit(10) = '#/kg' - qunit(11) = 'kg/kg' - qunit(12) = 'm^-3 kg^-1' - qunit(13) = '#/kg' - qunit(14) = 'kg/kg' - qunit(15) = 'm^-3 kg^-1' - qunit(16) = 'm^6 kg^-1' - qunit(17) = 'kg/kg' - qunit(18) = 'm^6 kg^-1' - qunit(19) = 'kg/kg' - qunit(20) = '#/kg' + qunit(11) = '#/kg' + qunit(12) = '#/kg' + qunit(13) = 'kg/kg' + qunit(14) = 'm^-3 kg^-1' + qunit(15) = 'm^6 kg^-1' + qunit(16) = 'kg/kg' + qunit(17) = '#/kg' + qunit(18) = 'kg/kg' + qunit(19) = 'm^-3 kg^-1' + qunit(20) = 'm^6 kg^-1' qunit(21) = 'kg/kg' - qunit(22) = 'm^-3 kg^-1' - qunit(23) = 'm^6 kg^-1' - qunit(24) = 'kg/kg' - qunit(25) = '#/kg' + qunit(22) = '#/kg' + qunit(23) = 'kg/kg' + qunit(24) = 'm^-3 kg^-1' + qunit(25) = 'm^6 kg^-1' qunit(26) = 'kg/kg' - qunit(27) = 'm^-3 kg^-1' - qunit(28) = 'm^6 kg^-1' - qunit(29) = 'kg/kg' + qunit(27) = '#/kg' + qunit(28) = 'kg/kg' + qunit(29) = 'm^-3 kg^-1' + qunit(30) = 'm^6 kg^-1' + qunit(31) = 'kg/kg' + qunit(32) = '#/kg' + qunit(33) = 'kg/kg' + qunit(34) = 'm^-3 kg^-1' + qunit(35) = 'm^6 kg^-1' + qunit(36) = 'kg/kg' + qunit(37) = '#/kg' + qunit(38) = 'kg/kg' + qunit(39) = 'm^-3 kg^-1' + qunit(40) = 'm^6 kg^-1' + qunit(41) = 'kg/kg' ! likely maximum value (order-of-magnitude) ! (needed for monotonic advection schemes) @@ -4886,39 +6293,45 @@ subroutine param(dt,dtlast,stattim,taptim,rsttim,radtim,prcltim, & qmag( 5) = 0.01 qmag( 6) = 0.01 qmag( 7) = 0.01 - qmag( 8) = 1.0e5 - qmag( 9) = 1.0e5 + qmag( 8) = 0.01 + qmag( 9) = 0.01 qmag(10) = 1.0e5 - qmag(11) = 0.01 - qmag(12) = 1.0e-5 - qmag(13) = 1.0e5 - qmag(14) = 0.01 - qmag(15) = 1.0e-5 - qmag(16) = 1.0e-3 - qmag(17) = 0.01 - qmag(18) = 1.0e-3 - qmag(19) = 0.01 - qmag(20) = 1.0e5 + qmag(11) = 1.0e5 + qmag(12) = 1.0e5 + qmag(13) = 0.01 + qmag(14) = 1.0e-5 + qmag(15) = 1.0e-3 + qmag(16) = 0.01 + qmag(17) = 1.0e5 + qmag(18) = 0.01 + qmag(19) = 1.0e-5 + qmag(20) = 1.0e-3 qmag(21) = 0.01 - qmag(22) = 1.0e-5 - qmag(23) = 1.0e-3 - qmag(24) = 0.01 - qmag(25) = 1.0e5 + qmag(22) = 1.0e5 + qmag(23) = 0.01 + qmag(24) = 1.0e-5 + qmag(25) = 1.0e-3 qmag(26) = 0.01 - qmag(27) = 1.0e-5 - qmag(28) = 1.0e-3 - qmag(29) = 0.01 + qmag(27) = 1.0e5 + qmag(28) = 0.01 + qmag(29) = 1.0e-5 + qmag(30) = 1.0e-3 + qmag(31) = 0.01 + qmag(32) = 1.0e5 + qmag(33) = 0.01 + qmag(34) = 1.0e-5 + qmag(35) = 1.0e-3 + qmag(36) = 0.01 + qmag(37) = 1.0e5 + qmag(38) = 0.01 + qmag(39) = 1.0e-5 + qmag(40) = 1.0e-3 + qmag(41) = 0.01 ! for p3 arrays: -!--v00: -!! np3a = 52 -! np3a = 57 ! for 3+2 additional output variables -! np3o = 12 -!-- - np3a = 52 ! 3-mom, liqfrac, 4-cat (no extra output) - np3a = np3a + nout2d + nout3d + 4 !(4 for dhmax_x) - np3o = 16 ! 4 x nCat for vmi_(x), dmi_(x), rhoi_(x), dhmax_(x) - + np3a = 70 ! 3-mom, liqfrac, 6-cat (no extra output) + np3a = np3a + nout2d + nout3d + 6 !(6 for dhmax_x) + np3o = 24 ! 4 x nCat; for vmi_(x), dmi_(x), rhoi_(x), dhmax_(x) ENDIF !cccccccccccccccccccccccccccccccccccccccccccccccccccc! @@ -5211,6 +6624,7 @@ subroutine param(dt,dtlast,stattim,taptim,rsttim,radtim,prcltim, & output_interp = max(0,min(1,output_interp))*iterrain output_rain = max(0,min(1,output_rain)) + output_hail = max(0,min(1,output_hail)) output_sws = max(0,min(1,output_sws)) output_svs = max(0,min(1,output_svs)) output_sps = max(0,min(1,output_sps)) @@ -5288,6 +6702,7 @@ subroutine param(dt,dtlast,stattim,taptim,rsttim,radtim,prcltim, & !!! endif if(imoist.eq.0)then output_rain=0 + output_hail=0 output_srs=0 output_sgs=0 output_qv=0 @@ -5350,6 +6765,7 @@ subroutine param(dt,dtlast,stattim,taptim,rsttim,radtim,prcltim, & if(dowr) write(outfile,*) 'output_filetype =',output_filetype if(dowr) write(outfile,*) 'output_interp =',output_interp if(dowr) write(outfile,*) 'output_rain =',output_rain + if(dowr) write(outfile,*) 'output_hail =',output_hail if(dowr) write(outfile,*) 'output_sws =',output_sws if(dowr) write(outfile,*) 'output_svs =',output_svs if(dowr) write(outfile,*) 'output_sps =',output_sps @@ -5773,8 +7189,10 @@ subroutine param(dt,dtlast,stattim,taptim,rsttim,radtim,prcltim, & ! array indices for P3 microphysics: ! (use these arrays for ISHMAEL diag output, too) if( imoist.eq.1 .and. ( ptype.eq.50 .or. ptype.eq.51 .or. ptype.eq.52 .or. & - ptype.eq.53 .or. ptype.eq.54 .or. ptype.eq.55 .or. ptype.eq.60 .or. & - ptype.eq.61 .or. ptype.eq.62 .or. ptype.eq.63) )then + ptype.eq.53 .or. ptype.eq.54 .or. ptype.eq.55 .or. ptype.eq.56 .or. & + ptype.eq.57 .or. ptype.eq.60 .or. & + ptype.eq.61 .or. ptype.eq.62 .or. ptype.eq.63 .or. & + ptype.eq.64 .or. ptype.eq.65 .or. ptype.eq.66 .or. ptype.eq.67) )then ibp3 = 1 iep3 = ni jbp3 = 1 @@ -10097,7 +11515,7 @@ subroutine param(dt,dtlast,stattim,taptim,rsttim,radtim,prcltim, & write(21,*) ' tconfig = ',tconfig write(21,*) ' bcturbs = ',bcturbs write(21,*) ' ptype = ',ptype - IF ( ptype.eq.26 .or. ptype.eq.27 ) THEN + IF ( ptype.eq.26 .or. ptype.eq.27 .or. ptype.eq.28 ) THEN write(21,*) ' nssl_3moment = ',nssl_3moment ENDIF write(21,*) ' wbc = ',wbc diff --git a/src/radiation_driver.F b/src/radiation_driver.F index 1ea45d7..204b719 100644 --- a/src/radiation_driver.F +++ b/src/radiation_driver.F @@ -470,14 +470,16 @@ subroutine radiation_driver(mtime,radtim,dt,rbufsz,xh,yh,xf,yf,zf,rmh,c1,c2, has_reqs = 1 endif if( ptype.eq.26 .or. ptype.eq.27 )then - ! NSSL scheme + ! NSSL scheme (DTD: will this work for 28 as well?) mp_physics = 18 has_reqc = 1 has_reqi = 1 has_reqs = 1 endif - if( ptype.eq.50 .or. ptype.eq.51 .or. ptype.eq.52 .or. ptype.eq.53 .or. ptype.eq.54 .or. ptype.eq.60 & - .or. ptype.eq.61 .or. ptype.eq.62 .or. ptype.eq.63)then + if( ptype.eq.50 .or. ptype.eq.51 .or. ptype.eq.52 .or. ptype.eq.53 .or. ptype.eq.54 .or. & + ptype.eq.56 .or. ptype.eq.57 .or. ptype.eq.60 & + .or. ptype.eq.61 .or. ptype.eq.62 .or. ptype.eq.63 & + .or. ptype.eq.64 .or. ptype.eq.65 .or. ptype.eq.66 .or. ptype.eq.67)then ! P3 microphysics ! use eff arrays from P3 scheme: mp_physics = ptype @@ -779,7 +781,7 @@ SUBROUTINE radconst(XTIME,DECLIN,SOLCON,JULIAN, & DECDEG,DJUL,RJUL,ECCFAC ! ! !DESCRIPTION: -! Compute terms used in radiation physics +! Compute terms used in radiation physics !EOP ! for short wave radiation @@ -788,12 +790,12 @@ SUBROUTINE radconst(XTIME,DECLIN,SOLCON,JULIAN, & SOLCON=0. !-----OBECL : OBLIQUITY = 23.5 DEGREE. - + OBECL=23.5*DEGRAD SINOB=SIN(OBECL) - + !-----CALCULATE LONGITUDE OF THE SUN FROM VERNAL EQUINOX: - + IF(JULIAN.GE.80.)SXLONG=DPD*(JULIAN-80.) IF(JULIAN.LT.80.)SXLONG=DPD*(JULIAN+285.) SXLONG=SXLONG*DEGRAD @@ -806,7 +808,7 @@ SUBROUTINE radconst(XTIME,DECLIN,SOLCON,JULIAN, & ECCFAC=1.000110+0.034221*COS(RJUL)+0.001280*SIN(RJUL)+0.000719* & COS(2*RJUL)+0.000077*SIN(2*RJUL) SOLCON=1370.*ECCFAC - + END SUBROUTINE radconst @@ -873,7 +875,7 @@ SUBROUTINE cal_cldfra1(CLDFRA, QV, QC, QI, QS, & USE module_state_description, ONLY : KFCUPSCHEME, KFETASCHEME !wig, CuP 4-Fb-2008 !BSINGH - For WRFCuP scheme #if (HWRF == 1) - USE module_state_description, ONLY : FER_MP_HIRES, FER_MP_HIRES_ADVECT, ETAMP_HWRF + USE module_state_description, ONLY : FER_MP_HIRES, FER_MP_HIRES_ADVECT, ETAMP_HWRF #else USE module_state_description, ONLY : FER_MP_HIRES, FER_MP_HIRES_ADVECT #endif @@ -928,13 +930,13 @@ SUBROUTINE cal_cldfra1(CLDFRA, QV, QC, QI, QS, & ! if provided. ! ! Whether QI or QC is active or not is determined from the indices of -! the fields into the 4D scalar arrays in WRF. These indices are +! the fields into the 4D scalar arrays in WRF. These indices are ! P_QI and P_QC, respectively, and they are passed in to the routine ! to enable testing to see if QI and QC represent active fields in ! the moisture 4D scalar array carried by WRF. -! +! ! If a field is active its index will have a value greater than or -! equal to PARAM_FIRST_SCALAR, which is also an input argument to +! equal to PARAM_FIRST_SCALAR, which is also an input argument to ! this routine. !EOP @@ -1095,8 +1097,8 @@ SUBROUTINE cal_cldfra1(CLDFRA, QV, QC, QI, QS, & !! ARG=MAX(ARG, ARGMIN) !! CLDFRA(i,j,k)=(RHUM/RHGRID)*(1.-EXP(ARG)) IF (CLDFRA(i,j,k) .LT. .01) CLDFRA(i,j,k)=0. - - ENDIF !--- End IF (QCLD .LT. QCLDMIN) ... + + ENDIF !--- End IF (QCLD .LT. QCLDMIN) ... ENDDO !--- End DO i ENDDO !--- End DO k ENDDO !--- End DO j diff --git a/src/solve1.F b/src/solve1.F index 4eb670a..80f8ef9 100644 --- a/src/solve1.F +++ b/src/solve1.F @@ -730,6 +730,20 @@ subroutine solve1(nstep,num_soil_layers, & IF( nql1.ge.1 )THEN + IF( qsum_invariant )THEN + ! permutation-invariant (sorted) sum over the liquid scalar slots + ! (category-swap bit-identity test; see NOTES.md): + !$omp parallel do default(shared) & + !$omp private(i,j,k) + do k=1,nk + do j=1,nj + do i=1,ni + dum2(i,j,k)=sortsumq(qa(i,j,k,nql1:nql2)) + enddo + enddo + enddo + ELSE + !$omp parallel do default(shared) & !$omp private(i,j,k) do k=1,nk @@ -752,6 +766,8 @@ subroutine solve1(nstep,num_soil_layers, & enddo enddo + ENDIF + ELSE !$omp parallel do default(shared) & @@ -768,6 +784,20 @@ subroutine solve1(nstep,num_soil_layers, & IF(iice.eq.1)THEN + IF( qsum_invariant )THEN + ! permutation-invariant (sorted) sum over the solid scalar slots + ! (category-swap bit-identity test; see NOTES.md): + !$omp parallel do default(shared) & + !$omp private(i,j,k) + do k=1,nk + do j=1,nj + do i=1,ni + dum3(i,j,k)=sortsumq(qa(i,j,k,nqs1:nqs2)) + enddo + enddo + enddo + ELSE + !$omp parallel do default(shared) & !$omp private(i,j,k) do k=1,nk @@ -790,6 +820,8 @@ subroutine solve1(nstep,num_soil_layers, & enddo enddo + ENDIF + ELSE !$omp parallel do default(shared) & diff --git a/src/solve2.F b/src/solve2.F index 596dd12..ab74063 100644 --- a/src/solve2.F +++ b/src/solve2.F @@ -331,6 +331,18 @@ subroutine solve2(nstep, & else ifql + IF( qsum_invariant )THEN + ! permutation-invariant (sorted) sum over the liquid scalar slots + ! (category-swap bit-identity test; see NOTES.md): + do k=1,nk + do j=1,nj + do i=1,ni + dum2(i,j,k)=sortsumq(q3d(i,j,k,nql1:nql2)) + enddo + enddo + enddo + ELSE + do k=1,nk do j=1,nj do i=1,ni @@ -349,10 +361,24 @@ subroutine solve2(nstep, & enddo enddo + ENDIF + endif ifql IF(iice.eq.1)THEN + IF( qsum_invariant )THEN + ! permutation-invariant (sorted) sum over the solid scalar slots + ! (category-swap bit-identity test; see NOTES.md): + do k=1,nk + do j=1,nj + do i=1,ni + dum3(i,j,k)=sortsumq(q3d(i,j,k,nqs1:nqs2)) + enddo + enddo + enddo + ELSE + do k=1,nk do j=1,nj do i=1,ni @@ -371,6 +397,8 @@ subroutine solve2(nstep, & enddo enddo + ENDIF + ELSE do k=1,nk diff --git a/src/solve3.F b/src/solve3.F index 2eab478..c539be5 100644 --- a/src/solve3.F +++ b/src/solve3.F @@ -83,7 +83,7 @@ subroutine solve3(nstep,num_soil_layers, & pi0,rho0,prs0,thv0,th0,rth0,qv0,qc0, & qi0,rr0,rf0,rrf0, & zs,gz,rgz,gzu,rgzu,gzv,rgzv,dzdx,dzdy, & - rain,sws,svs,sps,srs,sgs,sus,shs, & + rain,hail,sws,svs,sps,srs,sgs,sus,shs, & dum1,dum2,dum3,dum4,dum5,dum6,dum7,dum8, & divx,rho,rr,rf,prs, & u0,rru,ua,u3d,uten,uten1, & @@ -153,7 +153,7 @@ subroutine solve3(nstep,num_soil_layers, & real, intent(in), dimension(ib:ie,jb:je,kb:ke) :: qi0,rr0,rf0,rrf0 real, intent(in), dimension(ib:ie,jb:je) :: zs real, intent(in), dimension(itb:ite,jtb:jte) :: gz,rgz,gzu,rgzu,gzv,rgzv,dzdx,dzdy - real, intent(inout), dimension(ib:ie,jb:je,nrain) :: rain,sws,svs,sps,srs,sgs,sus,shs + real, intent(inout), dimension(ib:ie,jb:je,nrain) :: rain,hail,sws,svs,sps,srs,sgs,sus,shs real, intent(inout), dimension(ib:ie,jb:je,kb:ke) :: dum1,dum2,dum3,dum4,dum5,dum6,dum7,dum8 real, intent(inout), dimension(ib:ie,jb:je,kb:ke) :: divx,rho,rr,rf,prs real, intent(inout), dimension(ib:ie+1,jb:je,kb:ke) :: u0,rru,ua,u3d,uten,uten1 @@ -854,6 +854,17 @@ subroutine solve3(nstep,num_soil_layers, & ENDIF + IF( output_hail.eq.1 )THEN + + if(imove.eq.1.and.imoist.eq.1)then + weps = 10.0*epsilon + call movesfc(0.0,dt,weps,uh,vh,hail(ib,jb,2),dum1(ib,jb,1),dum1(ib,jb,2),dum1(ib,jb,3), & + reqs_s,sw31(1,1,1),sw32(1,1,1),se31(1,1,1),se32(1,1,1), & + ss31(1,1,1),ss32(1,1,1),sn31(1,1,1),sn32(1,1,1)) + endif + + ENDIF + !-------------------------------------------------------------------- ! Maximum horizontal wind speed at lowest model level: ! (include domain movement in calculation) diff --git a/src/turb.F b/src/turb.F index d373e01..dbd4cbc 100644 --- a/src/turb.F +++ b/src/turb.F @@ -430,6 +430,18 @@ subroutine sfc_and_turb(getsfc,getpbl,nstep,dt,dosfcflx,cloudvar,qbudget, & enddo ENDDO IF( nql1.gt.0 )THEN + IF( qsum_invariant )THEN + ! permutation-invariant (sorted) sum over the liquid scalar slots + ! (category-swap bit-identity test; see NOTES.md): + !$omp parallel do default(shared) private(i,j,k) + DO k=1,nk + do j=1,nj + do i=1,ni + dum7(i,j,k)=dum7(i,j,k)+sortsumq(qa(i,j,k,nql1:nql2)) + enddo + enddo + ENDDO + ELSE do n=nql1,nql2 !$omp parallel do default(shared) private(i,j,k) DO k=1,nk @@ -440,8 +452,21 @@ subroutine sfc_and_turb(getsfc,getpbl,nstep,dt,dosfcflx,cloudvar,qbudget, & enddo ENDDO enddo + ENDIF ENDIF IF(iice.eq.1)THEN + IF( qsum_invariant )THEN + ! permutation-invariant (sorted) sum over the solid scalar slots + ! (category-swap bit-identity test; see NOTES.md): + !$omp parallel do default(shared) private(i,j,k) + DO k=1,nk + do j=1,nj + do i=1,ni + dum7(i,j,k)=dum7(i,j,k)+sortsumq(qa(i,j,k,nqs1:nqs2)) + enddo + enddo + ENDDO + ELSE do n=nqs1,nqs2 !$omp parallel do default(shared) private(i,j,k) DO k=1,nk @@ -452,6 +477,7 @@ subroutine sfc_and_turb(getsfc,getpbl,nstep,dt,dosfcflx,cloudvar,qbudget, & enddo ENDDO enddo + ENDIF ENDIF ELSE !$omp parallel do default(shared) private(i,j,k,n) @@ -4997,21 +5023,42 @@ subroutine calcnm(c1,c2,mf,pi0,thv0,th0,cloudvar,nm,t,qt,thv,cloud,rh,qvci, & enddo ENDIF - DO n=1,numq - IF( (n.eq.nqv) .or. & - (n.ge.nql1.and.n.le.nql2) .or. & - (n.ge.nqs1.and.n.le.nqs2.and.iice.eq.1) )THEN - !$omp parallel do default(shared) & - !$omp private(i,j,k) - do k=1,nk - do j=1,nj - do i=1,ni - qt(i,j,k)=qt(i,j,k)+qa(i,j,k,n) - enddo - enddo - enddo - ENDIF - ENDDO + IF( qsum_invariant )THEN + ! category-order-invariant total water (matches the dum7 = Sql+Sqi + ! treatment in the turb driver; see qsum_invariant). qv + a value-sorted + ! liquid sum + a value-sorted solid sum, so qt -- and hence thv, N^2, the + ! subgrid TKE and the eddy diffusivities -- is independent of which + ! category slot holds which value. (Without this, the fixed slot-order + ! accumulation of the swapped ice masses seeds a ~1-ULP difference in the + ! diffusivity that breaks bit-identity under a category relabeling.) + !$omp parallel do default(shared) & + !$omp private(i,j,k) + do k=1,nk + do j=1,nj + do i=1,ni + qt(i,j,k) = qt(i,j,k) + qa(i,j,k,nqv) + if( nql1.gt.0 ) qt(i,j,k) = qt(i,j,k) + sortsumq(qa(i,j,k,nql1:nql2)) + if( nqs1.gt.0 .and. iice.eq.1 ) qt(i,j,k) = qt(i,j,k) + sortsumq(qa(i,j,k,nqs1:nqs2)) + enddo + enddo + enddo + ELSE + DO n=1,numq + IF( (n.eq.nqv) .or. & + (n.ge.nql1.and.n.le.nql2) .or. & + (n.ge.nqs1.and.n.le.nqs2.and.iice.eq.1) )THEN + !$omp parallel do default(shared) & + !$omp private(i,j,k) + do k=1,nk + do j=1,nj + do i=1,ni + qt(i,j,k)=qt(i,j,k)+qa(i,j,k,n) + enddo + enddo + enddo + ENDIF + ENDDO + ENDIF k = 1 diff --git a/src/writeout.F b/src/writeout.F index 03161d3..e1239f5 100644 --- a/src/writeout.F +++ b/src/writeout.F @@ -23,7 +23,7 @@ subroutine writeout(srec,urec,vrec,wrec,mrec,rtime,dt,fnum,nwrite,qname,qunit, xh,xf,uf,yh,yf,vf,xfref,yfref, & rds,sigma,rdsf,sigmaf,zh,zf,mf,gx,gy,wprof, & pi0,prs0,rho0,rr0,rf0,rrf0,th0,qv0,u0,v0,thv0,rth0,qc0,qi0, & - zs,rgzu,rgzv,rain,sws,svs,sps,srs,sgs,sus,shs,thflux,qvflux,psfc, & + zs,rgzu,rgzv,rain,hail,sws,svs,sps,srs,sgs,sus,shs,thflux,qvflux,psfc, & rxh,arh1,arh2,uh,ruh,rxf,arf1,arf2,vh,rvh,mh,rmh,rmf,rr,rf, & gz,rgz,gzu,gzv,gxu,gyv,dzdx,dzdy,c1,c2, & cd,ch,cq,tlh,f2d,psmth,prate,ustt,cm0, & @@ -101,7 +101,7 @@ subroutine writeout(srec,urec,vrec,wrec,mrec,rtime,dt,fnum,nwrite,qname,qunit, real, dimension(ib:ie,jb:je,kb:ke), intent(in) :: pi0,prs0,rho0,rr0,rf0,rrf0,th0,qv0,thv0,rth0,qc0,qi0 real, dimension(ib:ie,jb:je), intent(in) :: zs real, dimension(itb:ite,jtb:jte), intent(in) :: rgzu,rgzv - real, dimension(ib:ie,jb:je,nrain), intent(in) :: rain,sws,svs,sps,srs,sgs,sus,shs + real, dimension(ib:ie,jb:je,nrain), intent(in) :: rain,hail,sws,svs,sps,srs,sgs,sus,shs real, dimension(ib:ie,jb:je), intent(in) :: xland,psfc,psmth,thflux,qvflux,cd,ch,cq,tlh,f2d,prate,ustt,cm0 real, intent(in), dimension(ib:ie) :: rxh,arh1,arh2,uh,ruh real, intent(in), dimension(ib:ie+1) :: rxf,arf1,arf2 @@ -362,6 +362,19 @@ subroutine writeout(srec,urec,vrec,wrec,mrec,rtime,dt,fnum,nwrite,qname,qunit, call write2d(rain(ib,jb,1),fnum,srec,nwrite,nloop,dat1,dat2,dat3,reqt,myi1p,myi2p,myj1p,myj2p,ncid,time_index,name_output(n_out)) endif + !............................................. + + if(output_hail .eq.1)then + n_out = n_out + 1 + name_output(n_out) = 'hail ' + desc_output(n_out) = 'accumulated surface hailfall' + unit_output(n_out) = 'cm' + grid_output(n_out) = '2' ! s=scalar pts (3d) ; u=u pts (3d) ; v=v pts (3d) ; w=w pts (3d) ; 2=2d scalar pts + cmpr_output(n_out) = .true. + + call write2d(hail(ib,jb,1),fnum,srec,nwrite,nloop,dat1,dat2,dat3,reqt,myi1p,myi2p,myj1p,myj2p,ncid,time_index,name_output(n_out)) + endif + !............................................. if(output_rain .eq.1)then @@ -543,6 +556,23 @@ subroutine writeout(srec,urec,vrec,wrec,mrec,rtime,dt,fnum,nwrite,qname,qunit, call write2d(dum2d,fnum,srec,nwrite,nloop,dat1,dat2,dat3,reqt,myi1p,myi2p,myj1p,myj2p,ncid,time_index,name_output(n_out)) endif + if(output_hail .eq.1)then + n_out = n_out + 1 + name_output(n_out) = 'hail2 ' + desc_output(n_out) = 'translated surface hailfall' + unit_output(n_out) = 'cm' + grid_output(n_out) = '2' ! s=scalar pts (3d) ; u=u pts (3d) ; v=v pts (3d) ; w=w pts (3d) ; 2=2d scalar pts + + !$omp parallel do default(shared) & + !$omp private(i,j) + do j=1,nj + do i=1,ni + dum2d(i,j) = hail(i,j,2) + enddo + enddo + + call write2d(dum2d,fnum,srec,nwrite,nloop,dat1,dat2,dat3,reqt,myi1p,myi2p,myj1p,myj2p,ncid,time_index,name_output(n_out)) + endif endif !............................................. @@ -3571,7 +3601,7 @@ subroutine writeout(srec,urec,vrec,wrec,mrec,rtime,dt,fnum,nwrite,qname,qunit, enddo enddo enddo - + IF ( output_n_as_m3 > 0 ) THEN ! convert output to number per m^3 IF ( trim(qunit(n)) == '#/kg' ) THEN @@ -3589,6 +3619,26 @@ subroutine writeout(srec,urec,vrec,wrec,mrec,rtime,dt,fnum,nwrite,qname,qunit, ENDIF ENDIF + ! for NSSL microphysics: + IF( ptype.ge.26 .and. ptype.le.28 )THEN + IF ( output_n_as_m3 > 0 ) THEN + ! convert output to number per m^3 + IF ( trim(qunit(n)) == '#/kg' ) THEN + unit_output(n_out) = '#/m3' + + !$omp parallel do default(shared) & + !$omp private(i,j,k) + do k=1,maxk + do j=1,nj + do i=1,ni + dum1(i,j,k) = qa(i,j,k,n)*rho(i,j,k) + enddo + enddo + enddo + ENDIF + ENDIF + ENDIF + call writes(dum1,fnum,srec,nwrite,nloop,dat1,dat2,dat3,reqt,myi1p,myi2p,myj1p,myj2p,ncid,time_index,name_output(n_out),sigma,zs,zh,dum9) @@ -3606,8 +3656,9 @@ subroutine writeout(srec,urec,vrec,wrec,mrec,rtime,dt,fnum,nwrite,qname,qunit, IF( imoist.eq.1 .and. numq.gt.1 )THEN if (output_q.eq.1) then - if ( ptype.eq.50 .or. ptype.eq.51 .or. ptype.eq.52 .or. ptype.eq.53 .or. ptype.eq.54 .or. & - ptype.eq.60 .or. ptype.eq.61 .or. ptype.eq.62 .or. ptype.eq.63) then + if ( ptype.eq.50 .or. ptype.eq.51 .or. ptype.eq.52 .or. ptype.eq.53 .or. ptype.eq.54 .or. & + ptype.eq.56 .or. ptype.eq.57 .or.ptype.eq.60 .or. ptype.eq.61 .or. ptype.eq.62 .or. & + ptype.eq.63 .or. ptype.eq.64 .or. ptype.eq.65 .or. ptype.eq.66 .or. ptype.eq.67) then n_out = n_out + 1 name_output(n_out) = 'p3_vmi1' desc_output(n_out) = 'P3: mass-weighted mean fallspeed, ice category 1' @@ -3678,7 +3729,9 @@ subroutine writeout(srec,urec,vrec,wrec,mrec,rtime,dt,fnum,nwrite,qname,qunit, IF( imoist.eq.1 .and. numq.gt.1 )THEN if (output_q.eq.1) then - if (ptype.eq.52 .or. ptype.eq.54 .or. ptype.eq.61 .or. ptype.eq. 62 .or. ptype.eq.63) then + if (ptype.eq.52 .or. ptype.eq.54 .or. ptype.eq.56 .or. ptype.eq.57 .or.ptype.eq.61 .or. & + ptype.eq. 62 .or. ptype.eq.63 .or. ptype.eq.64 .or. ptype.eq.65 .or. ptype.eq.66 .or. & + ptype.eq.67) then n_out = n_out + 1 name_output(n_out) = 'p3_vmi2' desc_output(n_out) = 'P3: mass-weighted mean fallspeed, ice category 2' @@ -3750,7 +3803,8 @@ subroutine writeout(srec,urec,vrec,wrec,mrec,rtime,dt,fnum,nwrite,qname,qunit, IF( imoist.eq.1 .and. numq.gt.1 )THEN if (output_q.eq.1) then - if (ptype.eq.62 .or. ptype.eq.63) then + if (ptype.eq. 56 .or. ptype.eq.57 .or. ptype.eq.62 .or. ptype.eq.63 .or. & + ptype.eq.64 .or. ptype.eq.65 .or. ptype.eq.66 .or. ptype.eq.67) then n_out = n_out + 1 name_output(n_out) = 'p3_vmi3' desc_output(n_out) = 'P3: mass-weighted mean fallspeed, ice category 3' @@ -3824,7 +3878,8 @@ subroutine writeout(srec,urec,vrec,wrec,mrec,rtime,dt,fnum,nwrite,qname,qunit, IF( imoist.eq.1 .and. numq.gt.1 )THEN if (output_q.eq.1) then - if (ptype.eq.63) then + if (ptype.eq. 57 .or. ptype.eq.63 .or. & + ptype.eq.64 .or. ptype.eq.65 .or. ptype.eq.66 .or. ptype.eq.67) then n_out = n_out + 1 name_output(n_out) = 'p3_vmi4' desc_output(n_out) = 'P3: mass-weighted mean fallspeed, ice category 4' @@ -3895,6 +3950,158 @@ subroutine writeout(srec,urec,vrec,wrec,mrec,rtime,dt,fnum,nwrite,qname,qunit, endif ENDIF + !............................................. + + IF( imoist.eq.1 .and. numq.gt.1 )THEN + if (output_q.eq.1) then + if (ptype.eq.64 .or. ptype.eq.65 .or. ptype.eq.66 .or. ptype.eq.67) then + n_out = n_out + 1 + name_output(n_out) = 'p3_vmi5' + desc_output(n_out) = 'P3: mass-weighted mean fallspeed, ice category 5' + unit_output(n_out) = 'm/s' + grid_output(n_out) = 's' ! s=scalar pts (3d) ; u=u pts (3d) ; v=v pts (3d) ; w=w pts (3d) ; 2=2d scalar pts + + !$omp parallel do default(shared) & + !$omp private(i,j,k) + do k=1,maxk + do j=1,nj + do i=1,ni + dum1(i,j,k) = p3o(i,j,k,17) + enddo + enddo + enddo + call writes(dum1,fnum,srec,nwrite,nloop,dat1,dat2,dat3,reqt,myi1p,myi2p,myj1p,myj2p,ncid,time_index,name_output(n_out),sigma,zs,zh,dum9) + + n_out = n_out + 1 + name_output(n_out) = 'p3_dmi5' + desc_output(n_out) = 'P3: mass-weighted mean diameter, ice category 5' + unit_output(n_out) = 'm' + grid_output(n_out) = 's' ! s=scalar pts (3d) ; u=u pts (3d) ; v=v pts (3d) ; w=w pts (3d) ; 2=2d scalar pts + + !$omp parallel do default(shared) & + !$omp private(i,j,k) + do k=1,maxk + do j=1,nj + do i=1,ni + dum1(i,j,k) = p3o(i,j,k,18) + enddo + enddo + enddo + call writes(dum1,fnum,srec,nwrite,nloop,dat1,dat2,dat3,reqt,myi1p,myi2p,myj1p,myj2p,ncid,time_index,name_output(n_out),sigma,zs,zh,dum9) + + n_out = n_out + 1 + name_output(n_out) = 'p3_rhoi5' + desc_output(n_out) = 'P3: mean ice density, ice category 5' + unit_output(n_out) = 'kg/m3' + grid_output(n_out) = 's' ! s=scalar pts (3d) ; u=u pts (3d) ; v=v pts (3d) ; w=w pts (3d) ; 2=2d scalar pts + + !$omp parallel do default(shared) & + !$omp private(i,j,k) + do k=1,maxk + do j=1,nj + do i=1,ni + dum1(i,j,k) = p3o(i,j,k,19) + enddo + enddo + enddo + call writes(dum1,fnum,srec,nwrite,nloop,dat1,dat2,dat3,reqt,myi1p,myi2p,myj1p,myj2p,ncid,time_index,name_output(n_out),sigma,zs,zh,dum9) + + n_out = n_out + 1 + name_output(n_out) = 'p3_dhmax5' + desc_output(n_out) = 'P3: max. hail size, ice category 5' + unit_output(n_out) = 'm' + grid_output(n_out) = 's' ! s=scalar pts (3d) ; u=u pts (3d) ; v=v pts (3d) ; w=w pts (3d) ; 2=2d scalar pts + + !$omp parallel do default(shared) & + !$omp private(i,j,k) + do k=1,maxk + do j=1,nj + do i=1,ni + dum1(i,j,k) = p3o(i,j,k,20) + enddo + enddo + enddo + call writes(dum1,fnum,srec,nwrite,nloop,dat1,dat2,dat3,reqt,myi1p,myi2p,myj1p,myj2p,ncid,time_index,name_output(n_out),sigma,zs,zh,dum9) + endif + endif + ENDIF + + !............................................. + + IF( imoist.eq.1 .and. numq.gt.1 )THEN + if (output_q.eq.1) then + if (ptype.eq.65 .or. ptype.eq.67) then + n_out = n_out + 1 + name_output(n_out) = 'p3_vmi6' + desc_output(n_out) = 'P3: mass-weighted mean fallspeed, ice category 6' + unit_output(n_out) = 'm/s' + grid_output(n_out) = 's' ! s=scalar pts (3d) ; u=u pts (3d) ; v=v pts (3d) ; w=w pts (3d) ; 2=2d scalar pts + + !$omp parallel do default(shared) & + !$omp private(i,j,k) + do k=1,maxk + do j=1,nj + do i=1,ni + dum1(i,j,k) = p3o(i,j,k,21) + enddo + enddo + enddo + call writes(dum1,fnum,srec,nwrite,nloop,dat1,dat2,dat3,reqt,myi1p,myi2p,myj1p,myj2p,ncid,time_index,name_output(n_out),sigma,zs,zh,dum9) + + n_out = n_out + 1 + name_output(n_out) = 'p3_dmi6' + desc_output(n_out) = 'P3: mass-weighted mean diameter, ice category 6' + unit_output(n_out) = 'm' + grid_output(n_out) = 's' ! s=scalar pts (3d) ; u=u pts (3d) ; v=v pts (3d) ; w=w pts (3d) ; 2=2d scalar pts + + !$omp parallel do default(shared) & + !$omp private(i,j,k) + do k=1,maxk + do j=1,nj + do i=1,ni + dum1(i,j,k) = p3o(i,j,k,22) + enddo + enddo + enddo + call writes(dum1,fnum,srec,nwrite,nloop,dat1,dat2,dat3,reqt,myi1p,myi2p,myj1p,myj2p,ncid,time_index,name_output(n_out),sigma,zs,zh,dum9) + + n_out = n_out + 1 + name_output(n_out) = 'p3_rhoi6' + desc_output(n_out) = 'P3: mean ice density, ice category 6' + unit_output(n_out) = 'kg/m3' + grid_output(n_out) = 's' ! s=scalar pts (3d) ; u=u pts (3d) ; v=v pts (3d) ; w=w pts (3d) ; 2=2d scalar pts + + !$omp parallel do default(shared) & + !$omp private(i,j,k) + do k=1,maxk + do j=1,nj + do i=1,ni + dum1(i,j,k) = p3o(i,j,k,23) + enddo + enddo + enddo + call writes(dum1,fnum,srec,nwrite,nloop,dat1,dat2,dat3,reqt,myi1p,myi2p,myj1p,myj2p,ncid,time_index,name_output(n_out),sigma,zs,zh,dum9) + + n_out = n_out + 1 + name_output(n_out) = 'p3_dhmax6' + desc_output(n_out) = 'P3: max. hail size, ice category 6' + unit_output(n_out) = 'm' + grid_output(n_out) = 's' ! s=scalar pts (3d) ; u=u pts (3d) ; v=v pts (3d) ; w=w pts (3d) ; 2=2d scalar pts + + !$omp parallel do default(shared) & + !$omp private(i,j,k) + do k=1,maxk + do j=1,nj + do i=1,ni + dum1(i,j,k) = p3o(i,j,k,24) + enddo + enddo + enddo + call writes(dum1,fnum,srec,nwrite,nloop,dat1,dat2,dat3,reqt,myi1p,myi2p,myj1p,myj2p,ncid,time_index,name_output(n_out),sigma,zs,zh,dum9) + endif + endif + ENDIF + ! end P3 diagnostics !-------------------------------------------------------------------------------- ! begin ISHMAEL diagnostics @@ -6841,11 +7048,11 @@ subroutine writeout(srec,urec,vrec,wrec,mrec,rtime,dt,fnum,nwrite,qname,qunit, grid_output(n_out) = 'u' ! s=scalar pts (3d) ; u=u pts (3d) ; v=v pts (3d) ; w=w pts (3d) ; 2=2d scalar pts IF ( output_uv_ground == 0 ) THEN - + call writeu( ua ,unum,urec,nwrite,nloop,dat1,dat2,dat3,reqt,myi1p,myi2p,myj1p,myj2p,ncid,time_index,name_output(n_out)) - + ELSE - + do k=1,maxk do j=1,nj do i=1,ni+1 @@ -6853,9 +7060,9 @@ subroutine writeout(srec,urec,vrec,wrec,mrec,rtime,dt,fnum,nwrite,qname,qunit, enddo enddo enddo - + call writeu(dumu,unum,urec,nwrite,nloop,dat1,dat2,dat3,reqt,myi1p,myi2p,myj1p,myj2p,ncid,time_index,name_output(n_out)) - + ENDIF endif @@ -7317,11 +7524,11 @@ subroutine writeout(srec,urec,vrec,wrec,mrec,rtime,dt,fnum,nwrite,qname,qunit, grid_output(n_out) = 'v' ! s=scalar pts (3d) ; u=u pts (3d) ; v=v pts (3d) ; w=w pts (3d) ; 2=2d scalar pts IF ( output_uv_ground == 0 ) THEN - + call writev( va ,vnum,vrec,nwrite,nloop,dat1,dat2,dat3,reqt,myi1p,myi2p,myj1p,myj2p,ncid,time_index,name_output(n_out)) - + ELSE - + do k=1,maxk do j=1,nj+1 do i=1,ni @@ -7329,9 +7536,9 @@ subroutine writeout(srec,urec,vrec,wrec,mrec,rtime,dt,fnum,nwrite,qname,qunit, enddo enddo enddo - + call writev(dumv,vnum,vrec,nwrite,nloop,dat1,dat2,dat3,reqt,myi1p,myi2p,myj1p,myj2p,ncid,time_index,name_output(n_out)) - + ENDIF endif @@ -9167,7 +9374,7 @@ subroutine writeocomm3(numi,numj,numk1,numk2,ngxy,d2i,d2j,d3i,d3j,d3n,d3t,nodele enddo ! wait for data to arrive: - ntot = ppnode-1 + nodes-1 + ntot = ppnode-1 + nodes-1 do nn=1,ntot call mpi_waitany(ntot,reqt(1:ntot),index,MPI_STATUS_IGNORE,ierr) if( index.le.(ppnode-1) )then