From 61e58aa1ed96849ce0b2114b1b0fdab3971fe097 Mon Sep 17 00:00:00 2001 From: Sina Khani Date: Fri, 29 May 2026 16:21:20 -0400 Subject: [PATCH 01/40] To match the default values of SS_FOUND in ImportSpec from OpenWater and SeaiceInterface --- .../GEOSsaltwater_GridComp/GEOS_OpenWaterGridComp.F90 | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSsaltwater_GridComp/GEOS_OpenWaterGridComp.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSsaltwater_GridComp/GEOS_OpenWaterGridComp.F90 index 0f4ba9e7d8..6e6df781f3 100644 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSsaltwater_GridComp/GEOS_OpenWaterGridComp.F90 +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSsaltwater_GridComp/GEOS_OpenWaterGridComp.F90 @@ -1298,7 +1298,7 @@ subroutine SetServices ( GC, RC ) UNITS = 'PSU', & DIMS = MAPL_DimsTileOnly, & VLOCATION = MAPL_VLocationNone, & - DEFAULT = 30.0, & + DEFAULT = 33.3333, & !SK - Match the SS_FOUND in OpenWater and SeaiceInterface _RC) call MAPL_AddImportSpec(GC, & From 51bcdff15bc5802d881877e7d9e52fdfab1fc028 Mon Sep 17 00:00:00 2001 From: biljanaorescanin Date: Mon, 1 Jun 2026 09:31:48 -0400 Subject: [PATCH 02/40] add python for plotting and update readme --- .../Utils/Raster/makebcs/clsm_plots.py | 3025 +++++++++++++++++ .../Utils/Raster/makebcs/create_README.csh | 28 +- 2 files changed, 3043 insertions(+), 10 deletions(-) create mode 100755 GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/makebcs/clsm_plots.py diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/makebcs/clsm_plots.py b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/makebcs/clsm_plots.py new file mode 100755 index 0000000000..e1d625d022 --- /dev/null +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/makebcs/clsm_plots.py @@ -0,0 +1,3025 @@ +#!/usr/bin/env python3 +""" +Drop-in Python replacement for GEOS makebcs clsm_plots.pro. + +This script is intended to be run from the same place the IDL driver was run +(usually clsm/plots). With no arguments it reads $gfile, $workdir, $NC, and +$NR and writes the standard plot products into the current directory. + +Typical first run from clsm/plots: + + python clsm_plots.py \ + --gfile "$gfile" --workdir "$workdir" --nc "$NC" --nr "$NR" \ + --plots default --outdir . + +Notes: + * F77 unformatted files are read as sequential records with 4-byte record + markers by default. Use --endian/--record-marker if your files differ. + * Cartopy is optional. If available, this script can draw coastlines with + --coastlines. Otherwise plots are still generated with lon/lat axes. + * Movie generation is optional and potentially slow; use --plots movies or + --plots default. +""" +from __future__ import annotations + +import argparse +import dataclasses +import datetime as _dt +import glob +import math +import os +import sys +import re +import shutil +import subprocess +from pathlib import Path +from typing import Callable, Dict, Iterable, Iterator, List, Mapping, Optional, Sequence, Tuple + +import numpy as np + +import matplotlib +matplotlib.use("Agg") +import matplotlib.pyplot as plt +from matplotlib.colors import BoundaryNorm, ListedColormap +from matplotlib.cm import ScalarMappable +from matplotlib.collections import LineCollection +from matplotlib.ticker import FixedLocator, FixedFormatter + +try: + from scipy import sparse as sp_sparse # type: ignore +except Exception: # pragma: no cover - optional on Discover modules + sp_sparse = None + +try: + from scipy.stats import mode as scipy_mode # type: ignore +except Exception: # pragma: no cover + scipy_mode = None + +try: + import imageio.v2 as imageio # type: ignore +except Exception: # pragma: no cover + imageio = None + + +class FFMpegPipeWriter: + """Small MP4 writer that pipes RGB frames to the system ffmpeg executable. + + Discover's GEOSpyD imageio package may not include the imageio-ffmpeg plugin, + even when the shell ffmpeg module is available. Calling ffmpeg through + subprocess avoids that Python plugin dependency. Load the module with + + module load ffmpeg/5.0 + + or set CLSM_FFMPEG=/path/to/ffmpeg before running. + """ + + def __init__(self, outpath: Path, fps: int = 10): + self.outpath = Path(outpath) + self.fps = int(fps) + self.proc: Optional[subprocess.Popen] = None + self.width: Optional[int] = None + self.height: Optional[int] = None + + def __enter__(self): + self.outpath.parent.mkdir(parents=True, exist_ok=True) + return self + + def __exit__(self, exc_type, exc, tb): + if exc_type is not None: + if self.proc is not None and self.proc.poll() is None: + try: + self.proc.kill() + except Exception: + pass + return False + self.close() + return False + + @staticmethod + def _ffmpeg_exe() -> str: + explicit = os.environ.get("CLSM_FFMPEG") + if explicit: + p = Path(explicit).expanduser() + if p.exists(): + return str(p) + exe = shutil.which("ffmpeg") + if exe: + return exe + # Useful Discover fallback if the module path is present but PATH was not + # updated for some reason. The preferred route is still module load. + fallback = Path("/usr/local/other/ffmpeg/5.0/bin/ffmpeg") + if fallback.exists(): + return str(fallback) + raise ClsmPlotError( + "ffmpeg executable not found. Load it with `module load ffmpeg/5.0` " + "or set CLSM_FFMPEG=/path/to/ffmpeg before requesting movies." + ) + + @staticmethod + def _as_rgb_uint8(frame: np.ndarray) -> np.ndarray: + arr = np.asarray(frame) + if arr.ndim == 2: + arr = np.repeat(arr[:, :, None], 3, axis=2) + if arr.ndim != 3 or arr.shape[2] not in (3, 4): + raise ClsmPlotError(f"Movie frame must be HxWx3 or HxWx4, got shape {arr.shape}") + arr = arr[:, :, :3] + if arr.dtype != np.uint8: + arr = arr.astype(np.float32, copy=False) + if np.nanmax(arr) <= 1.0: + arr = arr * 255.0 + arr = np.nan_to_num(arr, nan=255.0, posinf=255.0, neginf=0.0) + arr = np.clip(arr, 0.0, 255.0).astype(np.uint8) + + # H.264 with yuv420p requires even frame dimensions. Adding the movie + # colorbar changed the canvas to 780x585 on Discover, which made + # ffmpeg reject the stream ("height not divisible by 2"). Pad, rather + # than crop, so no tick labels/colorbar pixels are lost. Use white + # padding to match the figure background. + h, w = arr.shape[:2] + new_h = h + (h % 2) + new_w = w + (w % 2) + if new_h != h or new_w != w: + padded = np.full((new_h, new_w, 3), 255, dtype=np.uint8) + padded[:h, :w, :] = arr + arr = padded + return np.ascontiguousarray(arr) + + def _start(self, frame: np.ndarray) -> None: + h, w = frame.shape[:2] + self.height, self.width = int(h), int(w) + ffmpeg = self._ffmpeg_exe() + cmd = [ + ffmpeg, + "-y", + "-loglevel", "error", + "-f", "rawvideo", + "-vcodec", "rawvideo", + "-pix_fmt", "rgb24", + "-s", f"{self.width}x{self.height}", + "-r", str(self.fps), + "-i", "-", + "-an", + "-vcodec", "libx264", + "-preset", "medium", + "-crf", "18", + "-pix_fmt", "yuv420p", + str(self.outpath), + ] + self.proc = subprocess.Popen( + cmd, + stdin=subprocess.PIPE, + stdout=subprocess.DEVNULL, + stderr=subprocess.PIPE, + ) + + def append_data(self, frame: np.ndarray) -> None: + rgb = self._as_rgb_uint8(frame) + if self.proc is None: + self._start(rgb) + if rgb.shape[0] != self.height or rgb.shape[1] != self.width: + raise ClsmPlotError( + f"Movie frame size changed from {self.width}x{self.height} " + f"to {rgb.shape[1]}x{rgb.shape[0]}" + ) + assert self.proc is not None and self.proc.stdin is not None + try: + self.proc.stdin.write(rgb.tobytes()) + except BrokenPipeError as exc: + err = b"" + if self.proc.stderr is not None: + err = self.proc.stderr.read() + raise ClsmPlotError(f"ffmpeg pipe closed while writing {self.outpath}: {err.decode(errors='replace')}") from exc + + def close(self) -> None: + if self.proc is None: + return + assert self.proc.stdin is not None + self.proc.stdin.close() + ret = self.proc.wait() + err = b"" + if self.proc.stderr is not None: + err = self.proc.stderr.read() + if ret != 0: + raise ClsmPlotError( + f"ffmpeg failed while writing {self.outpath} with exit code {ret}: " + f"{err.decode(errors='replace')}" + ) + + +def open_mp4_writer(outpath: Path, fps: int = 10): + """Open an MP4 writer. Uses system ffmpeg, not imageio-ffmpeg.""" + return FFMpegPipeWriter(Path(outpath), fps=fps) + +try: + import xarray as xr # type: ignore +except Exception: # pragma: no cover + xr = None + +try: + import cartopy.crs as ccrs # type: ignore + import cartopy.feature as cfeature # type: ignore + from cartopy.mpl.ticker import LongitudeFormatter, LatitudeFormatter # type: ignore +except Exception: # pragma: no cover + ccrs = None + cfeature = None + LongitudeFormatter = None + LatitudeFormatter = None + + +# ----------------------------------------------------------------------------- +# IDL-compatible color tables +# ----------------------------------------------------------------------------- + + +def _as_rgb(rows: Sequence[Sequence[int]]) -> np.ndarray: + return np.asarray(rows, dtype=np.float32) / 255.0 + + +def idl_palette() -> np.ndarray: + """Return a 256 x 3 RGB palette approximating load_colors.pro.""" + rgb = np.ones((256, 3), dtype=np.float32) + + def put(start: int, r: Sequence[int], g: Sequence[int], b: Sequence[int]) -> None: + n = len(r) + rgb[start:start + n, 0] = np.asarray(r) / 255.0 + rgb[start:start + n, 1] = np.asarray(g) / 255.0 + rgb[start:start + n, 2] = np.asarray(b) / 255.0 + + r_drought = [0, 0, 0, 0, 47, 200, 255, 255, 255, 255, 249, 197] + g_drought = [0, 115, 159, 210, 255, 255, 255, 255, 219, 157, 0, 0] + b_drought = [0, 0, 0, 0, 67, 130, 255, 0, 0, 0, 0, 0] + put(0, r_drought, g_drought, b_drought) + + r_green = [200, 150, 47, 60, 0, 0, 0, 0] + g_green = [255, 255, 255, 230, 219, 187, 159, 131] + b_green = [200, 150, 67, 15, 0, 0, 0, 0] + put(20, r_green, g_green, b_green) + + r_blue = [55, 0, 0, 0, 0, 0, 0, 0, 0, 0] + g_blue = [255, 255, 227, 195, 167, 115, 83, 0, 0, 0] + b_blue = [199, 255, 255, 255, 255, 255, 255, 255, 200, 130] + put(30, r_blue, g_blue, b_blue) + + r_red = [255, 240, 255, 255, 255, 255, 255, 233, 197] + g_red = [255, 255, 219, 187, 159, 131, 51, 23, 0] + b_red = [153, 15, 0, 0, 0, 0, 0, 0, 0] + put(40, r_red, g_red, b_red) + + r_grey = [245, 225, 205, 185, 165, 145, 125, 105, 85] + g_grey = [245, 225, 205, 185, 165, 145, 125, 105, 85] + b_grey = [245, 225, 205, 185, 165, 145, 125, 105, 85] + put(50, r_grey, g_grey, b_grey) + + r_type = [255, 106, 202, 251, 0, 29, 77, 109, 142, 233, 255, 255, 255, 127, 164, 164, 217, 217, 204, 104, 0] + g_type = [245, 91, 178, 154, 85, 115, 145, 165, 185, 23, 131, 131, 191, 39, 53, 53, 72, 72, 204, 104, 70] + b_type = [215, 154, 214, 153, 0, 0, 0, 0, 13, 0, 0, 200, 0, 4, 3, 200, 1, 200, 204, 200, 200] + put(60, r_type, g_type, b_type) + + r_lct2 = [0, 0, 0, 0, 0, 0, 0, 0, 0, 55, 120, 190, 240, 255, 255, 255, 255, 255, 233, 197, 158] + g_lct2 = [0, 0, 0, 83, 115, 167, 195, 227, 255, 255, 255, 255, 255, 219, 187, 159, 131, 51, 23, 0, 0] + b_lct2 = [130, 200, 255, 255, 255, 255, 255, 255, 255, 199, 135, 67, 15, 0, 0, 0, 0, 0, 0, 0, 0] + put(140, r_lct2, g_lct2, b_lct2) + + r_veg = [233, 255, 255, 255, 210, 0, 0, 0, 204, 170, 255, 220, 205, 0, 0, 170, 0, 40, 120, 140, 190, 150, 255, 255, 0, 0, 0, 195, 255, 0] + g_veg = [23, 131, 191, 255, 255, 255, 155, 0, 204, 240, 255, 240, 205, 100, 160, 200, 60, 100, 130, 160, 150, 100, 180, 235, 120, 150, 220, 20, 245, 70] + b_veg = [0, 0, 0, 178, 255, 255, 255, 200, 204, 240, 100, 100, 102, 0, 0, 0, 0, 0, 0, 0, 0, 0, 50, 175, 90, 120, 130, 0, 215, 200] + put(90, r_veg, g_veg, b_veg) + + r_grads_rb = [160, 110, 30, 0, 0, 0, 0, 160, 230, 230, 240, 250, 240] + g_grads_rb = [0, 0, 60, 150, 200, 210, 220, 230, 220, 175, 130, 60, 0] + b_grads_rb = [200, 220, 255, 255, 200, 140, 0, 50, 50, 45, 40, 60, 130] + put(120, r_grads_rb, g_grads_rb, b_grads_rb) + + rgb[255] = (1.0, 1.0, 1.0) + return rgb + + +PALETTE = idl_palette() +CONTINUOUS_COLOR_IDS = [27, 26, 25, 24, 23, 22, 21, 20, 40, 41, 42, 43, 44, 45, 46, 47, 48] +LAI_RGB = _as_rgb([ + [253, 253, 253], [224, 238, 224], [255, 255, 0], [238, 238, 0], + [205, 205, 0], [193, 255, 193], [152, 251, 152], [0, 255, 127], + [124, 252, 0], [0, 255, 0], [0, 238, 0], [0, 205, 0], + [0, 139, 0], [0, 128, 0], [0, 100, 0], [48, 128, 20], + [110, 139, 61], [85, 107, 47], +]) +LAI_LEVELS = np.asarray([0.0, 0.25, 0.5, 0.75, 1.0, 1.25, 1.5] + list(np.arange(11) * 0.5 + 2.0), dtype=np.float32) + +# Fraction-style seasonal diagnostics (GREEN and NDVI). These reuse the +# working LAI/GREEN movie time-series reader, but use a 0..1 scale. +FRACTION_LEVELS = np.asarray([ + 0.0, 0.025, 0.05, 0.075, 0.10, 0.125, 0.15, 0.20, + 0.30, 0.35, 0.40, 0.45, 0.50, 0.60, 0.70, 0.80, 0.90, 1.00 +], dtype=np.float32) +FRACTION_TICKS = np.asarray([0.0, 0.1, 0.2, 0.4, 0.6, 0.8, 1.0], dtype=float) +FRACTION_TICK_LABELS = ["0", "0.1", "0.2", "0.4", "0.6", "0.8", "1"] + +# IDL Z0 levels used by compute_zo for ascat/icarus/merged. Keep +# labels as strings so matplotlib cannot round the sub-1 bins to repeated +# ``0`` labels on the horizontal colorbar. +Z0_LEVELS = np.asarray([ + 0.02, 0.05, 0.07, 0.10, 0.30, 0.50, + 1.0, 2.0, 4.0, 6.0, 8.0, 10.0, + 50.0, 100.0, 500.0, 1000.0, 2000.0, 3000.0, 4000.0, 5000.0, +], dtype=np.float32) +Z0_TICK_LABELS = [ + "≤0.02", "0.05", "0.07", "0.10", "0.30", "0.50", + "1", "2", "4", "6", "8", "10", + "50", "100", "500", "1000", "2000", "3000", "4000", "5000", +] +Z0_COLOR_IDS = [74, 77, 35, 34, 33, 32, 25, 24, 23, 22, 21, 20, 41, 42, 43, 44, 45, 46, 47, 48] + +# User-tunable output quality for static JPG products. These are set from +# --dpi and --jpeg-quality in main(). +PLOT_DPI = int(os.environ.get("CLSM_PLOT_DPI", "180")) +JPEG_QUALITY = int(os.environ.get("CLSM_JPEG_QUALITY", "95")) + + +# ----------------------------------------------------------------------------- +# File readers +# ----------------------------------------------------------------------------- + + +class ClsmPlotError(RuntimeError): + pass + + +@dataclasses.dataclass(frozen=True) +class F77Layout: + endian: str = "<" + marker_bytes: int = 4 + + @property + def marker_dtype(self) -> np.dtype: + if self.marker_bytes == 4: + return np.dtype(self.endian + "i4") + if self.marker_bytes == 8: + return np.dtype(self.endian + "i8") + raise ValueError("record markers must be 4 or 8 bytes") + + + + +@dataclasses.dataclass(frozen=True) +class TimeSeriesLayout: + """Layout for LAI/GREEN/NDVI-style seasonal time series files. + + Most make_bcs files are F77 sequential records with a 9-value header + record followed by an ncat-value data record. Some completed BCS trees + expose renamed/symlinked files whose first header record is double + precision, and a few test copies may be raw streams. + """ + mode: str = "f77" + endian: str = "<" + marker_bytes: int = 4 + header_dtype: str = "f4" + value_dtype: str = "f4" + + @property + def f77_layout(self) -> F77Layout: + return F77Layout(self.endian, self.marker_bytes) + + +class TimeSeriesReader: + def __init__(self, path: Path, layout: TimeSeriesLayout, ncat: int): + self.path = Path(path) + self.layout = layout + self.ncat = int(ncat) + self.rdr = None + self.fh = None + + def __enter__(self) -> "TimeSeriesReader": + if self.layout.mode == "f77": + self.rdr = FortranSequentialReader(self.path, self.layout.f77_layout) + else: + self.fh = self.path.open("rb") + return self + + def __exit__(self, exc_type, exc, tb) -> None: # type: ignore[override] + if self.rdr is not None: + self.rdr.close() + if self.fh is not None: + self.fh.close() + + def _dt(self, kind: str) -> np.dtype: + return np.dtype(self.layout.endian + kind) + + def read_record(self) -> Tuple[np.ndarray, np.ndarray]: + hdt = self._dt(self.layout.header_dtype) + vdt = self._dt(self.layout.value_dtype) + if self.layout.mode == "f77": + if self.rdr is None: + raise ClsmPlotError("TimeSeriesReader not opened") + hpayload = self.rdr.read_record_bytes() + header = np.frombuffer(hpayload, dtype=hdt) + if header.size < 9: + raise ClsmPlotError(f"header record in {self.path} has {header.size} values, expected at least 9") + vpayload = self.rdr.read_record_bytes() + values = np.frombuffer(vpayload, dtype=vdt) + if values.size != self.ncat: + raise ClsmPlotError(f"data record in {self.path} has {values.size} values, expected {self.ncat}") + # IDL only reads the first 9 values from the header record. Extra + # fields may be present in finalized lai_clim/green/ndvi files. + return header[:9].astype(np.float64).copy(), values.astype(np.float32).copy() + if self.fh is None: + raise ClsmPlotError("TimeSeriesReader not opened") + hbytes = self.fh.read(9 * hdt.itemsize) + if not hbytes: + raise EOFError(f"end of file in {self.path}") + if len(hbytes) != 9 * hdt.itemsize: + raise ClsmPlotError(f"short raw header in {self.path}") + vbytes = self.fh.read(self.ncat * vdt.itemsize) + if len(vbytes) != self.ncat * vdt.itemsize: + raise ClsmPlotError(f"short raw data record in {self.path}") + return np.frombuffer(hbytes, dtype=hdt).astype(np.float64).copy(), np.frombuffer(vbytes, dtype=vdt).astype(np.float32).copy() + + +def detect_timeseries_layout(path: Path, ncat: int) -> TimeSeriesLayout: + path = Path(path) + head = path.read_bytes()[:128] + # F77 sequential: IDL reads the first 9 floats from each header record: + # readu,1,yr,mn,dy,dum,dum,dum,yr1,mn1,dy1 + # In finished BCS trees the header record can contain more than those 9 + # values. For example lai_clim_* often starts with a 56-byte record, i.e. + # 14 float32 values: the first 9 are the dates and the remaining values are + # metadata. Therefore accept any float32/float64 header record with at least + # 9 values, then verify that the following data record has ncat values. + for marker_bytes in (4, 8): + for endian in ("<", ">"): + if len(head) < marker_bytes: + continue + mdtype = np.dtype(endian + ("i4" if marker_bytes == 4 else "i8")) + nhead = int(np.frombuffer(head[:marker_bytes], dtype=mdtype)[0]) + if nhead <= 0: + continue + for hkind, hsize in (("f4", 4), ("f8", 8)): + if nhead % hsize != 0 or nhead < 9 * hsize: + continue + try: + with FortranSequentialReader(path, F77Layout(endian, marker_bytes)) as rdr: + hpayload = rdr.read_record_bytes() + header = np.frombuffer(hpayload, dtype=np.dtype(endian + hkind)) + if header.size < 9: + continue + # Simple sanity check for the date fields read by IDL. + # year offsets are usually 0/1/2, months 1..12, days 1..31. + if not (0 <= float(header[1]) <= 12 and 0 <= float(header[7]) <= 12): + continue + vpayload = rdr.read_record_bytes() + if len(vpayload) == int(ncat) * 4: + print(f"Detected time-series layout for {path.name}: mode=f77 endian={endian} marker={marker_bytes} header_values={header.size} header_dtype={hkind} value_dtype=f4") + return TimeSeriesLayout("f77", endian, marker_bytes, hkind, "f4") + if len(vpayload) == int(ncat) * 8: + print(f"Detected time-series layout for {path.name}: mode=f77 endian={endian} marker={marker_bytes} header_values={header.size} header_dtype={hkind} value_dtype=f8") + return TimeSeriesLayout("f77", endian, marker_bytes, hkind, "f8") + except Exception: + pass + # Raw fallback: header/data/header/data with no F77 markers. Accept both + # the exact IDL 9-value header and the 14-value extended header. + size = path.stat().st_size + for nheader in (9, 14): + rec4 = (nheader + int(ncat)) * 4 + rec8 = (nheader + int(ncat)) * 8 + if rec4 > 0 and size % rec4 == 0: + print(f"Detected time-series layout for {path.name}: mode=raw header_values={nheader} dtype=f4") + return TimeSeriesLayout("raw", "<", 0, "f4", "f4") + if rec8 > 0 and size % rec8 == 0: + print(f"Detected time-series layout for {path.name}: mode=raw header_values={nheader} dtype=f8") + return TimeSeriesLayout("raw", "<", 0, "f8", "f8") + raise ClsmPlotError( + f"Could not detect LAI/GREEN/NDVI time-series layout for {path}. " + "Expected an F77 header record with at least 9 float values followed by an ncat-value record, " + "or a raw stream of header+ncat float values." + ) + + +def choose_timeseries_layout(path: Path, ncat: int, endian: str = "auto", marker_bytes: int = 0) -> TimeSeriesLayout: + # Auto is safest because finished-layout symlinks can expose f4 or f8 headers. + if endian == "auto" or marker_bytes == 0: + return detect_timeseries_layout(path, ncat) + endian_char = "<" if endian in ("little", "<") else ">" + # Try single-precision first; detect_timeseries_layout will still be used + # if this explicit guess is wrong in the caller. + return TimeSeriesLayout("f77", endian_char, marker_bytes, "f4", "f4") + +class FortranSequentialReader: + """Read F77 sequential unformatted records.""" + + def __init__(self, path: Path, layout: F77Layout): + self.path = Path(path) + self.layout = layout + self.fh = self.path.open("rb") + + def close(self) -> None: + self.fh.close() + + def __enter__(self) -> "FortranSequentialReader": + return self + + def __exit__(self, exc_type, exc, tb) -> None: # type: ignore[override] + self.close() + + def read_record_bytes(self) -> bytes: + m = self.layout.marker_bytes + start = self.fh.read(m) + if not start: + raise EOFError(f"end of file in {self.path}") + if len(start) != m: + raise ClsmPlotError(f"short F77 record marker in {self.path}") + nbytes = int(np.frombuffer(start, dtype=self.layout.marker_dtype)[0]) + if nbytes < 0: + raise ClsmPlotError(f"negative F77 record length {nbytes} in {self.path}") + payload = self.fh.read(nbytes) + if len(payload) != nbytes: + raise ClsmPlotError(f"short F77 record payload in {self.path}: wanted {nbytes}, got {len(payload)}") + end = self.fh.read(m) + if len(end) != m: + raise ClsmPlotError(f"short trailing F77 record marker in {self.path}") + end_nbytes = int(np.frombuffer(end, dtype=self.layout.marker_dtype)[0]) + if end_nbytes != nbytes: + raise ClsmPlotError( + f"F77 marker mismatch in {self.path}: leading={nbytes}, trailing={end_nbytes}" + ) + return payload + + def read_array(self, dtype: np.dtype | str, count: Optional[int] = None) -> np.ndarray: + payload = self.read_record_bytes() + dt = np.dtype(dtype).newbyteorder(self.layout.endian) + arr = np.frombuffer(payload, dtype=dt) + if count is not None and arr.size != count: + raise ClsmPlotError( + f"record in {self.path} has {arr.size} values of {dt}, expected {count}" + ) + return arr.copy() + + +def detect_f77_layout(path: Path, expected_payload_bytes: int) -> F77Layout: + head = Path(path).read_bytes()[:32] + for marker_bytes in (4, 8): + for endian in ("<", ">"): + if len(head) < marker_bytes: + continue + dtype = np.dtype(endian + ("i4" if marker_bytes == 4 else "i8")) + n = int(np.frombuffer(head[:marker_bytes], dtype=dtype)[0]) + if n == expected_payload_bytes: + return F77Layout(endian=endian, marker_bytes=marker_bytes) + raise ClsmPlotError( + f"Could not detect F77 layout for {path}. Expected first record payload " + f"{expected_payload_bytes} bytes. Try --endian little|big and/or --record-marker." + ) + + +def choose_layout(path: Path, expected_payload_bytes: int, endian: str, marker_bytes: int) -> F77Layout: + if endian == "auto" or marker_bytes == 0: + return detect_f77_layout(path, expected_payload_bytes) + endian_char = "<" if endian in ("little", "<") else ">" + return F77Layout(endian=endian_char, marker_bytes=marker_bytes) + + +def is_netcdf(path: Path) -> bool: + try: + magic = Path(path).read_bytes()[:8] + except FileNotFoundError: + return False + return magic.startswith(b"CDF") or magic.startswith(b"\x89HDF\r\n\x1a\n") + + +def load_ascii_table(path: Path, skiprows: int = 0, min_cols: Optional[int] = None) -> np.ndarray: + if not path.exists(): + raise ClsmPlotError(f"Missing required file: {path}") + arr = np.loadtxt(path, comments="#", skiprows=skiprows) + if arr.ndim == 1: + arr = arr.reshape(1, -1) + if min_cols is not None and arr.shape[1] < min_cols: + raise ClsmPlotError(f"{path} has {arr.shape[1]} columns; expected at least {min_cols}") + return arr + + +def read_ncat(base_dir: Path) -> int: + path = base_dir / "catchment.def" + if not path.exists(): + raise ClsmPlotError(f"Missing catchment definition: {path}") + with path.open("r") as fh: + first = fh.readline().split() + if not first: + raise ClsmPlotError(f"Empty catchment definition: {path}") + return int(float(first[0])) + + +def read_limits(base_dir: Path, gfile: str) -> Tuple[float, float, float, float]: + """Return IDL-style default map limits as (min_lat, min_lon, max_lat, max_lon).""" + default = (-60.0, -180.0, 90.0, 180.0) + if "Pfafstetter" in gfile or "SMAP" in gfile: + return default + path = base_dir / "catchment.def" + try: + rows = load_ascii_table(path, skiprows=1, min_cols=6) + except Exception: + return default + min_lon = np.nanmin(rows[:, 2]) + max_lon = np.nanmax(rows[:, 3]) + min_lat = np.nanmin(rows[:, 4]) + max_lat = np.nanmax(rows[:, 5]) + if math.ceil(max_lon) - math.floor(min_lon) < 180: + return (math.floor(min_lat), math.floor(min_lon), math.ceil(max_lat), math.ceil(max_lon)) + return default + + + +def list_rst_files(workdir: Path, gfile: str, explicit_rst_file: Optional[str] = None) -> List[Path]: + """Return candidate rst files. + + IDL used a wildcard, ``/rst/*.rst``. For EASE grids this + can include several companion rasters, for example the pure EASE raster and + the EASE/Pfafstetter combined raster. The combined raster is often the one + that maps pixels to the CLSM/catchment tile IDs used by ``catchment.def``. + + Therefore do *not* discard filenames containing ``Pfafstetter`` here. Keep + every ``*.rst`` candidate and let ``select_rst_file`` score which one + actually behaves like a geographic CLSM tile-id raster. The user can still + force any file with ``--rst-file``. + """ + if explicit_rst_file: + p = Path(explicit_rst_file).expanduser() + if not p.is_absolute(): + p = Path.cwd() / p + if not p.exists(): + raise ClsmPlotError(f"Explicit --rst-file does not exist: {p}") + return [p.resolve()] + + rst_dir = workdir / "rst" + pattern = str(rst_dir / f"{gfile}*.rst") + matches = [Path(m).resolve() for m in sorted(glob.glob(pattern))] + if not matches: + raise ClsmPlotError(f"No restart/raster file matched {pattern}") + + # Stable unique order. + seen = set() + out: List[Path] = [] + for m in matches: + if m not in seen: + seen.add(m) + out.append(m) + return out + + +@dataclasses.dataclass(frozen=True) +class RstCandidateScore: + path: Path + layout: F77Layout + valid_fraction: float + valid_count: int + sample_count: int + min_value: int + max_value: int + first_valid_row: int + last_valid_row: int + valid_row_count: int + sampled_row_count: int + + @property + def row_span_fraction(self) -> float: + if self.first_valid_row < 0 or self.last_valid_row < 0 or self.sampled_row_count <= 1: + return 0.0 + return float(self.last_valid_row - self.first_valid_row) / float(max(1, self.sampled_row_count - 1)) + + +def sample_rst_candidate( + path: Path, + nc: int, + nr: int, + ncat: int, + endian: str, + marker_bytes: int, + sample_rows: int = 144, +) -> RstCandidateScore: + """Sample an rst candidate and summarize whether it looks like CLSM tile IDs. + + A misleading raster can contain many values in 1..ncat but only over a narrow + projected band when interpreted as lon/lat. The original IDL maps are + geographic/global, so for global grids the correct raster should have valid + land rows spread across much of the sampled row range. We therefore record + both the number of valid tile IDs and the sampled row span. + """ + layout = choose_layout(path, nc * 4, endian, marker_bytes) + record_bytes = layout.marker_bytes + nc * 4 + layout.marker_bytes + row_ids = np.unique(np.linspace(0, nr - 1, min(sample_rows, nr), dtype=np.int64)) + valid_count = 0 + sample_count = 0 + min_val: Optional[int] = None + max_val: Optional[int] = None + first_valid_idx = -1 + last_valid_idx = -1 + valid_row_count = 0 + marker_dtype = layout.marker_dtype + data_dtype = np.dtype(layout.endian + "i4") + + with path.open("rb") as fh: + for sample_idx, row in enumerate(row_ids): + fh.seek(int(row) * record_bytes) + marker = fh.read(layout.marker_bytes) + if len(marker) != layout.marker_bytes: + raise ClsmPlotError(f"short marker while sampling {path} row {row}") + nbytes = int(np.frombuffer(marker, dtype=marker_dtype)[0]) + if nbytes != nc * 4: + raise ClsmPlotError( + f"record length mismatch while sampling {path} row {row}: " + f"got {nbytes}, expected {nc * 4}" + ) + payload = fh.read(nc * 4) + if len(payload) != nc * 4: + raise ClsmPlotError(f"short payload while sampling {path} row {row}") + arr = np.frombuffer(payload, dtype=data_dtype) + sample_count += int(arr.size) + valid = (arr >= 1) & (arr <= ncat) + row_valid = int(np.count_nonzero(valid)) + valid_count += row_valid + if row_valid > 0: + if first_valid_idx < 0: + first_valid_idx = sample_idx + last_valid_idx = sample_idx + valid_row_count += 1 + row_min = int(arr.min()) + row_max = int(arr.max()) + min_val = row_min if min_val is None else min(min_val, row_min) + max_val = row_max if max_val is None else max(max_val, row_max) + + frac = float(valid_count) / float(sample_count) if sample_count else 0.0 + return RstCandidateScore( + path=path, + layout=layout, + valid_fraction=frac, + valid_count=valid_count, + sample_count=sample_count, + min_value=int(min_val or 0), + max_value=int(max_val or 0), + first_valid_row=first_valid_idx, + last_valid_row=last_valid_idx, + valid_row_count=valid_row_count, + sampled_row_count=int(len(row_ids)), + ) + + +def select_rst_file( + workdir: Path, + gfile: str, + ncat: int, + nc: int, + nr: int, + endian: str, + marker_bytes: int, + explicit_rst_file: Optional[str] = None, +) -> Tuple[Path, F77Layout]: + """Choose the raster that actually looks like the CLSM tile-id raster.""" + candidates = list_rst_files(workdir, gfile, explicit_rst_file) + if len(candidates) > 1: + print("RST candidates after filtering:") + scored: List[Tuple[float, float, float, int, RstCandidateScore]] = [] + errors: List[str] = [] + for idx, path in enumerate(candidates): + try: + score = sample_rst_candidate(path, nc, nr, ncat, endian, marker_bytes) + # Primary: row span. Secondary: number/fraction of valid tile IDs. + # Keep original order as the final tie breaker. + scored.append((score.row_span_fraction, score.valid_fraction, float(score.valid_count), -idx, score)) + if len(candidates) > 1 or explicit_rst_file: + print( + f" {path.name}: valid_sample={score.valid_count}/{score.sample_count} " + f"({score.valid_fraction:.6f}), valid_rows={score.valid_row_count}/{score.sampled_row_count}, " + f"row_span={score.row_span_fraction:.3f}, min={score.min_value}, max={score.max_value}, " + f"endian={score.layout.endian}, marker={score.layout.marker_bytes}" + ) + except Exception as exc: + errors.append(f"{path.name}: {exc}") + if len(candidates) > 1 or explicit_rst_file: + print(f" {path.name}: skipped ({exc})") + + if not scored: + detail = "\n".join(errors) + raise ClsmPlotError(f"No usable rst files found under {workdir / 'rst'}.\n{detail}") + + # Prefer candidates with the broadest sampled latitude/row coverage. This + # avoids selecting projection/Pfafstetter companion rasters that have valid + # numeric ranges but do not make global geographic plots. + scored.sort(key=lambda item: (-item[0], -item[1], -item[2], -item[3])) + best = scored[0][4] + if best.valid_count == 0: + raise ClsmPlotError( + f"Selected rst candidate has zero values in 1..ncat: {best.path}. " + "Check --gfile/--workdir/--nc/--nr or pass --rst-file explicitly." + ) + if len(candidates) > 1: + print( + f"Selected raster: {best.path} " + f"(row_span={best.row_span_fraction:.3f}, valid_sample_fraction={best.valid_fraction:.6f})" + ) + elif explicit_rst_file: + print( + f"Using explicit raster: {best.path} " + f"(row_span={best.row_span_fraction:.3f}, valid_sample_fraction={best.valid_fraction:.6f})" + ) + else: + print(f"Using raster file: {best.path}") + return best.path, best.layout + +def read_nc_var(path: Path, varname: str) -> np.ndarray: + if xr is None: + raise ClsmPlotError("xarray/netCDF support is not available in this Python environment") + if not path.exists(): + raise ClsmPlotError(f"Missing NetCDF file: {path}") + with xr.open_dataset(path, decode_times=False) as ds: + if varname not in ds: + raise ClsmPlotError(f"Variable {varname!r} not found in {path}. Available: {list(ds.data_vars)}") + return np.asarray(ds[varname].values) + + +# ----------------------------------------------------------------------------- +# Grid and tile tools +# ----------------------------------------------------------------------------- + + +def lon_lat_centers(nc: int, nr: int) -> Tuple[np.ndarray, np.ndarray]: + lon = np.arange(nc, dtype=np.float64) * (360.0 / nc) - 180.0 + 0.5 * (360.0 / nc) + lat = np.arange(nr, dtype=np.float64) * (180.0 / nr) - 90.0 + 0.5 * (180.0 / nr) + return lon, lat + + +def mode_rows_int(blocks: np.ndarray) -> np.ndarray: + """Return the row-wise mode for integer blocks.""" + if blocks.ndim != 2: + raise ValueError("blocks must be 2D") + if blocks.shape[1] == 1: + return blocks[:, 0].astype(np.int32, copy=False) + if scipy_mode is not None: + result = scipy_mode(blocks, axis=1, keepdims=False) + return np.asarray(result.mode, dtype=np.int32) + out = np.empty(blocks.shape[0], dtype=np.int32) + for i, row in enumerate(blocks): + vals, counts = np.unique(row, return_counts=True) + out[i] = vals[np.argmax(counts)] + return out + + +def dominant_land_tile(blocks: np.ndarray, ncat: int) -> np.ndarray: + """IDL-compatible dominant tile selection for a downsampled raster block. + + The IDL code ignores ocean/invalid values when a plotting cell contains at + least one land tile. A naive mode over values with invalid pixels replaced + by zero would let ocean dominate coastal cells, so we first compute a fast + mode and then repair only cells where zero won but valid land is present. + """ + valid = (blocks >= 1) & (blocks <= ncat) + masked = np.where(valid, blocks, 0).astype(np.int32, copy=False) + out = mode_rows_int(masked) + + repair = (out == 0) & valid.any(axis=1) + if np.any(repair): + repair_idx = np.flatnonzero(repair) + for i in repair_idx: + vals, counts = np.unique(blocks[i, valid[i]], return_counts=True) + out[i] = vals[np.argmax(counts)] + return out + + +def build_tile_id_from_rst( + rst_file: Path, + nc: int, + nr: int, + ncat: int, + nc_plot: int, + nr_plot: int, + layout: F77Layout, + cache: Optional[Path] = None, +) -> np.ndarray: + """Build the dominant catchment tile map. Returns array shape (nr_plot, nc_plot).""" + if cache and cache.exists(): + data = np.load(cache, allow_pickle=True) + meta = dict(data["meta"].item()) if "meta" in data else {} + rst_stat = rst_file.stat() + cache_ok = ( + meta.get("nc") == nc + and meta.get("nr") == nr + and meta.get("ncat") == ncat + and meta.get("nc_plot") == nc_plot + and meta.get("nr_plot") == nr_plot + and meta.get("rst_file") == str(rst_file.resolve()) + and meta.get("rst_size") == int(rst_stat.st_size) + ) + if cache_ok: + print(f"Reading cached tile map: {cache}") + return np.asarray(data["tile_id"], dtype=np.int32) + print(f"Ignoring stale cache: {cache}") + + if nc % nc_plot != 0 or nr % nr_plot != 0: + raise ClsmPlotError( + f"NC/NR must be integer multiples of plot grid. Got NC={nc}, NR={nr}, " + f"plot={nc_plot}x{nr_plot}. Try --plot-nc/--plot-nr." + ) + dx = nc // nc_plot + dy = nr // nr_plot + print(f"Building tile map from {rst_file}: source {nc}x{nr}, plot {nc_plot}x{nr_plot}, block {dx}x{dy}") + tile_id = np.zeros((nr_plot, nc_plot), dtype=np.int32) + + with FortranSequentialReader(rst_file, layout) as rdr: + for j in range(nr_plot): + rows = np.empty((dy, nc), dtype=np.int32) + for jj in range(dy): + rows[jj, :] = rdr.read_array(np.int32, nc) + if dx == 1 and dy == 1: + vals = rows[0].copy() + vals[(vals < 1) | (vals > ncat)] = 0 + tile_id[j, :] = vals + else: + block = rows.reshape(dy, nc_plot, dx).transpose(1, 0, 2).reshape(nc_plot, dx * dy) + tile_id[j, :] = dominant_land_tile(block, ncat) + if (j + 1) % max(1, nr_plot // 20) == 0 or j == nr_plot - 1: + print(f" tile map rows {j + 1}/{nr_plot}") + + if cache: + cache.parent.mkdir(parents=True, exist_ok=True) + np.savez_compressed( + cache, + tile_id=tile_id, + meta={ + "nc": nc, + "nr": nr, + "ncat": ncat, + "nc_plot": nc_plot, + "nr_plot": nr_plot, + "rst_file": str(rst_file.resolve()), + "rst_size": int(rst_file.stat().st_size), + }, + ) + print(f"Wrote tile-map cache: {cache}") + return tile_id + + +def vector_to_grid(tile_id: np.ndarray, vec: np.ndarray, fill_zero: bool = False) -> np.ndarray: + vals = np.asarray(vec) + out = np.full(tile_id.shape, np.nan, dtype=np.float32) + mask = (tile_id >= 1) & (tile_id <= vals.shape[0]) + out[mask] = vals[tile_id[mask] - 1].astype(np.float32) + if fill_zero: + out[~mask] = 0.0 + return out + +def build_tile_id_from_catchment_def( + base_dir: Path, + ncat: int, + nc_plot: int, + nr_plot: int, + cache: Optional[Path] = None, +) -> np.ndarray: + """Build a plotting tile map directly from catchment.def lon/lat boxes. + + This is a fallback for grids such as EASE where ``*.rst`` + companion rasters can contain projection-cell or Pfafstetter IDs rather + than the CLSM tile IDs that index the tile-parameter files. IDL primarily + used the rst map, but all of the global fixed-parameter maps ultimately + need only a lon/lat plotting grid whose values are row numbers in + ``catchment.def``/``cti_stats.dat``/``soil_param.dat``. The catchment + bounds in columns 3:6 of ``catchment.def`` provide that mapping. + """ + cdef = base_dir / "catchment.def" + if cache and cache.exists(): + data = np.load(cache, allow_pickle=True) + meta = dict(data["meta"].item()) if "meta" in data else {} + st = cdef.stat() + if ( + meta.get("source") == "catchment.def" + and meta.get("ncat") == ncat + and meta.get("nc_plot") == nc_plot + and meta.get("nr_plot") == nr_plot + and meta.get("catchment_def") == str(cdef.resolve()) + and meta.get("catchment_size") == int(st.st_size) + ): + print(f"Reading cached catchment.def tile map: {cache}") + return np.asarray(data["tile_id"], dtype=np.int32) + print(f"Ignoring stale catchment.def cache: {cache}") + + rows = load_ascii_table(cdef, skiprows=1, min_cols=6) + if rows.shape[0] < ncat: + raise ClsmPlotError(f"{cdef} has {rows.shape[0]} rows but ncat={ncat}") + rows = rows[:ncat] + minlon = rows[:, 2].astype(float) + maxlon = rows[:, 3].astype(float) + minlat = rows[:, 4].astype(float) + maxlat = rows[:, 5].astype(float) + + dx = 360.0 / float(nc_plot) + dy = 180.0 / float(nr_plot) + tile_id = np.zeros((nr_plot, nc_plot), dtype=np.int32) + + def lat_slice(lo: float, hi: float) -> Optional[slice]: + if not np.isfinite(lo) or not np.isfinite(hi): + return None + lo = max(-90.0, min(90.0, lo)) + hi = max(-90.0, min(90.0, hi)) + if hi < lo: + lo, hi = hi, lo + # Fill cells whose area intersects the catchment box. This guarantees + # very small boxes still get at least one plot pixel. + j0 = int(math.floor((lo + 90.0) / dy)) + j1 = int(math.ceil((hi + 90.0) / dy)) - 1 + j0 = max(0, min(nr_plot - 1, j0)) + j1 = max(0, min(nr_plot - 1, j1)) + if j1 < j0: + j = max(0, min(nr_plot - 1, int(round(((lo + hi) * 0.5 + 90.0) / dy - 0.5)))) + j0 = j1 = j + return slice(j0, j1 + 1) + + def lon_slices(lo: float, hi: float) -> List[slice]: + if not np.isfinite(lo) or not np.isfinite(hi): + return [] + # Normalize to [-180, 180). If the original box spans the dateline, + # split into two slices. + lo0, hi0 = lo, hi + lo = ((lo + 180.0) % 360.0) - 180.0 + hi = ((hi + 180.0) % 360.0) - 180.0 + wraps = (lo0 > hi0) or (lo > hi and abs(lo - hi) < 359.999) + + def one_slice(a: float, b: float) -> Optional[slice]: + a = max(-180.0, min(180.0, a)) + b = max(-180.0, min(180.0, b)) + i0 = int(math.floor((a + 180.0) / dx)) + i1 = int(math.ceil((b + 180.0) / dx)) - 1 + i0 = max(0, min(nc_plot - 1, i0)) + i1 = max(0, min(nc_plot - 1, i1)) + if i1 < i0: + i = max(0, min(nc_plot - 1, int(round(((a + b) * 0.5 + 180.0) / dx - 0.5)))) + i0 = i1 = i + return slice(i0, i1 + 1) + + if not wraps: + sl = one_slice(lo, hi) + return [sl] if sl is not None else [] + out: List[slice] = [] + sl1 = one_slice(lo, 180.0) + sl2 = one_slice(-180.0, hi) + if sl1 is not None: + out.append(sl1) + if sl2 is not None: + out.append(sl2) + return out + + print(f"Building tile map from catchment.def boxes: plot {nc_plot}x{nr_plot}") + for k in range(ncat): + js = lat_slice(float(minlat[k]), float(maxlat[k])) + if js is None: + continue + for is_ in lon_slices(float(minlon[k]), float(maxlon[k])): + tile_id[js, is_] = k + 1 + if (k + 1) % max(1, ncat // 10) == 0 or k == ncat - 1: + print(f" catchment boxes {k + 1}/{ncat}") + + if cache: + cache.parent.mkdir(parents=True, exist_ok=True) + np.savez_compressed( + cache, + tile_id=tile_id, + meta={ + "source": "catchment.def", + "ncat": ncat, + "nc_plot": nc_plot, + "nr_plot": nr_plot, + "catchment_def": str(cdef.resolve()), + "catchment_size": int(cdef.stat().st_size), + }, + ) + print(f"Wrote catchment.def tile-map cache: {cache}") + return tile_id + + +def catchment_spatial_match_fraction(tile_id: np.ndarray, base_dir: Path, lon: np.ndarray, lat: np.ndarray, ncat: int, max_samples: int = 200000) -> float: + """Return fraction of sampled tile_id cells whose lon/lat falls in its catchment.def box.""" + valid = (tile_id >= 1) & (tile_id <= ncat) + rows, cols = np.where(valid) + if rows.size == 0: + return 0.0 + if rows.size > max_samples: + step = int(math.ceil(rows.size / float(max_samples))) + rows = rows[::step] + cols = cols[::step] + ids = tile_id[rows, cols].astype(np.int64) - 1 + cdef = load_ascii_table(base_dir / "catchment.def", skiprows=1, min_cols=6)[:ncat] + minlon = cdef[:, 2].astype(float) + maxlon = cdef[:, 3].astype(float) + minlat = cdef[:, 4].astype(float) + maxlat = cdef[:, 5].astype(float) + x = lon[cols] + y = lat[rows] + tol_lon = 360.0 / float(lon.size) + 1e-6 + tol_lat = 180.0 / float(lat.size) + 1e-6 + inlat = (y >= minlat[ids] - tol_lat) & (y <= maxlat[ids] + tol_lat) + normal = minlon[ids] <= maxlon[ids] + inlon_normal = (x >= minlon[ids] - tol_lon) & (x <= maxlon[ids] + tol_lon) + inlon_wrap = (x >= minlon[ids] - tol_lon) | (x <= maxlon[ids] + tol_lon) + inlon = np.where(normal, inlon_normal, inlon_wrap) + return float(np.count_nonzero(inlat & inlon)) / float(rows.size) + + +def build_fractional_sparse_from_rst( + rst_file: Path, + nc: int, + nr: int, + ncat: int, + nc_out: int, + nr_out: int, + layout: F77Layout, + cache: Optional[Path] = None, +): + if sp_sparse is None: + raise ClsmPlotError("scipy.sparse is required for fractional movie aggregation") + if cache and cache.exists(): + print(f"Reading cached fractional mapping: {cache}") + return sp_sparse.load_npz(cache) + if nc % nc_out != 0 or nr % nr_out != 0: + raise ClsmPlotError( + f"NC/NR must be integer multiples of movie grid. Got NC={nc}, NR={nr}, movie={nc_out}x{nr_out}." + ) + dx = nc // nc_out + dy = nr // nr_out + row_idx: List[int] = [] + col_idx: List[int] = [] + weight: List[float] = [] + print(f"Building fractional mapping from {rst_file}: movie {nc_out}x{nr_out}, block {dx}x{dy}") + with FortranSequentialReader(rst_file, layout) as rdr: + for j in range(nr_out): + rows = np.empty((dy, nc), dtype=np.int32) + for jj in range(dy): + rows[jj, :] = rdr.read_array(np.int32, nc) + for i in range(nc_out): + subset = rows[:, i * dx:(i + 1) * dx].ravel() + valid = subset[(subset >= 1) & (subset <= ncat)] + if valid.size == 0: + continue + ids, counts = np.unique(valid, return_counts=True) + cell = j * nc_out + i + row_idx.extend([cell] * len(ids)) + col_idx.extend((ids - 1).astype(int).tolist()) + # IDL divides by the full block count, not only land count. + weight.extend((counts / float(subset.size)).astype(float).tolist()) + if (j + 1) % max(1, nr_out // 20) == 0 or j == nr_out - 1: + print(f" fractional rows {j + 1}/{nr_out}") + mat = sp_sparse.csr_matrix((weight, (row_idx, col_idx)), shape=(nc_out * nr_out, ncat), dtype=np.float32) + if cache: + cache.parent.mkdir(parents=True, exist_ok=True) + sp_sparse.save_npz(cache, mat) + print(f"Wrote fractional mapping cache: {cache}") + return mat + + +# ----------------------------------------------------------------------------- +# Plot helpers +# ----------------------------------------------------------------------------- + + +def _limits_to_extent(limits: Tuple[float, float, float, float]) -> Tuple[float, float, float, float]: + min_lat, min_lon, max_lat, max_lon = limits + return (min_lon, max_lon, min_lat, max_lat) + + +def crop_to_limits(grid: np.ndarray, lon: np.ndarray, lat: np.ndarray, limits: Tuple[float, float, float, float]): + min_lat, min_lon, max_lat, max_lon = limits + lon_mask = (lon >= min_lon) & (lon <= max_lon) + lat_mask = (lat >= min_lat) & (lat <= max_lat) + if not lon_mask.any() or not lat_mask.any(): + return grid, lon, lat, _limits_to_extent(limits) + sub = grid[np.ix_(lat_mask, lon_mask)] + lon_sub = lon[lon_mask] + lat_sub = lat[lat_mask] + dx = 360.0 / lon.size + dy = 180.0 / lat.size + extent = (lon_sub[0] - dx / 2, lon_sub[-1] + dx / 2, lat_sub[0] - dy / 2, lat_sub[-1] + dy / 2) + return sub, lon_sub, lat_sub, extent + + +def centers_to_edges(a: np.ndarray) -> np.ndarray: + """Convert a 1-D regular center-coordinate array to edges.""" + a = np.asarray(a, dtype=float) + if a.size == 0: + return a + if a.size == 1: + # Fall back to a one-degree cell for pathological one-cell debug plots. + return np.asarray([a[0] - 0.5, a[0] + 0.5], dtype=float) + d = float(np.median(np.diff(a))) + return np.r_[a[0] - 0.5 * d, a + 0.5 * d] + + +def add_land_outline(ax, sub: np.ndarray, lon_sub: np.ndarray, lat_sub: np.ndarray, coastlines: bool, linewidth: float = 0.75) -> None: + """Draw a no-dependency land/ocean outline from the valid-data mask. + + IDL drew MAP_CONTINENTS on every panel. When Cartopy is unavailable or + --no-coastlines is used, the plots otherwise lose all continent outlines. + This mask-derived outline is not a political boundary dataset, but it gives + the same visual coast/land edge cue and works on Discover without extra + data downloads. + """ + if coastlines and ccrs is not None: + return + try: + good = np.isfinite(sub).astype(float) + if good.shape[0] < 2 or good.shape[1] < 2 or np.nanmax(good) <= 0: + return + ax.contour(lon_sub, lat_sub, good, levels=[0.5], colors="black", linewidths=linewidth) + except Exception: + pass + + +def add_horizontal_category_key( + fig: plt.Figure, + colors: np.ndarray, + labels: Sequence[str], + *, + x0: float = 0.16, + y0: float = 0.035, + width: float = 0.68, + height: float = 0.035, + label_size: float = 7.0, + title: str = "", + tick_rotation: float = 45.0, +) -> None: + """Add an IDL-style horizontal categorical color strip.""" + n = len(labels) + if n == 0: + return + key_ax = fig.add_axes([x0, y0, width, height]) + cmap = ListedColormap(np.asarray(colors[:n], dtype=np.float32)) + key_ax.imshow(np.arange(n, dtype=float)[None, :], cmap=cmap, aspect="auto", extent=[0, n, 0, 1], interpolation="nearest") + key_ax.set_yticks([]) + key_ax.set_xticks(np.arange(n) + 0.5) + key_ax.set_xticklabels(labels, rotation=tick_rotation, fontsize=label_size, ha="right", va="top") + key_ax.tick_params(axis="x", length=0, pad=3) + for spine in key_ax.spines.values(): + spine.set_linewidth(0.8) + if title: + key_ax.set_xlabel(title, fontsize=8, labelpad=4) + + +def read_rst_subset( + rst_file: Path, + nc: int, + nr: int, + layout: F77Layout, + limits: Tuple[float, float, float, float], +) -> Tuple[np.ndarray, np.ndarray, np.ndarray]: + """Read a lon/lat subset from a fixed-record F77 int32 raster. + + This is used for US-east.jpg. The IDL code reads the full-resolution rst + raster directly for that regional plot; using the globally downsampled map + creates blocky catchments and apparent leakage. + """ + min_lat, min_lon, max_lat, max_lon = limits + dx = 360.0 / float(nc) + dy = 180.0 / float(nr) + i1 = max(0, int(math.floor((min_lon + 180.0) / dx))) + i2 = min(nc - 1, int(math.ceil((max_lon + 180.0) / dx)) - 1) + j1 = max(0, int(math.floor((min_lat + 90.0) / dy))) + j2 = min(nr - 1, int(math.ceil((max_lat + 90.0) / dy)) - 1) + if i2 < i1 or j2 < j1: + raise ClsmPlotError(f"Invalid rst subset for limits={limits}") + width = i2 - i1 + 1 + height = j2 - j1 + 1 + dtype = np.dtype(layout.endian + "i4") + rec_bytes = layout.marker_bytes + nc * 4 + layout.marker_bytes + out = np.empty((height, width), dtype=np.int32) + with Path(rst_file).open("rb") as fh: + for jj, j in enumerate(range(j1, j2 + 1)): + fh.seek(j * rec_bytes + layout.marker_bytes + i1 * 4) + row = np.fromfile(fh, dtype=dtype, count=width) + if row.size != width: + raise ClsmPlotError(f"Short read from {rst_file} row {j}: got {row.size}, wanted {width}") + out[jj, :] = row.astype(np.int32, copy=False) + lon_sub = -180.0 + (np.arange(i1, i2 + 1) + 0.5) * dx + lat_sub = -90.0 + (np.arange(j1, j2 + 1) + 0.5) * dy + return out, lon_sub, lat_sub + + +def build_boundary_segments_from_tile_ids( + tile_ids: np.ndarray, + lon_sub: np.ndarray, + lat_sub: np.ndarray, + ncat: int, +) -> Tuple[List[Tuple[Tuple[float, float], Tuple[float, float]]], List[Tuple[Tuple[float, float], Tuple[float, float]]]]: + """Return vertical and horizontal catchment/coast boundary line segments. + + IDL's plot_tiles draws an oplot line at every pixel edge where the raster + category changes, including category-to-ocean edges. Baking one-pixel black + edges into a full-resolution image can vanish when the figure is resampled, + so draw true matplotlib line segments in lon/lat coordinates instead. + """ + valid = (tile_ids >= 1) & (tile_ids <= int(ncat)) + if tile_ids.size == 0: + return [], [] + lon_edges = centers_to_edges(lon_sub) + lat_edges = centers_to_edges(lat_sub) + v_segments: List[Tuple[Tuple[float, float], Tuple[float, float]]] = [] + h_segments: List[Tuple[Tuple[float, float], Tuple[float, float]]] = [] + # Vertical boundaries between neighboring columns. + diff_v = tile_ids[:, 1:] != tile_ids[:, :-1] + draw_v = diff_v & (valid[:, 1:] | valid[:, :-1]) + rows, cols = np.where(draw_v) + for r, c in zip(rows.tolist(), cols.tolist()): + x = float(lon_edges[c + 1]) + h_segments_dummy = None + v_segments.append(((x, float(lat_edges[r])), (x, float(lat_edges[r + 1])))) + # Left/right outside edges where a valid cell borders the regional/ocean edge. + for r in range(tile_ids.shape[0]): + if valid[r, 0]: + x = float(lon_edges[0]) + v_segments.append(((x, float(lat_edges[r])), (x, float(lat_edges[r + 1])))) + if valid[r, -1]: + x = float(lon_edges[-1]) + v_segments.append(((x, float(lat_edges[r])), (x, float(lat_edges[r + 1])))) + # Horizontal boundaries between neighboring rows. + diff_h = tile_ids[1:, :] != tile_ids[:-1, :] + draw_h = diff_h & (valid[1:, :] | valid[:-1, :]) + rows, cols = np.where(draw_h) + for r, c in zip(rows.tolist(), cols.tolist()): + y = float(lat_edges[r + 1]) + h_segments.append(((float(lon_edges[c]), y), (float(lon_edges[c + 1]), y))) + # Bottom/top outside edges. + for c in range(tile_ids.shape[1]): + if valid[0, c]: + y = float(lat_edges[0]) + h_segments.append(((float(lon_edges[c]), y), (float(lon_edges[c + 1]), y))) + if valid[-1, c]: + y = float(lat_edges[-1]) + h_segments.append(((float(lon_edges[c]), y), (float(lon_edges[c + 1]), y))) + return v_segments, h_segments + + +def add_tile_boundary_lines(ax, tile_ids: np.ndarray, lon_sub: np.ndarray, lat_sub: np.ndarray, ncat: int, linewidth: float = 0.23) -> None: + v_segments, h_segments = build_boundary_segments_from_tile_ids(tile_ids, lon_sub, lat_sub, ncat) + if v_segments: + ax.add_collection(LineCollection(v_segments, colors="black", linewidths=linewidth, antialiaseds=False, zorder=5)) + if h_segments: + ax.add_collection(LineCollection(h_segments, colors="black", linewidths=linewidth, antialiaseds=False, zorder=5)) + + +def make_axes(fig: plt.Figure, nrows: int, ncols: int, idx: int, coastlines: bool): + if coastlines and ccrs is not None: + ax = fig.add_subplot(nrows, ncols, idx, projection=ccrs.PlateCarree()) + else: + ax = fig.add_subplot(nrows, ncols, idx) + return ax + + +def _nice_geo_ticks(lo: float, hi: float, is_lon: bool) -> np.ndarray: + """Return readable lon/lat tick locations for IDL-like map axes.""" + span = float(hi) - float(lo) + if span >= 300.0: + step = 60.0 + elif span >= 150.0: + step = 30.0 + elif span >= 70.0: + step = 15.0 + elif span >= 25.0: + step = 5.0 + elif span >= 10.0: + step = 2.0 + else: + step = 1.0 + start = math.ceil(float(lo) / step) * step + stop = math.floor(float(hi) / step) * step + ticks = np.arange(start, stop + 0.5 * step, step, dtype=float) + if ticks.size == 0: + ticks = np.asarray([lo, hi], dtype=float) + # Keep the full-domain endpoints when they are part of the requested map. + if is_lon: + if lo <= -179.999 and not np.isclose(ticks[0], -180.0): + ticks = np.r_[-180.0, ticks] + if hi >= 179.999 and not np.isclose(ticks[-1], 180.0): + ticks = np.r_[ticks, 180.0] + else: + if lo <= -89.999 and not np.isclose(ticks[0], -90.0): + ticks = np.r_[-90.0, ticks] + if hi >= 89.999 and not np.isclose(ticks[-1], 90.0): + ticks = np.r_[ticks, 90.0] + # Avoid too many labels in narrow panels. + if ticks.size > 9: + ticks = ticks[:: int(math.ceil(ticks.size / 9.0))] + return ticks + + +def _plain_lon_label(x: float) -> str: + x = float(x) + if abs(x) < 1e-9: + return "0°" + hemi = "E" if x > 0 else "W" + return f"{abs(x):g}°{hemi}" + + +def _plain_lat_label(y: float) -> str: + y = float(y) + if abs(y) < 1e-9: + return "0°" + hemi = "N" if y > 0 else "S" + return f"{abs(y):g}°{hemi}" + + +def decorate_geo( + ax, + limits: Tuple[float, float, float, float], + coastlines: bool, + show_xlabel: bool = True, + show_ylabel: bool = True, +) -> None: + min_lat, min_lon, max_lat, max_lon = limits + if coastlines and ccrs is not None and hasattr(ax, "set_extent"): + ax.set_extent([min_lon, max_lon, min_lat, max_lat], crs=ccrs.PlateCarree()) + ax.coastlines(linewidth=0.5) + try: + ax.add_feature(cfeature.BORDERS, linewidth=0.3) + except Exception: + pass + + # Cartopy axes do not show normal Matplotlib lon/lat ticks unless we + # explicitly set them. Without this, movie frames with --coastlines + # have coastlines but lose the longitude/latitude labels. + try: + xticks = _nice_geo_ticks(min_lon, max_lon, is_lon=True) + yticks = _nice_geo_ticks(min_lat, max_lat, is_lon=False) + ax.set_xticks(xticks, crs=ccrs.PlateCarree()) + ax.set_yticks(yticks, crs=ccrs.PlateCarree()) + if LongitudeFormatter is not None: + ax.xaxis.set_major_formatter(LongitudeFormatter(zero_direction_label=False)) + else: + ax.set_xticklabels([_plain_lon_label(x) for x in xticks]) + if LatitudeFormatter is not None: + ax.yaxis.set_major_formatter(LatitudeFormatter()) + else: + ax.set_yticklabels([_plain_lat_label(y) for y in yticks]) + ax.tick_params( + labelsize=7, + bottom=show_xlabel, labelbottom=show_xlabel, + left=show_ylabel, labelleft=show_ylabel, + top=False, right=False, + pad=2, + ) + ax.set_xlabel("Longitude" if show_xlabel else "", fontsize=8, labelpad=6) + ax.set_ylabel("Latitude" if show_ylabel else "", fontsize=8, labelpad=6) + try: + ax.gridlines( + xlocs=xticks, ylocs=yticks, draw_labels=False, + linewidth=0.25, color="0.35", alpha=0.35, linestyle="-", + ) + except Exception: + pass + except Exception: + # Coastlines are more important than labels; avoid failing plots if a + # particular Cartopy build cannot format projected tick labels. + pass + else: + ax.set_xlim(min_lon, max_lon) + ax.set_ylim(min_lat, max_lat) + ax.set_xlabel("Longitude" if show_xlabel else "", labelpad=6) + ax.set_ylabel("Latitude" if show_ylabel else "", labelpad=6) + ax.grid(True, linewidth=0.2, alpha=0.4) + try: + ax.set_aspect("equal", adjustable="box") + except Exception: + pass + + +def plot_continuous_on_ax( + ax, + grid: np.ndarray, + lon: np.ndarray, + lat: np.ndarray, + limits: Tuple[float, float, float, float], + title: str, + levels: Sequence[float], + color_ids: Optional[Sequence[int]] = None, + rgb: Optional[np.ndarray] = None, + coastlines: bool = False, + show_xlabel: bool = True, + show_ylabel: bool = True, +): + sub, lon_sub, lat_sub, extent = crop_to_limits(grid, lon, lat, limits) + finite = np.isfinite(sub) + if finite.any(): + print(f" plot {title}: finite={int(finite.sum())}/{sub.size}, min={float(np.nanmin(sub)):.6g}, max={float(np.nanmax(sub)):.6g}") + else: + print(f" plot {title}: finite=0/{sub.size} -- output will be blank") + if rgb is not None: + cmap = ListedColormap(rgb) + else: + cmap = ListedColormap(PALETTE[np.asarray(color_ids or CONTINUOUS_COLOR_IDS)]) + levels_arr = np.asarray(levels, dtype=float) + # BoundaryNorm expects one more boundary than colors. IDL uses each listed + # level as a filled-contour break; extend one upper boundary if needed. + if len(levels_arr) == cmap.N: + step = levels_arr[-1] - levels_arr[-2] if len(levels_arr) > 1 else 1.0 + boundaries = np.r_[levels_arr, levels_arr[-1] + step] + else: + boundaries = levels_arr + norm = BoundaryNorm(boundaries, cmap.N, clip=True) + # Convert data to an explicit RGBA image before putting it + # on the axes. On Discover some Agg/pcolormesh combinations were producing + # blank-looking panels even though the arrays contained valid data. This + # follows the successful direct-image debug path. + cmap.set_bad("white") + rgba = cmap(norm(np.ma.masked_invalid(sub))) + imshow_kwargs = dict( + origin="lower", + extent=extent, + interpolation="nearest", + aspect="equal", + ) + if coastlines and ccrs is not None: + imshow_kwargs["transform"] = ccrs.PlateCarree() + ax.imshow(rgba, **imshow_kwargs) + add_land_outline(ax, sub, lon_sub, lat_sub, coastlines) + try: + ax.set_aspect("equal", adjustable="box") + except Exception: + pass + ax.set_title(title, fontsize=10, pad=10) + decorate_geo(ax, limits, coastlines, show_xlabel=show_xlabel, show_ylabel=show_ylabel) + sm = ScalarMappable(norm=norm, cmap=cmap) + sm.set_array([]) + return sm + + +def plot_indexed_on_ax( + ax, + grid: np.ndarray, + lon: np.ndarray, + lat: np.ndarray, + limits: Tuple[float, float, float, float], + title: str, + classes: Sequence[int], + colors: Sequence[Sequence[float]] | np.ndarray, + labels: Optional[Sequence[str]] = None, + coastlines: bool = False, + show_xlabel: bool = True, + show_ylabel: bool = True, +): + sub, lon_sub, lat_sub, extent = crop_to_limits(grid, lon, lat, limits) + finite = np.isfinite(sub) + if finite.any(): + vals = np.unique(sub[finite]) + print(f" plot {title}: finite={int(finite.sum())}/{sub.size}, unique={vals.size}, first={vals[:8]}") + else: + print(f" plot {title}: finite=0/{sub.size} -- output will be blank") + cls = np.asarray(classes) + idx_grid = np.full(sub.shape, np.nan, dtype=np.float32) + for k, value in enumerate(cls): + idx_grid[sub == value] = k + cmap = ListedColormap(np.asarray(colors, dtype=np.float32)) + norm = BoundaryNorm(np.arange(-0.5, len(cls) + 0.5, 1.0), cmap.N) + cmap.set_bad("white") + rgba = cmap(norm(np.ma.masked_invalid(idx_grid))) + imshow_kwargs = dict( + origin="lower", + extent=extent, + interpolation="nearest", + aspect="equal", + ) + if coastlines and ccrs is not None: + imshow_kwargs["transform"] = ccrs.PlateCarree() + ax.imshow(rgba, **imshow_kwargs) + add_land_outline(ax, sub, lon_sub, lat_sub, coastlines) + try: + ax.set_aspect("equal", adjustable="box") + except Exception: + pass + ax.set_title(title, fontsize=10, pad=10) + decorate_geo(ax, limits, coastlines, show_xlabel=show_xlabel, show_ylabel=show_ylabel) + sm = ScalarMappable(norm=norm, cmap=cmap) + sm.set_array([]) + if labels: + cbar = plt.colorbar(sm, ax=ax, shrink=0.75, pad=0.02, ticks=np.arange(len(cls))) + cbar.ax.set_yticklabels(labels) + return sm + + +def save_fig(fig: plt.Figure, outpath: Path, dpi: Optional[int] = None) -> None: + """Save a static plot with package-wide DPI/JPEG quality settings.""" + outpath.parent.mkdir(parents=True, exist_ok=True) + use_dpi = int(PLOT_DPI if dpi is None else dpi) + kwargs = dict(dpi=use_dpi, bbox_inches="tight", facecolor="white") + if outpath.suffix.lower() in (".jpg", ".jpeg"): + kwargs["pil_kwargs"] = {"quality": int(JPEG_QUALITY), "optimize": True} + try: + fig.savefig(outpath, **kwargs) + except TypeError: + # Older Matplotlib builds may not support pil_kwargs. + kwargs.pop("pil_kwargs", None) + fig.savefig(outpath, **kwargs) + plt.close(fig) + print(f"Wrote {outpath}") + + +def panel_continuous( + grids: Sequence[np.ndarray], + titles: Sequence[str], + lon: np.ndarray, + lat: np.ndarray, + limits: Tuple[float, float, float, float], + outpath: Path, + ncols: int, + levels_list: Sequence[Sequence[float]], + color_ids_list: Optional[Sequence[Sequence[int]]] = None, + rgb_list: Optional[Sequence[np.ndarray]] = None, + figsize: Tuple[float, float] = (10, 8), + coastlines: bool = False, +) -> None: + n = len(grids) + nrows = int(math.ceil(n / ncols)) + # Multi-panel products need more vertical real estate than the default + # Matplotlib layout, especially once each panel has its own colorbar. + # Make this global rather than only fixing cti.jpg. This prevents titles + # such as POROS/COND/T2m from colliding with the axis labels of the panel + # above. + compact_two_column = (ncols == 2 and n in (4, 6)) + if compact_two_column: + # 4-panel (SoilAlb) and 6-panel (soil_param) global maps were + # visually too tall because Cartopy/geographic aspect makes each map + # panel wide and shallow. Use explicit compact figure heights for + # these layouts instead of the generic multi-panel height rule. + if n == 4: + figsize = (max(figsize[0], 12.0), 5.6) + else: # n == 6 + figsize = (max(figsize[0], 12.2), 7.35) + elif nrows > 1: + # Keep enough room for titles/colorbars, but avoid very large gaps. + min_h_per_row = 3.35 if ncols <= 2 else 2.85 + figsize = (max(figsize[0], 9.5 if ncols == 1 else figsize[0]), max(figsize[1], min_h_per_row * nrows)) + fig = plt.figure(figsize=figsize) + if compact_two_column: + fig.subplots_adjust(hspace=0.12, wspace=0.18, top=0.955, bottom=0.105, left=0.070, right=0.985) + elif nrows > 1: + hspace = 0.46 if ncols <= 2 else 0.34 + wspace = 0.20 if ncols > 1 else 0.14 + fig.subplots_adjust(hspace=hspace, wspace=wspace, top=0.965, bottom=0.085, left=0.075, right=0.975) + last_im = None + for k, grid in enumerate(grids): + ax = make_axes(fig, nrows, ncols, k + 1, coastlines) + row = k // ncols + col = k % ncols + show_xlabel = row == (nrows - 1) + show_ylabel = col == 0 + last_im = plot_continuous_on_ax( + ax, + grid, + lon, + lat, + limits, + titles[k], + levels=levels_list[k], + color_ids=(color_ids_list[k] if color_ids_list is not None else None), + rgb=(rgb_list[k] if rgb_list is not None else None), + coastlines=coastlines, + show_xlabel=show_xlabel, + show_ylabel=show_ylabel, + ) + cbar = fig.colorbar(last_im, ax=ax, shrink=0.65, pad=0.02) + cbar.ax.tick_params(labelsize=7) + save_fig(fig, outpath) + + +# ----------------------------------------------------------------------------- +# Plot products translated from clsm_plots.pro +# ----------------------------------------------------------------------------- + +def plot_tiles( + tile_id: np.ndarray, + lon: np.ndarray, + lat: np.ndarray, + limits: Tuple[float, float, float, float], + outdir: Path, + coastlines: bool, + rst_file: Optional[Path] = None, + nc_full: Optional[int] = None, + nr_full: Optional[int] = None, + ncat: Optional[int] = None, + layout: Optional[F77Layout] = None, + gfile: str = "", +) -> None: + n_levels = 30 + colors = PALETTE[np.arange(90, 90 + n_levels)] + + if nc_full is not None and nr_full is not None: + raster_res = max(int(nc_full), int(nr_full)) + else: + raster_res = 0 + + rst_name = str(rst_file).upper() if rst_file is not None else "" + grid_name = f"{gfile} {rst_name}".upper() + + is_ease = "EASE" in grid_name + is_ease_m01 = is_ease and "M01" in grid_name + is_ease_m03 = is_ease and "M03" in grid_name + + # Cubed-sphere logical resolution. + # Examples: + # CF0180x6C_DE1440xPE0720 + # CF2880x6C_CF2880x6C + # CF2160x6C-SG001_CF2160x6C + m_cf = re.search(r"CF0*([0-9]+)X6C", grid_name) + cf_res = int(m_cf.group(1)) if m_cf else 0 + + # Lat-lon / data-ocean style names. + # Examples: + # DC0288xPC0181_DE0360xPE0180 + # DE1440xPE0720 + is_latlon = bool( + re.search(r"(?:DC|DE)0*[0-9]+X(?:PC|PE)0*[0-9]+", grid_name) + ) + + if is_ease_m01: + # EASE 1-km: tight zoom. + us_east_limits = (38.35, -76.45, 38.75, -75.95) + + elif is_ease_m03: + # EASE 3-km: moderate zoom. + us_east_limits = (38.0, -77.2, 39.2, -75.4) + + elif is_ease: + # EASE M09/M25/M36 and any other EASE not explicitly zoomed. + us_east_limits = (35.0, -82.0, 42.0, -73.0) + + elif cf_res > 0 and cf_res <= 720: + # C12 through C720: broad region, like original IDL. + us_east_limits = (35.0, -82.0, 42.0, -73.0) + + elif cf_res >= 5760: + # C5760: tight Chesapeake zoom. + us_east_limits = (38.35, -76.45, 38.75, -75.95) + + elif cf_res >= 2160: + # C2160/C2880/C3072 and fine stretched. + us_east_limits = (38.0, -76.8, 39.0, -75.6) + + elif cf_res >= 768: + # C768/C1000/C1080/C1120/C1152/C1440/C1536. + us_east_limits = (37.6, -77.2, 39.2, -75.4) + + elif is_latlon: + # Lat-lon b/c/d/e grids: broad region. + us_east_limits = (35.0, -82.0, 42.0, -73.0) + + else: + # Preserve IDL-like behavior for unrecognized grids/res. + # Do NOT fall back to raster_res-based zoom here. + us_east_limits = (35.0, -82.0, 42.0, -73.0) + + print( + f" plot US-east catchment tile zoom: " + f"gfile={gfile}, cf_res={cf_res}, is_latlon={is_latlon}, " + f"raster_res={raster_res}, limits={us_east_limits}" + ) + if rst_file is not None and nc_full is not None and nr_full is not None and ncat is not None and layout is not None: + sub_id, lon_sub, lat_sub = read_rst_subset(Path(rst_file), int(nc_full), int(nr_full), layout, us_east_limits) + valid = (sub_id >= 1) & (sub_id <= int(ncat)) + idx = np.full(sub_id.shape, np.nan, dtype=np.float32) + idx[valid] = (sub_id[valid] % n_levels).astype(np.float32) + cmap = ListedColormap(colors) + cmap.set_bad("white") + rgba = cmap(np.ma.masked_invalid(idx.astype(float) / max(1, n_levels - 1))) + dx = 360.0 / float(nc_full) + dy = 180.0 / float(nr_full) + extent = (lon_sub[0] - dx / 2, lon_sub[-1] + dx / 2, lat_sub[0] - dy / 2, lat_sub[-1] + dy / 2) + fig = plt.figure(figsize=(7.0, 5.0)) + ax = make_axes(fig, 1, 1, 1, coastlines) + imshow_kwargs = dict(origin="lower", extent=extent, interpolation="nearest", aspect="equal", zorder=1) + if coastlines and ccrs is not None: + imshow_kwargs["transform"] = ccrs.PlateCarree() + ax.imshow(rgba, **imshow_kwargs) + + # Boundary linewidth is grid/resolution dependent. + # Coarse grids need visible borders so same-color neighboring tiles + # are still separable. Fine zooms need thinner borders. + if is_ease_m01: + tile_boundary_linewidth = 0.10 + elif is_ease_m03: + tile_boundary_linewidth = 0.16 + elif is_ease: + tile_boundary_linewidth = 0.23 + + elif cf_res > 0 and cf_res <= 720: + tile_boundary_linewidth = 0.23 + elif cf_res >= 5760: + tile_boundary_linewidth = 0.08 + elif cf_res >= 2160: + tile_boundary_linewidth = 0.12 + elif cf_res >= 768: + tile_boundary_linewidth = 0.16 + + elif is_latlon: + tile_boundary_linewidth = 0.23 + + else: + tile_boundary_linewidth = 0.23 + + if tile_boundary_linewidth > 0.0: + add_tile_boundary_lines( + ax, sub_id, lon_sub, lat_sub, int(ncat), + linewidth=tile_boundary_linewidth + ) + + decorate_geo(ax, us_east_limits, coastlines) + ax.grid(False) + ax.set_title("Catchment tiles", fontsize=10, pad=8) + save_fig(fig, outdir / "US-east.jpg") + return + + # Fallback for unusual runs where the rst file is unavailable. + grid = np.full(tile_id.shape, np.nan, dtype=np.float32) + mask = tile_id > 0 + grid[mask] = tile_id[mask] % n_levels + fig = plt.figure(figsize=(7.0, 5.0)) + ax = make_axes(fig, 1, 1, 1, coastlines) + plot_indexed_on_ax(ax, grid, lon, lat, us_east_limits, "Catchment tiles", np.arange(n_levels), colors, coastlines=coastlines) + save_fig(fig, outdir / "US-east.jpg") + +def plot_country_codes(base_dir: Path, tile_id: np.ndarray, lon: np.ndarray, lat: np.ndarray, limits, outdir: Path, coastlines: bool) -> None: + path = base_dir / "country_and_state_code.data" + if not path.exists(): + print(f"Skipping country codes; missing {path}") + return + # File has numeric columns followed by text labels such as UNK; read only + # the first three numeric columns instead of np.loadtxt-ing the whole row. + rows = np.genfromtxt(path, comments="#", usecols=(0, 1, 2), dtype=np.float64, invalid_raise=False) + if rows.ndim == 1: + rows = rows.reshape(1, -1) + if rows.shape[1] < 3: + raise ClsmPlotError(f"{path} has fewer than three numeric columns") + ncat = int(np.nanmax(tile_id)) + if rows.shape[0] < ncat: + print(f"WARNING: {path} has {rows.shape[0]} rows but tile map references {ncat} tiles") + cnt = rows[:ncat, 1].astype(np.float32) + st = rows[:ncat, 2].astype(np.float32) + us = cnt == 243 + cnt[us] = st[us] + cnt[cnt == 257] = np.nan + grid = vector_to_grid(tile_id, cnt + 1) + # Use a reproducible random-looking palette for up to 256 codes. + rng = np.random.default_rng(12345) + colors = rng.random((256, 3)) + colors[0] = 0 + colors[-1] = 1 + fig = plt.figure(figsize=(10, 5)) + ax = make_axes(fig, 1, 1, 1, coastlines) + sub, lon_sub, lat_sub, extent = crop_to_limits(grid, lon, lat, limits) + finite = np.isfinite(sub) + if finite.any(): + vals = np.unique(sub[finite]) + print(f" plot Country / state codes: finite={int(finite.sum())}/{sub.size}, unique={vals.size}, first={vals[:8]}") + else: + print(f" plot Country / state codes: finite=0/{sub.size} -- output will be blank") + cmap = ListedColormap(colors) + cmap.set_bad("white") + vals = np.ma.masked_invalid(sub) + # Wrap arbitrary numeric country/state codes into the available palette for + # a stable categorical image. The exact colors do not need to encode the + # numeric magnitude. + idx = np.full(sub.shape, np.nan, dtype=np.float32) + good = np.isfinite(sub) + idx[good] = (sub[good].astype(np.int64) % colors.shape[0]).astype(np.float32) + norm = BoundaryNorm(np.arange(-0.5, colors.shape[0] + 0.5, 1.0), cmap.N) + rgba = cmap(norm(np.ma.masked_invalid(idx))) + ax.imshow(rgba, origin="lower", extent=extent, interpolation="nearest", aspect="equal") + try: + ax.set_aspect("equal", adjustable="box") + except Exception: + pass + ax.set_title("Country / state codes") + decorate_geo(ax, limits, coastlines) + save_fig(fig, outdir / "Country_codes.jpg") + + +def plot_cti(base_dir: Path, tile_id: np.ndarray, lon: np.ndarray, lat: np.ndarray, limits, outdir: Path, coastlines: bool) -> None: + path = base_dir / "cti_stats.dat" + rows = load_ascii_table(path, skiprows=1, min_cols=7) + cti_mean = rows[:, 2].astype(np.float32) + cti_std = rows[:, 3].astype(np.float32) + cti_skew = rows[:, 6].astype(np.float32) + if not (base_dir / "CLM_veg_typs_fracs").exists(): + cti_mean = 0.961 * cti_mean - 1.957 + grids = [vector_to_grid(tile_id, v) for v in (cti_mean, cti_std, cti_skew)] + levels = [np.linspace(6.0, 14.0, 17), np.linspace(0.0, 4.0, 17), np.linspace(-2.5, 2.5, 17)] + panel_continuous( + grids, ["CTI mean", "CTI std", "CTI skew"], lon, lat, limits, outdir / "cti.jpg", + ncols=1, levels_list=levels, figsize=(10.4, 10.1), coastlines=coastlines, + ) + + +def plot_mosaic(base_dir: Path, tile_id: np.ndarray, lon: np.ndarray, lat: np.ndarray, limits, outdir: Path, coastlines: bool) -> None: + path = base_dir / "mosaic_veg_typs_fracs" + rows = load_ascii_table(path, min_cols=3) + mos_type = rows[:, 2].astype(int) + grid = vector_to_grid(tile_id, mos_type) + vtypes = [1, 2, 3, 4, 5, 6, 7, 8, 10, 11, 14, 20, 30, 40, 50, 60, 70, 90, 100, 110, 120, 130, 140, 150, 160, 170, 180, 190, 200, 210, 220, 230] + r = [233, 255, 255, 255, 210, 0, 0, 0, 204, 170, 255, 220, 205, 0, 0, 170, 0, 40, 120, 140, 190, 150, 255, 255, 0, 0, 0, 195, 255, 0, 255, 0] + g = [23, 131, 191, 255, 255, 255, 155, 0, 204, 240, 255, 240, 205, 100, 160, 200, 60, 100, 130, 160, 150, 100, 180, 235, 120, 150, 220, 20, 245, 70, 255, 0] + b = [0, 0, 0, 178, 255, 255, 255, 200, 204, 240, 100, 100, 102, 0, 0, 0, 0, 0, 0, 0, 0, 0, 50, 175, 90, 120, 130, 0, 215, 200, 255, 0] + colors = _as_rgb(list(zip(r, g, b))) + fig = plt.figure(figsize=(10.8, 5.4)) + fig.subplots_adjust(bottom=0.20, top=0.93) + ax = make_axes(fig, 1, 1, 1, coastlines) + plot_indexed_on_ax(ax, grid, lon, lat, limits, "Mosaic primary vegetation type", vtypes, colors, labels=None, coastlines=coastlines) + # The IDL map uses the full vtypes color table, but the legend intentionally + # labels only the six broad mosaic classes. + mos_labels = ["BL Evergreen", "BL Deciduous", "Needleleaf", "Grassland", "BL Shrubs", "Dwarf"] + add_horizontal_category_key(fig, colors[:6], mos_labels, x0=0.33, y0=0.050, width=0.36, height=0.026, label_size=7, tick_rotation=45.0) + save_fig(fig, outdir / "mosaic_prim.jpg") + +def _read_clm_rows(base_dir: Path) -> Optional[np.ndarray]: + path = base_dir / "CLM_veg_typs_fracs" + if not path.exists(): + print(f"Skipping CLM/Catchment-CN vegetation plots; missing {path}") + return None + return load_ascii_table(path, min_cols=12) + + +def plot_clm(base_dir: Path, tile_id: np.ndarray, lon: np.ndarray, lat: np.ndarray, limits, outdir: Path, coastlines: bool) -> None: + rows = _read_clm_rows(base_dir) + if rows is None: + return + clm = rows[:, [10, 11]].astype(int) + colors = _as_rgb(list(zip( + [255,106,202,251,0,29,77,109,142,233,255,255,127,164,217,204,0], + [245,91,178,154,85,115,145,165,185,23,131,191,39,53,72,204,70], + [215,154,214,153,0,0,0,0,13,0,0,0,4,3,1,204,200], + ))) + classes = list(range(1, 18)) + labels = ["BARE", "NLEt", "NLEB", "NLDB", "BLET", "BLEt", "BLDT", "BLDt", "BLDB", "BLEtS", "BLDtS", "BLDBS", "AC3G", "CC3G", "WC4G", "CROP"] + for idx, name in enumerate(["PRIM", "SEC"]): + grid = vector_to_grid(tile_id, clm[:, idx]) + fig = plt.figure(figsize=(10, 6)) + ax = make_axes(fig, 1, 1, 1, coastlines) + fig.subplots_adjust(bottom=0.18, top=0.92) + plot_indexed_on_ax(ax, grid, lon, lat, limits, f"CLM {name} vegetation type", classes, colors, labels=None, coastlines=coastlines) + add_horizontal_category_key(fig, colors[:len(labels)], labels, x0=0.16, y0=0.045, width=0.68, height=0.026, label_size=7, tick_rotation=45.0) + save_fig(fig, outdir / f"CLM_{name}_veg_typs.jpg") + + +def plot_carbon(base_dir: Path, tile_id: np.ndarray, lon: np.ndarray, lat: np.ndarray, limits, outdir: Path, coastlines: bool) -> None: + rows = _read_clm_rows(base_dir) + if rows is None: + return + cn = rows[:, [2, 3, 4, 5]].astype(int) + colors = _as_rgb(list(zip( + [106,202,251,0,29,77,109,142,233,255,255,255,127,164,164,217,217,204,104,0], + [91,178,154,85,115,145,165,185,23,131,131,191,39,53,53,72,72,204,104,70], + [154,214,153,0,0,0,0,13,0,0,200,0,4,3,200,1,200,204,200,200], + ))) + classes = list(range(1, 21)) + labels = ["NLEt", "NLEB", "NLDB", "BLET", "BLEt", "BLDT", "BLDt", "BLDB", "BLEtS", "BLDtS", "BLDtSm", "BLDBS", "AC3G", "CC3G", "CC3Gm", "WC4G", "WC4Gm", "CROP", "CROPm"] + for label, cols in [("PRIM", [0, 1]), ("SEC", [2, 3])]: + fig = plt.figure(figsize=(12.0, 8.6)) + fig.subplots_adjust(hspace=0.16, bottom=0.17, top=0.955, left=0.06, right=0.98) + for k, c in enumerate(cols): + ax = make_axes(fig, 2, 1, k + 1, coastlines) + grid = vector_to_grid(tile_id, cn[:, c]) + plot_indexed_on_ax(ax, grid, lon, lat, limits, f"Catchment-CN {label} vegetation {k + 1}", classes, colors, labels=None, coastlines=coastlines, show_xlabel=(k == 1)) + add_horizontal_category_key(fig, colors[:len(labels)], labels, x0=0.16, y0=0.055, width=0.68, height=0.026, label_size=7, tick_rotation=45.0) + save_fig(fig, outdir / f"CatchmentCN_{label}_veg_typs.jpg") + + +def plot_ndep_t2m_soilalb(base_dir: Path, tile_id: np.ndarray, lon: np.ndarray, lat: np.ndarray, limits, outdir: Path, coastlines: bool) -> None: + path = base_dir / "CLM_NDep_SoilAlb_T2m" + if not path.exists(): + print(f"Skipping NDep/T2m/SoilAlb; missing {path}") + return + rows = load_ascii_table(path, min_cols=7) + ndep, visdr, visdf, nirdr, nirdf, t2mm, t2mp = [rows[:, i].astype(np.float32) for i in range(7)] + grids = [vector_to_grid(tile_id, v) for v in (ndep, t2mm, t2mp)] + levels = [np.asarray(list(np.arange(15) * 4.0) + [65.0, 350.0]), np.linspace(250.0, 300.0, 17), np.linspace(250.0, 300.0, 17)] + panel_continuous(grids, ["NDep", "T2m mean", "T2m plus"], lon, lat, limits, outdir / "CLM_Ndep_T2m.jpg", ncols=1, levels_list=levels, figsize=(10.4, 9.8), coastlines=coastlines) + soilalb_grids = [vector_to_grid(tile_id, v) for v in (visdr, visdf, nirdr, nirdf)] + levels_alb = [np.linspace(0.0, 0.65, 17), np.linspace(0.0, 0.65, 17), np.linspace(0.0, 1.0, 17), np.linspace(0.0, 1.0, 17)] + panel_continuous(soilalb_grids, ["VISDR", "VISDF", "NIRDR", "NIRDF"], lon, lat, limits, outdir / "SoilAlb.jpg", ncols=2, levels_list=levels_alb, figsize=(10, 7), coastlines=coastlines) + + +def plot_soil(base_dir: Path, tile_id: np.ndarray, lon: np.ndarray, lat: np.ndarray, limits, outdir: Path, coastlines: bool) -> None: + path = base_dir / "soil_param.dat" + rows = load_ascii_table(path, min_cols=10) + vals = { + "BEE": rows[:, 4].astype(np.float32), + "PSIS": rows[:, 5].astype(np.float32), + "POROS": rows[:, 6].astype(np.float32), + "COND": rows[:, 7].astype(np.float32), + "WPWET": rows[:, 8].astype(np.float32), + "SOILDEPTH": rows[:, 9].astype(np.float32), + } + vlims = { + "BEE": (1.0, 8.0), + "PSIS": (-1.85, -0.1), + "POROS": (0.37, 0.8), + "COND": (2.37e-6, 2.845e-4), + "WPWET": (0.01, 0.45), + "SOILDEPTH": (1334.0, 5000.0), + } + grids, titles, levs = [], [], [] + for name in vals: + lo, hi = vlims[name] + if name == "POROS": + levels = np.r_[lo, lo + np.arange(15) * ((0.57 - lo) / 15.0), hi] + else: + levels = np.linspace(lo, hi, 17) + grids.append(vector_to_grid(tile_id, vals[name])) + titles.append(name) + levs.append(levels) + panel_continuous(grids, titles, lon, lat, limits, outdir / "soil_param.jpg", ncols=2, levels_list=levs, figsize=(11, 9), coastlines=coastlines) + + +def plot_elevation(base_dir: Path, tile_id: np.ndarray, lon: np.ndarray, lat: np.ndarray, limits, outdir: Path, coastlines: bool) -> None: + rows = load_ascii_table(base_dir / "catchment.def", skiprows=1, min_cols=7) + elevation = rows[:, 6].astype(np.float32) + grid = vector_to_grid(tile_id, elevation) + lo = float(np.nanmin(elevation)) + hi = float(np.nanmax(elevation)) + panel_continuous([grid], ["ELEVATION"], lon, lat, limits, outdir / "ELEVATION.jpg", ncols=1, levels_list=[np.linspace(lo, hi, 17)], figsize=(11.2, 5.6), coastlines=coastlines) + + +# ----------------------------------------------------------------------------- +# Time series LAI/GREEN/albedo readers and Z0 +# ----------------------------------------------------------------------------- + + +def read_timeseries_record(rdr, ncat: int) -> Tuple[np.ndarray, np.ndarray]: + if isinstance(rdr, TimeSeriesReader): + return rdr.read_record() + header = rdr.read_array(np.float32, 9) + values = rdr.read_array(np.float32, ncat) + return header, values + + +def _doy_from_header_part(yroff: float, month: float, day: float) -> float: + y = 2001 + int(round(float(yroff))) + m = max(1, min(12, int(round(float(month))))) + d = max(1, min(31, int(round(float(day))))) + dt = _dt.date(y, m, d) + return float((dt - _dt.date(2000, 12, 31)).days) + + +def midpoint_doy(header: np.ndarray) -> float: + start = _doy_from_header_part(header[0], header[1], header[2]) + end = _doy_from_header_part(header[6], header[7], header[8]) + return (end - start) / 2.0 + start + + +def _sanitize_lai(values: np.ndarray, *, max_lai: float = 12.0) -> np.ndarray: + """Return LAI with impossible/fill values masked as NaN. + + LAI in these climatology files should be non-negative and normally below + about 8. Use 12 as a conservative upper bound so real dense-canopy values + are retained while bad extrapolated/fill values do not contaminate Z0. + """ + out = np.asarray(values, dtype=np.float32).copy() + bad = (~np.isfinite(out)) | (out < 0.0) | (out > max_lai) | (np.abs(out) > 1.0e10) + out[bad] = np.nan + return out + + +def _sanitize_ndvi(values: np.ndarray) -> np.ndarray: + """Return NDVI with impossible/fill values masked as NaN.""" + out = np.asarray(values, dtype=np.float32).copy() + bad = (~np.isfinite(out)) | (out < -0.1) | (out > 1.1) | (np.abs(out) > 1.0e10) + out[bad] = np.nan + # Keep a very small tolerance for files with roundoff; clip to physical range. + out = np.where(np.isfinite(out), np.clip(out, 0.0, 1.0), np.nan).astype(np.float32) + return out + + +def _sanitize_fraction(values: np.ndarray) -> np.ndarray: + """Return generic fractional fields (GREEN/albedo) in 0..1 with fill values masked.""" + out = np.asarray(values, dtype=np.float32).copy() + bad = (~np.isfinite(out)) | (out < -0.01) | (out > 1.01) | (np.abs(out) > 1.0e10) + out[bad] = np.nan + out = np.where(np.isfinite(out), np.clip(out, 0.0, 1.0), np.nan).astype(np.float32) + return out + + +def _sanitize_z0_mm(values: np.ndarray, *, max_mm: float = 10000.0) -> np.ndarray: + """Mask impossible roughness length values in millimeters.""" + out = np.asarray(values, dtype=np.float32).copy() + bad = (~np.isfinite(out)) | (out < 0.0) | (out > max_mm) | (np.abs(out) > 1.0e20) + out[bad] = np.nan + return out + + +def _initial_loop_year_offset(h1: np.ndarray, h2: np.ndarray) -> int: + """Mimic the IDL loop's active year variable after the second header read. + + In clsm_plots.pro, the variable ``yr`` is overwritten by the *second* header + before the month/day loop starts. For files whose first interval is late + Dec -> Jan, using the first header's year makes January a full year too + early and causes large negative extrapolated LAI. Use h2[0] here to match + IDL's state at loop entry. + """ + return int(round(float(h2[0]))) + + +def _advance_loop_year_offset(header: np.ndarray, month: int) -> int: + yoff = int(round(float(header[0]))) + # IDL has: if((month eq 12) and (yr eq 2)) then yr = yr -1 + if month == 12 and yoff == 2: + yoff -= 1 + return yoff + + +def _valid_weighted_monthly_add(total: np.ndarray, count: np.ndarray, month_index: int, vals: np.ndarray) -> None: + good = np.isfinite(vals) + if np.any(good): + total[month_index, good] += vals[good].astype(np.float64) + count[month_index, good] += 1.0 + + +def monthly_means_from_interpolated(path: Path, ncat: int, layout: TimeSeriesLayout, kind: str = "raw") -> np.ndarray: + mdays = [31, 28, 31, 30, 31, 30, 31, 31, 30, 31, 30, 31] + total = np.zeros((12, ncat), dtype=np.float64) + count = np.zeros((12, ncat), dtype=np.float64) + if not path.exists(): + raise ClsmPlotError(f"Missing time series file: {path}") + with TimeSeriesReader(path, layout, ncat) as rdr: + h1, v1 = read_timeseries_record(rdr, ncat) + h2, v2 = read_timeseries_record(rdr, ncat) + b4 = midpoint_doy(h1) + nxt = midpoint_doy(h2) + current_year_offset = _initial_loop_year_offset(h1, h2) + for month in range(1, 13): + for day in range(1, mdays[month - 1] + 1): + now = float((_dt.date(2001 + current_year_offset, month, day) - _dt.date(2000, 12, 31)).days) + denom = (nxt - b4) if abs(nxt - b4) > 1e-6 else 1.0 + fac1 = (now - b4) / denom + fac2 = (nxt - now) / denom + vals = (fac1 * v2 + fac2 * v1).astype(np.float32) + if kind.lower() == "lai": + vals = _sanitize_lai(vals) + elif kind.lower() == "ndvi": + vals = _sanitize_ndvi(vals) + elif kind.lower() in ("fraction", "green", "albedo"): + vals = _sanitize_fraction(vals) + else: + vals = np.where(np.isfinite(vals), vals, np.nan).astype(np.float32) + _valid_weighted_monthly_add(total, count, month - 1, vals) + if now + 0.5 >= nxt: + v1 = v2 + b4 = nxt + try: + h2, v2 = read_timeseries_record(rdr, ncat) + nxt = midpoint_doy(h2) + current_year_offset = _advance_loop_year_offset(h2, month) + except EOFError: + nxt = now + 9999.0 + monthly = np.full((12, ncat), np.nan, dtype=np.float32) + good = count > 0.0 + monthly[good] = (total[good] / count[good]).astype(np.float32) + return monthly + + +def panel_continuous_shared_colorbar( + grids: Sequence[np.ndarray], + titles: Sequence[str], + lon: np.ndarray, + lat: np.ndarray, + limits: Tuple[float, float, float, float], + outpath: Path, + ncols: int, + levels: Sequence[float], + color_ids: Optional[Sequence[int]] = None, + rgb: Optional[np.ndarray] = None, + figsize: Tuple[float, float] = (13, 9), + coastlines: bool = False, + cbar_label: str = "", + cbar_ticks: Optional[Sequence[float]] = None, + cbar_ticklabels: Optional[Sequence[str]] = None, + cbar_tick_rotation: float = 90.0, +) -> None: + """Multi-panel plot with one shared colorbar. + + This is better for LAI and Z0 where all panels use identical bins. + It avoids shrinking every map panel to make room for separate colorbars. + """ + n = len(grids) + nrows = int(math.ceil(n / ncols)) + fig = plt.figure(figsize=figsize) + fig.subplots_adjust(left=0.065, right=0.985, top=0.955, bottom=0.145, hspace=0.30, wspace=0.14) + last_im = None + for k, grid in enumerate(grids): + ax = make_axes(fig, nrows, ncols, k + 1, coastlines) + row = k // ncols + col = k % ncols + last_im = plot_continuous_on_ax( + ax, + grid, + lon, + lat, + limits, + titles[k], + levels=levels, + color_ids=color_ids, + rgb=rgb, + coastlines=coastlines, + show_xlabel=(row == nrows - 1), + show_ylabel=(col == 0), + ) + if last_im is not None: + cax = fig.add_axes([0.20, 0.060, 0.60, 0.024]) + if cbar_ticks is not None: + tick_values = np.asarray(cbar_ticks, dtype=float) + cbar = fig.colorbar( + last_im, + cax=cax, + orientation="horizontal", + ticks=tick_values, + spacing="uniform", + ) + cbar.ax.xaxis.set_major_locator(FixedLocator(tick_values)) + if cbar_ticklabels is not None: + if len(cbar_ticklabels) != len(tick_values): + raise ClsmPlotError( + f"Colorbar label count {len(cbar_ticklabels)} does not match " + f"tick count {len(tick_values)} for {outpath}" + ) + cbar.ax.xaxis.set_major_formatter(FixedFormatter(list(cbar_ticklabels))) + else: + cbar = fig.colorbar(last_im, cax=cax, orientation="horizontal") + cbar.ax.tick_params(labelsize=7, rotation=cbar_tick_rotation, pad=4) + for label in cbar.ax.get_xticklabels(): + label.set_horizontalalignment("right" if abs(cbar_tick_rotation) > 1.0 else "center") + label.set_verticalalignment("top") + if cbar_label: + cbar.set_label(cbar_label, fontsize=8, labelpad=7) + save_fig(fig, outpath) + + +def plot_monthly_timeseries( + base_dir: Path, + tile_id: np.ndarray, + lon: np.ndarray, + lat: np.ndarray, + limits, + outdir: Path, + ncat: int, + filename: str, + outname: str, + product_label: str, + layout: Optional[TimeSeriesLayout], + coastlines: bool, + *, + kind: str = "raw", + levels: Sequence[float] = FRACTION_LEVELS, + rgb: np.ndarray = LAI_RGB, + cbar_label: str = "", + cbar_ticks: Optional[Sequence[float]] = None, + cbar_ticklabels: Optional[Sequence[str]] = None, +) -> None: + """Plot a 12-panel monthly climatology from a tile time-series file. + + This is the same machinery used by LAI. GREEN and NDVI are easy package + additions because they share the same F77 time-series layout already used + for GREEN.mp4 and merged_Z0 diagnostics. + """ + path = base_dir / filename + if not path.exists(): + print(f"Skipping {outname}; missing {path}") + return + if layout is None: + print(f"Skipping {outname}; could not determine time-series layout for {path}") + return + monthly = monthly_means_from_interpolated(path, ncat, layout, kind=kind) + names = ["JAN", "FEB", "MAR", "APR", "MAY", "JUN", "JUL", "AUG", "SEP", "OCT", "NOV", "DEC"] + titles = [f"{mon}" for mon in names] + grids = [vector_to_grid(tile_id, monthly[m, :]) for m in range(12)] + panel_continuous_shared_colorbar( + grids, + titles, + lon, + lat, + limits, + outdir / outname, + ncols=3, + levels=levels, + rgb=rgb, + figsize=(13.5, 9.2), + coastlines=coastlines, + cbar_label=(cbar_label or product_label), + cbar_ticks=cbar_ticks, + cbar_ticklabels=cbar_ticklabels, + cbar_tick_rotation=0.0 if cbar_ticks is not None else 90.0, + ) + + +def plot_lai(base_dir: Path, tile_id: np.ndarray, lon: np.ndarray, lat: np.ndarray, limits, outdir: Path, ncat: int, layout: Optional[TimeSeriesLayout], coastlines: bool) -> None: + plot_monthly_timeseries( + base_dir, tile_id, lon, lat, limits, outdir, ncat, + "lai.dat", "lai.jpg", "LAI", layout, coastlines, + kind="lai", levels=LAI_LEVELS, rgb=LAI_RGB, cbar_label="LAI", + ) + + +def plot_green(base_dir: Path, tile_id: np.ndarray, lon: np.ndarray, lat: np.ndarray, limits, outdir: Path, ncat: int, layout: Optional[TimeSeriesLayout], coastlines: bool) -> None: + plot_monthly_timeseries( + base_dir, tile_id, lon, lat, limits, outdir, ncat, + "green.dat", "green.jpg", "GREEN", layout, coastlines, + kind="fraction", levels=FRACTION_LEVELS, rgb=LAI_RGB, + cbar_label="Green vegetation fraction", + cbar_ticks=FRACTION_TICKS, + cbar_ticklabels=FRACTION_TICK_LABELS, + ) + + +def plot_ndvi(base_dir: Path, tile_id: np.ndarray, lon: np.ndarray, lat: np.ndarray, limits, outdir: Path, ncat: int, layout: Optional[TimeSeriesLayout], coastlines: bool) -> None: + plot_monthly_timeseries( + base_dir, tile_id, lon, lat, limits, outdir, ncat, + "ndvi.dat", "ndvi.jpg", "NDVI", layout, coastlines, + kind="ndvi", levels=FRACTION_LEVELS, rgb=LAI_RGB, + cbar_label="NDVI", + cbar_ticks=FRACTION_TICKS, + cbar_ticklabels=FRACTION_TICK_LABELS, + ) + +def z0_value(z2ch: np.ndarray, lai: np.ndarray, scale4z0: float) -> np.ndarray: + min_veg_height = 0.01 + z0_by_zveg = 0.13 + if scale4z0 == 2.0: + return scale4z0 * z0_by_zveg * (z2ch - (z2ch - min_veg_height) * np.exp(-lai)) + return z0_by_zveg * (z2ch - scale4z0 * (z2ch - min_veg_height) * np.exp(-lai)) + + +def read_vegdyn(base_dir: Path, ncat: int, layout: F77Layout) -> Tuple[np.ndarray, np.ndarray, np.ndarray]: + path = base_dir / "vegdyn.data" + if not path.exists(): + raise ClsmPlotError(f"Missing vegdyn data: {path}") + if is_netcdf(path): + ity = read_nc_var(path, "ITY").reshape(-1).astype(np.float32) + z2 = read_nc_var(path, "Z2CH").reshape(-1).astype(np.float32) + asz0 = read_nc_var(path, "ASCATZ0").reshape(-1).astype(np.float32) + return ity[:ncat], z2[:ncat], asz0[:ncat] + with FortranSequentialReader(path, layout) as rdr: + ity = rdr.read_array(np.float32, ncat) + z2 = rdr.read_array(np.float32, ncat) + asz0 = rdr.read_array(np.float32, ncat) + return ity, z2, asz0 + + +def plot_canoph_from_vegdyn(base_dir: Path, tile_id: np.ndarray, lon, lat, limits, outdir: Path, ncat: int, layout: F77Layout, coastlines: bool) -> Tuple[np.ndarray, np.ndarray]: + _, z2, asz0 = read_vegdyn(base_dir, ncat, layout) + grid = vector_to_grid(tile_id, z2) + levels = np.linspace(float(np.nanmin(z2)), float(np.nanmax(z2)), 17) + panel_continuous([grid], ["Canopy height Z2CH"], lon, lat, limits, outdir / "Canopy_Height_onTiles.jpg", ncols=1, levels_list=[levels], color_ids_list=[list(reversed(CONTINUOUS_COLOR_IDS))], figsize=(11.2, 5.6), coastlines=coastlines) + return z2, asz0 * 1000.0 + + +def seasonal_z0_and_ndvi(base_dir: Path, ncat: int, z2ch: np.ndarray, scale4z0: float, lai_layout: TimeSeriesLayout, ndvi_layout: Optional[TimeSeriesLayout] = None) -> Tuple[np.ndarray, np.ndarray]: + lai_path = base_dir / "lai.dat" + ndvi_path = base_dir / "ndvi.dat" + if not lai_path.exists() or not ndvi_path.exists(): + raise ClsmPlotError(f"Missing {lai_path} or {ndvi_path}; required for icarus/merged Z0") + mdays = [31, 28, 31, 30, 31, 30, 31, 31, 30, 31, 30, 31] + season_months = {0: [12, 1, 2], 1: [3, 4, 5], 2: [6, 7, 8], 3: [9, 10, 11]} + # Accumulate valid daily means only. Invalid LAI/NDVI should not become + # zero roughness; otherwise it appears as artificial brown/underflow bins. + zo_sum = np.zeros((ncat, 4), dtype=np.float64) + zo_count = np.zeros((ncat, 4), dtype=np.float64) + ndvi_sum = np.zeros((ncat, 4), dtype=np.float64) + ndvi_count = np.zeros((ncat, 4), dtype=np.float64) + + if ndvi_layout is None: + ndvi_layout = lai_layout + with TimeSeriesReader(lai_path, lai_layout, ncat) as lai_rdr, TimeSeriesReader(ndvi_path, ndvi_layout, ncat) as ndvi_rdr: + lh1, lv1 = read_timeseries_record(lai_rdr, ncat) + lh2, lv2 = read_timeseries_record(lai_rdr, ncat) + nh1, nv1 = read_timeseries_record(ndvi_rdr, ncat) + nh2, nv2 = read_timeseries_record(ndvi_rdr, ncat) + lb4, lnxt = midpoint_doy(lh1), midpoint_doy(lh2) + nb4, nnxt = midpoint_doy(nh1), midpoint_doy(nh2) + current_year_offset = _initial_loop_year_offset(lh1, lh2) + for month in range(1, 13): + season = 0 if month in (12, 1, 2) else 1 if month in (3, 4, 5) else 2 if month in (6, 7, 8) else 3 + for day in range(1, mdays[month - 1] + 1): + now = float((_dt.date(2001 + current_year_offset, month, day) - _dt.date(2000, 12, 31)).days) + lden = (lnxt - lb4) if abs(lnxt - lb4) > 1e-6 else 1.0 + nden = (nnxt - nb4) if abs(nnxt - nb4) > 1e-6 else 1.0 + lai = ((now - lb4) / lden) * lv2 + ((lnxt - now) / lden) * lv1 + ndvi = ((now - nb4) / nden) * nv2 + ((nnxt - now) / nden) * nv1 + lai = _sanitize_lai(lai) + ndvi = _sanitize_ndvi(ndvi) + zot_m = 1000.0 * z0_value(z2ch, lai, scale4z0) + zot_m = _sanitize_z0_mm(zot_m) + + good_z = np.isfinite(zot_m) + if np.any(good_z): + zo_sum[good_z, season] += zot_m[good_z] + zo_count[good_z, season] += 1.0 + good_n = np.isfinite(ndvi) + if np.any(good_n): + ndvi_sum[good_n, season] += ndvi[good_n] + ndvi_count[good_n, season] += 1.0 + + if now + 0.5 >= lnxt: + lv1 = lv2 + lb4 = lnxt + try: + lh2, lv2 = read_timeseries_record(lai_rdr, ncat) + lnxt = midpoint_doy(lh2) + current_year_offset = _advance_loop_year_offset(lh2, month) + except EOFError: + lnxt = now + 9999.0 + if now + 0.5 >= nnxt: + nv1 = nv2 + nb4 = nnxt + try: + nh2, nv2 = read_timeseries_record(ndvi_rdr, ncat) + nnxt = midpoint_doy(nh2) + except EOFError: + nnxt = now + 9999.0 + zo_vec_mm = np.full((ncat, 4), np.nan, dtype=np.float32) + ndvi_vec = np.full((ncat, 4), np.nan, dtype=np.float32) + goodz = zo_count > 0.0 + goodn = ndvi_count > 0.0 + zo_vec_mm[goodz] = (zo_sum[goodz] / zo_count[goodz]).astype(np.float32) + ndvi_vec[goodn] = (ndvi_sum[goodn] / ndvi_count[goodn]).astype(np.float32) + return zo_vec_mm, ndvi_vec + + +def plot_z0(base_dir: Path, tile_id: np.ndarray, lon, lat, limits, outdir: Path, ncat: int, z2: np.ndarray, asz0_mm: np.ndarray, layout: Optional[TimeSeriesLayout], coastlines: bool, products: Sequence[str], ndvi_layout: Optional[TimeSeriesLayout] = None) -> None: + scale4z0 = 0.5 if (base_dir / "CLM_veg_typs_fracs").exists() else 2.0 + need_lai = any(p in ("icarus", "merged") for p in products) + zo_vec_mm = ndvi_vec = None + if need_lai: + if layout is None: + print("Skipping icarus/merged Z0: could not determine LAI/NDVI time-series layout") + else: + try: + zo_vec_mm, ndvi_vec = seasonal_z0_and_ndvi(base_dir, ncat, z2, scale4z0, layout, ndvi_layout) + except Exception as exc: + print(f"Skipping icarus/merged Z0: {exc}") + colors = Z0_COLOR_IDS + levels = Z0_LEVELS + sea_label = ["DJF", "MAM", "JJA", "SON"] + seasons_to_plot = [0, 2] + asz0_mm = _sanitize_z0_mm(asz0_mm) + for pname in products: + grids: List[np.ndarray] = [] + titles: List[str] = [] + for season in seasons_to_plot: + if pname == "ascat": + data = asz0_mm.copy() + elif pname == "icarus" and zo_vec_mm is not None: + data = _sanitize_z0_mm(zo_vec_mm[:, season]) + elif pname == "merged" and zo_vec_mm is not None and ndvi_vec is not None: + icarus = _sanitize_z0_mm(zo_vec_mm[:, season]) + ndvi = _sanitize_ndvi(ndvi_vec[:, season]) + data = icarus.copy() + # IDL uses ASZ0 where seasonal NDVI <= 0.2. Also use ASZ0 + # when NDVI or icarus is invalid so bad seasonal values do not + # appear as artificial lowest-bin/brown areas. + use_ascat = (~np.isfinite(data)) | (~np.isfinite(ndvi)) | (ndvi <= 0.2) + data[use_ascat] = asz0_mm[use_ascat] + data = _sanitize_z0_mm(data) + else: + continue + grids.append(vector_to_grid(tile_id, data)) + titles.append(f"{pname}: {sea_label[season]}") + if grids: + panel_continuous_shared_colorbar( + grids, + titles, + lon, + lat, + limits, + outdir / f"{pname}_Z0.jpg", + ncols=1, + levels=levels, + color_ids=colors, + figsize=(11.0, 8.0), + coastlines=coastlines, + cbar_label="Z0 (mm)", + cbar_ticks=Z0_LEVELS, + cbar_ticklabels=Z0_TICK_LABELS, + cbar_tick_rotation=45.0, + ) + + + +# ----------------------------------------------------------------------------- +# Irrigation products - NOT TESTED IN Python Package due to file unavailability. +# ----------------------------------------------------------------------------- + + +def plot_irrig_method(base_dir: Path, tile_id: np.ndarray, lon, lat, limits, outdir: Path, coastlines: bool) -> None: + path = base_dir / "irrig.dat" + if not path.exists(): + print(f"Skipping irrigation method; missing {path}") + return + names = ["SPRINKLERFR", "DRIPFR", "FLOODFR"] + titles = ["SPRINKLER FRACTION", "DRIP FRACTION", "FLOOD FRACTION"] + grids = [] + for name in names: + vec = read_nc_var(path, name).reshape(-1).astype(np.float32) + vec[vec > 1.0] = np.nan + g = vector_to_grid(tile_id, vec) + g[g == 0.0] = np.nan + grids.append(g) + levels = [np.arange(21) * 0.05] * 3 + panel_continuous(grids, titles, lon, lat, limits, outdir / "IrrigMethod.png", ncols=1, levels_list=levels, color_ids_list=[list(range(140, 161))] * 3, figsize=(9, 11), coastlines=coastlines) + + +def plot_lai_minmax(base_dir: Path, tile_id: np.ndarray, lon, lat, limits, outdir: Path, coastlines: bool) -> None: + path = base_dir / "irrig.dat" + if not path.exists(): + print(f"Skipping LAI min/max; missing {path}") + return + grids = [] + for name in ["LAIMIN", "LAIMAX"]: + vec = read_nc_var(path, name).reshape(-1).astype(np.float32) + vec[vec > 100.0] = np.nan + g = vector_to_grid(tile_id, vec) + g[g == 0.0] = np.nan + grids.append(g) + panel_continuous(grids, ["LAI Minimum", "LAI Maximum"], lon, lat, limits, outdir / "LAI_minmax.png", ncols=1, levels_list=[LAI_LEVELS, LAI_LEVELS], rgb_list=[LAI_RGB, LAI_RGB], figsize=(9, 11), coastlines=coastlines) + + +def plot_irrig_fractions(base_dir: Path, tile_id: np.ndarray, lon, lat, limits, outdir: Path, coastlines: bool) -> None: + path = base_dir / "irrig.dat" + if not path.exists(): + print(f"Skipping irrigation fractions; missing {path}") + return + names = ["IRRIGFRAC", "PADDYFRAC", "RAINFEDFRAC"] + titles = ["IRRIGATED CROP FRACTION", "PADDY FRACTION", "RAINFED FRACTION"] + grids = [] + for name in names: + vec = read_nc_var(path, name).reshape(-1).astype(np.float32) + vec[vec > 1.0] = np.nan + g = vector_to_grid(tile_id, vec) + g[g == 0.0] = np.nan + grids.append(g) + levels = [np.arange(21) * 0.025] * 3 + panel_continuous(grids, titles, lon, lat, limits, outdir / "GIA-Hybrid_IrrigFracs.png", ncols=1, levels_list=levels, color_ids_list=[list(range(140, 161))] * 3, figsize=(9, 11), coastlines=coastlines) + + +def _decode_crop_names(arr: np.ndarray) -> List[str]: + if arr.dtype.kind in {"S", "U"}: + return [str(x).strip(" b'\x00") for x in arr.reshape(-1)] + # xarray sometimes returns char arrays. Try joining along the last dimension. + if arr.ndim >= 2 and arr.dtype.kind in {"S", "U"}: + return ["".join(map(str, row)).strip() for row in arr.reshape(arr.shape[0], -1)] + return [f"crop_{i + 1:02d}" for i in range(26)] + + +def plot_crop_times(base_dir: Path, tile_id: np.ndarray, lon, lat, limits, outdir: Path, coastlines: bool) -> None: + """A compact Python version of plot_crop_times. + + The IDL routine creates multiple 4-row pages with crop fraction, planting + day, harvest day, and irrigation type for up to 26 crops. This version keeps + that structure but uses raster panels for fraction and scatter panels for DOY + and irrigation type. + """ + path = base_dir / "irrig.dat" + if not path.exists(): + print(f"Skipping crop times; missing {path}") + return + if xr is None: + print("Skipping crop times; xarray is unavailable") + return + with xr.open_dataset(path, decode_times=False) as ds: + required = ["IRRIGPLANT", "IRRIGHARVEST", "CROPIRRIGFRAC", "IRRIGTYPE"] + missing = [v for v in required if v not in ds] + if missing: + print(f"Skipping crop times; missing variables in {path}: {missing}") + return + plantv = np.asarray(ds["IRRIGPLANT"].values) + harvestv = np.asarray(ds["IRRIGHARVEST"].values) + fracv = np.asarray(ds["CROPIRRIGFRAC"].values) + irrigtypev = np.asarray(ds["IRRIGTYPE"].values) + crop_names = _decode_crop_names(np.asarray(ds["CROPCLASSNAME"].values)) if "CROPCLASSNAME" in ds else [f"crop_{i + 1:02d}" for i in range(26)] + + ncat = int(np.nanmax(tile_id)) + # Normalize expected dimensions so tile is first, crop is last where possible. + plantv = np.asarray(plantv) + harvestv = np.asarray(harvestv) + fracv = np.asarray(fracv) + irrigtypev = np.asarray(irrigtypev) + # Best effort: assume first dimension is tile. If not, try moving the ncat dimension first. + def move_tile_first(a: np.ndarray) -> np.ndarray: + for ax, size in enumerate(a.shape): + if size >= ncat: + return np.moveaxis(a, ax, 0) + return a + plantv = move_tile_first(plantv) + harvestv = move_tile_first(harvestv) + fracv = move_tile_first(fracv) + irrigtypev = move_tile_first(irrigtypev) + ncrops = min(26, fracv.shape[-1]) + levels_frac = np.arange(21) * 0.025 + doy_levels = np.array([1, 32, 60, 91, 121, 152, 182, 213, 244, 274, 305, 335, 366, 370]) + page = 1 + row_in_page = 0 + fig = None + + def new_page(): + return plt.figure(figsize=(13, 11)) + + for crop in range(ncrops): + # Extract tile vectors. Common shapes are (tile, season, crop) for plant/harvest and (tile, crop) for frac/type. + frac = fracv[:ncat, crop].astype(np.float32) if fracv.ndim == 2 else fracv[:ncat, ..., crop].reshape(ncat, -1)[:, 0].astype(np.float32) + ityp = irrigtypev[:ncat, crop].astype(np.float32) if irrigtypev.ndim == 2 else irrigtypev[:ncat, ..., crop].reshape(ncat, -1)[:, 0].astype(np.float32) + plant = plantv[:ncat, 0, crop].astype(np.float32) if plantv.ndim >= 3 else plantv[:ncat, crop].astype(np.float32) + harvest = harvestv[:ncat, 0, crop].astype(np.float32) if harvestv.ndim >= 3 else harvestv[:ncat, crop].astype(np.float32) + if not np.isfinite(frac).any() or np.nanmax(frac) <= 0: + continue + if fig is None: + fig = new_page() + panels = [vector_to_grid(tile_id, frac), vector_to_grid(tile_id, plant), vector_to_grid(tile_id, harvest), vector_to_grid(tile_id, ityp)] + titles = ["frac", "DOY plant", "DOY harvest", "IRRIGTYPE"] + levels = [levels_frac, doy_levels, doy_levels, [1, 2, 3, 4]] + color_ids = [list(range(140, 161)), [69, 145, 64, 66, 70, 71, 73, 75, 76, 78, 80, 113, 114, 116, 117], [69, 145, 64, 66, 70, 71, 73, 75, 76, 78, 80, 113, 114, 116, 117], [69, 64, 80, 255]] + for col in range(4): + ax = make_axes(fig, 4, 4, row_in_page * 4 + col + 1, coastlines) + plot_continuous_on_ax(ax, panels[col], lon, lat, limits, f"{crop_names[crop] if crop < len(crop_names) else crop}: {titles[col]}", levels[col], color_ids[col], coastlines=coastlines) + row_in_page += 1 + if row_in_page == 4: + save_fig(fig, outdir / f"gia_irrig_params_{page:02d}.png") + fig = None + row_in_page = 0 + page += 1 + if fig is not None: + save_fig(fig, outdir / f"gia_irrig_params_{page:02d}.png") + + +# ----------------------------------------------------------------------------- +# Movies +# ----------------------------------------------------------------------------- + + +def _format_movie_tick_label(x: float) -> str: + """Compact numeric labels for per-frame movie colorbars.""" + x = float(x) + if abs(x) < 1.0e-10: + return "0" + if abs(x - round(x)) < 1.0e-10: + return str(int(round(x))) + if abs(x) < 0.1: + return f"{x:.3f}".rstrip("0").rstrip(".") + if abs(x) < 1.0: + return f"{x:.2f}".rstrip("0").rstrip(".") + return f"{x:g}" + + +def movie_colorbar_ticks(vname: str) -> Tuple[np.ndarray, List[str], str]: + """Return stable, readable colorbar ticks for seasonal movies. + + LAI uses the same color scale as lai.jpg but labels integer values. GREEN, + VISDF, and NIRDF are fractional fields, so label 0..1 directly. The map + still uses the full level set; these are only the displayed colorbar ticks. + """ + if vname == "LAI": + ticks = np.asarray([0, 1, 2, 3, 4, 5, 6, 7], dtype=float) + return ticks, [_format_movie_tick_label(x) for x in ticks], "LAI" + ticks = np.asarray([0.0, 0.1, 0.2, 0.4, 0.6, 0.8, 1.0], dtype=float) + label_map = { + "GREEN": "Green vegetation fraction", + "VISDF": "VIS diffuse albedo", + "NIRDF": "NIR diffuse albedo", + "NDVI": "NDVI", + } + return ticks, [_format_movie_tick_label(x) for x in ticks], label_map.get(vname, vname) + + +def add_movie_colorbar(fig: plt.Figure, ax, sm: ScalarMappable, vname: str, levels: Sequence[float]) -> None: + """Add one horizontal colorbar to every movie frame. + + The movie frame is captured from the raw canvas, so the colorbar must be + drawn into the figure before ``buffer_rgba`` is read. Use fixed ticks so + every frame has a stable scale and readable labels. + """ + ticks, labels, label = movie_colorbar_ticks(vname) + cax = fig.add_axes([0.19, 0.075, 0.62, 0.030]) + cbar = fig.colorbar(sm, cax=cax, orientation="horizontal", ticks=ticks, spacing="uniform") + cbar.ax.xaxis.set_major_locator(FixedLocator(ticks)) + cbar.ax.xaxis.set_major_formatter(FixedFormatter(labels)) + cbar.ax.tick_params(labelsize=7, rotation=0, pad=2) + cbar.set_label(label, fontsize=8, labelpad=3) + +def make_movie( + base_dir: Path, + rst_file: Path, + nc: int, + nr: int, + ncat: int, + layout: Optional[TimeSeriesLayout], + rst_layout: F77Layout, + outdir: Path, + gfile: str, + vname: str, + nc_movie: int, + nr_movie: int, + limits: Tuple[float, float, float, float], + cache_dir: Path, + coastlines: bool, +) -> None: + if layout is None: + print(f"Skipping {vname} movie; could not determine time-series layout") + return + mapping_cache = cache_dir / f"fractional_{gfile}_{nc_movie}x{nr_movie}.npz" + # The movie aggregation map is built from the integer raster (.rst), so it + # must use the raster F77 layout. The seasonal LAI/GREEN/AlbMap layout is + # a different object and does not have marker_dtype. Passing it here caused + # movie-only runs to fail with: 'TimeSeriesLayout' object has no attribute + # 'marker_dtype'. + mat = build_fractional_sparse_from_rst(rst_file, nc, nr, ncat, nc_movie, nr_movie, rst_layout, mapping_cache) + filename_map = { + "LAI": "lai.dat", + "GREEN": "green.dat", + "VISDF": "AlbMap.WS.8-day.tile.0.3_0.7.dat", + "NIRDF": "AlbMap.WS.8-day.tile.0.7_5.0.dat", + "NDVI": "ndvi.dat", + } + path = base_dir / filename_map[vname] + if not path.exists(): + print(f"Skipping {vname} movie; missing {path}") + return + levels = LAI_LEVELS if vname == "LAI" else FRACTION_LEVELS + rgb = LAI_RGB + lon, lat = lon_lat_centers(nc_movie, nr_movie) + mdays = [31,28,31,30,31,30,31,31,30,31,30,31] + outpath = outdir / f"{vname}.mp4" + print(f"Writing movie {outpath}") + with TimeSeriesReader(path, layout, ncat) as rdr: + h1, v1 = read_timeseries_record(rdr, ncat) + h2, v2 = read_timeseries_record(rdr, ncat) + b4 = midpoint_doy(h1) + nxt = midpoint_doy(h2) + # Use the same year-offset logic and sanitation as the LAI/Z0 static plots. + # Using h1[0] here can extrapolate January from the wrong year for Dec->Jan + # climatology records, producing negative LAI in the movie even when lai.jpg is OK. + current_year_offset = _initial_loop_year_offset(h1, h2) + with open_mp4_writer(outpath, fps=10) as writer: + for month in range(1, 13): + for day in range(1, mdays[month - 1] + 1): + now = float((_dt.date(2001 + current_year_offset, month, day) - _dt.date(2000, 12, 31)).days) + denom = (nxt - b4) if abs(nxt - b4) > 1e-6 else 1.0 + vec = ((now - b4) / denom) * v2 + ((nxt - now) / denom) * v1 + if vname == "LAI": + vec = _sanitize_lai(vec) + elif vname == "NDVI": + vec = _sanitize_ndvi(vec) + else: + # GREEN, VISDF, and NIRDF are fractional fields. Keep real + # values in [0,1] and mask impossible/fill values. + vec = np.asarray(vec, dtype=np.float32) + bad = (~np.isfinite(vec)) | (vec < 0.0) | (vec > 1.0) | (np.abs(vec) > 1.0e10) + vec = vec.copy() + vec[bad] = np.nan + flat = mat @ vec.astype(np.float32) + grid = np.asarray(flat).reshape(nr_movie, nc_movie) + fig = plt.figure(figsize=(7.8, 5.85), dpi=100) + # Leave room for lon/lat tick labels and a fixed colorbar. + # Movie frames are captured from the raw canvas, not through + # savefig(..., bbox_inches="tight"), so margins must be explicit. + fig.subplots_adjust(left=0.085, right=0.985, bottom=0.205, top=0.90) + ax = make_axes(fig, 1, 1, 1, coastlines) + date_stamp = f"{2001 + current_year_offset:04d}{month:02d}{day:02d}" + sm = plot_continuous_on_ax(ax, grid, lon, lat, limits, f"{vname}: {date_stamp}", levels, rgb=rgb, coastlines=coastlines) + add_movie_colorbar(fig, ax, sm, vname, levels) + fig.canvas.draw() + frame = np.asarray(fig.canvas.buffer_rgba())[:, :, :3] + writer.append_data(frame) + plt.close(fig) + if now + 0.5 >= nxt: + v1 = v2 + b4 = nxt + try: + h2, v2 = read_timeseries_record(rdr, ncat) + nxt = midpoint_doy(h2) + current_year_offset = _advance_loop_year_offset(h2, month) + except EOFError: + nxt = now + 9999.0 + print(f"Wrote {outpath}") + + +# ----------------------------------------------------------------------------- +# Main driver +# ----------------------------------------------------------------------------- + + +DEFAULT_PLOTS = [ + "tiles", "country", "cti", "mosaic", "clm", "carbon", "ndep", "soil", + "elevation", "lai", "green", "ndvi", "canopy", "z0" +] +MOVIE_PLOTS = ["movies"] +LEGACY_PLOTS = DEFAULT_PLOTS + MOVIE_PLOTS +# Irrigation products - NOT TESTED IN Python Package due to file unavailability. +# These routines exist as legacy/experimental helpers, but the active legacy IDL +# driver does not call them by default. Keep them explicitly requestable without +# making --plots all unexpectedly produce unvalidated products. +EXPERIMENTAL_PLOTS = ["irrig_method", "lai_minmax", "irrig_fractions", "crop_times"] +VALID_PLOTS = LEGACY_PLOTS + EXPERIMENTAL_PLOTS +# User-facing "all" is intentionally current legacy parity, not experimental extras. +ALL_PLOTS = LEGACY_PLOTS + + +def parse_plot_list(text: str) -> List[str]: + text = text.strip().lower() + if text in ("default", "main", "fixed", "images"): + return DEFAULT_PLOTS.copy() + if text in ("legacy", "legacy_idl", "legacy-idl", "idl", "idl_default", "idl-default"): + return LEGACY_PLOTS.copy() + if text in ("all", "everything"): + return ALL_PLOTS.copy() + if text in ("quick", "smoke"): + return ["tiles", "cti", "elevation"] + if text in ("experimental", "extras"): + return EXPERIMENTAL_PLOTS.copy() + plots = [] + aliases = { + "veg": "mosaic", + "ndep_t2m": "ndep", + "soilalb": "ndep", + "irrig": "irrig_fractions", + "irrigation": "irrig_fractions", + } + for item in text.split(","): + item = item.strip().lower().replace("-", "_") + if not item: + continue + plots.append(aliases.get(item, item)) + unknown = [p for p in plots if p not in VALID_PLOTS] + if unknown: + raise ClsmPlotError( + f"Unknown plot option(s): {unknown}. " + f"Valid modes: quick, default, movies, legacy, all, experimental. " + f"Valid explicit items: {VALID_PLOTS}" + ) + return plots + + +def build_arg_parser() -> argparse.ArgumentParser: + p = argparse.ArgumentParser(description="Drop-in Python replacement for IDL clsm_plots.pro") + p.add_argument("--gfile", default=os.environ.get("gfile"), help="Grid/file stem used to find workdir/rst/*.rst. Defaults to $gfile.") + p.add_argument("--workdir", default=os.environ.get("workdir"), help="BCS work directory containing rst/. Defaults to $workdir.") + p.add_argument("--nc", type=int, default=int(os.environ["NC"]) if os.environ.get("NC") else None, help="Full raster NC. Defaults to $NC.") + p.add_argument("--nr", type=int, default=int(os.environ["NR"]) if os.environ.get("NR") else None, help="Full raster NR. Defaults to $NR.") + p.add_argument("--base-dir", default="..", help="Directory containing catchment.def, cti_stats.dat, soil_param.dat, etc. Default: ..") + p.add_argument("--outdir", default=".", help="Directory for plot outputs. Default: current directory.") + p.add_argument("--plots", default=os.environ.get("CLSM_PLOTS", "legacy"), help=f"Comma list, or quick/default/movies/legacy/all/experimental. No-argument default is legacy (current legacy IDL-equivalent outputs: fixed JPGs + movies); override with $CLSM_PLOTS. Valid explicit items: {','.join(VALID_PLOTS)}") + p.add_argument("--plot-nc", type=int, default=4320, help="Output longitude cells for the main tile map. IDL default: 4320") + p.add_argument("--plot-nr", type=int, default=2160, help="Output latitude cells for the main tile map. IDL default: 2160") + p.add_argument("--movie-nc", type=int, default=720, help="Movie longitude cells. IDL default: 720") + p.add_argument("--movie-nr", type=int, default=360, help="Movie latitude cells. IDL default: 360") + p.add_argument("--dpi", type=int, default=int(os.environ.get("CLSM_PLOT_DPI", "180")), help="DPI for static JPG plots. Default: 180; may also be set with $CLSM_PLOT_DPI.") + p.add_argument("--jpeg-quality", type=int, default=int(os.environ.get("CLSM_JPEG_QUALITY", "95")), help="JPEG quality for static JPG plots. Default: 95; may also be set with $CLSM_JPEG_QUALITY.") + p.add_argument("--endian", choices=["auto", "little", "big", "<", ">"], default="auto", help="Endian for F77 binary files. Default: auto") + p.add_argument("--record-marker", type=int, choices=[0, 4, 8], default=0, help="F77 record marker bytes. 0 means auto; otherwise 4 or 8.") + p.add_argument("--cache-dir", default=None, help="Directory for tile/mapping caches. Default: /.clsm_plot_cache, so cache is not moved into final clsm/plots.") + p.add_argument("--rst-file", default=None, help="Explicit raster file to use instead of auto-selecting workdir/rst/*.rst. Useful when both .rst and -Pfafstetter.rst are present.") + p.add_argument("--tile-source", choices=["auto", "rst", "catchment"], default=os.environ.get("CLSM_TILE_SOURCE", "auto"), help="How to build the plotting tile map. rst reproduces the IDL raster path; catchment builds lon/lat boxes directly from catchment.def; auto uses rst unless its IDs fail a catchment.def spatial-consistency check. Default: auto; may also be set with $CLSM_TILE_SOURCE") + p.add_argument("--no-cache", action="store_true", help="Do not read/write tile-map cache") + p.add_argument("--coastlines", dest="coastlines", action="store_true", default=(ccrs is not None), help="Draw coastlines if Cartopy is installed. Default: on when Cartopy is available.") + p.add_argument("--no-coastlines", dest="coastlines", action="store_false", help="Disable Cartopy coastlines even if Cartopy is installed.") + p.add_argument("--z0-products", default="ascat,icarus,merged", help="Comma list of Z0 products: ascat,icarus,merged") + return p + + +def main(argv: Optional[Sequence[str]] = None) -> int: + args = build_arg_parser().parse_args(argv) + global PLOT_DPI, JPEG_QUALITY + PLOT_DPI = int(args.dpi) + JPEG_QUALITY = int(args.jpeg_quality) + missing = [name for name in ("gfile", "workdir", "nc", "nr") if getattr(args, name) in (None, "")] + if missing: + raise ClsmPlotError(f"Missing required settings: {missing}. Provide args or set gfile/workdir/NC/NR environment variables.") + + gfile = str(args.gfile) + workdir = Path(str(args.workdir)).expanduser().resolve() + base_dir = Path(args.base_dir).expanduser().resolve() + outdir = Path(args.outdir).expanduser().resolve() + outdir.mkdir(parents=True, exist_ok=True) + cache_dir = Path(args.cache_dir).expanduser().resolve() if args.cache_dir else workdir / ".clsm_plot_cache" + plots = parse_plot_list(args.plots) + + ncat = read_ncat(base_dir) + limits = read_limits(base_dir, gfile) + rst_file, layout = select_rst_file( + workdir, gfile, ncat, int(args.nc), int(args.nr), args.endian, args.record_marker, args.rst_file + ) + print(f"ncat={ncat}; limits={limits}; F77 layout=endian {layout.endian}, marker {layout.marker_bytes} bytes") + + lon, lat = lon_lat_centers(args.plot_nc, args.plot_nr) + tile_cache = None if args.no_cache else cache_dir / f"tile_id_{gfile}_{args.plot_nc}x{args.plot_nr}.npz" + catch_cache = None if args.no_cache else cache_dir / f"tile_id_from_catchment_def_{gfile}_{args.plot_nc}x{args.plot_nr}.npz" + + if args.tile_source == "catchment": + tile_id = build_tile_id_from_catchment_def(base_dir, ncat, args.plot_nc, args.plot_nr, catch_cache) + else: + tile_id = build_tile_id_from_rst(rst_file, int(args.nc), int(args.nr), ncat, args.plot_nc, args.plot_nr, layout, tile_cache) + match = catchment_spatial_match_fraction(tile_id, base_dir, lon, lat, ncat) + print(f"RST/catchment.def spatial match fraction: {match:.6f}") + if args.tile_source == "auto" and match < 0.05: + print( + "RST tile IDs do not spatially match catchment.def boxes well; " + "falling back to catchment.def-derived plotting tile map. " + "Use --tile-source rst to force IDL-style rst mapping." + ) + tile_id = build_tile_id_from_catchment_def(base_dir, ncat, args.plot_nc, args.plot_nr, catch_cache) + + valid_tile_cells = int(np.count_nonzero((tile_id >= 1) & (tile_id <= ncat))) + total_tile_cells = int(tile_id.size) + print(f"Valid plotting cells: {valid_tile_cells}/{total_tile_cells}") + if valid_tile_cells == 0: + raise ClsmPlotError( + "Tile map has zero valid CLSM tile ids. This usually means the wrong rst file was used " + "or catchment.def boxes could not be mapped to the plotting grid. Delete the cache, " + "rerun with --no-cache, or try --tile-source catchment / --rst-file ." + ) + + if "tiles" in plots: + plot_tiles( + tile_id, lon, lat, limits, outdir, args.coastlines, + rst_file, int(args.nc), int(args.nr), ncat, layout, + gfile=gfile, + ) + if "country" in plots: + plot_country_codes(base_dir, tile_id, lon, lat, limits, outdir, args.coastlines) + if "cti" in plots: + plot_cti(base_dir, tile_id, lon, lat, limits, outdir, args.coastlines) + if "mosaic" in plots: + plot_mosaic(base_dir, tile_id, lon, lat, limits, outdir, args.coastlines) + if "clm" in plots: + plot_clm(base_dir, tile_id, lon, lat, limits, outdir, args.coastlines) + if "carbon" in plots: + plot_carbon(base_dir, tile_id, lon, lat, limits, outdir, args.coastlines) + if "ndep" in plots: + plot_ndep_t2m_soilalb(base_dir, tile_id, lon, lat, limits, outdir, args.coastlines) + if "soil" in plots: + plot_soil(base_dir, tile_id, lon, lat, limits, outdir, args.coastlines) + if "elevation" in plots: + plot_elevation(base_dir, tile_id, lon, lat, limits, outdir, args.coastlines) + if "lai" in plots: + try: + ts_layout = choose_timeseries_layout(base_dir / "lai.dat", ncat, args.endian, args.record_marker) if (base_dir / "lai.dat").exists() else None + plot_lai(base_dir, tile_id, lon, lat, limits, outdir, ncat, ts_layout, args.coastlines) + except Exception as exc: + print(f"Skipping lai.jpg after error: {exc}") + if "green" in plots: + try: + green_layout = choose_timeseries_layout(base_dir / "green.dat", ncat, args.endian, args.record_marker) if (base_dir / "green.dat").exists() else None + plot_green(base_dir, tile_id, lon, lat, limits, outdir, ncat, green_layout, args.coastlines) + except Exception as exc: + print(f"Skipping green.jpg after error: {exc}") + if "ndvi" in plots: + try: + ndvi_layout_static = choose_timeseries_layout(base_dir / "ndvi.dat", ncat, args.endian, args.record_marker) if (base_dir / "ndvi.dat").exists() else None + plot_ndvi(base_dir, tile_id, lon, lat, limits, outdir, ncat, ndvi_layout_static, args.coastlines) + except Exception as exc: + print(f"Skipping ndvi.jpg after error: {exc}") + + z2 = asz0_mm = None + if "canopy" in plots or "z0" in plots: + try: + z2, asz0_mm = plot_canoph_from_vegdyn(base_dir, tile_id, lon, lat, limits, outdir, ncat, layout, args.coastlines) + except Exception as exc: + print(f"Skipping Canopy_Height_onTiles.jpg / ASZ0 inputs after error: {exc}") + if "z0" in plots and z2 is not None and asz0_mm is not None: + z0_products = [x.strip().lower() for x in args.z0_products.split(",") if x.strip()] + ts_layout = None + ndvi_layout = None + if (base_dir / "lai.dat").exists(): + try: + ts_layout = choose_timeseries_layout(base_dir / "lai.dat", ncat, args.endian, args.record_marker) + except Exception as exc: + print(f"Could not determine LAI layout for icarus/merged Z0: {exc}") + if (base_dir / "ndvi.dat").exists(): + try: + ndvi_layout = choose_timeseries_layout(base_dir / "ndvi.dat", ncat, args.endian, args.record_marker) + except Exception as exc: + print(f"Could not determine NDVI layout for icarus/merged Z0: {exc}") + try: + plot_z0(base_dir, tile_id, lon, lat, limits, outdir, ncat, z2, asz0_mm, ts_layout, args.coastlines, z0_products, ndvi_layout=ndvi_layout) + except Exception as exc: + print(f"Skipping Z0 plots after error: {exc}") + + if "irrig_method" in plots: + plot_irrig_method(base_dir, tile_id, lon, lat, limits, outdir, args.coastlines) + if "lai_minmax" in plots: + plot_lai_minmax(base_dir, tile_id, lon, lat, limits, outdir, args.coastlines) + if "irrig_fractions" in plots: + plot_irrig_fractions(base_dir, tile_id, lon, lat, limits, outdir, args.coastlines) + if "crop_times" in plots: + plot_crop_times(base_dir, tile_id, lon, lat, limits, outdir, args.coastlines) + + if "movies" in plots: + for vname in ["LAI", "GREEN", "VISDF", "NIRDF", "NDVI"]: + try: + movie_layout = choose_timeseries_layout(base_dir / {"LAI":"lai.dat", "GREEN":"green.dat", "VISDF":"AlbMap.WS.8-day.tile.0.3_0.7.dat", "NIRDF":"AlbMap.WS.8-day.tile.0.7_5.0.dat", "NDVI":"ndvi.dat"}[vname], ncat, args.endian, args.record_marker) if (base_dir / {"LAI":"lai.dat", "GREEN":"green.dat", "VISDF":"AlbMap.WS.8-day.tile.0.3_0.7.dat", "NIRDF":"AlbMap.WS.8-day.tile.0.7_5.0.dat", "NDVI":"ndvi.dat"}[vname]).exists() else None + make_movie(base_dir, rst_file, int(args.nc), int(args.nr), ncat, movie_layout, layout, outdir, gfile, vname, args.movie_nc, args.movie_nr, limits, cache_dir, args.coastlines) + except Exception as exc: + print(f"Skipping {vname}.mp4 after error: {exc}") + + print("Done.") + return 0 + + +if __name__ == "__main__": + try: + raise SystemExit(main()) + except ClsmPlotError as exc: + print(f"ERROR: {exc}", file=sys.stderr) + raise SystemExit(2) diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/makebcs/create_README.csh b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/makebcs/create_README.csh index 4998f77ada..8cc811d351 100755 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/makebcs/create_README.csh +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/makebcs/create_README.csh @@ -1616,28 +1616,36 @@ cat clsm/intro clsm/soil clsm/veg1 clsm/veg2 clsm/README1 clsm/README2 clsm/READ ################################################################################# mkdir -p clsm/plots -/bin/cp bin/clsm_plots.pro clsm/plots/. +/bin/cp -p bin/clsm_plots.py clsm/plots/. cd clsm/plots/ module purge -module use -a /discover/swdev/gmao_SIteam/modulefiles-SLES12 +module use -a /discover/swdev/gmao_SIteam/modulefiles-SLES15 source ../../bin/g5_modules -module load idl/8.5 +module load python/GEOSpyD/26.3.2-0/3.14 +module load ffmpeg/5.0 # we need this for movies mp4 -idl < Date: Mon, 1 Jun 2026 09:32:43 -0400 Subject: [PATCH 03/40] compile python remove idl --- .../GEOSsurface_GridComp/Utils/Raster/makebcs/CMakeLists.txt | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/makebcs/CMakeLists.txt b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/makebcs/CMakeLists.txt index 3fb24cb508..2352325f08 100755 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/makebcs/CMakeLists.txt +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/makebcs/CMakeLists.txt @@ -51,7 +51,7 @@ ecbuild_add_executable (TARGET mk_runofftbl.x SOURCES mk_runofftbl.F90 LIBS MAPL ecbuild_add_executable (TARGET mkEASETilesParam.x SOURCES mkEASETilesParam.F90 LIBS MAPL ${this}) ecbuild_add_executable (TARGET TileFile_ASCII_to_nc4.x SOURCES TileFile_ASCII_to_nc4.F90 LIBS MAPL ${this}) -install(PROGRAMS clsm_plots.pro create_README.csh DESTINATION bin) +install(PROGRAMS clsm_plots.py create_README.csh DESTINATION bin) file(GLOB MAKE_BCS_PYTHON CONFIGURE_DEPENDS "./make_bcs*.py") list(FILTER MAKE_BCS_PYTHON EXCLUDE REGEX "make_bcs_shared.py") install(PROGRAMS ${MAKE_BCS_PYTHON} DESTINATION bin) From b5ab543bfabc8b3735589b07f6ccd5af87dad251 Mon Sep 17 00:00:00 2001 From: Sina Khani Date: Tue, 2 Jun 2026 12:09:32 -0400 Subject: [PATCH 04/40] Match SS_FOUND default value with OpenWater and SeaiceInterface --- .../GEOSsaltwater_GridComp/GEOS_SimpleSeaiceGridComp.F90 | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSsaltwater_GridComp/GEOS_SimpleSeaiceGridComp.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSsaltwater_GridComp/GEOS_SimpleSeaiceGridComp.F90 index e3897efc1b..d573698cf4 100644 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSsaltwater_GridComp/GEOS_SimpleSeaiceGridComp.F90 +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSsaltwater_GridComp/GEOS_SimpleSeaiceGridComp.F90 @@ -1071,7 +1071,7 @@ subroutine SetServices ( GC, RC ) UNITS = 'psu', & DIMS = MAPL_DimsTileOnly, & VLOCATION = MAPL_VLocationNone, & - DEFAULT = 30.0, & + DEFAULT = 33.3333, & !SK - Match the SS_FOUND inSimpleSeaice with that from OpenWater and SeaiceInterface _RC ) call MAPL_AddImportSpec(GC, & From 0f845d841b470841cc8712980c369db13a05df2e Mon Sep 17 00:00:00 2001 From: Matthew Thompson Date: Thu, 4 Jun 2026 10:23:21 -0400 Subject: [PATCH 05/40] Update CI - 2026-Jun-04 --- .circleci/config.yml | 7 ++----- .github/workflows/workflow.yml | 4 +--- 2 files changed, 3 insertions(+), 8 deletions(-) diff --git a/.circleci/config.yml b/.circleci/config.yml index 03b7678226..6f01249940 100644 --- a/.circleci/config.yml +++ b/.circleci/config.yml @@ -1,7 +1,7 @@ version: 2.1 # Anchors in case we need to override the defaults from the orb -#baselibs_version: &baselibs_version v8.14.0 +#baselibs_version: &baselibs_version v8.32.0 #bcs_version: &bcs_version v12.0.0 orbs: @@ -21,10 +21,7 @@ workflows: #baselibs_version: *baselibs_version repo: GEOSgcm checkout_fixture: true - # V12 code uses a special branch for now. - fixture_branch: feature/sdrabenh/gcm_v12 - # We comment out this as it will "undo" the fixture_branch - #mepodevelop: true + mepodevelop: true persist_workspace: true # Needs to be true to run fv3/gcm experiment, costs extra # Run AMIP GCM (1 hour, no ExtData) diff --git a/.github/workflows/workflow.yml b/.github/workflows/workflow.yml index 951124df33..bb430dbbfe 100644 --- a/.github/workflows/workflow.yml +++ b/.github/workflows/workflow.yml @@ -21,7 +21,7 @@ jobs: strategy: fail-fast: false matrix: - compiler: [ifort, gfortran-14, gfortran-15] + compiler: [ifort, gfortran-15, ifx] build-type: [Debug] fixture-repo: [GEOS-ESM/GEOSgcm, GEOS-ESM/GEOSldas] include: @@ -37,7 +37,6 @@ jobs: compiler: ${{ matrix.compiler }} cmake-build-type: ${{ matrix.build-type }} fixture-repo: GEOS-ESM/GEOSgcm - fixture-ref: feature/sdrabenh/gcm_v12 spack_build: strategy: @@ -54,6 +53,5 @@ jobs: BUILDCACHE_TOKEN: ${{ secrets.BUILDCACHE_TOKEN }} with: fixture-repo: GEOS-ESM/GEOSgcm - fixture-ref: feature/sdrabenh/gcm_v12 load-fms: true From 49e5d0b5bc54277b45f8f09b340adbddea9fe7f0 Mon Sep 17 00:00:00 2001 From: biljanaorescanin Date: Fri, 5 Jun 2026 21:33:14 -0400 Subject: [PATCH 06/40] fix moving bug in GNUGLOBAL and GLOBAL tests --- .../GEOSroute_GridComp/GEOS_RouteGridComp.F90 | 50 +++++++++++++------ 1 file changed, 35 insertions(+), 15 deletions(-) diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSroute_GridComp/GEOS_RouteGridComp.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSroute_GridComp/GEOS_RouteGridComp.F90 index c964e4d535..ee28039cd9 100644 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSroute_GridComp/GEOS_RouteGridComp.F90 +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSroute_GridComp/GEOS_RouteGridComp.F90 @@ -597,8 +597,12 @@ subroutine create_mapping_handler(tilegrid, pfaf_tilegrid, rc) logical, allocatable :: mask(:) integer, allocatable :: srcIndices(:), positions(:), factorIndexList(:,:),map_tile(:,:) real, allocatable :: weights(:), global_frac(:), global_area(:) + !!real(kind=8), allocatable :: weights(:), global_frac(:), global_area(:) integer, allocatable :: local_src(:), local_dst(:), global_src(:), global_dst(:) real, allocatable :: areacat_glob(:),area_tile(:) + !real(kind=8), allocatable :: areacat_glob(:) + !real, allocatable :: area_tile(:) + !real(kind=8), allocatable :: areacat_glob(:), area_tile(:) integer, pointer :: pfaf_index(:), local_id(:), local_i(:), local_j(:) real , pointer :: tilearea(:),frac_tot(:),fscale(:),area_patch(:) integer, pointer :: pfaf_patch(:),tid_patch(:) @@ -608,10 +612,10 @@ subroutine create_mapping_handler(tilegrid, pfaf_tilegrid, rc) character(len=MAPL_TileNameLength), pointer :: GNAMES(:) ! create source for orignal tile space - route%field_src = ESMF_FieldCreate(grid=tilegrid, typekind=ESMF_TYPEKIND_R4, _RC) + route%field_src = ESMF_FieldCreate(grid=tilegrid, typekind=ESMF_TYPEKIND_R8, _RC) ! create destination for pfaf tile space - route%field = ESMF_FieldCreate(grid=pfaf_tilegrid, typekind=ESMF_TYPEKIND_R4, _RC) + route%field = ESMF_FieldCreate(grid=pfaf_tilegrid, typekind=ESMF_TYPEKIND_R8, _RC) call MAPL_LocstreamGet(LOCSTREAM, GRIDNAMES=GNAMES, pfaf_index=pfaf_index, tilearea=tilearea, local_id=local_id, local_i=local_i, local_j=local_j, _RC) ! ESMF use global indices increasing with mpi_rank, no mask here for tile grid @@ -948,6 +952,7 @@ subroutine RUN (GC,IMPORT, EXPORT, CLOCK, RC ) integer :: nt_global, nt_local real, pointer :: arrayPtr(:) + real(kind=8), pointer :: arrayPtr8(:) type (RES_STATE), pointer :: res !real, allocatable :: WTOT_BEFORE(:) @@ -1028,21 +1033,36 @@ subroutine RUN (GC,IMPORT, EXPORT, CLOCK, RC ) if (ESMF_AlarmIsRinging(CollectWaterAlarm)) then ! finalize runoff accumulation over ROUTE_DT - route%runoff_acc = (route%runoff_acc + RUNOFF_SRC0)/real(ROUTE_DT/HEARTBEAT) ! time-avg runoff over ROUTE_DT in land[ice] tile space [kg/m2/s] - - ! redistribute runoff from tile space of GEOS_LandGridComp to Pfafstetter catchment space of GEOS_RouteGridComp - call ESMF_FieldGet(route%field_src, farrayPtr=arrayPtr, rc=status) + route%runoff_acc = (route%runoff_acc + RUNOFF_SRC0)/real(ROUTE_DT/HEARTBEAT) + + ! Redistribute time-averaged runoff from GEOS_LandGridComp tile space + ! to GEOS_RouteGridComp Pfafstetter catchment space. + ! The route remap fields are R8 to reduce non-BFB roundoff in the + ! EASE/Pfaf sparse remap before casting back to the route runoff array. + + ! Clear destination route/Pfaf field before remapping. + call ESMF_FieldGet(route%field, farrayPtr=arrayPtr8, rc=status) VERIFY_(STATUS) - ArrayPtr = route%runoff_acc(:) - call ESMF_FieldSMM(srcField=route%field_src, dstField=route%Field, & - routeHandle=route%routeHandle, rc=rc) - call ESMF_FieldGet(route%field, farrayPtr=arrayPtr, rc=status) + arrayPtr8 = 0.0_8 + + ! Fill source field from accumulated runoff in original land tile space. + call ESMF_FieldGet(route%field_src, farrayPtr=arrayPtr8, rc=status) VERIFY_(STATUS) - ! convert units [kg/m2/s] --> [m3/s] - QRUNOFF = arrayPtr*route%areacat/1000. ! time-avg runoff over ROUTE_DT in Pfaf catch space [m3/s] - !WTOT_BEFORE = WSTREAM + WRIVER + WRES - - + arrayPtr8 = real(route%runoff_acc(:), kind=8) + + ! Map accumulated runoff from land tile space to route/Pfaf space. + call ESMF_FieldSMM(srcField=route%field_src, dstField=route%field, & + routeHandle=route%routeHandle, rc=status) + VERIFY_(STATUS) + + ! Get mapped route/Pfaf runoff field. + call ESMF_FieldGet(route%field, farrayPtr=arrayPtr8, rc=status) + VERIFY_(STATUS) + + ! Convert units [kg/m2/s] --> [m3/s]. + QRUNOFF = real(arrayPtr8 * real(route%areacat, kind=8) / 1000.0_8, & + kind=kind(QRUNOFF(1))) + ! Compute outflow from main river and (optionally) reservoirs ! ! Call river_routing_model (get outflows from main river and local streams, also updates storage of main river and local streams) From 9a6eb5ef690a4e5cf7b8cb1a5e467b3a48b2ab47 Mon Sep 17 00:00:00 2001 From: biljanaorescanin Date: Fri, 5 Jun 2026 21:39:44 -0400 Subject: [PATCH 07/40] cleanup from commented out prints --- .../GEOSroute_GridComp/GEOS_RouteGridComp.F90 | 6 +----- 1 file changed, 1 insertion(+), 5 deletions(-) diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSroute_GridComp/GEOS_RouteGridComp.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSroute_GridComp/GEOS_RouteGridComp.F90 index ee28039cd9..5ffeac79ac 100644 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSroute_GridComp/GEOS_RouteGridComp.F90 +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSroute_GridComp/GEOS_RouteGridComp.F90 @@ -597,12 +597,8 @@ subroutine create_mapping_handler(tilegrid, pfaf_tilegrid, rc) logical, allocatable :: mask(:) integer, allocatable :: srcIndices(:), positions(:), factorIndexList(:,:),map_tile(:,:) real, allocatable :: weights(:), global_frac(:), global_area(:) - !!real(kind=8), allocatable :: weights(:), global_frac(:), global_area(:) integer, allocatable :: local_src(:), local_dst(:), global_src(:), global_dst(:) real, allocatable :: areacat_glob(:),area_tile(:) - !real(kind=8), allocatable :: areacat_glob(:) - !real, allocatable :: area_tile(:) - !real(kind=8), allocatable :: areacat_glob(:), area_tile(:) integer, pointer :: pfaf_index(:), local_id(:), local_i(:), local_j(:) real , pointer :: tilearea(:),frac_tot(:),fscale(:),area_patch(:) integer, pointer :: pfaf_patch(:),tid_patch(:) @@ -1033,7 +1029,7 @@ subroutine RUN (GC,IMPORT, EXPORT, CLOCK, RC ) if (ESMF_AlarmIsRinging(CollectWaterAlarm)) then ! finalize runoff accumulation over ROUTE_DT - route%runoff_acc = (route%runoff_acc + RUNOFF_SRC0)/real(ROUTE_DT/HEARTBEAT) + route%runoff_acc = (route%runoff_acc + RUNOFF_SRC0)/real(ROUTE_DT/HEARTBEAT) ! time-avg runoff over ROUTE_DT in land[ice] tile space [kg/m2/s] ! Redistribute time-averaged runoff from GEOS_LandGridComp tile space ! to GEOS_RouteGridComp Pfafstetter catchment space. From 0aecc9f9a469e7c2a63e2bfe178cb20b881944cc Mon Sep 17 00:00:00 2001 From: biljanaorescanin Date: Fri, 5 Jun 2026 21:48:32 -0400 Subject: [PATCH 08/40] not used anymore --- .../GEOSroute_GridComp/GEOS_RouteGridComp.F90 | 1 - 1 file changed, 1 deletion(-) diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSroute_GridComp/GEOS_RouteGridComp.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSroute_GridComp/GEOS_RouteGridComp.F90 index 5ffeac79ac..4d71a0cfc0 100644 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSroute_GridComp/GEOS_RouteGridComp.F90 +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSroute_GridComp/GEOS_RouteGridComp.F90 @@ -947,7 +947,6 @@ subroutine RUN (GC,IMPORT, EXPORT, CLOCK, RC ) integer :: nt_global, nt_local - real, pointer :: arrayPtr(:) real(kind=8), pointer :: arrayPtr8(:) type (RES_STATE), pointer :: res From dd92d4882d93660ce0fd6be123f738f03a439d2d Mon Sep 17 00:00:00 2001 From: biljanaorescanin Date: Sat, 6 Jun 2026 06:54:13 -0400 Subject: [PATCH 09/40] maybe better comment --- .../GEOSroute_GridComp/GEOS_RouteGridComp.F90 | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSroute_GridComp/GEOS_RouteGridComp.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSroute_GridComp/GEOS_RouteGridComp.F90 index 4d71a0cfc0..1492cad82e 100644 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSroute_GridComp/GEOS_RouteGridComp.F90 +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSroute_GridComp/GEOS_RouteGridComp.F90 @@ -1032,9 +1032,9 @@ subroutine RUN (GC,IMPORT, EXPORT, CLOCK, RC ) ! Redistribute time-averaged runoff from GEOS_LandGridComp tile space ! to GEOS_RouteGridComp Pfafstetter catchment space. - ! The route remap fields are R8 to reduce non-BFB roundoff in the - ! EASE/Pfaf sparse remap before casting back to the route runoff array. - + ! Use R8 remap fields to avoid small run-to-run roundoff differences in + ! the EASE/Pfaf sparse remap before casting back to the route runoff array. + ! Clear destination route/Pfaf field before remapping. call ESMF_FieldGet(route%field, farrayPtr=arrayPtr8, rc=status) VERIFY_(STATUS) From 3cf25ec1d76cee3eafd8ad9714e0ffbb9033f4c1 Mon Sep 17 00:00:00 2001 From: biljanaorescanin Date: Mon, 8 Jun 2026 12:07:42 -0400 Subject: [PATCH 10/40] update based on feedback --- .../GEOSroute_GridComp/GEOS_RouteGridComp.F90 | 22 +++++++++---------- 1 file changed, 11 insertions(+), 11 deletions(-) diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSroute_GridComp/GEOS_RouteGridComp.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSroute_GridComp/GEOS_RouteGridComp.F90 index 1492cad82e..a06b3471fc 100644 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSroute_GridComp/GEOS_RouteGridComp.F90 +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSroute_GridComp/GEOS_RouteGridComp.F90 @@ -14,7 +14,7 @@ module GEOS_RouteGridCompMod ! IMPORTS : RUNOFF \\ ! !USES: - + use, intrinsic :: iso_fortran_env, only: REAL64 use ESMF use MAPL_Mod use MAPL_ConstantsMod @@ -549,7 +549,7 @@ function create_pfaf_grid(rc) result(pfaf_grid) type (ESMF_Grid) :: pfaf_grid integer, optional, intent(out) :: rc integer :: status - real(kind=8), pointer :: centers(:,:) + real(kind=REAL64), pointer :: centers(:,:) ! create catchment grid and it is tile space pfaf_Grid = ESMF_GridCreate( & name='CATCHMENT_GRID', & @@ -947,7 +947,7 @@ subroutine RUN (GC,IMPORT, EXPORT, CLOCK, RC ) integer :: nt_global, nt_local - real(kind=8), pointer :: arrayPtr8(:) + real(kind=REAL64), pointer :: arrayPtr8(:) type (RES_STATE), pointer :: res !real, allocatable :: WTOT_BEFORE(:) @@ -1029,21 +1029,21 @@ subroutine RUN (GC,IMPORT, EXPORT, CLOCK, RC ) ! finalize runoff accumulation over ROUTE_DT route%runoff_acc = (route%runoff_acc + RUNOFF_SRC0)/real(ROUTE_DT/HEARTBEAT) ! time-avg runoff over ROUTE_DT in land[ice] tile space [kg/m2/s] - + ! Redistribute time-averaged runoff from GEOS_LandGridComp tile space ! to GEOS_RouteGridComp Pfafstetter catchment space. ! Use R8 remap fields to avoid small run-to-run roundoff differences in - ! the EASE/Pfaf sparse remap before casting back to the route runoff array. - + ! the EASE/Pfaf sparse remap before casting back to the route runoff array. + ! Clear destination route/Pfaf field before remapping. call ESMF_FieldGet(route%field, farrayPtr=arrayPtr8, rc=status) VERIFY_(STATUS) - arrayPtr8 = 0.0_8 + arrayPtr8 = 0.0_REAL64 ! Fill source field from accumulated runoff in original land tile space. call ESMF_FieldGet(route%field_src, farrayPtr=arrayPtr8, rc=status) VERIFY_(STATUS) - arrayPtr8 = real(route%runoff_acc(:), kind=8) + arrayPtr8 = real(route%runoff_acc(:), kind=REAL64) ! Map accumulated runoff from land tile space to route/Pfaf space. call ESMF_FieldSMM(srcField=route%field_src, dstField=route%field, & @@ -1054,9 +1054,9 @@ subroutine RUN (GC,IMPORT, EXPORT, CLOCK, RC ) call ESMF_FieldGet(route%field, farrayPtr=arrayPtr8, rc=status) VERIFY_(STATUS) - ! Convert units [kg/m2/s] --> [m3/s]. - QRUNOFF = real(arrayPtr8 * real(route%areacat, kind=8) / 1000.0_8, & - kind=kind(QRUNOFF(1))) + ! Convert units [kg m-2 s-1] --> [m3 s-1]. + QRUNOFF = real(arrayPtr8 * real(route%areacat, kind=REAL64) / 1000.0_REAL64, & + kind=kind(QRUNOFF(1))) ! Compute outflow from main river and (optionally) reservoirs ! From 104017adfab9ad60a68b2cf0c52d1982cda84d82 Mon Sep 17 00:00:00 2001 From: Matt Thompson Date: Thu, 11 Jun 2026 14:48:05 -0400 Subject: [PATCH 11/40] bugfix: Replace non-standard fstat with standard Fortran INQUIRE in mkMITAquaRaster.F90 (#1446) Co-authored-by: Atanas L. Trayanov --- .../Utils/Raster/makebcs/mkMITAquaRaster.F90 | 37 +++++++++---------- 1 file changed, 17 insertions(+), 20 deletions(-) diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/makebcs/mkMITAquaRaster.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/makebcs/mkMITAquaRaster.F90 index 7edff67ed7..12eeb820dd 100644 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/makebcs/mkMITAquaRaster.F90 +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/makebcs/mkMITAquaRaster.F90 @@ -5,7 +5,7 @@ program MAIN use LogRectRasterizeMod, ONLY: LRRasterize use MAPL_ExceptionHandling - use, intrinsic :: iso_fortran_env, only: REAL64 + use, intrinsic :: iso_fortran_env, only: REAL64, INT64 implicit none integer, parameter :: IUNIT = 11, OUNIT = 12 @@ -14,9 +14,9 @@ program MAIN INTEGER :: NC INTEGER :: NX, NY - integer :: STATARRAY(12) - integer(REAL64) :: filesize - integer(REAL64) :: Length + integer :: ios + integer(INT64) :: filesize + integer(INT64) :: Length integer :: K integer :: i, j integer :: KF, L, NF @@ -84,7 +84,7 @@ program MAIN ! 161,162,179,180,197,198,215,216,233,234] !#15x15 nprocs = 360 !# blankList(1:108) -! [1,2,3,4,5,6,7,8,9,10,11,12,14,15,16,17,18,21,22,23,24,& +! [1,2,3,4,5,6,7,8,9,10,11,12,14,15,16,17,18,21,22,23,24,& ! 65,71,75,76,90,95,96,101,102,109,110,111,112,113,114,115,116,117,118,119,& ! 120,121,122,123,124,125,126,127,128,129,130,131,132,& ! 188,189,190,193,194,195,196,199,& @@ -112,7 +112,7 @@ program MAIN print *, trim(Usage) call exit(1) end if - + nxt = 1 call get_command_argument(nxt,arg) do while(arg(1:1)=='-') @@ -152,13 +152,12 @@ program MAIN BLNKSZ = count(blanklist /= 0) ! Open Facet 3 first. It is always a square (CS or LLC) - open (IUNIT,file=trim(GridDir)//'/tile003.mitgrid', status='old') - call fstat(IUNIT,statarray) - close (IUNIT) - filesize = statarray(8) + inquire(file=trim(GridDir)//'/tile003.mitgrid', size=filesize, iostat=ios) + if (ios /= 0) then + print *, 'Error opening file: ', trim(GridDir)//'/tile003.mitgrid' + call exit(1) + end if - !ALT: Kludge for LLC4320 - if (filesize <= 0) filesize = 2389893248 ! print *,'file size=',filesize LENGTH = filesize/REAL64 @@ -181,14 +180,12 @@ program MAIN LENGTH = nx*ny*REAL64 ! Open Facet 1 to check sizes CS or LLC) - open (IUNIT,file=trim(GridDir)//'/tile001.mitgrid', status='old') - call fstat(IUNIT,statarray) - close (IUNIT) - - filesize = statarray(8) + inquire(file=trim(GridDir)//'/tile001.mitgrid', size=filesize, iostat=ios) + if (ios /= 0) then + print *, 'Error opening file: ', trim(GridDir)//'/tile001.mitgrid' + call exit(1) + end if - !ALT: Kludge for LLC4320 - if (filesize <= 0) filesize = 7168573568 ! print *,'file size=',filesize LENGTH = filesize/(REAL64 * k) @@ -303,7 +300,7 @@ program MAIN open (IUNIT, FILE=trim(GridDir)//trim(FACEFILE), & ACCESS='DIRECT', RECL=LENGTH, STATUS='OLD',convert='big_endian') -! read (IUNIT,REC=5) rA +! read (IUNIT,REC=5) rA read (IUNIT,REC=6) XG read (IUNIT,REC=7) YG From d3d0cdf39d0c245561e1ec9ad1cdeaad2c98ca7d Mon Sep 17 00:00:00 2001 From: William Putman Date: Fri, 12 Jun 2026 18:16:52 -0400 Subject: [PATCH 12/40] ZeroDiff: latest L091 SCM and EMIP testing --- .../GEOSmoist_GridComp/ConvPar_GF2020.F90 | 176 +++++--- .../GEOS_GFDL_1M_InterfaceMod.F90 | 286 +++---------- .../GEOS_GF_InterfaceMod.F90 | 181 ++++++--- .../GEOS_MGB2_2M_InterfaceMod.F90 | 84 +--- .../GEOSmoist_GridComp/GEOS_MoistGridComp.F90 | 155 +++++--- .../GEOS_NSSL_2M_InterfaceMod.F90 | 25 -- .../GEOSmoist_GridComp/Process_Library.F90 | 376 +++++++++++++++--- .../aer_actv_single_moment.F90 | 57 ++- .../GEOSmoist_GridComp/gfdl_mp.F90 | 34 +- .../GEOS_TurbulenceGridComp.F90 | 72 ++-- .../GEOSturbulence_GridComp/LockEntrain.F90 | 21 +- 11 files changed, 843 insertions(+), 624 deletions(-) diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/ConvPar_GF2020.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/ConvPar_GF2020.F90 index 910b4cf72a..1fa200a1ed 100644 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/ConvPar_GF2020.F90 +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/ConvPar_GF2020.F90 @@ -48,7 +48,7 @@ MODULE ConvPar_GF2020 INTEGER :: OUTPUT_SOUND = 0 ! Diagnostic profile output flag LOGICAL :: wrtgrads = .FALSE. - INTEGER :: nrec = 0, ntimes = 0 + INTEGER :: ntimes = 0 REAL :: int_time = 0. !============================================================================= @@ -156,6 +156,15 @@ MODULE ConvPar_GF2020 INTEGER :: whoami_all, JCOL + !============================================================================= + ! OPENMP THREAD-PRIVATE STATE + !============================================================================= + !$OMP THREADPRIVATE( & + !$OMP HEI_DOWN_LAND, HEI_DOWN_OCEAN, HEI_UPDF_LAND, HEI_UPDF_OCEAN, & + !$OMP MIN_EDT_LAND, MIN_EDT_OCEAN, MAX_EDT_LAND, MAX_EDT_OCEAN, & + !$OMP FADJ_MASSFLX, USE_EXCESS, & + !$OMP JCOL ) + CONTAINS SUBROUTINE GF2020_INTERFACE( & @@ -774,7 +783,7 @@ SUBROUTINE GF2020_DRV( & INTEGER, DIMENSION(its:ite) :: kpbli, last_ierr INTEGER :: i, j, k, kr, n, itf, jtf, ktf, ispc, zmax, status, imemory, irun, jlx, kk, kss, plume, ii_plume - REAL :: dp, dq, exner, dtdt, PTEN, PQEN, PAPH, ZRHO, PAHFS, PQHFL, ZKHVFL, PGEOH, fixouts, dt_inv + REAL :: dp, dq, exner, dtdt, PTEN, PQEN, PAPH, ZRHO, PAHFS, PQHFL, ZKHVFL, PGEOH, fixouts, dt_inv, min_dist !=========================================================================== ! 2. INITIALIZATION & SETUP @@ -800,6 +809,41 @@ SUBROUTINE GF2020_DRV( & !=========================================================================== ! 3. MAIN HORIZONTAL (J) LOOP !=========================================================================== + !$OMP PARALLEL DO DEFAULT(NONE) & + !$OMP SHARED(jts, jtf, its, itf, kts, ktf, kte, dt, ite, dx2d, & + !$OMP conprr, lightn_dens, Tpert_h, Tpert_v, xland, sfc_press, & + !$OMP temp2m, topt, kpbl, lons, lats, zt, press, temp, rvap, & + !$OMP curr_rvap, u, v, dm, om, buoy_exc, rth_advten, rqvften, & + !$OMP rthblten, rqvblten, rthften, ccn_in, cnvfrc, srftype, & + !$OMP stochastic_sig, col_sat, mp_ice, mp_liq, mp_cf, CNV_Tracers, & + !$OMP flip, sflux_t, sflux_r, ADV_TRIGGER, APPLY_SUB_MP, & + !$OMP USE_TRACER_TRANSP, mtp, nmp, SH_MD_DP, & + !$OMP icumulus_gf, cum_hei_down_land, cum_hei_down_ocean, & + !$OMP cum_hei_updf_land, cum_hei_updf_ocean, cum_min_edt_land, & + !$OMP cum_min_edt_ocean, cum_max_edt_land, cum_max_edt_ocean, & + !$OMP cum_fadj_massflx, cum_use_excess, cumulus_type, closure_choice, & + !$OMP cum_entr_rate, cum_cap_maxs, FIX_NEGATIVES, USE_MOMENTUM_TRANSP, & + !$OMP CONVECTION_TRACER, do_this_column, & + !$OMP ierr4d, jmin4d, klcl4d, k224d, kbcon4d, ktop4d, kstabi4d, kstabm4d, & + !$OMP cprr4d, xmb4d, edt4d, pwav4d, sigma4d, pcup5d, entr5d, & + !$OMP up_massentr5d, up_massdetr5d, dd_massentr5d, dd_massdetr5d, & + !$OMP zup5d, zdn5d, prup5d, prdn5d, clwup5d, tup5d, conv_cld_fr5d, & + !$OMP sgs_vvel_5d, AA0, AA1, AA2, AA3, AA1_BL, AA1_CIN, TAU_BL, & + !$OMP TAU_DP, TAU_MD, RTHCUTEN, RVCUTEN, RUCUTEN, RQVCUTEN, RQCCUTEN, & + !$OMP REVSU_GF, PRFIL_GF, SUB_MPQL, SUB_MPQI, SUB_MPCF, RCHEMCUTEN, & + !$OMP RBUOYCUTEN) & + !$OMP PRIVATE(j, i, k, kr, n, ii_plume, plume, ispc, zmax, & + !$OMP pten, pqen, paph, zrho, pahfs, pqhfl, zkhvfl, pgeoh, & + !$OMP ztexec, zqexec, last_ierr, fixout_qv, revsu_gf_2d, & + !$OMP prfil_gf_2d, Tpert_2d, temp_tendqv, outt, outu, outv, & + !$OMP outq, outqc, outnice, outnliq, outbuoy, omeg, outmpqi, & + !$OMP outmpql, outmpcf, out_chem, xlandi, psur, tsur, ter11, & + !$OMP kpbli, xlons, xlats, zo, po, temp_old, qv_old, qv_curr, & + !$OMP rhoi, tkeg, rcpg, us, vs, dm2d, buoy_exc2d, temp_new_ADV, & + !$OMP qv_new_ADV, mpqi, mpql, mpcf, se_chem, pbl, h_sfc_flux, & + !$OMP le_sfc_flux, zws, TAU_, temp_new, qv_new, dhdt, & + !$OMP temp_new_BL, qv_new_BL, min_dist, distance, fixouts, cum_ztexec, & + !$OMP cum_zqexec) DO j = jts, jtf JCOL = j @@ -1067,12 +1111,21 @@ SUBROUTINE GF2020_DRV( & if (FIX_NEGATIVES) then DO i = its, itf if(do_this_column(i,j) == 0) cycle + + zmax = kts + min_dist = 99999.0 + do k = kts, ktf temp_tendqv(i,k) = outq(i,k,shal) + outq(i,k,deep) + outq(i,k,mid) distance(k) = qv_curr(i,k) + temp_tendqv(i,k) * dt + + if (distance(k) < min_dist) then + min_dist = distance(k) + zmax = k + end if enddo - if(minval(distance(kts:ktf)) < 0.0) then - zmax = MINLOC(distance(kts:ktf), 1) + + if(min_dist < 0.0) then if(abs(temp_tendqv(i,zmax) * dt) < mintracer) then fixout_qv(i) = 0.999999 else @@ -1334,9 +1387,9 @@ SUBROUTINE CUP_gf( & lambau_dn(:) = lambau_shdn CASE('mid') - z_cloud_top_min = 2500. ! Mid-level cloud - z_cloud_top_max = 5500. ! Capped below upper troposphere - depth_min = 1200. ! Noticeable mid-layer depth + z_cloud_top_min = 2000. ! Mid-level cloud + z_cloud_top_max = 6500. ! Capped below upper troposphere + depth_min = 1000. ! Noticeable mid-layer depth zkbmax = 5000. ! Elevated origin (above cold pools/PBL) zcutdown = 4000. ! Lower mid-levels z_detr = 1000. ! Evaporates in deep sub-cloud layer @@ -1695,7 +1748,8 @@ SUBROUTINE CUP_gf( & cd(i,k) = 0.75e-4 * (1.6 - frh) else ! --- RH dependence --- - rh_fac = max(0.5, min(1.1, 1.15 - 0.7*frh)) + ! Increase lateral mixing to reduce precipitation efficiency and moisten + rh_fac = max(0.5, min(1.3, 1.3 - 0.7*frh)) ! --- vertical scaling --- if (k >= klcl(i)) then z_fac = (qeso_cup(i,k) / qeso_cup(i,klcl(i)))**2.0 @@ -1705,11 +1759,12 @@ SUBROUTINE CUP_gf( & entr_rate(i,k) = entr_rate(i,k) * rh_fac endif entr_rate(i,k) = max(entr_rate(i,k), min_entr_rate) - SELECT CASE(trim(cumulus)) - CASE('deep'); cd(i,k) = 0.10 * entr_rate(i,k) - CASE('mid'); cd(i,k) = 0.50 * entr_rate(i,k) - CASE('shallow'); cd(i,k) = 0.75 * entr_rate(i,k) - END SELECT + ! --- Dynamic Updraft Detrainment (Physically driven by RH) --- + ! Uses incoming cd(i,k) [which is entr_rate_plume] and scales it + ! to shed more water into the environment to moisten the column + ! Drier air (frh -> 0) increases detrainment. + ! Moist air (frh -> 1) decreases detrainment. + cd(i,k) = cd(i,k) * (2.0 - frh) endif enddo ENDDO @@ -1725,29 +1780,22 @@ SUBROUTINE CUP_gf( & use_excess, zqexec, ztexec, x_add_buoy, xland, cnvfrc, itf, ktf, its, ite, kts, kte) !- Setup initial Downdraft Profile Parameters - if (ZERO_DIFF_ENTR == 1) then + if (ZERO_DIFF_ENTR == 1) then mentrd_rate = entr_rate_plume cdd = mentrd_rate sigd(:) = MERGE(1.0, 0.0, DOWNDRAFT) else - !- Scale-aware downdraft switch (matches updraft scaling perfectly) + !- Dynamically scale downdraft mixing using resolution awareness (sig) + ! At coarse resolutions (sig ~ 1), it mixes normally (multiplier ~1.0). + ! At fine resolutions (sig -> 0), the downdraft core is protected (multiplier drops to 0.5). + DO k = kts, kte + DO i = its, itf + if(ierr(i) /= 0) cycle + mentrd_rate(i,k) = entr_rate_plume * max(0.5, sig(i)) + cdd(i,k) = mentrd_rate(i,k) + ENDDO + ENDDO sigd(:) = MERGE(sig(:), 0.0, DOWNDRAFT) - !- Physically-based downdraft lateral mixing (Entrainment/Detrainment) - SELECT CASE(trim(cumulus)) - CASE('deep') - ! Restrict lateral mixing so the downdraft preserves its cold, - ! heavy core and transports moisture/mass forcefully into the lower levels - mentrd_rate = entr_rate_plume * 0.3 ! <--- DECREASED FROM 1.0 - CASE('mid') - ! Optionally reduce this too, or leave at 1.0 if you want mid-level - ! convection to remain leaky - mentrd_rate = entr_rate_plume * 0.5 - CASE('shallow') - mentrd_rate = entr_rate_plume * 0.3 - CASE DEFAULT - mentrd_rate = entr_rate_plume * 0.3 - END SELECT - cdd = mentrd_rate endif !- Update Source Parcels @@ -1871,10 +1919,10 @@ SUBROUTINE CUP_gf( & denom = (zu(i,k-1) - 0.5 * up_massdetro(i,k-1) + up_massentro(i,k-1)) if(denom > 0.0) then hco(i,k) = (hco(i,k-1) * zuo(i,k-1) - 0.5 * up_massdetro(i,k-1) * hco(i,k-1) + up_massentro(i,k-1) * heo(i,k-1)) / denom - if ( (ZERO_DIFF_ENTR /= 1) .AND. (k == start_level(i) + 1) ) then - x_add = (xlv*zqexec(i)+cp*ztexec(i)) + x_add_buoy(i) - hco(i,k)= hco(i,k) + x_add*up_massentro(i,k-1)/denom - endif + !if ( (ZERO_DIFF_ENTR /= 1) .AND. (k == start_level(i) + 1) ) then + ! x_add = (xlv*zqexec(i)+cp*ztexec(i)) + x_add_buoy(i) + ! hco(i,k)= hco(i,k) + x_add*up_massentro(i,k-1)/denom + !endif else hco(i,k) = hco(i,k-1) endif @@ -1939,12 +1987,11 @@ SUBROUTINE CUP_gf( & if(denom > 0.0 .and. denomU > 0.0) then hc(i,k) = (hc(i,k-1) * zu(i,k-1) - 0.5 * up_massdetr(i,k-1) * hc(i,k-1) + up_massentr(i,k-1) * he(i,k-1)) / denom hco(i,k) = (hco(i,k-1) * zuo(i,k-1) - 0.5 * up_massdetro(i,k-1) * hco(i,k-1) + up_massentro(i,k-1) * heo(i,k-1)) / denom - - if ( (ZERO_DIFF_ENTR /= 1) .AND. (k == start_level(i) + 1) ) then - x_add = (xlv*zqexec(i)+cp*ztexec(i)) + x_add_buoy(i) - hco(i,k)= hco(i,k) + x_add*up_massentro(i,k-1)/denom - hc (i,k)= hc (i,k) + x_add*up_massentr (i,k-1)/denom - endif + !if ( (ZERO_DIFF_ENTR /= 1) .AND. (k == start_level(i) + 1) ) then + ! x_add = (xlv*zqexec(i)+cp*ztexec(i)) + x_add_buoy(i) + ! hco(i,k)= hco(i,k) + x_add*up_massentro(i,k-1)/denom + ! hc (i,k)= hc (i,k) + x_add*up_massentr (i,k-1)/denom + !endif uc(i,k) = (uc(i,k-1) * zu(i,k-1) - 0.5 * up_massdetru(i,k-1) * uc(i,k-1) + up_massentru(i,k-1) * us(i,k-1) & - pgcon * 0.5 * (zu(i,k) + zu(i,k-1)) * (u_cup(i,k) - u_cup(i,k-1))) / denomU @@ -2143,6 +2190,7 @@ SUBROUTINE CUP_gf( & T_star = MERGE(5.0, 40.0, trim(cumulus) == 'deep') IF(SGS_W_TIMESCALE == 0.0) THEN + ! Option 1: Legacy / Default Method (Bechtold dx scaling) DO i = its, itf if(ierr(i) /= 0) cycle if(xland(i) > 0.99) then @@ -2158,17 +2206,37 @@ SUBROUTINE CUP_gf( & tau_ecmwf(i) = tau_ecmwf(i) * (1. + 1.66 * (dx(i) / 125000.)) ENDDO ELSE + ! Option 2: Dynamic / w_eff Method (Fixed logic, uses GF sig(i) scaling) DO i = its, itf if(ierr(i) /= 0) cycle + + ! 1. Boundary Layer Timescale Calculation umean = (1.0 - xland(i)) * 2.0 + xland(i) * (1.0 + sqrt(0.5 * (US(i,1)**2 + VS(i,1)**2 + US(i,kbcon(i))**2 + VS(i,kbcon(i))**2))) tau_bl(i) = max(1800.0, min(max(zo_cup(i,kbcon(i)) - z1(i), 1.0) / umean, 7200.0)) + ! 2. Dynamic ECMWF Timescale Calculation with GF sig(i) scale-awareness dz = max(zo_cup(i,ktop(i)) - zo_cup(i,kbcon(i)), 1.e-16) w_eff = min(max(vvel1d(i), 0.3), 4.0) tau_ecmwf(i) = (dz / w_eff) * (1.0 + sig(i)) * SGS_W_TIMESCALE - if(trim(cumulus) == 'deep') tau_ecmwf(i) = min(tau_deep, max(7200.0, max(tau_ecmwf(i), dtime))) - if(trim(cumulus) == 'mid') tau_ecmwf(i) = min(tau_mid , max(3600.0, max(tau_ecmwf(i), dtime))) - tau_ecmwf(i) = max(tau_ecmwf(i), tau_bl(i)) + + ! 3. Fix Min/Max Bounding Logic + ! Prevents hardcoding to tau_deep by keeping it between timestep and tau_deep + if(trim(cumulus) == 'deep') then + tau_ecmwf(i) = min(tau_deep, max(dtime, tau_ecmwf(i))) + elseif(trim(cumulus) == 'mid') then + tau_ecmwf(i) = min(tau_mid , max(dtime, tau_ecmwf(i))) + endif + + ! 4. Safely apply tau_bl as a lower limit without overriding tau_deep/tau_mid + ! Prevents a sluggish boundary layer wind from accidentally dragging the timescale to 7200s + if(trim(cumulus) == 'deep') then + tau_ecmwf(i) = max(tau_ecmwf(i), min(tau_bl(i), tau_deep)) + elseif(trim(cumulus) == 'mid') then + tau_ecmwf(i) = max(tau_ecmwf(i), min(tau_bl(i), tau_mid)) + else + tau_ecmwf(i) = max(tau_ecmwf(i), tau_bl(i)) + endif + ENDDO ENDIF @@ -2710,10 +2778,10 @@ SUBROUTINE CUP_gf( & xhc(i,k) = xhc(i,k-1) else xhc(i,k) = (xhc(i,k-1) * xzu(i,k-1) - .5 * up_massdetro(i,k-1) * xhc(i,k-1) + up_massentro(i,k-1) * xhe(i,k-1)) / denom - if ( (ZERO_DIFF_ENTR /= 1) .AND. (k == start_level(i) + 1) ) then - x_add = (xlv*zqexec(i)+cp*ztexec(i)) + x_add_buoy(i) - xhc(i,k)= xhc(i,k) + x_add*up_massentro(i,k-1)/denom - endif + !if ( (ZERO_DIFF_ENTR /= 1) .AND. (k == start_level(i) + 1) ) then + ! x_add = (xlv*zqexec(i)+cp*ztexec(i)) + x_add_buoy(i) + ! xhc(i,k)= xhc(i,k) + x_add*up_massentro(i,k-1)/denom + !endif endif xhc(i,k) = xhc(i,k) + xlf * (1. - p_liq_ice(i,k)) * qrco(i,k) enddo @@ -5019,7 +5087,7 @@ SUBROUTINE get_zu_zd_pdf(cumulus, draft,ierr,kb,kt,zu,kts,kte,ktf,kpbli,k22,kbco real , intent(inout) :: zu(kts:kte) character*(*), intent(in) ::draft,cumulus !- local var - integer :: kk,add,i,nrec=0,k,kb_adj,kpbli_adj,level_max_zu,ktarget + integer :: kk,add,i,k,kb_adj,kpbli_adj,level_max_zu,ktarget real :: zumax,ztop_adj,a2,beta, alpha,kratio,tunning,FZU,krmax,dzudk,hei_updf,hei_down real :: zuh(kts:kte),zul(kts:kte), pmaxzu ! pressure height of max zu for deep real, parameter :: px =45./120. ! px sets the pressure level of max zu. its range is from 1 to 120. @@ -5569,7 +5637,7 @@ SUBROUTINE get_zu_zd_pdf_orig(draft,ierr,kb,kt,zs,zuf,ztop,zu,kts,kte,ktf) character*(*), intent(in) ::draft !- local var - integer :: add,i,nrec=0,k,kb_adj + integer :: add,i,k,kb_adj real ::zumax,ztop_adj real ::beta, alpha,kratio,tunning @@ -5672,14 +5740,6 @@ SUBROUTINE get_zu_zd_pdf_orig(draft,ierr,kb,kt,zs,zuf,ztop,zu,kts,kte,ktf) return -!OPEN(19,FILE= 'zu.gra', FORM='unformatted',ACCESS='direct'& -! ,STATUS='unknown',RECL=4) -! DO k = kts,kte -! nrec=nrec+1 -! WRITE(19,REC=nrec) zu(k) -! END DO -!close (19) - END SUBROUTINE get_zu_zd_pdf_orig !------------------------------------------------------------------------------------ SUBROUTINE cup_up_cape(aa0,z,zu,dby,GAMMA_CUP,t_cup, & diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/GEOS_GFDL_1M_InterfaceMod.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/GEOS_GFDL_1M_InterfaceMod.F90 index 6504faf30c..ae499e991c 100644 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/GEOS_GFDL_1M_InterfaceMod.F90 +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/GEOS_GFDL_1M_InterfaceMod.F90 @@ -63,15 +63,6 @@ module GEOS_GFDL_1M_InterfaceMod logical :: LMELTFRZ_CLDMICRO real :: GFDL_MP_KLID - - logical :: LIQUID_SKIN_SNOW - logical :: LIQUID_SKIN_GRAUPEL - logical :: LIQUID_SKIN_HAIL - - real, PARAMETER :: W_START = 6.0 - real, PARAMETER :: W_FULL = 12.0 - real :: fraction_hail - logical :: REPORT_GFDL_1M_NEGATIVES logical :: GFDL_MP3 @@ -223,19 +214,19 @@ subroutine GFDL_1M_Setup (GC, CF, RC) call MAPL_AddExportSpec(GC, & SHORT_NAME = 'REF_DBZ', & LONG_NAME = 'Simulated_gfdl_radar_reflectivity', & - UNITS = 'dBZ', & + UNITS = 'dBZ', & DIMS = MAPL_DimsHorzVert, & VLOCATION = MAPL_VLocationCenter, RC=STATUS ) - VERIFY_(STATUS) - + VERIFY_(STATUS) + call MAPL_AddExportSpec(GC, & SHORT_NAME = 'REF_DBZ_MAX', & LONG_NAME = 'Maximum_composite_gfdl_radar_reflectivity', & - UNITS = 'dBZ', & + UNITS = 'dBZ', & DIMS = MAPL_DimsHorzOnly, & - VLOCATION = MAPL_VLocationNone, RC=STATUS ) + VLOCATION = MAPL_VLocationNone, RC=STATUS ) VERIFY_(STATUS) - + call MAPL_AddExportSpec(GC, & SHORT_NAME = 'REF_DBZ_1KM', & LONG_NAME = 'Base_1KM_AGL_gfdl_radar_reflectivity', & @@ -260,7 +251,7 @@ subroutine GFDL_1M_Setup (GC, CF, RC) VLOCATION = MAPL_VLocationNone, RC=STATUS ) VERIFY_(STATUS) - call MAPL_TimerAdd(GC, name="--GFDL_1M", RC=STATUS) + call MAPL_TimerAdd(GC, name="--GFDL_1M",RC=STATUS); VERIFY_(STATUS) VERIFY_(STATUS) end subroutine GFDL_1M_Setup @@ -285,30 +276,11 @@ subroutine GFDL_1M_Initialize (MAPL, CF, CLOCK, IMPORT, EXPORT, RC) CHARACTER(len=ESMF_MAXSTR) :: errmsg - real :: DBZ_DT - type(ESMF_Calendar) :: calendar - type(ESMF_Time) :: currTime - type(ESMF_Alarm) :: DBZ_RunAlarm - type(ESMF_TimeInterval) :: ringInterval - integer :: LM, year, month, day, hh, mm, ss - - call MAPL_Get(MAPL, LM=LM, RUNALARM=ALARM, RC=STATUS );VERIFY_(STATUS) + call MAPL_Get(MAPL, RUNALARM=ALARM, RC=STATUS );VERIFY_(STATUS) call ESMF_AlarmGet(ALARM, RingInterval=TINT, RC=STATUS); VERIFY_(STATUS) call ESMF_TimeIntervalGet(TINT, S_R8=DT_R8,RC=STATUS); VERIFY_(STATUS) DT_MOIST = DT_R8 - DBZ_DT = max(DT_MOIST,900.0) - call MAPL_GetResource(MAPL, DBZ_DT, 'DBZ_DT:', default=DBZ_DT, RC=STATUS); VERIFY_(STATUS) - ! Get the current time in addition to the calendar - call ESMF_ClockGet(CLOCK, currTime=currTime, calendar=calendar, RC=STATUS); VERIFY_(STATUS) - call ESMF_TimeIntervalSet(ringInterval, S=nint(DBZ_DT), calendar=calendar, RC=STATUS); VERIFY_(STATUS) - ! Add RingTime = currTime to anchor the alarm - DBZ_RunAlarm = ESMF_AlarmCreate(Clock = CLOCK, & - Name = 'DBZ_RunAlarm', & - RingTime = currTime, & - RingInterval = ringInterval, & - Sticky = .false. , RC=STATUS); VERIFY_(STATUS) - call MAPL_GetResource( MAPL, LPHYS_HYDROSTATIC, Label="PHYS_HYDROSTATIC:", default=.TRUE., RC=STATUS) VERIFY_(STATUS) LHYDROSTATIC = LPHYS_HYDROSTATIC @@ -332,7 +304,7 @@ subroutine GFDL_1M_Initialize (MAPL, CF, CLOCK, IMPORT, EXPORT, RC) call MAPL_GetResource(MAPL, REPORT_GFDL_1M_NEGATIVES, 'REPORT_GFDL_1M_NEGATIVES:', default=.FALSE., RC=STATUS) ; VERIFY_(STATUS) call MAPL_GetResource( MAPL, GFDL_MP3, Label="GFDL_MP3:", default=.TRUE., RC=STATUS); VERIFY_(STATUS) - if (DT_R8 <= 150.0) do_hail = .true. + if (DT_R8 <= 150.0) do_hail = .true. if (DT_R8 <= 150.0) do_sedi_heat = .true. if (DT_R8 <= 150.0) do_sedi_melt_qi = .true. if (DT_R8 <= 150.0) do_sedi_melt_qs = .true. @@ -343,7 +315,7 @@ subroutine GFDL_1M_Initialize (MAPL, CF, CLOCK, IMPORT, EXPORT, RC) call gfdl_mp_init(LHYDROSTATIC,DT_MOIST) call WRITE_PARALLEL ("INITIALIZED GFDL_1M gfdl_mp v3 in non-generic GC INIT") call MAPL_GetResource( MAPL, do_ref, Label="DO_GFDL_REFLECTIVITY:", default=.TRUE., RC=STATUS); VERIFY_(STATUS) - else + else call gfdl_cloud_microphys_init() call WRITE_PARALLEL ("INITIALIZED GFDL_1M gfdl_cloud_microphys in non-generic GC INIT") do_ref = .false. ! Force to false so MAPL DBZ Calc triggers, as older driver has no DBZ3D @@ -353,19 +325,6 @@ subroutine GFDL_1M_Initialize (MAPL, CF, CLOCK, IMPORT, EXPORT, RC) call MAPL_GetResource( MAPL, SH_MD_DP , 'SH_MD_DP:' , DEFAULT= .TRUE., RC=STATUS); VERIFY_(STATUS) - call MAPL_GetResource( MAPL, DBZ_VAR_INTERCP , 'DBZ_VAR_INTERCP:' , DEFAULT= DBZ_VAR_INTERCP, RC=STATUS); VERIFY_(STATUS) - - call MAPL_GetResource( MAPL, LIQUID_SKIN_SNOW , 'LIQUID_SKIN_SNOW:' , DEFAULT= .FALSE. , RC=STATUS); VERIFY_(STATUS) - call MAPL_GetResource( MAPL, LIQUID_SKIN_GRAUPEL , 'LIQUID_SKIN_GRAUPEL:' , DEFAULT= .FALSE., RC=STATUS); VERIFY_(STATUS) - call MAPL_GetResource( MAPL, LIQUID_SKIN_HAIL , 'LIQUID_SKIN_HAIL:' , DEFAULT= .TRUE. , RC=STATUS); VERIFY_(STATUS) - - refl10cm_allow_wet_graupel = .false. - call MAPL_GetResource( MAPL, refl10cm_allow_wet_graupel , 'refl10cm_allow_wet_graupel:' , & - DEFAULT= refl10cm_allow_wet_graupel, RC=STATUS); VERIFY_(STATUS) - refl10cm_allow_wet_snow = .false. - call MAPL_GetResource( MAPL, refl10cm_allow_wet_snow , 'refl10cm_allow_wet_snow:' , & - DEFAULT= refl10cm_allow_wet_snow, RC=STATUS); VERIFY_(STATUS) - call MAPL_GetResource( MAPL, constrain_modis_ice, 'constrain_modis_ice:', DEFAULT= .FALSE., RC=STATUS); VERIFY_(STATUS) call MAPL_GetResource( MAPL, TURNRHCRIT_PARAM, 'TURNRHCRIT:' , DEFAULT= -9999., RC=STATUS); VERIFY_(STATUS) @@ -396,13 +355,10 @@ subroutine GFDL_1M_Initialize (MAPL, CF, CLOCK, IMPORT, EXPORT, RC) call MAPL_GetResource( MAPL, CCI_EVAP_EFF, 'CCI_EVAP_EFF:', DEFAULT= CCI_EVAP_EFF, RC=STATUS); VERIFY_(STATUS) call MAPL_GetResource( MAPL, CNV_FRACTION_MIN, 'CNV_FRACTION_MIN:', DEFAULT= 500.0, RC=STATUS); VERIFY_(STATUS) - call MAPL_GetResource( MAPL, CNV_FRACTION_MAX, 'CNV_FRACTION_MAX:', DEFAULT= 3000.0, RC=STATUS); VERIFY_(STATUS) - call MAPL_GetResource( MAPL, CNV_FRACTION_EXP, 'CNV_FRACTION_EXP:', DEFAULT= 2.0, RC=STATUS); VERIFY_(STATUS) + call MAPL_GetResource( MAPL, CNV_FRACTION_MAX, 'CNV_FRACTION_MAX:', DEFAULT= 2500.0, RC=STATUS); VERIFY_(STATUS) call MAPL_GetResource( MAPL, GFDL_MP_KLID , 'GFDL_MP_KLID:' , DEFAULT= -999.0, RC=STATUS); VERIFY_(STATUS) - call init_refl10cm() - end subroutine GFDL_1M_Initialize subroutine GFDL_1M_Run (GC, IMPORT, EXPORT, CLOCK, RC) @@ -438,7 +394,7 @@ subroutine GFDL_1M_Run (GC, IMPORT, EXPORT, CLOCK, RC) real, allocatable, dimension(:,:,:) :: PLmb, ZL0 real, allocatable, dimension(:,:,:) :: DZ, DZET, DP, MASS, iMASS real, allocatable, dimension(:,:,:) :: DQST3, QST3 - real, allocatable, dimension(:,:,:) :: DBZ3D, TMP_NACTR + real, allocatable, dimension(:,:,:) :: DBZ3D real, allocatable, dimension(:,:,:) :: DQVDTmic, DQLDTmic, DQRDTmic, DQIDTmic, & DQSDTmic, DQGDTmic, DQADTmic, & DUDTmic, DVDTmic, DTDTmic, DWDTmic @@ -467,7 +423,7 @@ subroutine GFDL_1M_Run (GC, IMPORT, EXPORT, CLOCK, RC) real, pointer, dimension(:,:,:) :: PFR_LS, PFS_LS, PFG_LS real, pointer, dimension(:,:,:) :: PDFITERS real, pointer, dimension(:,:,:) :: RHCRIT3D - real, pointer, dimension(:,:,:) :: CNV_PRC3 + real, pointer, dimension(:,:,:) :: CNV_PRC3 real, pointer, dimension(:,:) :: EIS, LTS real, pointer, dimension(:,:) :: DBZ_MAX, DBZ_1KM, DBZ_TOP, DBZ_M10C real, pointer, dimension(:,:,:) :: DBZ @@ -505,7 +461,7 @@ subroutine GFDL_1M_Run (GC, IMPORT, EXPORT, CLOCK, RC) call MAPL_GetObjectFromGC ( GC, MAPL, RC=STATUS) VERIFY_(STATUS) - call MAPL_TimerOn (MAPL,"--GFDL_1M",RC=STATUS) + call MAPL_TimerOn (MAPL,"--GFDL_1M",RC=STATUS); VERIFY_(STATUS) ! Get parameters from generic state. !----------------------------------- @@ -596,11 +552,11 @@ subroutine GFDL_1M_Run (GC, IMPORT, EXPORT, CLOCK, RC) ALLOCATE ( DUDTmic(IM,JM,LM ) ) ALLOCATE ( DVDTmic(IM,JM,LM ) ) ALLOCATE ( DTDTmic(IM,JM,LM ) ) - ALLOCATE ( DWDTmic(IM,JM,LM ) ) + ALLOCATE ( DWDTmic(IM,JM,LM ) ) ! 2D Variables ALLOCATE ( TMP2D (IM,JM) ) ! 1D Variables - ALLOCATE ( TMP1D ( LM ) ) + ALLOCATE ( TMP1D ( LM ) ) ! Initialize to clear DBZ DBZ3D = -30.0 @@ -693,7 +649,7 @@ subroutine GFDL_1M_Run (GC, IMPORT, EXPORT, CLOCK, RC) ( QICN(I,J,L) < 0.0 ) .OR. ( QICN(I,J,L) /= QICN(I,J,L)) .OR. & ( QRAIN(I,J,L) < 0.0 ) .OR. ( QRAIN(I,J,L) /= QRAIN(I,J,L)) .OR. & ( QSNOW(I,J,L) < 0.0 ) .OR. ( QSNOW(I,J,L) /= QSNOW(I,J,L)) .OR. & - (QGRAUPEL(I,J,L) < 0.0 ) .OR. (QGRAUPEL(I,J,L) /= QGRAUPEL(I,J,L)) ) then + (QGRAUPEL(I,J,L) < 0.0 ) .OR. (QGRAUPEL(I,J,L) /= QGRAUPEL(I,J,L)) ) then print *, "T or Q spike detected : ", T(I,J,L) print *, " On Entry to GFDL : " print *, " Latitude =", LATS(I,J)*180.0/MAPL_PI @@ -709,7 +665,7 @@ subroutine GFDL_1M_Run (GC, IMPORT, EXPORT, CLOCK, RC) end do endif - call MAPL_TimerOn(MAPL,"---CLDMACRO") + call MAPL_TimerOn(MAPL,"---CLDMACRO",RC=STATUS); VERIFY_(STATUS) call MAPL_GetPointer(EXPORT, DQVDT_macro, 'DQVDT_macro' , ALLOC=.TRUE., RC=STATUS); VERIFY_(STATUS) call MAPL_GetPointer(EXPORT, DQIDT_macro, 'DQIDT_macro' , ALLOC=.TRUE., RC=STATUS); VERIFY_(STATUS) call MAPL_GetPointer(EXPORT, DQLDT_macro, 'DQLDT_macro' , ALLOC=.TRUE., RC=STATUS); VERIFY_(STATUS) @@ -763,9 +719,9 @@ subroutine GFDL_1M_Run (GC, IMPORT, EXPORT, CLOCK, RC) enddo enddo endif - + call MAPL_GetPointer(EXPORT, PTR3D, 'SHLW_SNO3', ALLOC=.TRUE., RC=STATUS); VERIFY_(STATUS) - if (associated(PTR3D)) then + if (associated(PTR3D)) then !$OMP parallel do default(none) & !$OMP shared(LM, JM, IM, QSNOW, PTR3D, DT_MOIST) & !$OMP private(I, J, L) @@ -804,7 +760,7 @@ subroutine GFDL_1M_Run (GC, IMPORT, EXPORT, CLOCK, RC) ! evap/subl/pdf call MAPL_GetPointer(EXPORT, RHCRIT3D, 'RHCRIT', ALLOC=.TRUE., RC=STATUS); VERIFY_(STATUS) - + !$OMP parallel do default(none) & !$OMP shared(LM, JM, IM, Q, T, QLLS, QILS, CLLS, QLCN, QICN, CLCN, KLID, & !$OMP facEIS_2d, minrhcrit_2d, turnrhcrit_2d, MAX_RH_CRIT, PLmb, PLEmb, & @@ -820,15 +776,15 @@ subroutine GFDL_1M_Run (GC, IMPORT, EXPORT, CLOCK, RC) call FIX_UP_CLOUDS( Q(I,J,L), T(I,J,L), QLLS(I,J,L), QILS(I,J,L), CLLS(I,J,L), & QLCN(I,J,L), QICN(I,J,L), CLCN(I,J,L), & REMOVE_CLOUDS=(L < KLID) ) - + ! Use Slingo-Ritter (1985) formulation for critical relative humidity ! Ensure the max is never lower than the min safe_max_rh_crit = MAX(MAX_RH_CRIT, minrhcrit_2d(I,J)) - if (PLmb(i,j,l) .le. turnrhcrit_2d(I,J)) then + if (PLmb(i,j,l) .le. turnrhcrit_2d(I,J)) then MIN_RH_CRIT = minrhcrit_2d(I,J) else if (L .eq. LM) then MIN_RH_CRIT = safe_max_rh_crit - else + else x_norm = (PLmb(i,j,l) - turnrhcrit_2d(I,J)) / (PLEmb(i,j,LM) - turnrhcrit_2d(I,J)) ! Cubic smoothstep S-curve: x^2 * (3 - 2x) MIN_RH_CRIT = minrhcrit_2d(I,J) + (safe_max_rh_crit - minrhcrit_2d(I,J)) * & @@ -837,7 +793,7 @@ subroutine GFDL_1M_Run (GC, IMPORT, EXPORT, CLOCK, RC) ! ----------------------------------------------------------------- ! Scale-Aware Blending for RHCRIT ! ----------------------------------------------------------------- - RHCRIT = MAX_RH_CRIT + (MIN_RH_CRIT-MAX_RH_CRIT)*SQRT(SQRT(AREA(I,J)/1.e10)) + RHCRIT = MAX_RH_CRIT + (MIN_RH_CRIT-MAX_RH_CRIT)*SQRT(SQRT(AREA(I,J)/1.e10)) ! limit ALPHA to < 30% ALPHA = max(0.0,min(0.30, (1.0-RHCRIT))) ! fill RHCRIT export @@ -882,7 +838,7 @@ subroutine GFDL_1M_Run (GC, IMPORT, EXPORT, CLOCK, RC) if (LMELTFRZ_CLDMACRO) then ! meltfrz new condensates call MELTFRZ ( DT_MOIST , & - CNV_FRC(I,J) , & + 1.0 , & ! since we are explicitly operating on CN types pass CNV_FRC always as 1.0 SRF_TYPE(I,J), & T(I,J,L) , & QLCN(I,J,L) , & @@ -927,7 +883,7 @@ subroutine GFDL_1M_Run (GC, IMPORT, EXPORT, CLOCK, RC) endif ! cleanup clouds after cldmacro call FIX_UP_CLOUDS( Q(I,J,L), T(I,J,L), QLLS(I,J,L), QILS(I,J,L), CLLS(I,J,L), & - QLCN(I,J,L), QICN(I,J,L), CLCN(I,J,L), & + QLCN(I,J,L), QICN(I,J,L), CLCN(I,J,L), & REMOVE_CLOUDS=(L < KLID) ) end do ! IM loop end do ! JM loop @@ -937,7 +893,7 @@ subroutine GFDL_1M_Run (GC, IMPORT, EXPORT, CLOCK, RC) deallocate(facEIS_2d, minrhcrit_2d, turnrhcrit_2d) ! Get fill negative export pointers if requested -! ---------------------------------------------- +! ---------------------------------------------- call MAPL_GetPointer(EXPORT, DQVDT_FILL, 'DQVDT_FILL_CLDMACRO', RC=STATUS); VERIFY_(STATUS) call MAPL_GetPointer(EXPORT, DQLLSDT_FILL, 'DQLLSDT_FILL_CLDMACRO', RC=STATUS); VERIFY_(STATUS) call MAPL_GetPointer(EXPORT, DQLCNDT_FILL, 'DQLCNDT_FILL_CLDMACRO', RC=STATUS); VERIFY_(STATUS) @@ -953,9 +909,9 @@ subroutine GFDL_1M_Run (GC, IMPORT, EXPORT, CLOCK, RC) call FILLQ2ZERO( QLCN , MASS, DT=DT_MOIST, DQDT=DQLCNDT_FILL, VM=VMG, RC=STATUS); VERIFY_(STATUS) call FILLQ2ZERO( QILS , MASS, DT=DT_MOIST, DQDT=DQILSDT_FILL, VM=VMG, RC=STATUS); VERIFY_(STATUS) call FILLQ2ZERO( QICN , MASS, DT=DT_MOIST, DQDT=DQICNDT_FILL, VM=VMG, RC=STATUS); VERIFY_(STATUS) - call FILLQ2ZERO( QRAIN , MASS, DT=DT_MOIST, DQDT= DQRDT_FILL, VM=VMG, RC=STATUS); VERIFY_(STATUS) - call FILLQ2ZERO( QSNOW , MASS, DT=DT_MOIST, DQDT= DQSDT_FILL, VM=VMG, RC=STATUS); VERIFY_(STATUS) - call FILLQ2ZERO( QGRAUPEL, MASS, DT=DT_MOIST, DQDT= DQGDT_FILL, VM=VMG, RC=STATUS); VERIFY_(STATUS) + call FILLQ2ZERO( QRAIN , MASS, DT=DT_MOIST, DQDT= DQRDT_FILL, VM=VMG, RC=STATUS); VERIFY_(STATUS) + call FILLQ2ZERO( QSNOW , MASS, DT=DT_MOIST, DQDT= DQSDT_FILL, VM=VMG, RC=STATUS); VERIFY_(STATUS) + call FILLQ2ZERO( QGRAUPEL, MASS, DT=DT_MOIST, DQDT= DQGDT_FILL, VM=VMG, RC=STATUS); VERIFY_(STATUS) ! Update macrophysics tendencies !$OMP parallel do default(none) & @@ -980,7 +936,7 @@ subroutine GFDL_1M_Run (GC, IMPORT, EXPORT, CLOCK, RC) enddo enddo enddo - call MAPL_TimerOff(MAPL,"---CLDMACRO") + call MAPL_TimerOff(MAPL,"---CLDMACRO",RC=STATUS); VERIFY_(STATUS) if (DEBUG_TQ_ERRORS) then do L = 1, LM @@ -1003,14 +959,14 @@ subroutine GFDL_1M_Run (GC, IMPORT, EXPORT, CLOCK, RC) print *, " CLLS=", CLLS(I,J,L), " CLCN=", CLCN(I,J,L) print *, " QV=", Q(I,J,L), " QLLS=", QLLS(I,J,L), " QLCN=", QLCN(I,J,L) print *, " QILS=", QILS(I,J,L), " QICN=", QICN(I,J,L) - print *, " QR=", QRAIN(I,J,L), " QS=", QSNOW(I,J,L), " QG=", QGRAUPEL(I,J,L) + print *, " QR=", QRAIN(I,J,L), " QS=", QSNOW(I,J,L), " QG=", QGRAUPEL(I,J,L) endif enddo enddo enddo endif - call MAPL_TimerOn(MAPL,"---CLDMICRO") + call MAPL_TimerOn(MAPL,"---CLDMICRO",RC=STATUS); VERIFY_(STATUS) ! Zero-out microphysics tendencies call MAPL_GetPointer(EXPORT, DQVDT_micro, 'DQVDT_micro' , ALLOC=.TRUE., RC=STATUS); VERIFY_(STATUS) call MAPL_GetPointer(EXPORT, DQIDT_micro, 'DQIDT_micro' , ALLOC=.TRUE., RC=STATUS); VERIFY_(STATUS) @@ -1114,7 +1070,7 @@ subroutine GFDL_1M_Run (GC, IMPORT, EXPORT, CLOCK, RC) enddo enddo if (do_ref) then - call MAPL_TimerOn(MAPL,"---CLD_REF_DBZ") + call MAPL_TimerOn(MAPL,"---CLD_REF_DBZ",RC=STATUS); VERIFY_(STATUS) call MAPL_GetPointer(EXPORT, DBZ , 'REF_DBZ' , RC=STATUS); VERIFY_(STATUS) call MAPL_GetPointer(EXPORT, DBZ_MAX , 'REF_DBZ_MAX' , RC=STATUS); VERIFY_(STATUS) call MAPL_GetPointer(EXPORT, DBZ_1KM , 'REF_DBZ_1KM' , RC=STATUS); VERIFY_(STATUS) @@ -1129,19 +1085,19 @@ subroutine GFDL_1M_Run (GC, IMPORT, EXPORT, CLOCK, RC) endif if (associated(DBZ_1KM)) then call cs_interpolator(1, IM, 1, JM, LM, DBZ3D, 1000., ZLE0, DBZ_1KM, -20.) - endif + endif if (associated(DBZ_TOP)) then DBZ_TOP=MAPL_UNDEF DO J=1,JM ; DO I=1,IM - DO L=LM,1,-1 + DO L=LM,1,-1 if (ZLE0(i,j,l) >= 25000.) continue if (DBZ3D(i,j,l) >= 18.5 ) then DBZ_TOP(I,J) = ZLE0(I,J,L) exit - endif + endif END DO END DO ; END DO - endif + endif if (associated(DBZ_M10C)) then DBZ_M10C=MAPL_UNDEF DO J=1,JM ; DO I=1,IM @@ -1154,7 +1110,7 @@ subroutine GFDL_1M_Run (GC, IMPORT, EXPORT, CLOCK, RC) END DO END DO ; END DO endif - call MAPL_TimerOff(MAPL,"---CLD_REF_DBZ") + call MAPL_TimerOff(MAPL,"---CLD_REF_DBZ",RC=STATUS); VERIFY_(STATUS) endif else call gfdl_cloud_microphys_driver( & @@ -1236,7 +1192,7 @@ subroutine GFDL_1M_Run (GC, IMPORT, EXPORT, CLOCK, RC) enddo ! Get fill negative export pointers if requested - ! ---------------------------------------------- + ! ---------------------------------------------- call MAPL_GetPointer(EXPORT, DQVDT_FILL, 'DQVDT_FILL_CLDMICRO', RC=STATUS); VERIFY_(STATUS) call MAPL_GetPointer(EXPORT, DQLLSDT_FILL, 'DQLLSDT_FILL_CLDMICRO', RC=STATUS); VERIFY_(STATUS) call MAPL_GetPointer(EXPORT, DQLCNDT_FILL, 'DQLCNDT_FILL_CLDMICRO', RC=STATUS); VERIFY_(STATUS) @@ -1307,14 +1263,14 @@ subroutine GFDL_1M_Run (GC, IMPORT, EXPORT, CLOCK, RC) tmp_val = MIN(1.0, MAX(QLCN(I,J,L) / MAX(RAD_QL(I,J,L), 1.E-8), 0.0)) PFL_AN(I,J,L) = (PFL_LS(I,J,L) + PFR_LS(I,J,L)) * tmp_val PFL_LS(I,J,L) = (PFL_LS(I,J,L) + PFR_LS(I,J,L)) - PFL_AN(I,J,L) - + tmp_val = MIN(1.0, MAX(QICN(I,J,L) / MAX(RAD_QI(I,J,L), 1.E-8), 0.0)) PFI_AN(I,J,L) = (PFI_LS(I,J,L) + PFS_LS(I,J,L) + PFG_LS(I,J,L)) * tmp_val PFI_LS(I,J,L) = (PFI_LS(I,J,L) + PFS_LS(I,J,L) + PFG_LS(I,J,L)) - PFI_AN(I,J,L) ! MeltFreeze and FixUp if (LMELTFRZ_CLDMICRO) then - call MELTFRZ(DT_MOIST, CNV_FRC(I,J), SRF_TYPE(I,J), T(I,J,L), QLCN(I,J,L), QICN(I,J,L)) + call MELTFRZ(DT_MOIST, CNV_FRC(I,J), SRF_TYPE(I,J), T(I,J,L), QLCN(I,J,L), QICN(I,J,L)) call MELTFRZ(DT_MOIST, CNV_FRC(I,J), SRF_TYPE(I,J), T(I,J,L), QLLS(I,J,L), QILS(I,J,L)) call FIX_UP_CLOUDS(Q(I,J,L), T(I,J,L), QLLS(I,J,L), QILS(I,J,L), CLLS(I,J,L), & QLCN(I,J,L), QICN(I,J,L), CLCN(I,J,L), REMOVE_CLOUDS=(L < KLID)) @@ -1381,7 +1337,7 @@ subroutine GFDL_1M_Run (GC, IMPORT, EXPORT, CLOCK, RC) enddo enddo enddo - call MAPL_TimerOff(MAPL,"---CLDMICRO") + call MAPL_TimerOff(MAPL,"---CLDMICRO",RC=STATUS); VERIFY_(STATUS) if (DEBUG_TQ_ERRORS) then do L = 1, LM @@ -1412,7 +1368,7 @@ subroutine GFDL_1M_Run (GC, IMPORT, EXPORT, CLOCK, RC) enddo endif - call MAPL_TimerOn(MAPL,"---CLDDIAGS") + call MAPL_TimerOn(MAPL,"---CLDDIAGS",RC=STATUS); VERIFY_(STATUS) call MAPL_GetPointer(EXPORT, PTR3D, 'DQRL', RC=STATUS); VERIFY_(STATUS) if(associated(PTR3D)) PTR3D = DQRDT_macro + DQRDT_micro @@ -1425,147 +1381,12 @@ subroutine GFDL_1M_Run (GC, IMPORT, EXPORT, CLOCK, RC) DVDT_macro+DVDT_micro,PTR3D) endif - ! Compute DBZ radar reflectivity - call ESMF_ClockGetAlarm(clock, 'DBZ_RunAlarm', alarm, RC=STATUS); VERIFY_(STATUS) - alarm_is_ringing = ESMF_AlarmIsRinging(alarm, RC=STATUS); VERIFY_(STATUS) - - call MAPL_GetPointer(EXPORT, NACTR, 'NACTR', RC=STATUS); VERIFY_(STATUS) - call MAPL_GetPointer(EXPORT, PTR2D, 'REFL10CM_MAX', RC=STATUS); VERIFY_(STATUS) - - ! 1. If the user explicitly requested NACTR export, fill it every time (or whenever needed) - if (associated(NACTR)) then - NACTR = 1.e8 * QRAIN**0.8 - endif - - ! 2. Handle the reflectivity alarm - if (alarm_is_ringing) then - call ESMF_AlarmRingerOff(alarm, RC=STATUS); VERIFY_(STATUS) - - ! Only compute if the user actually requested the reflectivity output - if (associated(PTR2D)) then - call MAPL_TimerOn(MAPL,"---CLD_REFL10CM") - rand1 = 0.0 - TMP3D = 0.0 - - ! If NACTR wasn't associated, we still need it for calc_refl10cm! - ! We can use TMP3D to temporarily hold NACTR if needed, or if calc_refl10cm - ! requires it as a distinct array, use a locally allocated TMP_NACTR array. - ! Assuming TMP_NACTR is an allocatable 3D array defined at the top: - - if (.not. associated(NACTR)) then - ! Fill a local temporary array to pass into the subroutine - ALLOCATE ( TMP_NACTR(IM,JM,LM) ) - TMP_NACTR = 1.e8 * QRAIN**0.8 - endif - - DO J=1,JM ; DO I=1,IM - ! Pass either the Export pointer (if associated) or the local temporary array - if (associated(NACTR)) then - call calc_refl10cm(Q(I,J,:), QRAIN(I,J,:), NACTR(I,J,:), QSNOW(I,J,:), QGRAUPEL(I,J,:), & - T(I,J,:), 100*PLmb(I,J,:), TMP3D(I,J,:), rand1, 1, LM, I, J) - else - call calc_refl10cm(Q(I,J,:), QRAIN(I,J,:), TMP_NACTR(I,J,:), QSNOW(I,J,:), QGRAUPEL(I,J,:), & - T(I,J,:), 100*PLmb(I,J,:), TMP3D(I,J,:), rand1, 1, LM, I, J) - endif - END DO ; END DO - - if (.not. associated(NACTR)) then - DEALLOCATE ( TMP_NACTR ) - endif - - PTR2D = -9999.0 - DO L=1,LM ; DO J=1,JM ; DO I=1,IM - PTR2D(I,J) = MAX(PTR2D(I,J),TMP3D(I,J,L)) - END DO ; END DO ; END DO - - call MAPL_TimerOff(MAPL,"---CLD_REFL10CM") - endif - endif - - call MAPL_TimerOn(MAPL,"---CLD_CALCDBZ") - call MAPL_GetPointer(EXPORT, DBZ , 'DBZ' , RC=STATUS); VERIFY_(STATUS) - call MAPL_GetPointer(EXPORT, DBZ_MAX , 'DBZ_MAX' , RC=STATUS); VERIFY_(STATUS) - call MAPL_GetPointer(EXPORT, DBZ_1KM , 'DBZ_1KM' , RC=STATUS); VERIFY_(STATUS) - call MAPL_GetPointer(EXPORT, DBZ_TOP , 'DBZ_TOP' , RC=STATUS); VERIFY_(STATUS) - call MAPL_GetPointer(EXPORT, DBZ_M10C, 'DBZ_M10C', RC=STATUS); VERIFY_(STATUS) - if ( (associated(DBZ) .OR. & - associated(DBZ_MAX) .OR. associated(DBZ_1KM) .OR. associated(DBZ_TOP) .OR. associated(DBZ_M10C)) ) then - allocate ( qg_col(LM) ) - allocate ( qh_col(LM) ) - allocate ( prs_col(LM) ) - allocate ( dbz_col(LM) ) - !$OMP parallel do default(none) & - !$OMP shared(IM, JM, LM, W, QGRAUPEL, PLmb, T, Q, QRAIN, QSNOW, & - !$OMP DBZ_VAR_INTERCP, LIQUID_SKIN_SNOW, LIQUID_SKIN_GRAUPEL, LIQUID_SKIN_HAIL, DBZ3D) & - !$OMP private(I, J, L, fraction_hail, qg_col, qh_col, prs_col, dbz_col) - DO J = 1, JM - DO I = 1, IM - ! 1. Prepare the 1D column data for this specific (I,J) location - DO L = 1, LM - ! Calculate a fraction between 0.0 and 1.0 based on updraft W - fraction_hail = MAX(0.0, MIN(1.0, (W(I,J,L) - W_START) / (W_FULL - W_START))) - ! Partition the mass into 1D thread-private columns - qh_col(L) = QGRAUPEL(I,J,L) * fraction_hail - qg_col(L) = QGRAUPEL(I,J,L) * (1.0 - fraction_hail) - ! Pre-multiply pressure for the function - prs_col(L) = 100.0 * PLmb(I,J,L) - END DO - ! 2. Call the newly refactored 1D column function - ! Note: We pass 1D array slices like T(I,J,:) directly. - dbz_col = compute_radar_reflectivity( & - PRS = prs_col, & - TMK = T(I,J,:), & - QVP = Q(I,J,:), & - QRAIN = QRAIN(I,J,:), & - QSNOW = QSNOW(I,J,:), & - QGRAUPEL = qg_col, & - QHAIL = qh_col, & - disable_variable_intercept_params = (DBZ_VAR_INTERCP == 0), & - liqskin_snow = LIQUID_SKIN_SNOW, & - liqskin_graupel = LIQUID_SKIN_GRAUPEL, & - liqskin_hail = LIQUID_SKIN_HAIL) - ! 3. Store the returned column back into the 3D state - DO L = 1, LM - DBZ3D(I,J,L) = dbz_col(L) - END DO - END DO - END DO - end if - if (associated(DBZ)) DBZ = DBZ3D - if (associated(DBZ_MAX)) then - DBZ_MAX=-9999.0 - DO L=1,LM ; DO J=1,JM ; DO I=1,IM - DBZ_MAX(I,J) = MAX(DBZ_MAX(I,J),DBZ3D(I,J,L)) - END DO ; END DO ; END DO - endif - if (associated(DBZ_1KM)) then - call cs_interpolator(1, IM, 1, JM, LM, DBZ3D, 1000., ZLE0, DBZ_1KM, -20.) - endif - if (associated(DBZ_TOP)) then - DBZ_TOP=MAPL_UNDEF - DO J=1,JM ; DO I=1,IM - DO L=LM,1,-1 - if (ZLE0(i,j,l) >= 25000.) continue - if (DBZ3D(i,j,l) >= 18.5 ) then - DBZ_TOP(I,J) = ZLE0(I,J,L) - exit - endif - END DO - END DO ; END DO - endif - if (associated(DBZ_M10C)) then - DBZ_M10C=MAPL_UNDEF - DO J=1,JM ; DO I=1,IM - DO L=LM,1,-1 - if (ZLE0(i,j,l) >= 25000.) continue - if (T(i,j,l) <= MAPL_TICE-10.0) then - DBZ_M10C(I,J) = DBZ3D(I,J,L) - exit - endif - END DO - END DO ; END DO - endif - call MAPL_TimerOff(MAPL,"---CLD_CALCDBZ") + ! Call the shared radar diagnostics routine + call MAPL_TimerOn(MAPL,"---RADAR_DIAGS",RC=STATUS); VERIFY_(STATUS) + call compute_radar_diagnostics(EXPORT, CLOCK, IM, JM, LM, & + Q, QRAIN, QSNOW, QGRAUPEL, T, PLmb, W, ZLE0, & + STATUS); VERIFY_(STATUS) + call MAPL_TimerOff(MAPL,"---RADAR_DIAGS",RC=STATUS); VERIFY_(STATUS) call MAPL_GetPointer(EXPORT, PTR3D, 'QRTOT', RC=STATUS); VERIFY_(STATUS) if (associated(PTR3D)) PTR3D = QRAIN @@ -1582,11 +1403,10 @@ subroutine GFDL_1M_Run (GC, IMPORT, EXPORT, CLOCK, RC) call MAPL_GetPointer(EXPORT, PTR2D, 'IWP', RC=STATUS); VERIFY_(STATUS) if (associated(PTR2D)) PTR2D = SUM( ( QICN+QILS+QSNOW+QGRAUPEL ) *MASS , 3 ) - call MAPL_TimerOff(MAPL,"---CLDDIAGS") - + call MAPL_TimerOff(MAPL,"---CLDDIAGS",RC=STATUS); VERIFY_(STATUS) endif ! USE_PYMOIST_GFDL1M - call MAPL_TimerOff(MAPL,"--GFDL_1M",RC=STATUS) + call MAPL_TimerOff(MAPL,"--GFDL_1M",RC=STATUS); VERIFY_(STATUS) end subroutine GFDL_1M_Run diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/GEOS_GF_InterfaceMod.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/GEOS_GF_InterfaceMod.F90 index 69f640feea..ca1c45f0e4 100644 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/GEOS_GF_InterfaceMod.F90 +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/GEOS_GF_InterfaceMod.F90 @@ -41,7 +41,6 @@ module GEOS_GF_InterfaceMod logical :: FIX_CNV_CLOUD logical :: REPORT_GF_NEGATIVES integer :: ZERO_DIFF_TAU - integer :: ZERO_DIFF_AUTOCONV integer :: ZERO_DIFF_VGRID integer :: ZERO_DIFF_OTHER logical :: USE_PYMOIST_GF2020 @@ -158,7 +157,6 @@ subroutine GF_Initialize (MAPL, CF, CLOCK, IMPORT, EXPORT, RC) call MAPL_GetResource(MAPL, ZERO_DIFF_VVEL , 'ZERO_DIFF_VVEL:' ,default= 1, RC=STATUS );VERIFY_(STATUS) call MAPL_GetResource(MAPL, ZERO_DIFF_ENTR , 'ZERO_DIFF_ENTR:' ,default= 1, RC=STATUS );VERIFY_(STATUS) call MAPL_GetResource(MAPL, ZERO_DIFF_TAU , 'ZERO_DIFF_TAU:' ,default= 1, RC=STATUS );VERIFY_(STATUS) - call MAPL_GetResource(MAPL, ZERO_DIFF_AUTOCONV , 'ZERO_DIFF_AUTOCONV:' ,default= 1, RC=STATUS );VERIFY_(STATUS) call MAPL_GetResource(MAPL, ZERO_DIFF_VGRID , 'ZERO_DIFF_VGRID:' ,default= 1, RC=STATUS );VERIFY_(STATUS) call MAPL_GetResource(MAPL, ZERO_DIFF_OTHER , 'ZERO_DIFF_OTHER:' ,default= 1, RC=STATUS );VERIFY_(STATUS) else @@ -167,7 +165,6 @@ subroutine GF_Initialize (MAPL, CF, CLOCK, IMPORT, EXPORT, RC) call MAPL_GetResource(MAPL, ZERO_DIFF_VVEL , 'ZERO_DIFF_VVEL:' ,default= 0, RC=STATUS );VERIFY_(STATUS) call MAPL_GetResource(MAPL, ZERO_DIFF_ENTR , 'ZERO_DIFF_ENTR:' ,default= 0, RC=STATUS );VERIFY_(STATUS) call MAPL_GetResource(MAPL, ZERO_DIFF_TAU , 'ZERO_DIFF_TAU:' ,default= 0, RC=STATUS );VERIFY_(STATUS) - call MAPL_GetResource(MAPL, ZERO_DIFF_AUTOCONV , 'ZERO_DIFF_AUTOCONV:' ,default= 0, RC=STATUS );VERIFY_(STATUS) call MAPL_GetResource(MAPL, ZERO_DIFF_VGRID , 'ZERO_DIFF_VGRID:' ,default= 0, RC=STATUS );VERIFY_(STATUS) call MAPL_GetResource(MAPL, ZERO_DIFF_OTHER , 'ZERO_DIFF_OTHER:' ,default= 0, RC=STATUS );VERIFY_(STATUS) endif @@ -192,34 +189,31 @@ subroutine GF_Initialize (MAPL, CF, CLOCK, IMPORT, EXPORT, RC) call MAPL_GetResource(MAPL, CUM_ENTR_RATE(SHAL) , 'ENTR_SH:' ,default= 6.0e-4,RC=STATUS );VERIFY_(STATUS) else call MAPL_GetResource(MAPL, MIN_ENTR_RATE , 'MIN_ENTR_RATE:' ,default= 0.1e-4,RC=STATUS );VERIFY_(STATUS) - call MAPL_GetResource(MAPL, CUM_ENTR_RATE(DEEP) , 'ENTR_DP:' ,default= 1.0e-4,RC=STATUS );VERIFY_(STATUS) + call MAPL_GetResource(MAPL, CUM_ENTR_RATE(DEEP) , 'ENTR_DP:' ,default= 1.2e-4,RC=STATUS );VERIFY_(STATUS) call MAPL_GetResource(MAPL, CUM_ENTR_RATE(MID) , 'ENTR_MD:' ,default= 9.0e-4,RC=STATUS );VERIFY_(STATUS) call MAPL_GetResource(MAPL, CUM_ENTR_RATE(SHAL) , 'ENTR_SH:' ,default= 1.0e-3,RC=STATUS );VERIFY_(STATUS) endif call MAPL_GetResource(MAPL, AUTOCONV , 'AUTOCONV:' ,default= 1, RC=STATUS );VERIFY_(STATUS) call MAPL_GetResource(MAPL, C0_DEEP , 'C0_DEEP:' ,default= 2.0e-3,RC=STATUS );VERIFY_(STATUS) - call MAPL_GetResource(MAPL, C0_MID , 'C0_MID:' ,default= 2.0e-3,RC=STATUS );VERIFY_(STATUS) + call MAPL_GetResource(MAPL, C0_MID , 'C0_MID:' ,default= 0.5e-3,RC=STATUS );VERIFY_(STATUS) call MAPL_GetResource(MAPL, C0_SHAL , 'C0_SHAL:' ,default= 0.0 ,RC=STATUS );VERIFY_(STATUS) call MAPL_GetResource(MAPL, QRC_CRIT_OCN , 'QRC_CRIT_OCN:' ,default= 2.0e-4,RC=STATUS );VERIFY_(STATUS) call MAPL_GetResource(MAPL, QRC_CRIT_LND , 'QRC_CRIT_LND:' ,default= 2.0e-4,RC=STATUS );VERIFY_(STATUS) - if (INT(ZERO_DIFF_AUTOCONV) == 0) then - ! C1: Explicit cloud condensate detrainment rate [m^-1]. - ! Controls how much suspended liquid/ice is forcibly shed into the grid-scale environment. - ! Default (1.0e-3) favors convective precipitation; increasing (e.g., 2.0e-3 to 3.0e-3) shifts - ! moisture to host microphysics, where evaporation can moisten the 700-300 mb free troposphere. - call MAPL_GetResource(MAPL, C1 , 'C1:' ,default= 3.0e-3,RC=STATUS );VERIFY_(STATUS) - else - call MAPL_GetResource(MAPL, C1 , 'C1:' ,default= 1.0e-3,RC=STATUS );VERIFY_(STATUS) - endif + ! C1: Explicit cloud condensate detrainment rate [m^-1]. + ! Controls how much suspended liquid/ice is forcibly shed into the grid-scale environment. + ! Default (1.0e-3) favors convective precipitation; increasing (e.g., 2.0e-3 to 3.0e-3) shifts + ! moisture to host microphysics, where evaporation can moisten the 700-300 mb free troposphere. + ! Caution: impact may inadvertantly flatten the ITCZ too much + call MAPL_GetResource(MAPL, C1 , 'C1:' ,default= 1.5e-3,RC=STATUS );VERIFY_(STATUS) if (INT(ZERO_DIFF_TAU) == 0) then call MAPL_GetResource(MAPL, GF_MIN_AREA , 'GF_MIN_AREA:' ,default= 0.0, RC=STATUS );VERIFY_(STATUS) SGS_W_TIMESCALE = 1.0 ! factor for adjusting GF2020 timescales call MAPL_GetResource(MAPL, SGS_W_TIMESCALE , 'SGS_W_TIMESCALE:' ,default= SGS_W_TIMESCALE, RC=STATUS );VERIFY_(STATUS) ! These are UPPER bounds for new GF timescales - call MAPL_GetResource(MAPL, TAU_MID , 'TAU_MID:' ,default= 7200., RC=STATUS );VERIFY_(STATUS) - call MAPL_GetResource(MAPL, TAU_DEEP , 'TAU_DEEP:' ,default=10800., RC=STATUS );VERIFY_(STATUS) + call MAPL_GetResource(MAPL, TAU_MID , 'TAU_MID:' ,default= 3600., RC=STATUS );VERIFY_(STATUS) + call MAPL_GetResource(MAPL, TAU_DEEP , 'TAU_DEEP:' ,default= 5400., RC=STATUS );VERIFY_(STATUS) ! FADJ_MASSFLX is a fractional mass flux tuning factor (1.0 is no reduction) in low CAPE environments call MAPL_GetResource(MAPL, CUM_FADJ_MASSFLX(DEEP) , 'FADJ_MASSFLX_DP:' ,default= 1.0, RC=STATUS );VERIFY_(STATUS) call MAPL_GetResource(MAPL, CUM_FADJ_MASSFLX(SHAL) , 'FADJ_MASSFLX_SH:' ,default= 0.5, RC=STATUS );VERIFY_(STATUS) @@ -401,7 +395,8 @@ subroutine GF_Run (GC, IMPORT, EXPORT, CLOCK, RC) integer :: IM,JM,LM real, pointer, dimension(:,:) :: LONS real, pointer, dimension(:,:) :: LATS - real :: minrhx + real :: minrhx, fqi_local, tmp_local + logical :: ptr_is_assoc ! Internals real, pointer, dimension(:,:,:) :: Q, QLLS, QLCN, CLLS, CLCN, QILS, QICN @@ -572,16 +567,48 @@ subroutine GF_Run (GC, IMPORT, EXPORT, CLOCK, RC) ALLOCATE ( SEEDCNV(IM,JM) ) ALLOCATE ( TMP2D (IM,JM) ) - ! derived quantaties ! Derived States - PL = 0.5*(PLE(:,:,0:LM-1) + PLE(:,:,1:LM)) - PK = (PL/MAPL_P00)**(MAPL_KAPPA) - DO L=0,LM - ZLE0(:,:,L)= ZLE(:,:,L) - ZLE(:,:,LM) ! Edge Height (m) above the surface - END DO - ZL0 = 0.5*(ZLE0(:,:,0:LM-1) + ZLE0(:,:,1:LM) ) ! Layer Height (m) above the surface - TH = T/PK - MASS = ( PLE(:,:,1:LM)-PLE(:,:,0:LM-1) )/MAPL_GRAV + !-------------------------------------------------------------- + + ! 1. Top-of-atmosphere edge (L = 0) + !$OMP PARALLEL DO DEFAULT(NONE) & + !$OMP SHARED(IM, JM, LM, ZLE0, ZLE) & + !$OMP PRIVATE(I, J) + do J = 1, JM + !DIR$ IVDEP + do I = 1, IM + ZLE0(I,J,0) = ZLE(I,J,0) - ZLE(I,J,LM) + end do + end do + !$OMP END PARALLEL DO + + ! 2. Remaining edges and all layer variables (L = 1 to LM) + !$OMP PARALLEL DO DEFAULT(NONE) & + !$OMP SHARED(IM, JM, LM, ZLE0, ZLE, PL, PLE, PK, & + !$OMP ZL0, TH, T, MASS) & + !$OMP PRIVATE(I, J, L) + do L = 1, LM + do J = 1, JM + !DIR$ IVDEP + do I = 1, IM + + ! Edge variables + ZLE0(I,J,L) = ZLE(I,J,L) - ZLE(I,J,LM) + + ! Layer variables + PL(I,J,L) = 0.5 * (PLE(I,J,L-1) + PLE(I,J,L)) + PK(I,J,L) = (PL(I,J,L) / MAPL_P00)**(MAPL_KAPPA) + + ZL0(I,J,L) = 0.5 * (ZLE0(I,J,L-1) + ZLE0(I,J,L)) + + TH(I,J,L) = T(I,J,L) / PK(I,J,L) + + MASS(I,J,L) = (PLE(I,J,L) - PLE(I,J,L-1)) / MAPL_GRAV + + end do + end do + end do + !$OMP END PARALLEL DO call ESMF_ClockGetAlarm(clock, 'GF_RunAlarm', alarm, RC=STATUS); VERIFY_(STATUS) alarm_is_ringing = ESMF_AlarmIsRinging(alarm, RC=STATUS); VERIFY_(STATUS) @@ -736,42 +763,78 @@ subroutine GF_Run (GC, IMPORT, EXPORT, CLOCK, RC) ,REVSU, PRFIL) ENDIF - ! update DeepCu QL/QI/CF tendencies - fQi = ice_fraction( T+DTDT_DC*GF_DT, CNV_FRC, SRF_TYPE ) - TMP3D = CNV_DQCDT/MASS - DQLDT_DC = (1.0-fQi)*TMP3D - DQIDT_DC = fQi *TMP3D - DQADT_DC = MFD_DC*SCLM_DEEP/MASS - ! evap/subl and precip fluxes - do L=1,LM - !--- sublimation/evaporation tendencies (kg/kg/s) - RSU_CN (:,:,L) = REVSU(:,:,L)* fQi(:,:,L) - REV_CN (:,:,L) = REVSU(:,:,L)*(1.0-fQi(:,:,L)) - !--- preciptation fluxes (kg/kg/s) - PFI_CN (:,:,L) = PRFIL(:,:,L)* fQi(:,:,L) - PFL_CN (:,:,L) = PRFIL(:,:,L)*(1.0-fQi(:,:,L)) - enddo - ! Export - call MAPL_GetPointer(EXPORT, PTR3D, 'CNV_FICE', RC=STATUS); VERIFY_(STATUS) - if (associated(PTR3D)) PTR3D = fQi - call MAPL_GetPointer(EXPORT, PTR3D, 'DQRC', RC=STATUS); VERIFY_(STATUS) - if(associated(PTR3D)) PTR3D = CNV_PRC3 / GF_DT - call MAPL_GetPointer(EXPORT, PTR2D, 'CCWP', RC=STATUS); VERIFY_(STATUS) - if (associated(PTR2D)) PTR2D = SUM( CNV_QC*MASS , 3 ) - - endif ! alarm_is_ringing + + call MAPL_GetPointer(EXPORT, PTR3D, 'CNV_FICE', RC=STATUS); VERIFY_(STATUS) + ptr_is_assoc = associated(PTR3D) + + ! Update DeepCu QL/QI/CF tendencies, evap/subl and precip fluxes + !-------------------------------------------------------------- + !$OMP PARALLEL DO DEFAULT(NONE) & + !$OMP SHARED(IM, JM, LM, T, DTDT_DC, GF_DT, CNV_FRC, SRF_TYPE, & + !$OMP CNV_DQCDT, MASS, DQLDT_DC, DQIDT_DC, DQADT_DC, & + !$OMP MFD_DC, SCLM_DEEP, RSU_CN, REVSU, REV_CN, & + !$OMP PFI_CN, PRFIL, PFL_CN, ptr_is_assoc, PTR3D) & + !$OMP PRIVATE(I, J, L, fQi_local, tmp_local) + do L = 1, LM + do J = 1, JM + !DIR$ IVDEP + do I = 1, IM + ! 1. Calculate local ice fraction and tmp scalar + fQi_local = ice_fraction(T(I,J,L) + DTDT_DC(I,J,L) * GF_DT, CNV_FRC(I,J), SRF_TYPE(I,J)) + tmp_local = CNV_DQCDT(I,J,L) / MASS(I,J,L) + + ! Fill the exported 3D pointer if associated + if (ptr_is_assoc) PTR3D(I,J,L) = fQi_local + + ! 2. Update DeepCu QL/QI/CF tendencies + DQLDT_DC(I,J,L) = (1.0 - fQi_local) * tmp_local + DQIDT_DC(I,J,L) = fQi_local * tmp_local + DQADT_DC(I,J,L) = MFD_DC(I,J,L) * SCLM_DEEP / MASS(I,J,L) + + ! 3. Evap/subl and precip fluxes (kg/kg/s) + RSU_CN(I,J,L) = REVSU(I,J,L) * fQi_local + REV_CN(I,J,L) = REVSU(I,J,L) * (1.0 - fQi_local) + + PFI_CN(I,J,L) = PRFIL(I,J,L) * fQi_local + PFL_CN(I,J,L) = PRFIL(I,J,L) * (1.0 - fQi_local) + end do + end do + end do + !$OMP END PARALLEL DO + + ! Other Exports + call MAPL_GetPointer(EXPORT, PTR3D, 'DQRC', RC=STATUS); VERIFY_(STATUS) + if(associated(PTR3D)) PTR3D = CNV_PRC3 / GF_DT + call MAPL_GetPointer(EXPORT, PTR2D, 'CCWP', RC=STATUS); VERIFY_(STATUS) + if (associated(PTR2D)) PTR2D = SUM( CNV_QC*MASS , 3 ) + + endif ! Alarm ringing endif ! USE_PYMOIST_GF2020 - ! add tendencies to the moist import state - U = U + DUDT_DC*MOIST_DT - V = V + DVDT_DC*MOIST_DT - Q = Q + DQVDT_DC*MOIST_DT - T = T + DTDT_DC*MOIST_DT - ! add QI/QL/CL tendencies - QLCN = QLCN + DQLDT_DC*MOIST_DT - QICN = QICN + DQIDT_DC*MOIST_DT - CLCN = MAX(MIN(CLCN + DQADT_DC*MOIST_DT, 1.0), 0.0) + ! Add tendencies to the moist import state + !-------------------------------------------------------------- + !$OMP PARALLEL DO DEFAULT(NONE) & + !$OMP SHARED(IM, JM, LM, U, DUDT_DC, MOIST_DT, V, DVDT_DC, Q, DQVDT_DC, & + !$OMP T, DTDT_DC, QLCN, DQLDT_DC, QICN, DQIDT_DC, CLCN, DQADT_DC) & + !$OMP PRIVATE(I, J, L) + do L = 1, LM + do J = 1, JM + !DIR$ IVDEP + do I = 1, IM + U(I,J,L) = U(I,J,L) + DUDT_DC(I,J,L) * MOIST_DT + V(I,J,L) = V(I,J,L) + DVDT_DC(I,J,L) * MOIST_DT + Q(I,J,L) = Q(I,J,L) + DQVDT_DC(I,J,L) * MOIST_DT + T(I,J,L) = T(I,J,L) + DTDT_DC(I,J,L) * MOIST_DT + + ! Add QI/QL/CL tendencies + QLCN(I,J,L) = QLCN(I,J,L) + DQLDT_DC(I,J,L) * MOIST_DT + QICN(I,J,L) = QICN(I,J,L) + DQIDT_DC(I,J,L) * MOIST_DT + CLCN(I,J,L) = MAX(0.0, MIN(CLCN(I,J,L) + DQADT_DC(I,J,L) * MOIST_DT, 1.0)) + end do + end do + end do + !$OMP END PARALLEL DO ! Cleanup negative water species ! ------------------------------ diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/GEOS_MGB2_2M_InterfaceMod.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/GEOS_MGB2_2M_InterfaceMod.F90 index 3578d7ce13..af20ed686b 100644 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/GEOS_MGB2_2M_InterfaceMod.F90 +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/GEOS_MGB2_2M_InterfaceMod.F90 @@ -473,7 +473,6 @@ subroutine MGB2_2M_Initialize (MAPL, RC) call MAPL_GetResource( MAPL, CNV_FRACTION_MIN, 'CNV_FRACTION_MIN:', DEFAULT= 500.0, RC=STATUS); VERIFY_(STATUS) call MAPL_GetResource( MAPL, CNV_FRACTION_MAX, 'CNV_FRACTION_MAX:', DEFAULT= 1500.0, RC=STATUS); VERIFY_(STATUS) call MAPL_GetResource( MAPL, CNV_FRACTION_EXP, 'CNV_FRACTION_EXP:', DEFAULT= 1.0, RC=STATUS); VERIFY_(STATUS) - call MAPL_GetResource( MAPL, DBZ_LIQUID_SKIN , 'DBZ_LIQUID_SKIN:' , DEFAULT= 0 , RC=STATUS); VERIFY_(STATUS) end subroutine MGB2_2M_Initialize @@ -534,7 +533,6 @@ subroutine MGB2_2M_Run (GC, IMPORT, EXPORT, CLOCK, RC) real, pointer, dimension(:,:,:) :: PFI_LS, PFI_AN real, pointer, dimension(:,:,:) :: PDF_A, PDFITERS real, pointer, dimension(:,:,:) :: RHCRIT - real, pointer, dimension(:,: ) :: DBZ_MAX, DBZ_1KM, DBZ_TOP, DBZ_M10C real, pointer, dimension(:,:,:) :: PTR3D real, pointer, dimension(:,: ) :: PTR2D #ifdef PDFDIAG @@ -2605,82 +2603,12 @@ subroutine MGB2_2M_Run (GC, IMPORT, EXPORT, CLOCK, RC) DVDT_macro+DVDT_micro,PTR3D) endif - ! Compute DBZ radar reflectivity - call MAPL_GetPointer(EXPORT, PTR3D , 'DBZ' , RC=STATUS); VERIFY_(STATUS) - call MAPL_GetPointer(EXPORT, DBZ_MAX , 'DBZ_MAX' , RC=STATUS); VERIFY_(STATUS) - call MAPL_GetPointer(EXPORT, DBZ_1KM , 'DBZ_1KM' , RC=STATUS); VERIFY_(STATUS) - call MAPL_GetPointer(EXPORT, DBZ_TOP , 'DBZ_TOP' , RC=STATUS); VERIFY_(STATUS) - call MAPL_GetPointer(EXPORT, DBZ_M10C, 'DBZ_M10C', RC=STATUS); VERIFY_(STATUS) - - if (associated(PTR3D) .OR. & - associated(DBZ_MAX) .OR. associated(DBZ_1KM) .OR. associated(DBZ_TOP) .OR. associated(DBZ_M10C)) then - - call CALCDBZ(TMP3D,100*PLmb,T,Q,QRAIN,QSNOW,QGRAUPEL,IM,JM,LM,1,0,DBZ_LIQUID_SKIN) - if (associated(PTR3D)) PTR3D = TMP3D - - if (associated(DBZ_MAX)) then - DBZ_MAX=-9999.0 - DO L=1,LM ; DO J=1,JM ; DO I=1,IM - DBZ_MAX(I,J) = MAX(DBZ_MAX(I,J),TMP3D(I,J,L)) - END DO ; END DO ; END DO - endif - - if (associated(DBZ_1KM)) then - call cs_interpolator(1, IM, 1, JM, LM, TMP3D, 1000., ZLE0, DBZ_1KM, -20.) - endif - - if (associated(DBZ_TOP)) then - DBZ_TOP=MAPL_UNDEF - DO J=1,JM ; DO I=1,IM - DO L=LM,1,-1 - if (ZLE0(i,j,l) >= 25000.) continue - if (TMP3D(i,j,l) >= 18.5 ) then - DBZ_TOP(I,J) = ZLE0(I,J,L) - exit - endif - END DO - END DO ; END DO - endif - - if (associated(DBZ_M10C)) then - DBZ_M10C=MAPL_UNDEF - DO J=1,JM ; DO I=1,IM - DO L=LM,1,-1 - if (ZLE0(i,j,l) >= 25000.) continue - if (T(i,j,l) <= MAPL_TICE-10.0) then - DBZ_M10C(I,J) = TMP3D(I,J,L) - exit - endif - END DO - END DO ; END DO - endif - - endif - - call MAPL_GetPointer(EXPORT, PTR2D , 'DBZ_MAX_R' , RC=STATUS); VERIFY_(STATUS) - if (associated(PTR2D)) then - call CALCDBZ(TMP3D,100*PLmb,T,Q,QRAIN,0.0*QSNOW,0.0*QGRAUPEL,IM,JM,LM,1,0,DBZ_LIQUID_SKIN) - PTR2D=-9999.0 - DO L=1,LM ; DO J=1,JM ; DO I=1,IM - PTR2D(I,J) = MAX(PTR2D(I,J),TMP3D(I,J,L)) - END DO ; END DO ; END DO - endif - call MAPL_GetPointer(EXPORT, PTR2D , 'DBZ_MAX_S' , RC=STATUS); VERIFY_(STATUS) - if (associated(PTR2D)) then - call CALCDBZ(TMP3D,100*PLmb,T,Q,0.0*QRAIN,QSNOW,0.0*QGRAUPEL,IM,JM,LM,1,0,DBZ_LIQUID_SKIN) - PTR2D=-9999.0 - DO L=1,LM ; DO J=1,JM ; DO I=1,IM - PTR2D(I,J) = MAX(PTR2D(I,J),TMP3D(I,J,L)) - END DO ; END DO ; END DO - endif - call MAPL_GetPointer(EXPORT, PTR2D , 'DBZ_MAX_G' , RC=STATUS); VERIFY_(STATUS) - if (associated(PTR2D)) then - call CALCDBZ(TMP3D,100*PLmb,T,Q,0.0*QRAIN,0.0*QSNOW,QGRAUPEL,IM,JM,LM,1,0,DBZ_LIQUID_SKIN) - PTR2D=-9999.0 - DO L=1,LM ; DO J=1,JM ; DO I=1,IM - PTR2D(I,J) = MAX(PTR2D(I,J),TMP3D(I,J,L)) - END DO ; END DO ; END DO - endif + ! Call the shared radar diagnostics routine + call MAPL_TimerOn(MAPL,"---RADAR_DIAGS",RC=STATUS); VERIFY_(STATUS) + call compute_radar_diagnostics(EXPORT, CLOCK, IM, JM, LM, & + Q, QRAIN, QSNOW, QGRAUPEL, T, PLmb, W, ZLE0, & + STATUS); VERIFY_(STATUS) + call MAPL_TimerOff(MAPL,"---RADAR_DIAGS",RC=STATUS); VERIFY_(STATUS) call MAPL_GetPointer(EXPORT, PTR3D, 'QRTOT', RC=STATUS); VERIFY_(STATUS) if (associated(PTR3D)) PTR3D = QRAIN diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/GEOS_MoistGridComp.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/GEOS_MoistGridComp.F90 index ecd9b275c3..5d958b2ae7 100644 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/GEOS_MoistGridComp.F90 +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/GEOS_MoistGridComp.F90 @@ -47,7 +47,8 @@ module GEOS_MoistGridCompMod logical :: LUPDATE_PRECIP_TYPE real :: CCN_OCN real :: CCN_LND - logical :: MOVE_CN_TO_LS + real :: DETRAIN_INACTIVE_CNV + real :: TAU_DETRAIN_CNV logical :: USE_NCLOUD_CLIM ! !PUBLIC MEMBER FUNCTIONS: @@ -187,7 +188,7 @@ subroutine SetServices ( GC, RC ) call MAPL_GetResource( CF, DEBUG_MST, Label="DEBUG_MST:", default=.false., RC=STATUS) ; VERIFY_(STATUS) - + call MAPL_GetResource( CF, DEBUG_TQ_ERRORS, Label="DEBUG_TQ_ERRORS:", default=.false., RC=STATUS) ; VERIFY_(STATUS) !***********Aerosol-Cloud related call MAPL_GetResource( CF, USE_NCLOUD_CLIM, Label='USE_NCLOUD_CLIM:', default=.FALSE., RC=STATUS) @@ -2113,6 +2114,14 @@ subroutine SetServices ( GC, RC ) UNITS = '# m-3', & DIMS = MAPL_DimsHorzVert, & VLOCATION = MAPL_VLocationCenter, RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddExportSpec(GC, & + SHORT_NAME = 'REFL10CM_MAX', & + LONG_NAME = 'Maximum_composite_10cm_radar_reflectivity', & + UNITS = 'dBZ', & + DIMS = MAPL_DimsHorzOnly, & + VLOCATION = MAPL_VLocationNone, RC=STATUS ) VERIFY_(STATUS) call MAPL_AddExportSpec(GC, & @@ -2123,38 +2132,6 @@ subroutine SetServices ( GC, RC ) VLOCATION = MAPL_VLocationCenter, RC=STATUS ) VERIFY_(STATUS) - call MAPL_AddExportSpec(GC, & - SHORT_NAME = 'DBZ_MAX_S', & - LONG_NAME = 'Maximum_composite_radar_reflectivity_snow', & - UNITS = 'dBZ', & - DIMS = MAPL_DimsHorzOnly, & - VLOCATION = MAPL_VLocationNone, RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddExportSpec(GC, & - SHORT_NAME = 'DBZ_MAX_R', & - LONG_NAME = 'Maximum_composite_radar_reflectivity_rain', & - UNITS = 'dBZ', & - DIMS = MAPL_DimsHorzOnly, & - VLOCATION = MAPL_VLocationNone, RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddExportSpec(GC, & - SHORT_NAME = 'DBZ_MAX_G', & - LONG_NAME = 'Maximum_composite_radar_reflectivity_graupel', & - UNITS = 'dBZ', & - DIMS = MAPL_DimsHorzOnly, & - VLOCATION = MAPL_VLocationNone, RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddExportSpec(GC, & - SHORT_NAME = 'REFL10CM_MAX', & - LONG_NAME = 'Maximum_composite_10cm_radar_reflectivity', & - UNITS = 'dBZ', & - DIMS = MAPL_DimsHorzOnly, & - VLOCATION = MAPL_VLocationNone, RC=STATUS ) - VERIFY_(STATUS) - call MAPL_AddExportSpec(GC, & SHORT_NAME = 'DBZ_MAX', & LONG_NAME = 'Maximum_composite_radar_reflectivity', & @@ -5602,6 +5579,16 @@ subroutine Initialize ( GC, IMPORT, EXPORT, CLOCK, RC ) logical :: initialize_aer_cloud + type (ESMF_Alarm ) :: ALARM + type (ESMF_TimeInterval) :: TINT + real(ESMF_KIND_R8) :: DT_R8 + real :: DT_MOIST + real :: DBZ_DT + type(ESMF_Calendar) :: calendar + type(ESMF_Time) :: currTime + type(ESMF_Alarm) :: DBZ_RunAlarm + type(ESMF_TimeInterval) :: ringInterval + !============================================================================= ! Begin... @@ -5649,7 +5636,8 @@ subroutine Initialize ( GC, IMPORT, EXPORT, CLOCK, RC ) call MAPL_GetResource( MAPL, CCN_OCN, 'NCCN_OCN:', DEFAULT= 100., RC=STATUS); VERIFY_(STATUS) call MAPL_GetResource( MAPL, CCN_LND, 'NCCN_LND:', DEFAULT= 300., RC=STATUS); VERIFY_(STATUS) - call MAPL_GetResource( MAPL, MOVE_CN_TO_LS, Label="MOVE_CN_TO_LS:", default=.FALSE., RC=STATUS); VERIFY_(STATUS) + call MAPL_GetResource( MAPL, DETRAIN_INACTIVE_CNV, Label="DETRAIN_INACTIVE_CNV:", default=0.0, RC=STATUS); VERIFY_(STATUS) + call MAPL_GetResource( MAPL, TAU_DETRAIN_CNV, Label="TAU_DETRAIN_CNV:", default=1800.0, RC=STATUS); VERIFY_(STATUS) if (adjustl(CONVPAR_OPTION)=="RAS" ) call RAS_Initialize(MAPL, RC=STATUS) ; VERIFY_(STATUS) if (adjustl(CONVPAR_OPTION)=="GF" ) call GF_Initialize(MAPL, CF, CLOCK, IMPORT, EXPORT, RC=STATUS) ; VERIFY_(STATUS) @@ -5659,6 +5647,30 @@ subroutine Initialize ( GC, IMPORT, EXPORT, CLOCK, RC ) if (adjustl(CLDMICR_OPTION)=="THOM_1M") call THOM_1M_Initialize(MAPL, RC=STATUS) ; VERIFY_(STATUS) if (adjustl(CLDMICR_OPTION)=="MGB2_2M") call MGB2_2M_Initialize(MAPL, RC=STATUS) ; VERIFY_(STATUS) + call MAPL_Get(MAPL, RUNALARM=ALARM, RC=STATUS );VERIFY_(STATUS) + call ESMF_AlarmGet(ALARM, RingInterval=TINT, RC=STATUS); VERIFY_(STATUS) + call ESMF_TimeIntervalGet(TINT, S_R8=DT_R8,RC=STATUS); VERIFY_(STATUS) + DT_MOIST = DT_R8 + + DBZ_DT = max(DT_MOIST,900.0) + call MAPL_GetResource(MAPL, DBZ_DT, 'DBZ_DT:', default=DBZ_DT, RC=STATUS); VERIFY_(STATUS) + ! Get the current time in addition to the calendar + call ESMF_ClockGet(CLOCK, currTime=currTime, calendar=calendar, RC=STATUS); VERIFY_(STATUS) + call ESMF_TimeIntervalSet(ringInterval, S=nint(DBZ_DT), calendar=calendar, RC=STATUS); VERIFY_(STATUS) + ! Add RingTime = currTime to anchor the alarm + DBZ_RunAlarm = ESMF_AlarmCreate(Clock = CLOCK, & + Name = 'DBZ_RunAlarm', & + RingTime = currTime-TINT, & + RingInterval = ringInterval, & + Sticky = .false. , RC=STATUS); VERIFY_(STATUS) + call init_refl10cm() + call MAPL_GetResource( MAPL, refl10cm_allow_wet_graupel , 'refl10cm_allow_wet_graupel:' , DEFAULT= .FALSE. , RC=STATUS); VERIFY_(STATUS) + call MAPL_GetResource( MAPL, refl10cm_allow_wet_snow , 'refl10cm_allow_wet_snow:' , DEFAULT= .FALSE. , RC=STATUS); VERIFY_(STATUS) + call MAPL_GetResource( MAPL, DBZ_VAR_INTERCP , 'DBZ_VAR_INTERCP:' , DEFAULT= DBZ_VAR_INTERCP, RC=STATUS); VERIFY_(STATUS) + call MAPL_GetResource( MAPL, LIQUID_SKIN_SNOW , 'LIQUID_SKIN_SNOW:' , DEFAULT= .FALSE. , RC=STATUS); VERIFY_(STATUS) + call MAPL_GetResource( MAPL, LIQUID_SKIN_GRAUPEL , 'LIQUID_SKIN_GRAUPEL:' , DEFAULT= .FALSE., RC=STATUS); VERIFY_(STATUS) + call MAPL_GetResource( MAPL, LIQUID_SKIN_HAIL , 'LIQUID_SKIN_HAIL:' , DEFAULT= .TRUE. , RC=STATUS); VERIFY_(STATUS) + ! All done !--------- @@ -5709,6 +5721,12 @@ subroutine RUN ( GC, IMPORT, EXPORT, CLOCK, RC ) real :: DT_MOIST ! Local variables + real :: MFC ! Layer-centered mass flux [kg m-2 s-1] + real :: inactivity_weight ! Scale from 0.0 to 1.0 based on MFC + real :: transfer_rate ! Fraction of mass to transfer this timestep + real :: dq_l ! Liquid mass being transferred + real :: dq_i ! Ice mass being transferred + real :: d_cf ! Cloud fraction being transferred real :: Tmax, KCBLMIN, PMIN_CBL real :: CNV_CAPE_NORM, CNV_CAPE_SCALE real, allocatable, dimension(:,:,:) :: PLEmb, PKE, ZLE0, PK, MASS @@ -5784,6 +5802,8 @@ subroutine RUN ( GC, IMPORT, EXPORT, CLOCK, RC ) if ( ESMF_AlarmIsRinging( ALARM, RC=STATUS) ) then + call MAPL_TimerOn(MAPL,"---MOIST_PROLOGUE") + call ESMF_AlarmRingerOff(ALARM, RC=STATUS) ; VERIFY_(STATUS) ! Internal State @@ -5826,16 +5846,18 @@ subroutine RUN ( GC, IMPORT, EXPORT, CLOCK, RC ) call MAPL_GetPointer(IMPORT, NCPI_CLIM, 'NCPI_CLIM' , RC=STATUS); VERIFY_(STATUS) end if - where ( (FRLANDICE > 0.5) .OR. (FRACI > 0.5) ) - SRF_TYPE = 3.0 ! Ice + where (FRLANDICE > 0.5) + SRF_TYPE = SRF_TYPE_LANDICE + elsewhere (FRACI > 0.5) + SRF_TYPE = SRF_TYPE_ICE elsewhere ( SNOMAS > 0.1 .AND. SNOMAS /= MAPL_UNDEF ) ! NOTE: SNOMAS has UNDEFs so we need to make sure we don't ! allow that to infect this comparison - SRF_TYPE = 2.0 ! Snow + SRF_TYPE = SRF_TYPE_SNOW elsewhere (FRLAND > 0.1) - SRF_TYPE = 1.0 ! Land + SRF_TYPE = SRF_TYPE_LAND elsewhere - SRF_TYPE = 0.0 ! Ocean + SRF_TYPE = SRF_TYPE_OCEAN end where ! Allocatables @@ -5981,8 +6003,12 @@ subroutine RUN ( GC, IMPORT, EXPORT, CLOCK, RC ) call MAPL_GetPointer(EXPORT, LFC, 'ZLFC' , ALLOC=.TRUE., RC=STATUS); VERIFY_(STATUS) call MAPL_GetPointer(EXPORT, LNB, 'ZLNB' , ALLOC=.TRUE., RC=STATUS); VERIFY_(STATUS) call MAPL_GetPointer(EXPORT, LCL_AGL, 'LCL_AGL', ALLOC=.TRUE., RC=STATUS); VERIFY_(STATUS) + + call MAPL_TimerOn(MAPL,"-----BUOYANCY2") call BUOYANCY2( IM, JM, LM, T, Q, QST3, DQST3, DZET, ZL0, PLmb, PLEmb(:,:,LM), & SBCAPE, MLCAPE, MUCAPE, SBCIN, MLCIN, MUCIN, BYNCY, LFC, LNB, LCL_AGL ) + call MAPL_TimerOff(MAPL,"-----BUOYANCY2") + call BUOYANCY( T, Q, QST3, DQST3, DZET, ZL0, BYNCY, CAPE, INHB) ! initialize diagnosed convective fraction @@ -6006,6 +6032,8 @@ subroutine RUN ( GC, IMPORT, EXPORT, CLOCK, RC ) endif endif + call MAPL_TimerOff(MAPL,"---MOIST_PROLOGUE") + ! Extract convective tracers from the TR bundle call MAPL_TimerOn (MAPL,"---CONV_TRACERS") call CNV_Tracers_Init(TR, RC) @@ -6099,6 +6127,8 @@ subroutine RUN ( GC, IMPORT, EXPORT, CLOCK, RC ) endif endif + call MAPL_TimerOn(MAPL,"---MOIST_EPILOGUE") + ! Mass fluxes ! accumuated over deep and shalow convection call MAPL_GetPointer(EXPORT, PTR3D, 'CNV_MFC', ALLOC=.TRUE., RC=STATUS); VERIFY_(STATUS) @@ -6107,22 +6137,33 @@ subroutine RUN ( GC, IMPORT, EXPORT, CLOCK, RC ) PTR3D = 0.0 if (associated(PTRDC)) PTR3D = PTR3D + PTRDC if (associated(PTRSC)) PTR3D = PTR3D + PTRSC - - if (MOVE_CN_TO_LS) then + if (DETRAIN_INACTIVE_CNV > 0.0) then do L = 1, LM do J = 1, JM do I = 1, IM - if (0.5*(PTR3D(I,J,L)+PTR3D(I,J,L+1)) < 1.e-5) then - ! Move all QL,QI,CL to LS when cnv_mfc is 0.0 - QLLS(I,J,L) = QLLS(I,J,L)+QLCN(I,J,L) - QLCN(I,J,L) = 0.0 - QILS(I,J,L) = QILS(I,J,L)+QICN(I,J,L) - QICN(I,J,L) = 0.0 - CLLS(I,J,L) = CLLS(I,J,L)+CLCN(I,J,L) - CLCN(I,J,L) = 0.0 + ! Calculate local mass flux + MFC = 0.5 * (PTR3D(I,J,L) + PTR3D(I,J,L+1)) + if (MFC < DETRAIN_INACTIVE_CNV) then + ! 1. Calculate a smooth inactivity factor (0.0 at threshold, 1.0 when MFC is 0) + ! 2. Scale it by the timestep vs relaxation time (DT_MOIST / TAU) + inactivity_weight = 1.0 - (MFC / DETRAIN_INACTIVE_CNV) + transfer_rate = inactivity_weight * (DT_MOIST / TAU_DETRAIN_CNV) + ! Bound the rate safely between 0 and 1 + transfer_rate = min(1.0, max(0.0, transfer_rate)) + ! Calculate the exact amounts to transfer this timestep + dq_l = QLCN(I,J,L) * transfer_rate + dq_i = QICN(I,J,L) * transfer_rate + d_cf = CLCN(I,J,L) * transfer_rate + ! Move the Liquid + QLLS(I,J,L) = QLLS(I,J,L) + dq_l + QLCN(I,J,L) = QLCN(I,J,L) - dq_l + ! Move the Ice + QILS(I,J,L) = QILS(I,J,L) + dq_i + QICN(I,J,L) = QICN(I,J,L) - dq_i + ! Move the Cloud Fraction using Random Overlap for the transferred piece + CLLS(I,J,L) = CLLS(I,J,L) + d_cf - (CLLS(I,J,L) * d_cf) + CLCN(I,J,L) = CLCN(I,J,L) - d_cf endif - ! cleanup clouds - call FIX_UP_CLOUDS( Q(I,J,L), T(I,J,L), QLLS(I,J,L), QILS(I,J,L), CLLS(I,J,L), QLCN(I,J,L), QICN(I,J,L), CLCN(I,J,L) ) enddo enddo enddo @@ -6135,11 +6176,15 @@ subroutine RUN ( GC, IMPORT, EXPORT, CLOCK, RC ) if (associated(PTRDC)) PTR3D = PTR3D + PTRDC if (associated(PTRSC)) PTR3D = PTR3D + PTRSC + call MAPL_TimerOff(MAPL,"---MOIST_EPILOGUE") + if (adjustl(CLDMICR_OPTION)=="BACM_1M") call BACM_1M_Run(GC, IMPORT, EXPORT, CLOCK, RC=STATUS) ; VERIFY_(STATUS) if (adjustl(CLDMICR_OPTION)=="GFDL_1M") call GFDL_1M_Run(GC, IMPORT, EXPORT, CLOCK, RC=STATUS) ; VERIFY_(STATUS) if (adjustl(CLDMICR_OPTION)=="THOM_1M") call THOM_1M_Run(GC, IMPORT, EXPORT, CLOCK, RC=STATUS) ; VERIFY_(STATUS) if (adjustl(CLDMICR_OPTION)=="MGB2_2M") call MGB2_2M_Run(GC, IMPORT, EXPORT, CLOCK, RC=STATUS) ; VERIFY_(STATUS) + call MAPL_TimerOn(MAPL,"---MOIST_EPILOGUE") + if (DEBUG_MST) then call MAPL_MaxMin('MST: Q_AF_MP ', Q) call MAPL_MaxMin('MST: T_AF_MP ', T) @@ -6619,7 +6664,9 @@ subroutine RUN ( GC, IMPORT, EXPORT, CLOCK, RC ) call MAPL_GetPointer(EXPORT, PTR2D, 'LFR_GCC', NotFoundOk=.TRUE., RC=STATUS); VERIFY_(STATUS) if (associated(PTR2D)) PTR2D = 0.0 - else + call MAPL_TimerOff(MAPL,"---MOIST_EPILOGUE") + + else ! Alarm ringing ! Internal State call MAPL_GetPointer(INTERNAL, Q, 'Q' , RC=STATUS); VERIFY_(STATUS) @@ -6676,7 +6723,7 @@ subroutine RUN ( GC, IMPORT, EXPORT, CLOCK, RC ) call MAPL_GetPointer(EXPORT, PTR3D, 'RH2', RC=STATUS); VERIFY_(STATUS) if (associated(PTR3D)) PTR3D = MAX(MIN( Q/GEOS_QSAT (T, PLmb) , 1.02 ),0.0) - endif + endif ! Alarm call MAPL_TimerOff(MAPL,"TOTAL") diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/GEOS_NSSL_2M_InterfaceMod.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/GEOS_NSSL_2M_InterfaceMod.F90 index 2c79b6b1dc..5e16f87203 100644 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/GEOS_NSSL_2M_InterfaceMod.F90 +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/GEOS_NSSL_2M_InterfaceMod.F90 @@ -1087,31 +1087,6 @@ SUBROUTINE nssl_2mom_driver(qv, qc, qr, qi, qs, qh, qhl, ccw, crw, cci, csw, chw endif - call MAPL_GetPointer(EXPORT, PTR2D , 'DBZ_MAX_R' , RC=STATUS); VERIFY_(STATUS) - if (associated(PTR2D)) then - call CALCDBZ(TMP3D,100*PLmb,T,Q,QRAIN,0.0*QSNOW,0.0*QGRAUPEL,IM,JM,LM,1,0,DBZ_LIQUID_SKIN) - PTR2D=-9999.0 - DO L=1,LM ; DO J=1,JM ; DO I=1,IM - PTR2D(I,J) = MAX(PTR2D(I,J),TMP3D(I,J,L)) - END DO ; END DO ; END DO - endif - call MAPL_GetPointer(EXPORT, PTR2D , 'DBZ_MAX_S' , RC=STATUS); VERIFY_(STATUS) - if (associated(PTR2D)) then - call CALCDBZ(TMP3D,100*PLmb,T,Q,0.0*QRAIN,QSNOW,0.0*QGRAUPEL,IM,JM,LM,1,0,DBZ_LIQUID_SKIN) - PTR2D=-9999.0 - DO L=1,LM ; DO J=1,JM ; DO I=1,IM - PTR2D(I,J) = MAX(PTR2D(I,J),TMP3D(I,J,L)) - END DO ; END DO ; END DO - endif - call MAPL_GetPointer(EXPORT, PTR2D , 'DBZ_MAX_G' , RC=STATUS); VERIFY_(STATUS) - if (associated(PTR2D)) then - call CALCDBZ(TMP3D,100*PLmb,T,Q,0.0*QRAIN,0.0*QSNOW,QGRAUPEL,IM,JM,LM,1,0,DBZ_LIQUID_SKIN) - PTR2D=-9999.0 - DO L=1,LM ; DO J=1,JM ; DO I=1,IM - PTR2D(I,J) = MAX(PTR2D(I,J),TMP3D(I,J,L)) - END DO ; END DO ; END DO - endif - call MAPL_GetPointer(EXPORT, PTR3D, 'QRTOT', RC=STATUS); VERIFY_(STATUS) if (associated(PTR3D)) PTR3D = QRAIN diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/Process_Library.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/Process_Library.F90 index bf4bc89d78..66c7adb8fd 100644 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/Process_Library.F90 +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/Process_Library.F90 @@ -10,10 +10,8 @@ module GEOSmoist_Process_Library use ESMF use MAPL use GEOS_UtilsMod - !use Aer_Actv_Single_Moment - !use aer_cloud - USE module_mp_radar - + use GEOS_RadarMod + use module_mp_radar implicit none private @@ -37,10 +35,11 @@ module GEOSmoist_Process_Library end interface ICE_FRACTION ! SRF_TYPE constants - integer, parameter :: SRF_TYPE_LAND = 1 - integer, parameter :: SRF_TYPE_SNOW = 2 - integer, parameter :: SRF_TYPE_ICE = 3 - integer, parameter :: SRF_TYPE_OCEAN = 0 + integer, parameter :: SRF_TYPE_OCEAN = 0 + integer, parameter :: SRF_TYPE_LAND = 1 + integer, parameter :: SRF_TYPE_SNOW = 2 + integer, parameter :: SRF_TYPE_ICE = 3 + integer, parameter :: SRF_TYPE_LANDICE = 4 ! ICE_FRACTION constants logical :: constrain_modis_ice = .FALSE. @@ -113,11 +112,16 @@ module GEOSmoist_Process_Library ! control for order of plumes logical :: SH_MD_DP = .FALSE. - ! Radar parameter + ! Radar parameters integer :: DBZ_VAR_INTERCP=2 ! use variable intercept parameters: 1 - on, 2 - snow boost, 3 - hail instead of graupel integer :: DBZ_LIQUID_SKIN=1 ! use liquid skin on snow(1) and graupel/hail(2) in warm environments - LOGICAL :: refl10cm_allow_wet_graupel = .false. - LOGICAL :: refl10cm_allow_wet_snow = .true. + logical :: refl10cm_allow_wet_graupel = .false. + logical :: refl10cm_allow_wet_snow = .true. + logical :: LIQUID_SKIN_SNOW = .false. + logical :: LIQUID_SKIN_GRAUPEL = .false. + logical :: LIQUID_SKIN_HAIL = .true. + real, PARAMETER :: W_START = 6.0 + real, PARAMETER :: W_FULL = 12.0 ! Thompson radar constants LOGICAL, PARAMETER:: iiwarm = .false. @@ -224,8 +228,6 @@ module GEOSmoist_Process_Library real :: CNV_FRACTION_EXP = 1.0 ! Storage of aerosol properties for activation - !type(AerPropsNew) :: AeroPropsNew(nsmx_par) - !type(AerProps), allocatable, dimension (:,:,:) :: AeroProps ! Tracer Bundle things for convection type CNV_Tracer_Type @@ -274,6 +276,7 @@ module GEOSmoist_Process_Library public :: AeroPropsNew public :: CNV_Tracer_Type, CNV_Tracers, CNV_Tracers_Init public :: constrain_modis_ice + public :: SRF_TYPE_OCEAN, SRF_TYPE_LAND, SRF_TYPE_SNOW, SRF_TYPE_ICE, SRF_TYPE_LANDICE public :: ICE_FRACTION, EVAP3, SUBL3, LDRADIUS4, BUOYANCY, BUOYANCY2 public :: REDISTRIBUTE_CLOUDS_SCALAR, REDISTRIBUTE_CLOUDS, RADCOUPLE_SCALE_AWARE, RADCOUPLE, FIX_UP_CLOUDS public :: hystpdf, fix_up_clouds_2M @@ -288,8 +291,7 @@ module GEOSmoist_Process_Library public :: pdffrac, pdfcondensate, precalc_dblgss, partition_dblgss, partition_dblgss2 public :: SIGMA_DX, SIGMA_EXP public :: CNV_FRACTION_MIN, CNV_FRACTION_MAX, CNV_FRACTION_EXP - public :: SH_MD_DP, DBZ_VAR_INTERCP, DBZ_LIQUID_SKIN, LIQ_RADII_PARAM, ICE_RADII_PARAM - public :: refl10cm_allow_wet_graupel, refl10cm_allow_wet_snow + public :: SH_MD_DP, LIQ_RADII_PARAM, ICE_RADII_PARAM public :: update_cld, meltfrz_inst2M public :: FIX_NEGATIVE_PRECIP public :: FIND_KLID @@ -297,11 +299,15 @@ module GEOSmoist_Process_Library public :: smooth_cloud_binary public :: pdf_alpha public :: get_fac_eis - public :: init_refl10cm, calc_refl10cm public :: neg_adj_external public :: compute_sgs_vvel public :: cf_geom_correction - + public :: compute_radar_diagnostics + public :: init_refl10cm, calc_refl10cm + public :: refl10cm_allow_wet_graupel, refl10cm_allow_wet_snow + public :: DBZ_VAR_INTERCP, DBZ_LIQUID_SKIN + public :: LIQUID_SKIN_SNOW, LIQUID_SKIN_GRAUPEL, LIQUID_SKIN_HAIL + contains !=========Aerosol properties utilities @@ -676,8 +682,8 @@ function ICE_FRACTION_SC (TEMP,CNV_FRACTION,SRF_TYPE) RESULT(ICEFRCT) ICEFRCT_C = ICEFRCT_C**aICEFRPWR ! Sigmoidal functions like figure 6b/6c of Hu et al 2010, doi:10.1029/2009JD012384 select case (nint(SRF_TYPE)) - case (SRF_TYPE_SNOW, SRF_TYPE_ICE) - ! Over snow (SRF_TYPE == 2.0) and ice (SRF_TYPE == 3.0) + case (SRF_TYPE_SNOW, SRF_TYPE_ICE, SRF_TYPE_LANDICE) + ! Over snow (SRF_TYPE == 2.0) and ice (SRF_TYPE >= 3.0) ICEFRCT_M = 0.00 if ( TEMP <= iT_ICE_ALL ) then ICEFRCT_M = 1.000 @@ -2833,6 +2839,8 @@ subroutine hystpdf( & ! ======================================================================= ! PHASE 4: Finalization & Mapping back to Absolute Grid Box + ! Scale the environmental values back down to grid-box absolutes, + ! partition into ice/liquid, and update prognostic variables. ! ======================================================================= CLLS = cf_env * (1.0 - CLCN) @@ -3151,24 +3159,53 @@ end subroutine MELTFRZ_1D subroutine MELTFRZ_SC( DT, CNVFRC, SRFTYPE, TE, QL, QI ) real, intent(in ) :: DT, CNVFRC, SRFTYPE - real, intent(inout) :: TE,QL,QI - real :: fQi,dQil - integer :: K + real, intent(inout) :: TE, QL, QI + + real :: fQi, dQil, target_ice, target_melt, max_phase_change + real :: L_f + + ! Latent heat of fusion + L_f = MAPL_ALHS - MAPL_ALHL + if ( TE <= MAPL_TICE ) then - ! freeze liquid - fQi = ice_fraction( TE, CNVFRC, SRFTYPE ) - dQil = Ql *(1.0 - EXP( -DT * fQi / max(DT,taufrz) ) ) - dQil = max( 0., dQil ) - Qi = Qi + dQil - Ql = Ql - dQil - TE = TE + (MAPL_ALHS-MAPL_ALHL)*dQil/MAPL_CP + ! ------------------------------------------------------------- + ! FREEZING REGIME (TE <= TICE) + ! ------------------------------------------------------------- + + ! 1. Target ice deficit (new_ice_condensate) + fQi = ice_fraction( TE, CNVFRC, SRFTYPE ) + target_ice = min( max(0.0, fQi*(QL + QI) - QI), QL ) + + ! 2. Thermodynamic limit (prevent latent heating above freezing point) + max_phase_change = max( 0.0, (MAPL_TICE - TE) * MAPL_CP / L_f ) + + ! 3. Apply relaxation timescale (fQi is no longer in the exponent) + dQil = ( 1.0 - EXP( -DT / max(DT,taufrz) ) ) * min( target_ice, max_phase_change ) + + ! 4. Update states (liquid -> ice, temp warms) + Qi = Qi + dQil + Ql = Ql - dQil + TE = TE + (L_f * dQil) / MAPL_CP + else - ! melt ice above 0^C - dQil = -Qi *(1.0 - EXP( -DT / max(DT,taumlt) ) ) - dQil = min( 0., dQil ) - Qi = Qi + dQil - Ql = Ql - dQil - TE = TE + (MAPL_ALHS-MAPL_ALHL)*dQil/MAPL_CP + ! ------------------------------------------------------------- + ! MELTING REGIME (TE > TICE) + ! ------------------------------------------------------------- + + ! 1. Target melt (assuming 0% ice fraction above freezing) + target_melt = QI + + ! 2. Thermodynamic limit (prevent latent cooling below freezing point) + max_phase_change = max( 0.0, (TE - MAPL_TICE) * MAPL_CP / L_f ) + + ! 3. Apply relaxation timescale + dQil = ( 1.0 - EXP( -DT / max(DT,taumlt) ) ) * min( target_melt, max_phase_change ) + + ! 4. Update states (ice -> liquid, temp cools) + Qi = Qi - dQil + Ql = Ql + dQil + TE = TE - (L_f * dQil) / MAPL_CP + end if end subroutine MELTFRZ_SC @@ -3672,7 +3709,7 @@ function FIND_KLCL( T, Q, PL, IM, JM, LM ) result( KLCL ) end function FIND_KLCL function GET_LCL_AGL( T, Q, PL, Z, IM, JM, LM ) result( LCL_AGL ) - ! !DESCRIPTION: + ! !DESCRIPTION: ! Calculates the precise height of the Lifting Condensation Level (LCL) ! in meters Above Ground Level (AGL). @@ -4315,40 +4352,85 @@ subroutine FIX_NEGATIVE_PRECIP(QRAIN, QSNOW, QGRAUPEL) end subroutine FIX_NEGATIVE_PRECIP subroutine REDISTRIBUTE_CLOUDS_SCALAR(CF, QL, QI, CLCN, CLLS, QLCN, QLLS, QICN, QILS, QV, TE) - ! Note: Changed from dimension(:,:,:) to scalar inputs real, intent(inout) :: CF, QL, QI, CLCN, CLLS, QLCN, QLLS, QICN, QILS, QV, TE - - ! Liquid - QLLS = QLLS + (QL - (QLCN+QLLS)) - if (QLLS < 0.0) then - QLCN = max(0.0, QLCN + QLLS) - QLLS = 0.0 + + real :: QL_old, QI_old, CF_old + real :: f_cn + real, parameter :: epsilon = 1.0e-15 + + ! --------------------------------------------------------- + ! 1. Liquid Growth vs. Decay Redistribution + ! --------------------------------------------------------- + QL_old = QLCN + QLLS + if (QL < QL_old) then + ! DECAY: Microphysics consumed liquid. Reduce proportionally. + if (QL_old > epsilon) then + f_cn = QLCN / QL_old + QLCN = QL * f_cn + QLLS = QL * (1.0 - f_cn) + else + QLCN = 0.0 + QLLS = 0.0 + endif + else + ! GROWTH: Microphysics created new liquid. All new mass is Large-Scale. + ! QLCN remains unchanged + QLLS = QL - QLCN endif - ! Ice - QILS = QILS + (QI - (QICN+QILS)) - if (QILS < 0.0) then - QICN = max(0.0, QICN + QILS) - QILS = 0.0 + ! --------------------------------------------------------- + ! 2. Ice Growth vs. Decay Redistribution + ! --------------------------------------------------------- + QI_old = QICN + QILS + if (QI < QI_old) then + ! DECAY: Reduce proportionally + if (QI_old > epsilon) then + f_cn = QICN / QI_old + QICN = QI * f_cn + QILS = QI * (1.0 - f_cn) + else + QICN = 0.0 + QILS = 0.0 + endif + else + ! GROWTH: All new ice is Large-Scale + ! QICN remains unchanged + QILS = QI - QICN endif - ! Cloud - CLLS = min(1.0, CLLS + (CF - (CLCN+CLLS))) - if (CLLS < 0.0) then - CLCN = max(0.0, min(1.0, CLCN + CLLS)) - CLLS = 0.0 + ! --------------------------------------------------------- + ! 3. Cloud Fraction Growth vs. Decay Redistribution + ! --------------------------------------------------------- + CF_old = CLCN + CLLS + if (CF < CF_old) then + ! DECAY: Cloud fraction shrank. Reduce proportionally. + if (CF_old > epsilon) then + f_cn = CLCN / CF_old + CLCN = min(1.0, CF * f_cn) + CLLS = min(1.0, CF * (1.0 - f_cn)) + else + CLCN = 0.0 + CLLS = 0.0 + endif + else + ! GROWTH: Cloud expanded. Convective core stays its original size. + ! CLCN remains unchanged (bounded to CF just in case) + CLCN = min(CLCN, CF) + CLLS = min(1.0, CF - CLCN) endif - ! Evaporate/Sublimate liquid/ice where clouds are gone - if ( (CLLS == 0.0) .and. (QLLS+QILS > 0.0) ) then + ! --------------------------------------------------------- + ! 4. Clean up: Evaporate/Sublimate if clouds are completely gone + ! --------------------------------------------------------- + if ( (CLLS <= 0.0) .and. (QLLS+QILS > 0.0) ) then QV = QV + QLLS + QILS TE = TE - (alhlbcp)*QLLS - (alhsbcp)*QILS CLLS = 0.0 QLLS = 0.0 QILS = 0.0 endif - - if ( (CLCN == 0.0) .and. (QLCN+QICN > 0.0) ) then + + if ( (CLCN <= 0.0) .and. (QLCN+QICN > 0.0) ) then QV = QV + QLCN + QICN TE = TE - (alhlbcp)*QLCN - (alhsbcp)*QICN CLCN = 0.0 @@ -5362,4 +5444,184 @@ subroutine compute_sgs_vvel(IM,JM,LM,ZLE0,W,BYNCY, & end subroutine compute_sgs_vvel + subroutine compute_radar_diagnostics(EXPORT, clock, IM, JM, LM, & + Q, QRAIN, QSNOW, QGRAUPEL, T, PLmb, W, ZLE0, & + RC) + + implicit none + + ! --- Arguments --- + type(ESMF_State), intent(inout) :: EXPORT + type(ESMF_Clock), intent(in) :: clock + integer, intent(in) :: IM, JM, LM + real, intent(in) :: Q(IM,JM,LM), QRAIN(IM,JM,LM), QSNOW(IM,JM,LM) + real, intent(in) :: QGRAUPEL(IM,JM,LM), T(IM,JM,LM), PLmb(IM,JM,LM) + real, intent(in) :: W(IM,JM,LM), ZLE0(IM,JM,LM) + integer, intent(out) :: RC + + ! --- Local Variables --- + integer :: I, J, L, STATUS + type(ESMF_Alarm) :: alarm + logical :: alarm_is_ringing + real :: rand1, fraction_hail + + ! MAPL Export Pointers + real, pointer :: NACTR(:,:,:) + real, pointer :: PTR2D(:,:) + real, pointer :: DBZ(:,:,:) + real, pointer :: DBZ_MAX(:,:) + real, pointer :: DBZ_1KM(:,:) + real, pointer :: DBZ_TOP(:,:) + real, pointer :: DBZ_M10C(:,:) + + ! Temporary arrays + real, allocatable :: TMP3D(:,:,:) + real, allocatable :: TMP_NACTR(:,:,:) + real, allocatable :: DBZ3D(:,:,:) + + ! Automatic arrays for 1D columns (Thread-safe for OpenMP) + real :: qg_col(LM), qh_col(LM), prs_col(LM), dbz_col(LM) + + RC = ESMF_SUCCESS + STATUS = ESMF_SUCCESS + + ! Compute DBZ radar reflectivity + call ESMF_ClockGetAlarm(clock, 'DBZ_RunAlarm', alarm, RC=STATUS); VERIFY_(STATUS) + alarm_is_ringing = ESMF_AlarmIsRinging(alarm, RC=STATUS); VERIFY_(STATUS) + + call MAPL_GetPointer(EXPORT, NACTR, 'NACTR', RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT, PTR2D, 'REFL10CM_MAX', RC=STATUS); VERIFY_(STATUS) + + ! 1. If the user explicitly requested NACTR export, fill it every time (or whenever needed) + if (associated(NACTR)) then + NACTR = 1.e8 * QRAIN**0.8 + endif + + ! 2. Handle the reflectivity alarm + if (alarm_is_ringing) then + call ESMF_AlarmRingerOff(alarm, RC=STATUS); VERIFY_(STATUS) + + ! Only compute if the user actually requested the reflectivity output + if (associated(PTR2D)) then + rand1 = 0.0 + + ALLOCATE(TMP3D(IM,JM,LM)) + TMP3D = 0.0 + + if (.not. associated(NACTR)) then + ALLOCATE ( TMP_NACTR(IM,JM,LM) ) + TMP_NACTR = 1.e8 * QRAIN**0.8 + endif + + DO J=1,JM ; DO I=1,IM + if (associated(NACTR)) then + call calc_refl10cm(Q(I,J,:), QRAIN(I,J,:), NACTR(I,J,:), QSNOW(I,J,:), QGRAUPEL(I,J,:), & + T(I,J,:), 100*PLmb(I,J,:), TMP3D(I,J,:), rand1, 1, LM, I, J) + else + call calc_refl10cm(Q(I,J,:), QRAIN(I,J,:), TMP_NACTR(I,J,:), QSNOW(I,J,:), QGRAUPEL(I,J,:), & + T(I,J,:), 100*PLmb(I,J,:), TMP3D(I,J,:), rand1, 1, LM, I, J) + endif + END DO ; END DO + + if (.not. associated(NACTR)) DEALLOCATE ( TMP_NACTR ) + + PTR2D = -9999.0 + DO L=1,LM ; DO J=1,JM ; DO I=1,IM + PTR2D(I,J) = MAX(PTR2D(I,J),TMP3D(I,J,L)) + END DO ; END DO ; END DO + + DEALLOCATE(TMP3D) + endif + endif + + call MAPL_GetPointer(EXPORT, DBZ , 'DBZ' , RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT, DBZ_MAX , 'DBZ_MAX' , RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT, DBZ_1KM , 'DBZ_1KM' , RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT, DBZ_TOP , 'DBZ_TOP' , RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT, DBZ_M10C, 'DBZ_M10C', RC=STATUS); VERIFY_(STATUS) + + if ( (associated(DBZ) .OR. & + associated(DBZ_MAX) .OR. associated(DBZ_1KM) .OR. associated(DBZ_TOP) .OR. associated(DBZ_M10C)) ) then + + ALLOCATE(DBZ3D(IM,JM,LM)) + + !$OMP parallel do default(none) & + !$OMP shared(IM, JM, LM, W, QGRAUPEL, PLmb, T, Q, QRAIN, QSNOW, DBZ3D, & + !$OMP DBZ_VAR_INTERCP, LIQUID_SKIN_SNOW, LIQUID_SKIN_GRAUPEL, LIQUID_SKIN_HAIL) & + !$OMP private(I, J, L, fraction_hail, qg_col, qh_col, prs_col, dbz_col) + DO J = 1, JM + DO I = 1, IM + ! 1. Prepare the 1D column data for this specific (I,J) location + DO L = 1, LM + fraction_hail = MAX(0.0, MIN(1.0, (W(I,J,L) - W_START) / (W_FULL - W_START))) + qh_col(L) = QGRAUPEL(I,J,L) * fraction_hail + qg_col(L) = QGRAUPEL(I,J,L) * (1.0 - fraction_hail) + prs_col(L) = 100.0 * PLmb(I,J,L) + END DO + + ! 2. Call the newly refactored 1D column function + dbz_col = compute_radar_reflectivity( & + PRS = prs_col, & + TMK = T(I,J,:), & + QVP = Q(I,J,:), & + QRAIN = QRAIN(I,J,:), & + QSNOW = QSNOW(I,J,:), & + QGRAUPEL = qg_col, & + QHAIL = qh_col, & + disable_variable_intercept_params = (DBZ_VAR_INTERCP == 0), & + liqskin_snow = LIQUID_SKIN_SNOW, & + liqskin_graupel = LIQUID_SKIN_GRAUPEL, & + liqskin_hail = LIQUID_SKIN_HAIL) + + ! 3. Store the returned column back into the 3D state + DO L = 1, LM + DBZ3D(I,J,L) = dbz_col(L) + END DO + END DO + END DO + + if (associated(DBZ)) DBZ(:,:,:) = DBZ3D(:,:,:) + + if (associated(DBZ_MAX)) then + DBZ_MAX=-9999.0 + DO L=1,LM ; DO J=1,JM ; DO I=1,IM + DBZ_MAX(I,J) = MAX(DBZ_MAX(I,J),DBZ3D(I,J,L)) + END DO ; END DO ; END DO + endif + + if (associated(DBZ_1KM)) then + call cs_interpolator(1, IM, 1, JM, LM, DBZ3D, 1000., ZLE0, DBZ_1KM, -20.) + endif + + if (associated(DBZ_TOP)) then + DBZ_TOP=MAPL_UNDEF + DO J=1,JM ; DO I=1,IM + DO L=LM,1,-1 + if (ZLE0(i,j,l) >= 25000.) continue + if (DBZ3D(i,j,l) >= 18.5 ) then + DBZ_TOP(I,J) = ZLE0(I,J,L) + exit + endif + END DO + END DO ; END DO + endif + + if (associated(DBZ_M10C)) then + DBZ_M10C=MAPL_UNDEF + DO J=1,JM ; DO I=1,IM + DO L=LM,1,-1 + if (ZLE0(i,j,l) >= 25000.) continue + if (T(i,j,l) <= MAPL_TICE-10.0) then + DBZ_M10C(I,J) = DBZ3D(I,J,L) + exit + endif + END DO + END DO ; END DO + endif + + DEALLOCATE(DBZ3D) + end if + + end subroutine compute_radar_diagnostics + end module GEOSmoist_Process_Library diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/aer_actv_single_moment.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/aer_actv_single_moment.F90 index 0dbad61a11..4f989f6faa 100644 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/aer_actv_single_moment.F90 +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/aer_actv_single_moment.F90 @@ -24,8 +24,11 @@ MODULE Aer_Actv_Single_Moment real(AER_PR), parameter :: deltai = 2.809e+3 real(AER_PR), parameter :: densic = 917.0 !Ice crystal density in kgm-3 - real, parameter :: NN_MIN = 100.0e6 - real, parameter :: NN_MAX = 500.0e6 + real, parameter :: NN_MIN_LIQ = 100.0e6 + real, parameter :: NN_MAX_LIQ = 500.0e6 + + real, parameter :: NN_MIN_ICE = 100.0e6 + real, parameter :: NN_MAX_ICE = 500.0e6 LOGICAL :: USE_BERGERON = .FALSE. LOGICAL :: USE_AEROSOL_NN = .TRUE. @@ -161,9 +164,19 @@ SUBROUTINE Aer_Activation(MAPL, IM,JM,LM, q, t, plo, ple, tke, vvel, FRLAND, & AeroPropsNew(n)%nmods = n_modes - where (AeroPropsNew(n)%kap > 0.4) - NWFA = NWFA + AeroPropsNew(n)%num - end where + ! Replace the slow 'where' construct with a threaded explicit loop + !$OMP parallel do default(none) & + !$OMP shared(IM, JM, LM, AeroPropsNew, n, NWFA) & + !$OMP private(i, j, k) + do k = 1, LM + do j = 1, JM + do i = 1, IM + if (AeroPropsNew(n)%kap(i,j,k) > 0.4) then + NWFA(i,j,k) = NWFA(i,j,k) + AeroPropsNew(n)%num(i,j,k) + endif + enddo + enddo + enddo end do ACTIVATION_PROPERTIES @@ -180,9 +193,11 @@ SUBROUTINE Aer_Activation(MAPL, IM,JM,LM, q, t, plo, ple, tke, vvel, FRLAND, & allocate(bibar(IM,JM,n_modes), source=0.0, __STAT__) allocate( nact(IM,JM,n_modes), source=0.0, __STAT__) - !$OMP parallel do default(none) shared(IM,JM,LM,n_modes,T,plo,vvel,tke,MAPL_RGAS, & - !$OMP AeroPropsNew,NACTL,NACTI,NN_MIN,NN_MAX,ai,bi,ci,di) & - !$OMP private(k,n,tk,press,air_den,wupdraft,ni,rg,bibar,sig0,nact) + !$OMP parallel do default(none) & + !$OMP shared(IM, JM, LM, n_modes, T, plo, vvel, tke, AeroPropsNew, & + !$OMP NACTL, NACTI) & + !$OMP private(k, n, i, j, tk, press, air_den, wupdraft, ni, rg, bibar, & + !$OMP sig0, nact, numbinit) DO k=1,LM tk = T(:,:,k) ! K @@ -197,6 +212,8 @@ SUBROUTINE Aer_Activation(MAPL, IM,JM,LM, q, t, plo, ple, tke, vvel, FRLAND, & bibar(:,:,n) = AeroPropsNew(n)%kap(:,:,k) sig0 (:,:,n) = AeroPropsNew(n)%sig(:,:,k) ENDDO + + ! Passed nact to ensure the private copy is populated call GetActFrac(IM*JM, n_modes & , ni(1,1,1) & , rg(1,1,1) & @@ -207,6 +224,7 @@ SUBROUTINE Aer_Activation(MAPL, IM,JM,LM, q, t, plo, ple, tke, vvel, FRLAND, & ,wupdraft(1,1) & , nact(1,1,1) & ) + numbinit(:,:) = 0. NACTL(:,:,k) = 0. DO n=1,n_modes @@ -219,12 +237,14 @@ SUBROUTINE Aer_Activation(MAPL, IM,JM,LM, q, t, plo, ple, tke, vvel, FRLAND, & ENDDO ENDDO ENDDO - numbinit = numbinit * air_den ! #/m3 + + ! Fused array multiplication into the existing loop for better cache performance DO j = 1, JM DO i = 1, IM + numbinit(i,j) = numbinit(i,j) * air_den(i,j) numbinit(i,j) = max(numbinit(i,j),0.0) NACTL(i,j,k) = MIN(NACTL(i,j,k),0.99*numbinit(i,j)) - NACTL(i,j,k) = MAX(MIN(NACTL(i,j,k),NN_MAX),NN_MIN) + NACTL(i,j,k) = MAX(MIN(NACTL(i,j,k),NN_MAX_LIQ),NN_MIN_LIQ) ENDDO ENDDO @@ -240,13 +260,22 @@ SUBROUTINE Aer_Activation(MAPL, IM,JM,LM, q, t, plo, ple, tke, vvel, FRLAND, & ENDDO ENDDO ENDDO - numbinit = numbinit * air_den ! #/m3 + + ! Optimized conditional calculation DO j = 1, JM DO i = 1, IM + numbinit(i,j) = numbinit(i,j) * air_den(i,j) numbinit(i,j) = max(numbinit(i,j),0.0) - ! Number of activated IN following deMott (2010) [#/m3] - NACTI(i,j,k) = (ai*(max(0.0,(MAPL_TICE-tk(i,j)))**bi)) * (numbinit(i,j)**(ci*max((MAPL_TICE-tk(i,j)),0.0)+di)) !#/m3 - NACTI(i,j,k) = MAX(MIN(NACTI(i,j,k),NN_MAX),NN_MIN) + + ! Only compute expensive exponents if cold enough AND aerosols exist + if (tk(i,j) < MAPL_TICE .and. numbinit(i,j) > 0.0) then + ! Number of activated IN following deMott (2010) [#/m3] + NACTI(i,j,k) = (ai*(max(0.0,(MAPL_TICE-tk(i,j)))**bi)) * (numbinit(i,j)**(ci*max((MAPL_TICE-tk(i,j)),0.0)+di)) + else + NACTI(i,j,k) = 0.0 + endif + + NACTI(i,j,k) = MAX(MIN(NACTI(i,j,k),NN_MAX_ICE),NN_MIN_ICE) ENDDO ENDDO diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/gfdl_mp.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/gfdl_mp.F90 index bb0b774b86..9dd21c1277 100644 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/gfdl_mp.F90 +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/gfdl_mp.F90 @@ -306,9 +306,9 @@ module gfdl_mp_mod logical :: z_slope_ice = .true. ! use linear mono slope for autocconversions logical :: use_rhc_cevap = .false. ! cap of rh for cloud water evaporation - logical :: use_rhc_revap = .false. ! cap of rh for rain evaporation + logical :: use_rhc_revap = .true. ! cap of rh for rain evaporation - logical :: use_enhanced_dry_evap = .false. ! Alternative minimum evaporation formula + logical :: use_enhanced_dry_evap = .true. ! Alternative minimum evaporation formula logical :: const_vw = .false. ! if .ture., the constants are specified by v * _fac logical :: const_vi = .false. ! if .ture., the constants are specified by v * _fac @@ -333,7 +333,7 @@ module gfdl_mp_mod logical :: do_warm_rain_mp = .false. ! do warm rain cloud microphysics only - logical :: do_wbf = .false. ! do Wegener Bergeron Findeisen process + logical :: do_wbf = .true. ! do Wegener Bergeron Findeisen process logical :: do_bigg = .false. ! do Bigg process @@ -436,7 +436,7 @@ module gfdl_mp_mod real :: pwbf_qi_crt = 0.8e-4 ! WBF liquid to ice freezing threshold (kg/m^3) real :: pgaut_qs_crt = 0.6e-3 ! snow to graupel autoconversion threshold (0.6e-3 in Purdue Lin scheme) (kg/m^3) - real :: c_paut = 0.75 ! cloud water to rain autoconversion efficiency + real :: c_paut = 0.5 ! cloud water to rain autoconversion efficiency ! ----------------------------------------------------------------------- ! collection efficiencies for accretion @@ -1453,12 +1453,17 @@ subroutine mpdrv (hydrostatic, ua, va, wa, delp, pt, qv, ql, qr, qi, qs, qg, qa, fac_eis = get_fac_eis(eis(i),srf_type) ! Estimated inversion strength determine stable regime ! ----------------------------------------------------------------------- - ! adjust autoconversion rates and thresholds for stable vs unstable + ! Adjust autoconversion rates and thresholds using decoupled regimes ! ----------------------------------------------------------------------- - ! include stability dependence - cpaut = cpaut0 * ( 0.75*fac_eis + (1.0-fac_eis)) - ! include stability dependence - fac_rc = rc * (rthreshs*fac_eis + rthreshu*(1.0-fac_eis)) ** 3 + ! 1. Rate scaling based on Boundary Layer Stability (EIS) + ! High inversion (fac_eis=1.0) -> reduced to 0.5 * cpaut0 + ! Low inversion (fac_eis=0.0) -> stays at 1.0 * cpaut0 + cpaut = cpaut0 * (0.5 * fac_eis + 1.0 * (1.0 - fac_eis)) + ! 2. Threshold scaling based on Deep Instability (CAPE / cnv_fraction) + ! convective (cnv_fraction=1) -> rthreshu + ! stratiform (cnv_fraction=0) -> rthreshs + ! NOTE: Consider raising rthreshu from 7.0e-6 to 8.0e-6 or 8.5e-6 to help suppress ITCZ over-precipitation + fac_rc = rc * (rthreshu * cnv_fraction + rthreshs * (1.0 - cnv_fraction)) ** 3 ! ----------------------------------------------------------------------- ! conversion of temperature @@ -4894,14 +4899,14 @@ subroutine pwbf (ks, ke, dts, qa, qv, ql, qr, qi, qs, qg, dp, tz, cvm, te8, den, real :: tc, tin, sink, dqdt, qsw, qsi, qim, tmp, fac_wbf real :: tau_wbf_eff - real, parameter :: wbf_coarse_mult = 10.0 ! How much slower WBF is at 50km vs 2km + real, parameter :: wbf_coarse_mult = 3.0 ! How much slower WBF is at 50km vs 2km if (.not. do_wbf) return ! ------------------------------------------------------------------- ! Scale tau_wbf: - ! If onemsig = 1.0 (2km), tau_wbf_eff = tau_wbf * 1.0 - ! If onemsig = 0.0 (50km), tau_wbf_eff = tau_wbf * 10.0 + ! If onemsig = 1.0 (2km), tau_wbf_eff = tau_wbf + ! If onemsig = 0.0 (50km), tau_wbf_eff = tau_wbf * wbf_coarse_mult ! ------------------------------------------------------------------- tau_wbf_eff = tau_wbf * (wbf_coarse_mult * (1.0 - onemsig) + onemsig) @@ -4916,8 +4921,11 @@ subroutine pwbf (ks, ke, dts, qa, qv, ql, qr, qi, qs, qg, dp, tz, cvm, te8, den, qsw = wqs (tin, den (k), dqdt) qsi = iqs (tin, den (k), dqdt) + ! heterogeneity and allow WBF to operate in large-scale updrafts + ! when the environment is supersaturated with respect to ice (qv > qsi) + ! and there is both liquid and ice present if (tc .gt. 0. .and. ql (k) .gt. qcmin .and. qi (k) .gt. qcmin .and. & - qv (k) .gt. qsi .and. qv (k) .lt. qsw) then + qv (k) .gt. qsi) then sink = min (fac_wbf * ql (k), tc / icpk (k)) qim = pwbf_qi_crt / den (k) diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSturbulence_GridComp/GEOS_TurbulenceGridComp.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSturbulence_GridComp/GEOS_TurbulenceGridComp.F90 index f5e7ff31df..9bd39023ed 100644 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSturbulence_GridComp/GEOS_TurbulenceGridComp.F90 +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSturbulence_GridComp/GEOS_TurbulenceGridComp.F90 @@ -3217,17 +3217,17 @@ subroutine REFRESH(IM,JM,LM,RC) call MAPL_GetResource (MAPL, USE_EIS, trim(COMP_NAME)//"_USE_EIS:", default=.false.,RC=STATUS); VERIFY_(STATUS) else call MAPL_GetResource (MAPL, LAMBDADISS, trim(COMP_NAME)//"_LAMBDADISS:", default=15., RC=STATUS); VERIFY_(STATUS) - call MAPL_GetResource (MAPL, KHRADFAC, trim(COMP_NAME)//"_KHRADFAC:", default=1.0, RC=STATUS); VERIFY_(STATUS) + call MAPL_GetResource (MAPL, KHRADFAC, trim(COMP_NAME)//"_KHRADFAC:", default=0.8, RC=STATUS); VERIFY_(STATUS) call MAPL_GetResource (MAPL, KHSFCFAC_LND, trim(COMP_NAME)//"_KHSFCFAC_LND:", default=1.0, RC=STATUS); VERIFY_(STATUS) call MAPL_GetResource (MAPL, KHSFCFAC_OCN, trim(COMP_NAME)//"_KHSFCFAC_OCN:", default=1.0, RC=STATUS); VERIFY_(STATUS) call MAPL_GetResource (MAPL, PRANDTLSFC, trim(COMP_NAME)//"_PRANDTLSFC:", default=1.0, RC=STATUS); VERIFY_(STATUS) call MAPL_GetResource (MAPL, PRANDTLRAD, trim(COMP_NAME)//"_PRANDTLRAD:", default=0.75, RC=STATUS); VERIFY_(STATUS) - call MAPL_GetResource (MAPL, BETA_RAD, trim(COMP_NAME)//"_BETA_RAD:", default=0.30, RC=STATUS); VERIFY_(STATUS) - call MAPL_GetResource (MAPL, BETA_SURF, trim(COMP_NAME)//"_BETA_SURF:", default=0.15, RC=STATUS); VERIFY_(STATUS) + call MAPL_GetResource (MAPL, BETA_RAD, trim(COMP_NAME)//"_BETA_RAD:", default=0.15, RC=STATUS); VERIFY_(STATUS) + call MAPL_GetResource (MAPL, BETA_SURF, trim(COMP_NAME)//"_BETA_SURF:", default=0.10, RC=STATUS); VERIFY_(STATUS) call MAPL_GetResource (MAPL, ENTRATE_SURF, trim(COMP_NAME)//"_ENTRATE_SURF:", default=1.5e-3, RC=STATUS); VERIFY_(STATUS) - call MAPL_GetResource (MAPL, TPFAC_MIN, trim(COMP_NAME)//"_TPFAC_MIN:", default=0.0, RC=STATUS); VERIFY_(STATUS) - call MAPL_GetResource (MAPL, TPFAC_MAX, trim(COMP_NAME)//"_TPFAC_MAX:", default=0.0, RC=STATUS); VERIFY_(STATUS) - call MAPL_GetResource (MAPL, PCEFF_SURF, trim(COMP_NAME)//"_PCEFF_SURF:", default=0.0, RC=STATUS); VERIFY_(STATUS) + call MAPL_GetResource (MAPL, TPFAC_MIN, trim(COMP_NAME)//"_TPFAC_MIN:", default=10.0, RC=STATUS); VERIFY_(STATUS) + call MAPL_GetResource (MAPL, TPFAC_MAX, trim(COMP_NAME)//"_TPFAC_MAX:", default=20.0, RC=STATUS); VERIFY_(STATUS) + call MAPL_GetResource (MAPL, PCEFF_SURF, trim(COMP_NAME)//"_PCEFF_SURF:", default=0.375, RC=STATUS); VERIFY_(STATUS) call MAPL_GetResource (MAPL, LOCK_ON, trim(COMP_NAME)//"_LOCK_ON:", default=1, RC=STATUS); VERIFY_(STATUS) call MAPL_GetResource (MAPL, VSCALE_SURF, trim(COMP_NAME)//"_VSCALE_SURF:", default=2.5e-3, RC=STATUS); VERIFY_(STATUS) call MAPL_GetResource (MAPL, USE_EIS, trim(COMP_NAME)//"_USE_EIS:", default=.false.,RC=STATUS); VERIFY_(STATUS) @@ -4826,29 +4826,47 @@ subroutine REFRESH(IM,JM,LM,RC) else temparray(1:LM+1) = KH(I,J,0:LM) endif - maxkh = maxval(temparray) - - if (USE_EIS) then - if (EIS(I,J) >= 12.0) then - eis_stable = 1.0 - elseif (EIS(I,J) <= 0.0) then - eis_stable = 0.0 - else - eis_stable = (EIS(I,J) / 12.0)**1.5 - endif - ! Adaptive threshold: 10-30% based on EIS - kh_thresh = 0.10 + eis_stable * 0.20 + if ( (LM .eq. 72) .OR. (JASON_TRB) ) then + maxkh = maxval(temparray) + kh_thresh = 0.1 + do L=LM-1,2,-1 + if ( (temparray(L) < kh_thresh*maxkh) .and. (temparray(L+1) >= kh_thresh*maxkh) & + .and. (KPBL_SC(I,J) == MAPL_UNDEF ) ) then + KPBL_SC(I,J) = float(L) + end if + end do else - kh_thresh = 0.1 + ! ----------------------------------------------------------------- + ! Find max turbulence, but ignore the lowest 50 meters + ! to safely bypass grid-dependent numerical surface spikes + ! ----------------------------------------------------------------- + maxkh = 0.0 + do L = 1, LM + ! Assuming Z(I,J,L) is height. + ! (If Z is altitude MSL, use: Z(I,J,L) - Z(I,J,LM) > 50.0) + if ( Z(I,J,L) > 50.0 ) then + if (temparray(L) > maxkh) then + maxkh = temparray(L) + endif + endif + end do + ! Safety fallback: If maxkh is still 0.0 (e.g., highly stable arctic night), + ! just grab the absolute maximum of the whole column. + if (maxkh == 0.0) then + maxkh = maxval(temparray) + endif + ! ----------------------------------------------------------------- + kh_thresh = 0.1*maxkh + ! Search TOP-DOWN to find the true PBL top + do L = 2, LM-1 + if ( (temparray(L) >= kh_thresh) .and. & + (KPBL_SC(I,J) == MAPL_UNDEF ) ) then + KPBL_SC(I,J) = float(L) + exit ! Break the loop once we hit the top of the turbulence + end if + end do endif - - do L=LM-1,2,-1 - if ( (temparray(L) < kh_thresh*maxkh) .and. (temparray(L+1) >= kh_thresh*maxkh) & - .and. (KPBL_SC(I,J) == MAPL_UNDEF ) ) then - KPBL_SC(I,J) = float(L) - end if - end do - if ( KPBL_SC(I,J) .eq. MAPL_UNDEF .or. (maxkh.lt.1.)) then + if ( KPBL_SC(I,J) .eq. MAPL_UNDEF .or. (maxkh.lt.1.)) then KPBL_SC(I,J) = float(LM) endif end do diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSturbulence_GridComp/LockEntrain.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSturbulence_GridComp/LockEntrain.F90 index 9664332c05..71546f6c3d 100644 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSturbulence_GridComp/LockEntrain.F90 +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSturbulence_GridComp/LockEntrain.F90 @@ -810,8 +810,7 @@ subroutine entrain( & ! 3. Apply combined factor ! Ensure the floor isn't too low for marine clouds - ! (0.5 is a safer floor for marine Sc than 0.4) - eis_floor = 0.5 - (0.1 * frland(i,j)) + eis_floor = 0.2 - (0.1 * frland(i,j)) wentr_tmp = wentr_tmp * depth_factor * max(eis_floor, eis_factor) else ! Original depth-only scaling @@ -840,8 +839,11 @@ subroutine entrain( & if (ipbl .lt. ibot) then if (use_eis) then - khsfcfac = khsfcfac_lnd*( eis_stability) + & - khsfcfac_ocn*(1.0-eis_stability) + ! Calculate the base geographic factor first + khsfcfac = khsfcfac_lnd*frland(i,j) + khsfcfac_ocn*(1.0-frland(i,j)) + ! Then modulate it based on stability (e.g., reduce it under high stability) + ! (Adjust the 0.5 factor to whatever tuning you prefer) + khsfcfac = khsfcfac * (1.0 - 0.5 * eis_stability) else khsfcfac = khsfcfac_lnd*frland(i,j) + khsfcfac_ocn*(1.0-frland(i,j)) endif @@ -1100,7 +1102,7 @@ subroutine entrain( & wentr_rad = wentr_rad * max(0.0,(zradtop-500.)/300.) endif wentr_rad = wentr_rad * min(3.0,(zradtop/800.)) - endif + endif !----------------------------------------- k_entr_tmp = min ( akmax, wentr_rad*(zfull(i,j,kcldtop-1)-zfull(i,j,kcldtop)) ) @@ -1353,7 +1355,14 @@ subroutine mpbl_depth(i,j,icol,jcol,nlev, tpfac_min, tpfac_max, entrate, pceff, pp = p(i,j,k) du = sqrt ( ( u2 - u1 )**2 + ( v2 - v1 )**2 ) / (z2-z1) - du = min(du,1.0e-8) + if (tpfac_max /= tpfac_min) then + ! Prevent negative/zero shear, but allow real shear (e.g., 0.01 to 0.1 s-1) + du = max(du, 1.0e-8) + ! Optional: If we need to cap extreme shear + du = min(du, 0.1) + else + du = min(du, 1.0e-8) ! This is likely a bug + endif if (use_eis) then entrate_x = (entrate - 0.6e-3*LTS_FAC) * & ! adjust entrate based on LTS_FAC From 658dc814e57ff42671d1231edb8a0708463d7446 Mon Sep 17 00:00:00 2001 From: biljanaorescanin Date: Sun, 14 Jun 2026 16:59:35 -0400 Subject: [PATCH 13/40] update climatology plot and movie colorbars --- .../Utils/Raster/makebcs/clsm_plots.py | 153 +++++++++++------- 1 file changed, 97 insertions(+), 56 deletions(-) diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/makebcs/clsm_plots.py b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/makebcs/clsm_plots.py index e1d625d022..427d11970f 100755 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/makebcs/clsm_plots.py +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/makebcs/clsm_plots.py @@ -1,6 +1,6 @@ #!/usr/bin/env python3 """ -Drop-in Python replacement for GEOS makebcs clsm_plots.pro. +Python replacement/extension for GEOS makebcs clsm_plots.pro This script is intended to be run from the same place the IDL driver was run (usually clsm/plots). With no arguments it reads $gfile, $workdir, $NC, and @@ -17,8 +17,8 @@ markers by default. Use --endian/--record-marker if your files differ. * Cartopy is optional. If available, this script can draw coastlines with --coastlines. Otherwise plots are still generated with lon/lat axes. - * Movie generation is optional and potentially slow; use --plots movies or - --plots default. + * Movie generation is optional and potentially slow. Use --plots movies + for movies only, or --plots legacy for fixed JPGs plus movies. """ from __future__ import annotations @@ -33,7 +33,7 @@ import shutil import subprocess from pathlib import Path -from typing import Callable, Dict, Iterable, Iterator, List, Mapping, Optional, Sequence, Tuple +from typing import List, Optional, Sequence, Tuple import numpy as np @@ -55,12 +55,6 @@ except Exception: # pragma: no cover scipy_mode = None -try: - import imageio.v2 as imageio # type: ignore -except Exception: # pragma: no cover - imageio = None - - class FFMpegPipeWriter: """Small MP4 writer that pipes RGB frames to the system ffmpeg executable. @@ -303,16 +297,53 @@ def put(start: int, r: Sequence[int], g: Sequence[int], b: Sequence[int]) -> Non [0, 139, 0], [0, 128, 0], [0, 100, 0], [48, 128, 20], [110, 139, 61], [85, 107, 47], ]) -LAI_LEVELS = np.asarray([0.0, 0.25, 0.5, 0.75, 1.0, 1.25, 1.5] + list(np.arange(11) * 0.5 + 2.0), dtype=np.float32) +# White is reserved for missing / invalid / no-data only. +# It is not used as a valid data color in LAI, GREEN, NDVI, VISDF, or NIRDF. +NO_DATA_COLOR = (1.0, 1.0, 1.0) + +# LAI is plotted from 0.0 to 7.5 using 0.5 increments. +# There are 16 boundaries and therefore 15 valid color intervals. +# Drop the first nearly-white color from LAI_RGB so the first valid data +# interval, 0.0-0.5, is light gray instead of white. +LAI_LEVELS = np.asarray([ + 0.0, 0.5, 1.0, 1.5, 2.0, 2.5, + 3.0, 3.5, 4.0, 4.5, 5.0, 5.5, + 6.0, 6.5, 7.0, 7.5, +], dtype=np.float32) + +LAI_PLOT_RGB = LAI_RGB[1:len(LAI_LEVELS)].copy() + +LAI_TICKS = LAI_LEVELS.astype(float) -# Fraction-style seasonal diagnostics (GREEN and NDVI). These reuse the -# working LAI/GREEN movie time-series reader, but use a 0..1 scale. +LAI_TICK_LABELS = [ + "0", "0.5", "1", "1.5", "2", "2.5", + "3", "3.5", "4", "4.5", "5", "5.5", + "6", "6.5", "7", "7.5", +] + +# Fraction fields use FRACTION_LEVELS as true 0..1 bin boundaries. +# FRACTION_LEVELS has 18 boundaries, so it needs 17 colors. +# White is reserved for missing/no-data; valid zero values use light blue. FRACTION_LEVELS = np.asarray([ - 0.0, 0.025, 0.05, 0.075, 0.10, 0.125, 0.15, 0.20, - 0.30, 0.35, 0.40, 0.45, 0.50, 0.60, 0.70, 0.80, 0.90, 1.00 + 0.00, 0.025, 0.050, 0.075, 0.10, + 0.15, 0.20, 0.25, 0.30, 0.35, + 0.40, 0.45, 0.50, + 0.60, 0.70, 0.80, 0.90, 1.00, ], dtype=np.float32) -FRACTION_TICKS = np.asarray([0.0, 0.1, 0.2, 0.4, 0.6, 0.8, 1.0], dtype=float) -FRACTION_TICK_LABELS = ["0", "0.1", "0.2", "0.4", "0.6", "0.8", "1"] + +FRACTION_RGB = LAI_RGB[1:len(FRACTION_LEVELS)].copy() + +FRACTION_TICKS = FRACTION_LEVELS.astype(float) + +FRACTION_TICK_LABELS = [ + "0", "0.025", "0.05", "0.075", "0.1", + "0.15", "0.2", "0.25", "0.3", "0.35", + "0.4", "0.45", "0.5", + "0.6", "0.7", "0.8", "0.9", "1", +] + +FRACTION_RGB = LAI_RGB[1:].copy() +FRACTION_RGB[0] = _as_rgb([[210, 230, 255]])[0] # IDL Z0 levels used by compute_zo for ascat/icarus/merged. Keep # labels as strings so matplotlib cannot round the sub-1 bins to repeated @@ -362,13 +393,14 @@ def marker_dtype(self) -> np.dtype: @dataclasses.dataclass(frozen=True) class TimeSeriesLayout: - """Layout for LAI/GREEN/NDVI-style seasonal time series files. - - Most make_bcs files are F77 sequential records with a 9-value header - record followed by an ncat-value data record. Some completed BCS trees - expose renamed/symlinked files whose first header record is double - precision, and a few test copies may be raw streams. - """ + """Layout for LAI/GREEN/NDVI/AlbMap-style seasonal time-series files. + + Most make_bcs files are F77 sequential records with a header record + containing at least the 9 IDL date fields, followed by an ncat-value data + record. Finished BCS trees may expose renamed/symlinked files with extended + headers or double-precision header fields. A few test copies may be raw + header+data streams without F77 record markers. + """ mode: str = "f77" endian: str = "<" marker_bytes: int = 4 @@ -498,8 +530,9 @@ def choose_timeseries_layout(path: Path, ncat: int, endian: str = "auto", marker if endian == "auto" or marker_bytes == 0: return detect_timeseries_layout(path, ncat) endian_char = "<" if endian in ("little", "<") else ">" - # Try single-precision first; detect_timeseries_layout will still be used - # if this explicit guess is wrong in the caller. + # When endian and record-marker are explicitly specified, assume a + # single-precision F77 layout. Use auto detection for files that may + # have extended or double-precision headers. return TimeSeriesLayout("f77", endian_char, marker_bytes, "f4", "f4") class FortranSequentialReader: @@ -1321,7 +1354,6 @@ def build_boundary_segments_from_tile_ids( rows, cols = np.where(draw_v) for r, c in zip(rows.tolist(), cols.tolist()): x = float(lon_edges[c + 1]) - h_segments_dummy = None v_segments.append(((x, float(lat_edges[r])), (x, float(lat_edges[r + 1])))) # Left/right outside edges where a valid cell borders the regional/ocean edge. for r in range(tile_ids.shape[0]): @@ -1481,7 +1513,6 @@ def decorate_geo( except Exception: pass - def plot_continuous_on_ax( ax, grid: np.ndarray, @@ -1495,6 +1526,7 @@ def plot_continuous_on_ax( coastlines: bool = False, show_xlabel: bool = True, show_ylabel: bool = True, + bad_color = "white", ): sub, lon_sub, lat_sub, extent = crop_to_limits(grid, lon, lat, limits) finite = np.isfinite(sub) @@ -1519,7 +1551,7 @@ def plot_continuous_on_ax( # on the axes. On Discover some Agg/pcolormesh combinations were producing # blank-looking panels even though the arrays contained valid data. This # follows the successful direct-image debug path. - cmap.set_bad("white") + cmap.set_bad(bad_color) rgba = cmap(norm(np.ma.masked_invalid(sub))) imshow_kwargs = dict( origin="lower", @@ -1625,6 +1657,7 @@ def panel_continuous( rgb_list: Optional[Sequence[np.ndarray]] = None, figsize: Tuple[float, float] = (10, 8), coastlines: bool = False, + bad_color = "white", ) -> None: n = len(grids) nrows = int(math.ceil(n / ncols)) @@ -1674,6 +1707,7 @@ def panel_continuous( coastlines=coastlines, show_xlabel=show_xlabel, show_ylabel=show_ylabel, + bad_color=bad_color, ) cbar = fig.colorbar(last_im, ax=ax, shrink=0.65, pad=0.02) cbar.ax.tick_params(labelsize=7) @@ -1872,7 +1906,6 @@ def plot_country_codes(base_dir: Path, tile_id: np.ndarray, lon: np.ndarray, lat print(f" plot Country / state codes: finite=0/{sub.size} -- output will be blank") cmap = ListedColormap(colors) cmap.set_bad("white") - vals = np.ma.masked_invalid(sub) # Wrap arbitrary numeric country/state codes into the available palette for # a stable categorical image. The exact colors do not need to encode the # numeric magnitude. @@ -2190,6 +2223,7 @@ def panel_continuous_shared_colorbar( cbar_ticks: Optional[Sequence[float]] = None, cbar_ticklabels: Optional[Sequence[str]] = None, cbar_tick_rotation: float = 90.0, + bad_color = "white", ) -> None: """Multi-panel plot with one shared colorbar. @@ -2218,9 +2252,10 @@ def panel_continuous_shared_colorbar( coastlines=coastlines, show_xlabel=(row == nrows - 1), show_ylabel=(col == 0), + bad_color=bad_color, ) if last_im is not None: - cax = fig.add_axes([0.20, 0.060, 0.60, 0.024]) + cax = fig.add_axes([0.14, 0.060, 0.72, 0.024]) if cbar_ticks is not None: tick_values = np.asarray(cbar_ticks, dtype=float) cbar = fig.colorbar( @@ -2262,10 +2297,11 @@ def plot_monthly_timeseries( product_label: str, layout: Optional[TimeSeriesLayout], coastlines: bool, + bad_color = NO_DATA_COLOR, *, kind: str = "raw", levels: Sequence[float] = FRACTION_LEVELS, - rgb: np.ndarray = LAI_RGB, + rgb: np.ndarray = FRACTION_RGB, cbar_label: str = "", cbar_ticks: Optional[Sequence[float]] = None, cbar_ticklabels: Optional[Sequence[str]] = None, @@ -2303,22 +2339,25 @@ def plot_monthly_timeseries( cbar_ticks=cbar_ticks, cbar_ticklabels=cbar_ticklabels, cbar_tick_rotation=0.0 if cbar_ticks is not None else 90.0, - ) + bad_color=bad_color, + ) def plot_lai(base_dir: Path, tile_id: np.ndarray, lon: np.ndarray, lat: np.ndarray, limits, outdir: Path, ncat: int, layout: Optional[TimeSeriesLayout], coastlines: bool) -> None: plot_monthly_timeseries( base_dir, tile_id, lon, lat, limits, outdir, ncat, "lai.dat", "lai.jpg", "LAI", layout, coastlines, - kind="lai", levels=LAI_LEVELS, rgb=LAI_RGB, cbar_label="LAI", - ) + kind="lai", levels=LAI_LEVELS, rgb=LAI_PLOT_RGB, cbar_label="LAI", + cbar_ticks=LAI_TICKS, + cbar_ticklabels=LAI_TICK_LABELS, + ) def plot_green(base_dir: Path, tile_id: np.ndarray, lon: np.ndarray, lat: np.ndarray, limits, outdir: Path, ncat: int, layout: Optional[TimeSeriesLayout], coastlines: bool) -> None: plot_monthly_timeseries( base_dir, tile_id, lon, lat, limits, outdir, ncat, "green.dat", "green.jpg", "GREEN", layout, coastlines, - kind="fraction", levels=FRACTION_LEVELS, rgb=LAI_RGB, + kind="fraction", levels=FRACTION_LEVELS, rgb=FRACTION_RGB, cbar_label="Green vegetation fraction", cbar_ticks=FRACTION_TICKS, cbar_ticklabels=FRACTION_TICK_LABELS, @@ -2329,7 +2368,7 @@ def plot_ndvi(base_dir: Path, tile_id: np.ndarray, lon: np.ndarray, lat: np.ndar plot_monthly_timeseries( base_dir, tile_id, lon, lat, limits, outdir, ncat, "ndvi.dat", "ndvi.jpg", "NDVI", layout, coastlines, - kind="ndvi", levels=FRACTION_LEVELS, rgb=LAI_RGB, + kind="ndvi", levels=FRACTION_LEVELS, rgb=FRACTION_RGB, cbar_label="NDVI", cbar_ticks=FRACTION_TICKS, cbar_ticklabels=FRACTION_TICK_LABELS, @@ -2373,7 +2412,6 @@ def seasonal_z0_and_ndvi(base_dir: Path, ncat: int, z2ch: np.ndarray, scale4z0: if not lai_path.exists() or not ndvi_path.exists(): raise ClsmPlotError(f"Missing {lai_path} or {ndvi_path}; required for icarus/merged Z0") mdays = [31, 28, 31, 30, 31, 30, 31, 31, 30, 31, 30, 31] - season_months = {0: [12, 1, 2], 1: [3, 4, 5], 2: [6, 7, 8], 3: [9, 10, 11]} # Accumulate valid daily means only. Invalid LAI/NDVI should not become # zero roughness; otherwise it appears as artificial brown/underflow bins. zo_sum = np.zeros((ncat, 4), dtype=np.float64) @@ -2534,7 +2572,7 @@ def plot_lai_minmax(base_dir: Path, tile_id: np.ndarray, lon, lat, limits, outdi g = vector_to_grid(tile_id, vec) g[g == 0.0] = np.nan grids.append(g) - panel_continuous(grids, ["LAI Minimum", "LAI Maximum"], lon, lat, limits, outdir / "LAI_minmax.png", ncols=1, levels_list=[LAI_LEVELS, LAI_LEVELS], rgb_list=[LAI_RGB, LAI_RGB], figsize=(9, 11), coastlines=coastlines) + panel_continuous(grids, ["LAI Minimum", "LAI Maximum"], lon, lat, limits, outdir / "LAI_minmax.png", ncols=1, levels_list=[LAI_LEVELS, LAI_LEVELS], rgb_list=[LAI_PLOT_RGB, LAI_PLOT_RGB], figsize=(9, 11), coastlines=coastlines) def plot_irrig_fractions(base_dir: Path, tile_id: np.ndarray, lon, lat, limits, outdir: Path, coastlines: bool) -> None: @@ -2664,24 +2702,18 @@ def _format_movie_tick_label(x: float) -> str: def movie_colorbar_ticks(vname: str) -> Tuple[np.ndarray, List[str], str]: - """Return stable, readable colorbar ticks for seasonal movies. - - LAI uses the same color scale as lai.jpg but labels integer values. GREEN, - VISDF, and NIRDF are fractional fields, so label 0..1 directly. The map - still uses the full level set; these are only the displayed colorbar ticks. - """ - if vname == "LAI": - ticks = np.asarray([0, 1, 2, 3, 4, 5, 6, 7], dtype=float) - return ticks, [_format_movie_tick_label(x) for x in ticks], "LAI" - ticks = np.asarray([0.0, 0.1, 0.2, 0.4, 0.6, 0.8, 1.0], dtype=float) + """Return movie colorbar ticks consistent with static plots.""" label_map = { "GREEN": "Green vegetation fraction", "VISDF": "VIS diffuse albedo", "NIRDF": "NIR diffuse albedo", "NDVI": "NDVI", } - return ticks, [_format_movie_tick_label(x) for x in ticks], label_map.get(vname, vname) + if vname == "LAI": + return LAI_TICKS, list(LAI_TICK_LABELS), "LAI" + + return FRACTION_TICKS, list(FRACTION_TICK_LABELS), label_map.get(vname, vname) def add_movie_colorbar(fig: plt.Figure, ax, sm: ScalarMappable, vname: str, levels: Sequence[float]) -> None: """Add one horizontal colorbar to every movie frame. @@ -2691,11 +2723,11 @@ def add_movie_colorbar(fig: plt.Figure, ax, sm: ScalarMappable, vname: str, leve every frame has a stable scale and readable labels. """ ticks, labels, label = movie_colorbar_ticks(vname) - cax = fig.add_axes([0.19, 0.075, 0.62, 0.030]) + cax = fig.add_axes([0.08, 0.075, 0.84, 0.030]) cbar = fig.colorbar(sm, cax=cax, orientation="horizontal", ticks=ticks, spacing="uniform") cbar.ax.xaxis.set_major_locator(FixedLocator(ticks)) cbar.ax.xaxis.set_major_formatter(FixedFormatter(labels)) - cbar.ax.tick_params(labelsize=7, rotation=0, pad=2) + cbar.ax.tick_params(labelsize=5, rotation=0, pad=2) cbar.set_label(label, fontsize=8, labelpad=3) def make_movie( @@ -2725,6 +2757,12 @@ def make_movie( # movie-only runs to fail with: 'TimeSeriesLayout' object has no attribute # 'marker_dtype'. mat = build_fractional_sparse_from_rst(rst_file, nc, nr, ncat, nc_movie, nr_movie, rst_layout, mapping_cache) + # Rows with no contributing land/catchment tiles are ocean/no-data. + # Sparse matrix multiplication returns 0.0 for empty rows, which would + # otherwise be plotted as a valid zero/low-value color in movies. Static + # climatology plots get NaN from vector_to_grid() for invalid cells; do + # the equivalent here so cmap.set_bad(NO_DATA_COLOR) is used consistently. + movie_cell_has_data = np.asarray(mat.getnnz(axis=1)).ravel() > 0 filename_map = { "LAI": "lai.dat", "GREEN": "green.dat", @@ -2737,7 +2775,8 @@ def make_movie( print(f"Skipping {vname} movie; missing {path}") return levels = LAI_LEVELS if vname == "LAI" else FRACTION_LEVELS - rgb = LAI_RGB + rgb = LAI_PLOT_RGB if vname == "LAI" else FRACTION_RGB + bad_color = NO_DATA_COLOR lon, lat = lon_lat_centers(nc_movie, nr_movie) mdays = [31,28,31,30,31,30,31,31,30,31,30,31] outpath = outdir / f"{vname}.mp4" @@ -2768,8 +2807,9 @@ def make_movie( bad = (~np.isfinite(vec)) | (vec < 0.0) | (vec > 1.0) | (np.abs(vec) > 1.0e10) vec = vec.copy() vec[bad] = np.nan - flat = mat @ vec.astype(np.float32) - grid = np.asarray(flat).reshape(nr_movie, nc_movie) + flat = np.asarray(mat @ vec.astype(np.float32), dtype=np.float32).ravel() + flat[~movie_cell_has_data] = np.nan + grid = flat.reshape(nr_movie, nc_movie) fig = plt.figure(figsize=(7.8, 5.85), dpi=100) # Leave room for lon/lat tick labels and a fixed colorbar. # Movie frames are captured from the raw canvas, not through @@ -2777,7 +2817,7 @@ def make_movie( fig.subplots_adjust(left=0.085, right=0.985, bottom=0.205, top=0.90) ax = make_axes(fig, 1, 1, 1, coastlines) date_stamp = f"{2001 + current_year_offset:04d}{month:02d}{day:02d}" - sm = plot_continuous_on_ax(ax, grid, lon, lat, limits, f"{vname}: {date_stamp}", levels, rgb=rgb, coastlines=coastlines) + sm = plot_continuous_on_ax(ax, grid, lon, lat, limits, f"{vname}: {date_stamp}", levels, rgb=rgb, coastlines=coastlines, bad_color=bad_color) add_movie_colorbar(fig, ax, sm, vname, levels) fig.canvas.draw() frame = np.asarray(fig.canvas.buffer_rgba())[:, :, :3] @@ -3023,3 +3063,4 @@ def main(argv: Optional[Sequence[str]] = None) -> int: except ClsmPlotError as exc: print(f"ERROR: {exc}", file=sys.stderr) raise SystemExit(2) + From e5170929111254bad1bec774b50632095be52083 Mon Sep 17 00:00:00 2001 From: biljanaorescanin Date: Mon, 15 Jun 2026 11:13:08 -0400 Subject: [PATCH 14/40] Remove legacy IDL CLSM plotting script --- .../Utils/Raster/makebcs/clsm_plots.pro | 3738 ----------------- 1 file changed, 3738 deletions(-) delete mode 100755 GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/makebcs/clsm_plots.pro diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/makebcs/clsm_plots.pro b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/makebcs/clsm_plots.pro deleted file mode 100755 index d5584b3dde..0000000000 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/makebcs/clsm_plots.pro +++ /dev/null @@ -1,3738 +0,0 @@ -;_____________________________________________________________________ - -FUNCTION NCDF_ISNCDF, FILENAME - -;- Set return values - -false = 0B -true = 1B - -;- Establish error handler - -catch, error_status -if error_status ne 0 then begin - catch, /cancel - return, false -endif - -;- Try opening the file - -cdfid = ncdf_open( filename ) - -;- If we get this far, open must have worked - -ncdf_close, cdfid -catch, /cancel -return, true - -END - -; ---------------- - -function nint, x, LONG = long ;Nearest Integer Function -;+ -; NAME: -; NINT -; PURPOSE: -; Nearest integer function. -; EXPLANATION: -; NINT() is similar to the intrinsic ROUND function, with the following -; two differences: -; (1) if no absolute value exceeds 32767, then the array is returned as -; as a type INTEGER instead of LONG -; (2) NINT will work on strings, e.g. print,nint(['3.4','-0.9']) will -; give [3,-1], whereas ROUND() gives an error message -; -; CALLING SEQUENCE: -; result = nint( x, [ /LONG] ) -; -; INPUT: -; X - An IDL variable, scalar or vector, usually floating or double -; Unless the LONG keyword is set, X must be between -32767.5 and -; 32767.5 to avoid integer overflow -; -; OUTPUT -; RESULT - Nearest integer to X -; -; OPTIONAL KEYWORD INPUT: -; LONG - If this keyword is set and non-zero, then the result of NINT -; is of type LONG. Otherwise, the result is of type LONG if -; any absolute values exceed 32767, and type INTEGER if all -; all absolute values are less than 32767. -; EXAMPLE: -; If X = [-0.9,-0.1,0.1,0.9] then NINT(X) = [-1,0,0,1] -; -; PROCEDURE CALL: -; None: -; REVISION HISTORY: -; Written W. Landsman January 1989 -; Added LONG keyword November 1991 -; Use ROUND if since V3.1.0 June 1993 -; Always start with ROUND function April 1995 -; Return LONG values, if some input value exceed 32767 -; and accept string values February 1998 -; Use size(/TNAME) instead of DATATYPE() October 2001 -;- -xmax = max(x,min=xmin) - xmax = abs(xmax) > abs(xmin) - if (xmax gt 32767) or keyword_set(long) then begin - if size(x,/TNAME) eq 'STRING' then b = round(float(x)) else b = round(x) - end else begin - if size(x,/TNAME) eq 'STRING' then b = fix(round(float(x))) else $ - b = fix(round(x)) - endelse - - return, b - end - -; ------------------------------------------------------------------------------------------- - -FUNCTION IS_IN_DOMAIN, xylim, x,y - -if (((x ge xylim(1)) and (x le xylim(3))) and $ - ((y ge xylim(0)) and (y le xylim(2)))) then begin - - return_value = boolean(1) - -endif else begin - - return_value = boolean(0) - -endelse - -return,return_value - -END - -; ####################################################### - -FUNCTION Z0_VALUE, Z2CH, lai, SCALE4Z0 - -MIN_VEG_HEIGHT = 0.01 -Z0_BY_ZVEG = 0.13 - -if (SCALE4Z0 eq 2.) then begin - return_value = SCALE4Z0 * Z0_BY_ZVEG * (Z2CH - (Z2CH - MIN_VEG_HEIGHT) * exp(-1.*LAI)) -endif else begin - return_value = Z0_BY_ZVEG * (Z2CH - SCALE4Z0 * (Z2CH - MIN_VEG_HEIGHT) * exp(-1.*LAI)) -endelse - -return,return_value - -END - -;=========================================================== -;+ -; NAME: -; SHUFFLE -; -; PURPOSE: -; This function returns the uniformly-shuffled elements of an array. -; -; CATEGORY: -; Math. -; -; CALLING SEQUENCE: -; -; Result = SHUFFLE( A [, Num]) -; -; INPUTS: -; A: Array containing the elements to shuffle (e.g. INDGEN(100)) -; -; OPTIONAL INPUTS: -; Num: Number of shuffled elements to return. Must be < N_ELEMENTS(A)+1 -; -; OPTIONAL INPUT KEYWORD PARAMETERS: -; SEED: Number used to seed the random number generator, RANDOMU. -; -; OUTPUTS: -; Returns the Num shuffled elements of the A array. -; -; OPTIONAL OUTPUT KEYWORD PARAMETERS: -; -; INDICES: Array of indices pointing to the shuffled elements of A. -; -; EXAMPLE: -; Pick 10 unique random integers between the numbers 1..100: -; -; i = INDGEN(100) -; j = SHUFFLE(i,10) -; -; MODIFICATION HISTORY: -; Written by: Han Wen, January 1997. -;- -function SHUFFLE, A, Num, INDICES=Indices, SEED=Seed - - NP = N_PARAMS() - N = N_ELEMENTS(A) - if (N eq 0) then message, $ - 'Must be called with 1-2 parameters: A [,Num]' - if (NP eq 1) then Num = N - - r = RANDOMU(Seed, N) - Indices = SORT(r) - return, A(Indices(0:Num-1)) -end - -; ######################################################### - -PRO clsm_plots - -; ########################################################## -; Calling Sequence: -; (1) get environment variables -; (2) reading catchment.def and setting map limits -; (3) generating NC_plot x NR_plot mask for plotting maps -; (4) plotting catchment-tiles in the Eastern United States -; (5) processing JPL Height -; (6) plotting CTI statistics -; (7) plotting vegetation types -; (8) plotting soil hydraulic properties -; (9) plotting elevation -; (10)plot LAI monthly climatology -; (11)generating NC_plot x NR_plot mask for plotting maps -; (12)making movies of Seasonal data -; -; Miscellaneous Routines -; (a1) check_satparam - Check ars and arw parameters -; (a2) create_vec_file - For LIS/GSWP-2 type applications -; ########################################################## - -; (1) Reading in Enviornment variables -; -------------------------------- - -gfile=GETENV('gfile') -path =GETENV('workdir') -NC =1l*GETENV('NC') -NR =1l*GETENV('NR') - - -; (2) Reading number of catchments -;--------------------------------- - -openr,1,'../catchment.def' -ncat = 0l -readf,1,ncat - -if((stregex (gfile,'Pfafstetter') ge 0) or (stregex (gfile,'SMAP') ge 0)) then begin -; global plots -endif else begin - -min_lon = 180. -max_lon = -180. -min_lat = 90. -max_lat = -90. -a1 = 0. -a2 = 0. -a3 = 0. -a4 = 0. -k = 0 - -for i = 0l,ncat -1l do begin - readf,1,k,k,a1, a2, a3, a4 - if (a1 lt min_lon) then min_lon = a1 - if (a2 gt max_lon) then max_lon = a2 - if (a3 lt min_lat) then min_lat = a3 - if (a4 gt max_lat) then max_lat = a4 -endfor - -limits = [floor(min_lat), floor(min_lon),ceil(max_lat),ceil(max_lon)] -if((ceil(max_lon) - floor(min_lon)) lt 180.) then save,limits,file ='limits.idl' - -endelse - -close,1 - -; (3) generating NC_plot x NR_plot mask for plotting maps -;-------------------------------------------------------- - -NC_plot = 4320 -NR_plot = 2160 - -tile_id = lonarr (NC_plot,NR_plot) - -dx = NC/NC_plot -dy = NR/NR_plot - -catrow = lonarr(nc) -cat = lonarr(nc,dy) - -rst_file=path + '/rst/' + gfile+'*.rst' -openr,1,rst_file,/F77_UNFORMATTED - -for j = 0l, NR_plot -1 do begin - - for i=0,dy -1 do begin - readu,1,catrow - cat (*,i) = catrow - endfor - - for i = 0, NC_plot -1 do begin - subset = cat (i*dx: (i+1)*dx -1,*) - if (min (subset) le ncat) then begin - min1 = min(subset) - subset(where (subset gt ncat)) = 0 - hh = histogram(subset,bin=1,min = min1, locations=loc_val) - dom_tile = max(hh,loc) - tile_id[i,j] = loc_val(loc) - endif - endfor - -endfor - -close,1 - - -; (4) plotting catchment-tiles in the Eastern United States -;---------------------------------------------------------- - -plot_tiles,nc,nr,ncat,gfile,path - -; plot countr_codes -country_codes, tile_id - -; (5) Plot canopy height -; ---------------------- - -;canop_Height, nc,nr, tile_id, gfile, path - -; (6) plotting CTI statistics -;---------------------------- - -filename = '../cti_stats.dat' -cti_mean = fltarr (ncat) -cti_std = fltarr (ncat) -cti_skew = fltarr (ncat) - -a1 = 0. -a2 = 0. -a3 = 0. -a4 = 0. -a5 = 0. -k = 0 -openr,1,filename - -readf,1,k - -for i = 0l,ncat -1l do begin - readf,1,k,k,a1, a2, a3, a4, a5 - cti_mean (i) = a1 - cti_std (i) = a2 - cti_skew (i) = a5 -endfor - -close,1 -clm_file = '../CLM_veg_typs_fracs' -if (file_test (clm_file)) then begin -endif else begin -cti_mean = 0.961*cti_mean - 1.957 -endelse - - -;plot_vars2, ncat, tile_id, cti_mean, 'cti_mean' -;plot_vars2, ncat, tile_id, cti_std , 'cti_std' -;plot_vars2, ncat, tile_id, cti_skew, 'cti_skew' - -plot_three_vars1, ncat, tile_id, cti_mean, cti_std, cti_skew - -cti_mean = 0. -cti_std = 0. -cti_skew = 0. - -; (7) plotting vegetation types -;------------------------------ - -plot_mosaic, ncat, tile_id -clm_file = '../CLM_veg_typs_fracs' - -if (file_test (clm_file)) then begin - - plot_clm , ncat, tile_id - plot_carbon, ncat, tile_id - -; Now plot Ndep, T2m and SoilAlb -; ------------------------------ - - filename = '../CLM_NDep_SoilAlb_T2m' - ndep = fltarr (ncat) - visdr = fltarr (ncat) - visdf = fltarr (ncat) - nirdr = fltarr (ncat) - nirdf = fltarr (ncat) - t2mm = fltarr (ncat) - t2mp = fltarr (ncat) - - a1 = 0. - a2 = 0. - a3 = 0. - a4 = 0. - a5 = 0. - a6 = 0. - a7 = 0. - - openr,1,filename - - for i = 0l,ncat -1l do begin - readf,1,a1, a2, a3, a4, a5, a6, a7 - ndep (i) = a1 - visdr(i) = a2 - visdf(i) = a3 - nirdr(i) = a4 - nirdf(i) = a5 - t2mm (i) = a6 - t2mp (i) = a7 - - endfor - - close,1 - plot_three_vars2, ncat, tile_id, ndep, t2mm, t2mp - plot_soilalb, ncat, tile_id,VISDR, VISDF, NIRDR, NIRDF - - ndep = 0. - visdr = 0. - visdf = 0. - nirdr = 0. - nirdf = 0. - t2mm = 0. - t2mp = 0. - -endif - -; (8) plotting soil hydraulic properties -;--------------------------------------- - -filename = '../soil_param.dat' -bee = fltarr (ncat) -psis = fltarr (ncat) -poro = fltarr (ncat) -cond = fltarr (ncat) -wwet = fltarr (ncat) -sdep = fltarr (ncat) -a1 = 0. -a2 = 0. -a3 = 0. -a4 = 0. -a5 = 0. -a6 = 0. -k = 0 - -openr,1,filename - -for i = 0l,ncat -1l do begin - readf,1,k,k,k,k,a1, a2, a3, a4, a5, a6 - bee (i) = a1 - psis (i) = a2 - poro (i) = a3 - cond (i) = a4 - wwet (i) = a5 - sdep (i) = a6 -endfor - -close,1 - -thisDevice = !D.Name -set_plot,'Z' -Device, Set_Resolution=[720,800], Z_Buffer=0 -load_colors -Erase,255 - -!p.background = 255 - -!P.position=0 -!P.Multi = [0, 2, 3, 0, 0] - -plot_vars, ncat, tile_id, bee, [1. ,8.], 'BEE' -plot_vars, ncat, tile_id, psis,[-1.85,-0.1],'PSIS',advance =1 -plot_vars, ncat, tile_id, poro,[0.37,0.8],'POROS',advance =1 -plot_vars, ncat, tile_id, cond,[2.37e-6,2.845e-4],'COND',advance =1 -plot_vars, ncat, tile_id, wwet,[0.01,0.45],'WPWET',advance =1 -plot_vars, ncat, tile_id, sdep,[1334.,5000.],'SOILDEPTH',advance =1 - -snapshot = TVRD() -TVLCT, r, g, b, /Get -Device, Z_Buffer=1 -Set_Plot, thisDevice -image24 = BytArr(3, 720, 800) -image24[0,*,*] = r[snapshot] -image24[1,*,*] = g[snapshot] -image24[2,*,*] = b[snapshot] -Write_JPEG, 'soil_param.jpg', image24, True=1, Quality=100 - -;plot_vars2, ncat, tile_id, bee, 'BEE' -;plot_vars2, ncat, tile_id, psis,'PSIS' -;plot_vars2, ncat, tile_id, poro,'POROS' -;plot_vars2, ncat, tile_id, cond,'COND' -;plot_vars2, ncat, tile_id, wwet,'WPWET' -;plot_vars2, ncat, tile_id, sdep,'SOILDEPTH' - -bee = 0. -psis = 0. -poro = 0. -cond = 0. -wwet = 0. -sdep = 0. - -; (9) plotting elevation -;----------------------- - -filename = '../catchment.def' -elevation = fltarr (ncat) - -a1 = 0. -a2 = 0. -k = 0 - -openr,1,filename - -readf,1,k - -for i = 0l,ncat -1l do begin - readf,1,k,k,a1, a1, a1, a1, a2 - elevation (i) = a2 -endfor - -close,1 - -plot_vars2, ncat, tile_id, elevation, 'ELEVATION' - -elevation = 0. - -; (10) plot LAI monthly climatology -; -------------------------------- - -plot_lai, ncat, tile_id - -; (11) vegetation height and roughness length -filename = '../vegdyn.data' -ncdf_file = boolean (ncdf_isncdf(filename)) - -if (ncdf_file) then begin - - ncid = NCDF_OPEN(filename,/NOWRITE) - NCDF_VARGET, ncid,'ITY', ITYP - NCDF_VARGET, ncid,'Z2CH', Z2 - NCDF_VARGET, ncid,'ASCATZ0', ASZ0 - NCDF_CLOSE, ncid - -endif else begin - - openr,1,filename,/F77_UNFORMATTED - ityp = fltarr (ncat) - z2 = fltarr (ncat) - asz0 = fltarr (ncat) - - readu,1,ITYP - readu,1,Z2 - readu,1,ASZ0 - close,1 - -endelse - -ASZ0 = ASZ0 * 1000. - - -plot_canoph, z2, tile_id - -if (file_test ( '../CLM_veg_typs_fracs')) then begin -SCALE4Z0 = 0.5 -endif else begin -SCALE4Z0 = 2. -endelse - -compute_zo,'ascat' , SCALE4Z0, ASZ0, Z2, tile_id -compute_zo,'icarus', SCALE4Z0, ASZ0, Z2, tile_id -compute_zo,'merged', SCALE4Z0, ASZ0, Z2, tile_id - -; plotting irrigation parameters -; ------------------------------ - -;plot_crop_times, ncat, tile_id -;irrig_method, ncat, tile_id -;plot_lai_minmax, ncat, tile_id -;irrig_fractions, ncat, tile_id - - -; (12) generating NC_plot x NR_plot mask for plotting maps -;-------------------------------------------------------- - -NC_movie = 720 -NR_movie = 360 -Ntiles_per_cell = 30 -if(NC gt 8640) then Ntiles_per_cell = 800 - -vec_map = {NT:0, TID: lonarr (Ntiles_per_cell), TFrac : fltarr (Ntiles_per_cell)} -vec2grid = REPLICATE (vec_map,NC_movie,NR_movie) - -dx = NC/NC_movie -dy = NR/NR_movie -cat = lonarr(nc,dy) -catrow = lonarr(nc) - -rst_file=path + '/rst/' + gfile+'*.rst' -openr,1,rst_file,/F77_UNFORMATTED - -for j = 0l, NR_movie -1 do begin - for i=0,dy -1 do begin - readu,1,catrow - cat (*,i) = catrow - endfor - - for i = 0, NC_movie -1 do begin - subset = cat (i*dx: (i+1)*dx -1,*) - cat_unq = Subset[uniq(Subset,sort(Subset))] - k_land = where ((cat_unq ge 1l) and (cat_unq le ncat)) - if (max(k_land) ne -1) then begin - hh = intarr(n_elements (cat_unq)) - for k = 0,n_elements (cat_unq) -1 do hh[k] = $ - n_elements(where (Subset eq cat_unq[k])) - NCOUNT = 0 - - for k = 0, n_elements (hh) -1 do begin - if((cat_unq (k) ge 1) and (cat_unq (k) le ncat)) then begin - if (NCOUNT eq Ntiles_per_cell) then begin - print, 'Increase Ntiles_per_cell' - stop - endif - vec2grid[i,j].NT = vec2grid[i,j].NT + 1 - vec2grid[i,j].TID (NCOUNT) = cat_unq (k) - vec2grid[i,j].TFrac(NCOUNT) = 1.*hh(k)/total(hh) - NCOUNT = NCOUNT + 1 - endif - endfor - endif - endfor -endfor - -close,1 - -; (12) Making movies of Seasonal data -;------------------------------------ - -make_movies, ncat, vec2grid, 'LAI' -make_movies, ncat, vec2grid, 'GREEN' -make_movies, ncat, vec2grid, 'VISDF' -make_movies, ncat, vec2grid, 'NIRDF' - -END - -; ============================================================================== -; Catchment-CN classes -; ============================================================================== - -PRO plot_carbon,ncat, tile_id - -im = n_elements(tile_id[*,0]) -jm = n_elements(tile_id[0,*]) - -dx = 360. / im -dy = 180. / jm - -x = indgen(im)*dx -180. + dx/2. -y = indgen(jm)*dy -90. + dy/2. - -clm_type = intarr (ncat,4) -clm_grid = intarr (im,jm,4) - -filename = '../CLM_veg_typs_fracs' -openr,1,filename -k = 0 -v = 0 -fr= 0. -v1= 0 -v2= 0 -v3= 0 -v4 =0 - -for i = 0l,ncat -1l do begin - readf,1,k,k,v1,v2,v3,v4,fr,fr,fr,fr,v,v - clm_type(i,0) = v1 - clm_type(i,1) = v2 - clm_type(i,2) = v3 - clm_type(i,3) = v4 -endfor - -close,1 - -clm_grid (*,*,*) = !VALUES.F_NAN - -for j = 0l, jm -1l do begin - for i = 0l, im -1 do begin - if(tile_id[i,j] gt 0) then begin - clm_grid(i,j,0) = clm_type(tile_id[i,j] -1,0) - clm_grid(i,j,1) = clm_type(tile_id[i,j] -1,1) - clm_grid(i,j,2) = clm_type(tile_id[i,j] -1,2) - clm_grid(i,j,3) = clm_type(tile_id[i,j] -1,3) - endif - endfor -endfor - -clm_type = 0 - -limits = [-60,-180,90,180] -if file_test ('limits.idl') then restore,'limits.idl' - -thisDevice = !D.Name -set_plot,'Z' -Device, Set_Resolution=[700,1000], Z_Buffer=0 -;types= [ 2, 3, 4, 5, 6, 7, 8, 9, 10, 11,11a, 12, 13, 14,14a, 15,15a, 16,16a, 17] -r_in = [106,202,251, 0, 29, 77,109,142,233,255,255,255,127,164,164,217,217,204,104, 0] -g_in = [ 91,178,154, 85,115,145,165,185, 23,131,131,191, 39, 53, 53, 72, 72,204,104, 70] -b_in = [154,214,153, 0, 0, 0, 0, 13, 0, 0,200, 0, 4, 3,200, 1,200,204,200,200] -vtypes= [ 1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11, 12, 13, 14, 15, 16, 17, 18, 19, 20] - -red = intarr (256) -green= intarr (256) -blue = intarr (256) - -red (255) = 255 -green(255) = 255 -blue (255) = 255 - -for k = 0, n_elements(vtypes) -1 do begin - red (vtypes(k)) = r_in (k) - green(vtypes(k)) = g_in (k) - blue (vtypes(k)) = b_in (k) -endfor - -TVLCT,red,green,blue - -colors = vtypes -levels = vtypes - -clm_name = strarr(19) -clm_name( 0) = 'NLEt' ; 1 needleleaf evergreen temperate tree -clm_name( 1) = 'NLEB' ; 2 needleleaf evergreen boreal tree -clm_name( 2) = 'NLDB' ; 3 needleleaf deciduous boreal tree -clm_name( 3) = 'BLET' ; 4 broadleaf evergreen tropical tree -clm_name( 4) = 'BLEt' ; 5 broadleaf evergreen temperate tree -clm_name( 5) = 'BLDT' ; 6 broadleaf deciduous tropical tree -clm_name( 6) = 'BLDt' ; 7 broadleaf deciduous temperate tree -clm_name( 7) = 'BLDB' ; 8 broadleaf deciduous boreal tree -clm_name( 8) = 'BLEtS' ; 9 broadleaf evergreen temperate shrub -clm_name( 9) = 'BLDtS' ; 10 broadleaf deciduous temperate shrub [moisture + deciduous] -clm_name(10) = 'BLDtSm'; 11 broadleaf deciduous temperate shrub [moisture stress only] -clm_name(11) = 'BLDBS' ; 12 broadleaf deciduous boreal shrub -clm_name(12) = 'AC3G' ; 13 arctic c3 grass -clm_name(13) = 'CC3G' ; 14 cool c3 grass [moisture + deciduous] -clm_name(14) = 'CC3Gm' ; 15 cool c3 grass [moisture stress only] -clm_name(15) = 'WC4G' ; 16 warm c4 grass [moisture + deciduous] -clm_name(16) = 'WC4Gm' ; 17 warm c4 grass [moisture stress only] -clm_name(17) = 'CROP' ; 18 crop [moisture + deciduous] -clm_name(18) = 'CROPm' ; 19 crop [moisture stress only] - -Erase,255 -!p.background = 255 -!P.position=0 -!P.Multi = [0, 1, 2, 0, 1] - -MAP_SET,/CYLINDRICAL,/hires,color= 0,/NoErase,limit=limits -contour, clm_grid[*,*,0],x,y,levels = levels,c_colors=colors,/cell_fill,/overplot -MAP_CONTINENTS,/COASTS,color=0,MLINETHICK=2 - -MAP_SET,/CYLINDRICAL,/hires,color= 0,/NoErase,limit=limits,/advance -contour, clm_grid[*,*,1],x,y,levels = levels,c_colors=colors,/cell_fill,/overplot -MAP_CONTINENTS,/COASTS,color=0,MLINETHICK=2 - -n_levels = n_elements(vtypes) -alpha=fltarr(n_levels,2) -alpha(*,0)=levels (0:n_levels-1) -alpha(*,1)=levels (0:n_levels-1) -h=[0,1] - -!P.position=[0.15, 0.0+0.005, 0.85, 0.015+0.005] -clev = levels -clev (*) = 1 -contour,alpha,levels,h,levels=levels,c_colors=colors,/fill,/xstyle,/ystyle, $ - /noerase,yticks=1,ytickname=[' ',' '] ,xrange=[min(levels),max(levels)], $ - xtitle=' ', color=0,xtickv=levels, $ - C_charsize=1.0, charsize=0.5 ,xtickformat = "(A1)" -contour,alpha,levels,h,levels=levels,color=0,/overplot,c_label=clev - for k = 0,n_elements(clm_name) -1 do xyouts,levels[k]+0.5,1.1,clm_name(k) ,orientation=90,color=0 -snapshot = TVRD() - -TVLCT, r, g, b, /Get -Device, Z_Buffer=1 -Set_Plot, thisDevice -image24 = BytArr(3, 700, 1000) -image24[0,*,*] = r[snapshot] -image24[1,*,*] = g[snapshot] -image24[2,*,*] = b[snapshot] -Write_JPEG, 'CatchmentCN_PRIM_veg_typs.jpg', image24, True=1, Quality=100 - -; now plotting secondary -thisDevice = !D.Name -set_plot,'Z' -Device, Set_Resolution=[700,1000], Z_Buffer=0 - -Erase,255 -!p.background = 255 -!P.position=0 -!P.Multi = [0, 1, 2, 0, 1] - -MAP_SET,/CYLINDRICAL,/hires,color= 0,/NoErase,limit=limits -contour, clm_grid[*,*,2],x,y,levels = levels,c_colors=colors,/cell_fill,/overplot -MAP_CONTINENTS,/COASTS,color=0,MLINETHICK=2 - -MAP_SET,/CYLINDRICAL,/hires,color= 0,/NoErase,limit=limits,/advance -contour, clm_grid[*,*,3],x,y,levels = levels,c_colors=colors,/cell_fill,/overplot -MAP_CONTINENTS,/COASTS,color=0,MLINETHICK=2 - -n_levels = n_elements(vtypes) -alpha=fltarr(n_levels,2) -alpha(*,0)=levels (0:n_levels-1) -alpha(*,1)=levels (0:n_levels-1) -h=[0,1] - -!P.position=[0.15, 0.0+0.005, 0.85, 0.015+0.005] -clev = levels -clev (*) = 1 -contour,alpha,levels,h,levels=levels,c_colors=colors,/fill,/xstyle,/ystyle, $ - /noerase,yticks=1,ytickname=[' ',' '] ,xrange=[min(levels),max(levels)], $ - xtitle=' ', color=0,xtickv=levels, $ - C_charsize=1.0, charsize=0.5 ,xtickformat = "(A1)" -contour,alpha,levels,h,levels=levels,color=0,/overplot,c_label=clev - for k = 0,n_elements(clm_name) -1 do xyouts,levels[k]+0.5,1.1,clm_name(k) ,orientation=90,color=0 -snapshot = TVRD() - -TVLCT, r, g, b, /Get -Device, Z_Buffer=1 -Set_Plot, thisDevice -image24 = BytArr(3, 700, 1000) -image24[0,*,*] = r[snapshot] -image24[1,*,*] = g[snapshot] -image24[2,*,*] = b[snapshot] -Write_JPEG, 'CatchmentCN_SEC_veg_typs.jpg', image24, True=1, Quality=100 - -END - -; ============================================================================== -; CLM classes -; ============================================================================== - -PRO plot_clm,ncat, tile_id - -im = n_elements(tile_id[*,0]) -jm = n_elements(tile_id[0,*]) - -dx = 360. / im -dy = 180. / jm - -x = indgen(im)*dx -180. + dx/2. -y = indgen(jm)*dy -90. + dy/2. - -clm_type = intarr (ncat,2) -clm_grid = intarr (im,jm,2) - -filename = '../CLM_veg_typs_fracs' -openr,1,filename -k = 0 -v = 0 -fr= 0. -v1= 0 -v2= 0 - -for i = 0l,ncat -1l do begin - readf,1,k,k,v,v,v,v,fr,fr,fr,fr,v1,v2 - clm_type(i,0) = v1 - clm_type(i,1) = v2 -endfor - -close,1 - -clm_grid (*,*,*) = !VALUES.F_NAN - -for j = 0l, jm -1l do begin - for i = 0l, im -1 do begin - if(tile_id[i,j] gt 0) then begin - clm_grid(i,j,0) = clm_type(tile_id[i,j] -1,0) - clm_grid(i,j,1) = clm_type(tile_id[i,j] -1,1) - endif - endfor -endfor - -clm_type = 0 - -limits = [-60,-180,90,180] -if file_test ('limits.idl') then restore,'limits.idl' - -thisDevice = !D.Name -set_plot,'Z' -Device, Set_Resolution=[700,500], Z_Buffer=0 - -r_in = [255,106,202,251, 0, 29, 77,109,142,233,255,255,127,164,217,204, 0] -g_in = [245, 91,178,154, 85,115,145,165,185, 23,131,191, 39, 53, 72,204, 70] -b_in = [215,154,214,153, 0, 0, 0, 0, 13, 0, 0, 0, 4, 3, 1,204,200] -vtypes= [ 1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11, 12, 13, 14, 15, 16, 17] - -red = intarr (256) -green= intarr (256) -blue = intarr (256) - -red (255) = 255 -green(255) = 255 -blue (255) = 255 - -for k = 0, n_elements(vtypes) -1 do begin - red (vtypes(k)) = r_in (k) - green(vtypes(k)) = g_in (k) - blue (vtypes(k)) = b_in (k) -endfor - -TVLCT,red,green,blue - -colors = vtypes -levels = vtypes - -clm_name = strarr(16) -clm_name( 0) = 'BARE' ; 1 bare -clm_name( 1) = 'NLEt' ; 2 needleleaf evergreen temperate tree -clm_name( 2) = 'NLEB' ; 3 needleleaf evergreen boreal tree -clm_name( 3) = 'NLDB' ; 4 needleleaf deciduous boreal tree -clm_name( 4) = 'BLET' ; 5 broadleaf evergreen tropical tree -clm_name( 5) = 'BLEt' ; 6 broadleaf evergreen temperate tree -clm_name( 6) = 'BLDT' ; 7 broadleaf deciduous tropical tree -clm_name( 7) = 'BLDt' ; 8 broadleaf deciduous temperate tree -clm_name( 8) = 'BLDB' ; 9 broadleaf deciduous boreal tree -clm_name( 9) = 'BLEtS'; 10 broadleaf evergreen temperate shrub -clm_name(10) = 'BLDtS'; 11 broadleaf deciduous temperate shrub -clm_name(11) = 'BLDBS'; 12 broadleaf deciduous boreal shrub -clm_name(12) = 'AC3G' ; 13 arctic c3 grass -clm_name(13) = 'CC3G' ; 14 cool c3 grass -clm_name(14) = 'WC4G' ; 15 warm c4 grass -clm_name(15) = 'CROP' ; 16 crop - -Erase,255 -!p.background = 255 -!P.position=0 -!P.Multi = [0, 1, 1, 0, 1] - -MAP_SET,/CYLINDRICAL,/hires,color= 0,/NoErase,limit=limits -contour, clm_grid[*,*,0],x,y,levels = levels,c_colors=colors,/cell_fill,/overplot -MAP_CONTINENTS,/COASTS,color=0,MLINETHICK=2 - -n_levels = n_elements(vtypes) -alpha=fltarr(n_levels,2) -alpha(*,0)=levels (0:n_levels-1) -alpha(*,1)=levels (0:n_levels-1) -h=[0,1] - -!P.position=[0.15, 0.0+0.005, 0.85, 0.015+0.005] -clev = levels -clev (*) = 1 -contour,alpha,levels,h,levels=levels,c_colors=colors,/fill,/xstyle,/ystyle, $ - /noerase,yticks=1,ytickname=[' ',' '] ,xrange=[min(levels),max(levels)], $ - xtitle=' ', color=0,xtickv=levels, $ - C_charsize=1.0, charsize=0.5 ,xtickformat = "(A1)" -contour,alpha,levels,h,levels=levels,color=0,/overplot,c_label=clev - for k = 0,n_elements(clm_name) -1 do xyouts,levels[k]+0.5,1.1,clm_name(k) ,orientation=90,color=0 -snapshot = TVRD() - -TVLCT, r, g, b, /Get -Device, Z_Buffer=1 -Set_Plot, thisDevice -image24 = BytArr(3, 700, 500) -image24[0,*,*] = r[snapshot] -image24[1,*,*] = g[snapshot] -image24[2,*,*] = b[snapshot] -Write_JPEG, 'CLM_PRIM_veg_typs.jpg', image24, True=1, Quality=100 - -; now plotting secondary -thisDevice = !D.Name -set_plot,'Z' -Device, Set_Resolution=[700,500], Z_Buffer=0 - -Erase,255 -!p.background = 255 -!P.position=0 -!P.Multi = [0, 1, 1, 0, 1] - -MAP_SET,/CYLINDRICAL,/hires,color= 0,/NoErase,limit=limits -contour, clm_grid[*,*,1],x,y,levels = levels,c_colors=colors,/cell_fill,/overplot -MAP_CONTINENTS,/COASTS,color=0,MLINETHICK=2 - -n_levels = n_elements(vtypes) -alpha=fltarr(n_levels,2) -alpha(*,0)=levels (0:n_levels-1) -alpha(*,1)=levels (0:n_levels-1) -h=[0,1] - -!P.position=[0.15, 0.0+0.005, 0.85, 0.015+0.005] -clev = levels -clev (*) = 1 -contour,alpha,levels,h,levels=levels,c_colors=colors,/fill,/xstyle,/ystyle, $ - /noerase,yticks=1,ytickname=[' ',' '] ,xrange=[min(levels),max(levels)], $ - xtitle=' ', color=0,xtickv=levels, $ - C_charsize=1.0, charsize=0.5 ,xtickformat = "(A1)" -contour,alpha,levels,h,levels=levels,color=0,/overplot,c_label=clev - for k = 0,n_elements(clm_name) -1 do xyouts,levels[k]+0.5,1.1,clm_name(k) ,orientation=90,color=0 -snapshot = TVRD() - -TVLCT, r, g, b, /Get -Device, Z_Buffer=1 -Set_Plot, thisDevice -image24 = BytArr(3, 700, 500) -image24[0,*,*] = r[snapshot] -image24[1,*,*] = g[snapshot] -image24[2,*,*] = b[snapshot] -Write_JPEG, 'CLM_SEC_veg_typs.jpg', image24, True=1, Quality=100 - -END - -; ============================================================================== -; Make movies -; ============================================================================== - -PRO make_movies, ncat, vec2grid, vname - -upval = 1. -lwval = 0. - -if (vname eq 'LAI') then upval = 6. - -if (vname eq 'LAI') then filename = '../lai.dat' -if (vname eq 'GREEN') then filename = '../green.dat' -if (vname eq 'VISDF') then filename = '../AlbMap.WS.8-day.tile.0.3_0.7.dat' -if (vname eq 'NIRDF') then filename = '../AlbMap.WS.8-day.tile.0.7_5.0.dat' - -im = n_elements(vec2grid[*,0].NT) -jm = n_elements(vec2grid[0,*].NT) - -dx = 360. / im -dy = 180. / jm - -x = indgen(im)*dx -180. + dx/2. -y = indgen(jm)*dy -90. + dy/2. - -limits = [-60,-180,90,180] -if file_test ('limits.idl') then restore,'limits.idl' - -DEVICE, DECOMPOSED = 0 - -r_in = [253,224,255,238,205,193,152, 0,124, 0, 0, 0, 0, 0, 0, 48,110, 85] -g_in = [253,238,255,238,205,255,251,255,252,255,238,205,139,128,100,128,139,107] -b_in = [253,224, 0, 0, 0,193,152,127, 0, 0, 0, 0, 0, 0, 0, 20, 61, 47] - -n_levels = n_elements (r_in) - -if (vname eq 'LAI') then begin - levels=[0.,0.25,0.5,0.75,1.,1.25,1.5,10. * indgen(11)*0.05+2.] -endif else begin - levels=[0.,0.025,0.05,0.075,0.1,0.125,0.15,0.2,0.3,0.35,0.4,0.45,0.5,0.6,0.7,0.8,0.9,1.0] -endelse - -red = intarr (256) -green= intarr (256) -blue = intarr (256) - -red (255) = 255 -green(255) = 255 -blue (255) = 255 - -for k = 0, N_levels -1 do begin - red (k+1) = r_in (k) - green(k+1) = g_in (k) - blue (k+1) = b_in (k) -endfor - -TVLCT,red,green,blue - -colors = indgen (N_levels) + 1 - -compile_opt idl2 - -openr,1,filename,/F77_UNFORMATTED - -yr=0. -mn =0. -dy =0. -dum =0. -yr1 =0. -mn1 =0. -dy1 =0. -yrg=0. -mng =0. -lai = fltarr (im,jm) -lai1 = fltarr (im,jm) -lai2 = fltarr (im,jm) -lai_vec = fltarr (ncat) -lai1 [*,*] = !VALUES.F_NAN -lai2 [*,*] = !VALUES.F_NAN - -alpha = fltarr(n_levels,2) -alpha [*,0] = levels -alpha [*,1] = levels -h = [0,1] -m_days = [31,28,31,30,31,30,31,31,30,31,30,31] - -readu,1,yr,mn,dy,dum,dum,dum,yr1,mn1,dy1 -readu,1,lai_vec - -for j = 0l, jm -1l do begin - for i = 0l, im -1 do begin - if(vec2grid[i,j].NT gt 0) then begin - for k = 0, vec2grid[i,j].NT -1 do begin - if (k eq 0) then lai1[i,j] = 0. - lai1[i,j] = lai1[i,j] + lai_vec[vec2grid[i,j].TID[k] -1]*vec2grid[i,j].TFrac[k] - endfor - endif - endfor -endfor - -dofyr_b4 = ((float(julday(mn1,dy1,2001+yr1)-julday(12,31,2000))) - (float(julday(mn,dy,2001+yr)-julday(12,31,2000))))/2 + $ - float(julday(mn,dy,2001+yr)-julday(12,31,2000)) - -readu,1,yr,mn,dy,dum,dum,dum,yr1,mn1,dy1 -dofyr_nxt = ((float(julday(mn1,dy1,2001+yr1)-julday(12,31,2000))) - (float(julday(mn,dy,2001+yr)-julday(12,31,2000))))/2 + $ - float(julday(mn,dy,2001+yr)-julday(12,31,2000)) - -readu,1,lai_vec - -for j = 0l, jm -1l do begin - for i = 0l, im -1 do begin - if(vec2grid[i,j].NT gt 0) then begin - for k = 0, vec2grid[i,j].NT -1 do begin - if (k eq 0) then lai2[i,j] = 0. - lai2[i,j] = lai2[i,j] + lai_vec[vec2grid[i,j].TID[k] -1]*vec2grid[i,j].TFrac[k] - endfor - endif - endfor -endfor - -compile_opt idl2 - -video_file = vname+'.mp4' -video = idlffvideowrite(video_file) -framerate = 10 -framedims = [750,512] -stream = video.addvideostream(framedims[0], framedims[1], framerate) -set_plot, 'z', /copy -device, set_resolution=framedims, set_pixel_depth=24, decomposed=0 - -for month = 1,12 do begin - for day =1,m_days[month -1] do begin - !P.position=0 - dofyr_now = float(julday(month,day,2001+yr)-julday(12,31,2000)) - fac1 = (dofyr_now - dofyr_b4 )/(dofyr_nxt - dofyr_b4) - fac2 = (dofyr_nxt - dofyr_now)/(dofyr_nxt - dofyr_b4) - lai = fac1*lai2 + fac2*lai1 - - dstamp =string(2001+fix(yr),'(i4.4)')+string(fix(month),'(i2.2)')+string(fix(day),'(i2.2)') - Erase, Color= 255 - MAP_SET,/CYLINDRICAL,/hires,color= 0,/NoErase,limit=limits,title=vname + ':' + dstamp - contour, lai,x,y,levels = levels,c_colors=colors,/cell_fill,/overplot - MAP_CONTINENTS,/COASTS,color=0,MLINETHICK=2 - - !P.position=[0.15, 0.0+0.005, 0.85, 0.015+0.005] - contour,alpha,levels,h,levels=levels,c_colors=colors,/fill,/xstyle,/ystyle, $ - /noerase,yticks=1,ytickname=[' ',' '] ,xrange=[min(levels),max(levels)], $ - xtitle=' ', color=255,xtickv=levels, $ - C_charsize=1.0, charsize=0.5 ,xtickformat = "(A1)" - - contour,alpha,levels,h,levels=levels,color=0,/overplot,c_label=levels - if (vname eq 'LAI') then begin - for k = 0,n_elements(colors) -1 do xyouts,levels[k],1.1,string(levels[k],format='(f4.2)') ,orientation=90,color=0,charsize =0.8 - endif else begin - for k = 0,n_elements(colors) -1 do xyouts,levels[k],1.1,string(levels[k],format='(f5.3)') ,orientation=90,color=0,charsize =0.8 - endelse - - timestamp = video.put(stream, tvrd(true=1)) - - if(dofyr_now + 0.5 ge dofyr_nxt) then begin - lai1 = lai2 - dofyr_b4 = dofyr_nxt - readu,1,yr,mn,dy,dum,dum,dum,yr1,mn1,dy1 - - dofyr_nxt = ((float(julday(mn1,dy1,2001+yr1)-julday(12,31,2000))) - (float(julday(mn,dy,2001+yr)-julday(12,31,2000))))/2 + $ - float(julday(mn,dy,2001+yr)-julday(12,31,2000)) - if((month eq 12) and (yr eq 2)) then yr = yr -1 - readu,1,lai_vec - - for j = 0l, jm -1l do begin - for i = 0l, im -1 do begin - if(vec2grid[i,j].NT gt 0) then begin - for k = 0, vec2grid[i,j].NT -1 do begin - if (k eq 0) then lai2[i,j] = 0. - lai2[i,j] = lai2[i,j] + lai_vec[vec2grid[i,j].TID[k] -1]*vec2grid[i,j].TFrac[k] - endfor - endif - endfor - endfor - endif - endfor - endfor - -close,1 - -device, /close -set_plot, strlowcase(!version.os_family) eq 'windows' ? 'win' : 'x' -video.cleanup - -END - -; ============================================================================== -; Mosaic classes -; ============================================================================== - -PRO plot_mosaic, ncat, tile_id - -im = n_elements(tile_id[*,0]) -jm = n_elements(tile_id[0,*]) - -dx = 360. / im -dy = 180. / jm - -x = indgen(im)*dx -180. + dx/2. -y = indgen(jm)*dy -90. + dy/2. - -mos_type = intarr (ncat) -mos_grid = intarr (im,jm) - -filename = '../mosaic_veg_typs_fracs' -openr,1,filename -k = 0 -v = 0 -for i = 0l,ncat -1l do begin - readf,1,k,k,v - mos_type(i) = v -endfor - -close,1 - -mos_grid (*,*) = !VALUES.F_NAN - -for j = 0l, jm -1l do begin - for i = 0l, im -1 do begin - if(tile_id[i,j] gt 0) then mos_grid(i,j) = mos_type(tile_id[i,j] -1) - endfor -endfor - -limits = [-60,-180,90,180] -if file_test ('limits.idl') then restore,'limits.idl' - -thisDevice = !D.Name -set_plot,'Z' -Device, Set_Resolution=[700,500], Z_Buffer=0 - -r_in = [233,255,255,255,210, 0, 0, 0,204,170,255,220,205, 0, 0,170, 0, 40,120,140,190,150,255,255, 0, 0, 0,195,255, 0,255, 0] -g_in = [ 23,131,191,255,255,255,155, 0,204,240,255,240,205,100,160,200, 60,100,130,160,150,100,180,235,120,150,220, 20,245, 70,255, 0] -b_in = [ 0, 0, 0,178,255,255,255,200,204,240,100,100,102, 0, 0, 0, 0, 0, 0, 0, 0, 0, 50,175, 90,120,130, 0,215,200,255, 0] -vtypes =[ 1, 2, 3, 4, 5, 6, 7, 8, 10, 11, 14, 20, 30, 40, 50, 60, 70, 90,100,110,120,130,140,150,160,170,180,190,200,210,220,230] - -red = intarr (256) -green= intarr (256) -blue = intarr (256) -red (255) = 255 -green(255) = 255 -blue (255) = 255 - -for k = 0, n_elements(vtypes) -1 do begin - red (vtypes(k)) = r_in (k) - green(vtypes(k)) = g_in (k) - blue (vtypes(k)) = b_in (k) -endfor - -TVLCT,red,green,blue - -colors = vtypes -levels = vtypes - -Erase,255 -!p.background = 255 -!P.position=0 -!P.Multi = [0, 1, 1, 0, 1] -MAP_SET,/CYLINDRICAL,/hires,color= 0,/NoErase,limit=limits -contour, mos_grid,x,y,levels = levels,c_colors=colors,/cell_fill,/overplot -MAP_CONTINENTS,/COASTS,color=0,MLINETHICK=2 - -mos_name = strarr(6) -mos_name( 0) = 'BL Evergreen' -mos_name( 1) = 'BL Deciduous' -mos_name( 2) = 'Needleleaf' -mos_name( 3) = 'Grassland' -mos_name( 4) = 'BL Shrubs' -mos_name( 5) = 'Dwarf' - -n_levels = 6;n_elements(vtypes) -alpha=fltarr(n_levels+1,2) -alpha[*,0]=levels [0:n_levels] -alpha[*,1]=levels [0:n_levels] -h=[0,1] -!P.position=[0.30, 0.0+0.005, 0.70, 0.015+0.005] -clev = levels -clev (*) = 1 -contour,alpha,levels[0:6],h,levels=levels,c_colors=colors,/fill,/xstyle,/ystyle, $ - /noerase,yticks=1,ytickname=[' ',' '] ,xrange=[1,7], $ - xtitle=' ', color=0,xtickv=levels, $ - C_charsize=1.0, charsize=0.5 ,xtickformat = "(A1)" -contour,alpha,levels[0:6],h,levels=levels,color=0,/overplot,c_label=clev -for k = 0,5 do xyouts,levels[k]+0.5,1.2,mos_name[k] ,orientation=90,color=0 - -snapshot = TVRD() -TVLCT, r, g, b, /Get -Device, Z_Buffer=1 -Set_Plot, thisDevice -image24 = BytArr(3, 700, 500) -image24[0,*,*] = r[snapshot] -image24[1,*,*] = g[snapshot] -image24[2,*,*] = b[snapshot] -Write_JPEG, 'mosaic_prim.jpg', image24, True=1, Quality=100 - - -END - -; ============================================================================== -; Catchment-tiles in the Eastern United States -; ============================================================================== - -PRO plot_tiles,nc,nr,ncat,gfile,path - -dx=360./nc -dy=180./nr - -glon = fltarr (nc) -glat = fltarr (nr) - -for i = 0l,nc -1l do glon(i) = -180. + dx/2. + i*dx -for i = 0l,nr -1l do glat(i) = -90. + dy/2. + i*dy - -xylim = [35.,-82.,42.,-73] - -if file_test ('limits.idl') then begin - restore,'limits.idl' - xylim = limits -endif - -i1 = where((glon ge xylim(1)) and (glon lt xylim(1) + dx)) -i2 = where((glon ge xylim(3)) and (glon lt xylim(3) + dx)) -j1 = where((glat ge xylim(0)) and (glat lt xylim(0) + dy)) -j2 = where((glat ge xylim(2)) and (glat lt xylim(2) + dy)) - -xlen=xylim(3)-xylim(1) -ylen=xylim(2)-xylim(0) -init=replicate(0.,xlen,ylen) -x = indgen(xlen)+xylim(1) -y = indgen(ylen)+xylim(0) - -thisDevice = !D.Name -set_plot,'Z' -Device, Set_Resolution=[700,500], Z_Buffer=0 -n_levels = 30 -colors = indgen(30) + 90 -load_colors -Erase,255 -!p.background = 255 - -!P.position=0 -!P.Multi = [0, 1, 1, 0, 1] - -contour,init,x,y,title=tit,xrange=[x(0),x(xlen-1)+1.],yrange=[y(0),y(ylen-1)+1.],xstyle=1,ystyle=1,color =0 - -pfc =0l -pfc1=0l -pfcl=0l -pfcr=0l - -cat =lonarr(nc) -catp=lonarr(nc) -rst_file=path + '/rst/' + gfile+'*.rst' -idum=0l -openr,1,rst_file,/F77_UNFORMATTED - -for j= 0l,j2(0) do begin - - readu,1,cat - if(j ge j1) then begin - yu = -90. + j*dy + dy - yl = -90. + j*dy - for i = i1(0),i2(0) do begin - pfc =cat(i) - pfc1=cat(i) - if((pfc ge 1) and (pfc le ncat)) then begin - if(i ne 0) then pfcl = cat(i-1) - if(i ne nc-1) then pfcr = cat(i+1) - if(j eq 0)then catp(i)=pfc - xl= -180. + i*dx - xr= -180. + i*dx +dx - xx=fltarr(5) - yy=fltarr(5) - xx=[xl,xl,xr,xr,xl] - yy=[yu,yl,yl,yu,yu] - n = pfc mod n_levels - polyfill,xx,yy,color=colors(n) - if(pfc ne catp(i)) then oplot,[xl,xr],[yl,yl],color =0 - if(pfc ne pfcl) then oplot,[xl,xl],[yl,yu],color =0 - if(pfc ne pfcr) then oplot,[xr,xr],[yl,yu],color =0 - endif - catp(i)=pfc - endfor - endif -endfor -close,1 -snapshot = TVRD() -TVLCT, r, g, b, /Get -Device, Z_Buffer=1 -Set_Plot, thisDevice -image24 = BytArr(3, 700, 500) -image24[0,*,*] = r[snapshot] -image24[1,*,*] = g[snapshot] -image24[2,*,*] = b[snapshot] -Write_JPEG, 'US-east.jpg', image24, True=1, Quality=100 - -END - -;======================================================================== -; Global maps -;======================================================================== - -PRO plot_vars, ncat, tile_id, data, vlim, vname,advance = advance - -lwval = vlim(0) -upval = vlim(1) -if (vname eq 'SOILDEPTH') then upval = 5000. - -im = n_elements(tile_id[*,0]) -jm = n_elements(tile_id[0,*]) - -dx = 360. / im -dy = 180. / jm - -x = indgen(im)*dx -180. + dx/2. -y = indgen(jm)*dy -90. + dy/2. - -data_grid = fltarr (im,jm) -data_grid (*,*) = !VALUES.F_NAN - -for j = 0l, jm -1l do begin - for i = 0l, im -1 do begin - if(tile_id[i,j] gt 0) then data_grid(i,j) = data(tile_id[i,j] -1) - endfor -endfor - -limits = [-60,-180,90,180] -if file_test ('limits.idl') then restore,'limits.idl' - -colors = [27,26,25,24,23,22,21,20,40,41,42,43,44,45,46,47,48] -n_levels = n_elements (colors) - -levels = [lwval,lwval+(upval-lwval)/(n_levels -1) +indgen(n_levels -1)*(upval-lwval)/(n_levels -1)] - -if(vname eq 'POROS') then $ -levels = [lwval,lwval+(0.57-lwval)/(n_levels -2) +indgen(n_levels -2)*(0.57-lwval)/(n_levels -2),upval] - -if keyword_set (advance) then begin - -MAP_SET,/CYLINDRICAL,/hires,color= 0,/NoErase,limit=limits,/ADVANCE,/ISOTROPIC,/NOBORDER -endif else begin -MAP_SET,/CYLINDRICAL,/hires,color= 0,/NoErase,limit=limits,/ISOTROPIC,/NOBORDER -endelse - -contour, data_grid,x,y,levels = levels,c_colors=colors,/cell_fill,/overplot -MAP_CONTINENTS,/COASTS,color=0,MLINETHICK=2 - -levels_x = levels - -if(vname eq 'POROS') then begin -dxp = (0.8-0.37)/16. -levels_x = indgen(17)*dxp+ 0.37 -endif - -alpha=fltarr(n_levels,2) -alpha(*,0)=levels -alpha(*,1)=levels -h=[0,1] - -dx = (240.)/(n_levels-1) - -clev = levels -clev (*) = 1 -n=0 -k = 0 -fmt_string = '(f4.2)' -if(vname eq 'COND') then fmt_string = '(e8.2)' -if(vname eq 'SOILDEPTH') then fmt_string = '(i4)' -if(vname eq 'PSIS') then fmt_string = '(f5.2)' - -if(vname eq 'BEE') then !P.position=[0.064, 0.675, 0.41, 0.69] -if(vname eq 'PSIS') then !P.position=[0.58, 0.675, 0.92, 0.69] -if(vname eq 'POROS') then !P.position=[0.064, 0.345, 0.41, 0.36] -if(vname eq 'COND') then !P.position=[0.58, 0.345, 0.92, 0.36] -if(vname eq 'WPWET') then !P.position=[0.064, 0.015, 0.41, 0.03] -if(vname eq 'SOILDEPTH') then !P.position=[0.58, 0.015, 0.92, 0.03] - -;!P.position=[0.064, 0.675, 0.41, 0.69] -;!P.position=[0.58, 0.0+0.005, 0.92, 0.015+0.005] - -contour,alpha,levels_x,h,levels=levels,c_colors=colors,/fill,/xstyle,/ystyle, $ - /noerase,yticks=1,ytickname=[' ',' '] ,xrange=[min(levels),max(levels)], $ - xtitle=' ', color=0,xtickv=levels, $ - C_charsize=1.0, charsize=0.5 ,xtickformat = "(A1)" -contour,alpha,levels_x,h,levels=levels,color=0,/overplot,c_label=clev - for k = 0,n_elements(colors) -1 do xyouts,levels_x[k],1.1,string(levels[k],format=fmt_string) ,orientation=90,color=0,charsize =0.8 - -;for l = 0,n_levels -2 do begin -; k = l -; xbox = [-120. + k*dx,-120. + k*dx, -120. + (k+1)*dx, -120. + (k+1)*dx,-120. + k*dx] -; ybox = [-65., -55.,-55.,-65.,-65.] -; polyfill, xbox,ybox,color=colors [k] -; -; xyouts,xbox[1],ybox[2]+0.05,string(levels[l],format=fmt_string),color =0, orientation =90,charsize =0.8 -; k = k + 1 -;endfor -; -;l = n_levels -1 -;xyouts,-120. + l*dx,ybox[2]+0.05,string(levels[l],format=fmt_string),color =0, orientation =90,charsize =0.8 -!P.position=0 - -END - -;________________________________________________________ -;________________________________________________________ -;________________________________________________________ - - -PRO plot_vars2, ncat, tile_id, data, vname - -lwval = min(data) -upval = max(data) -if (vname eq 'SOILDEPTH') then upval = 5000. - -im = n_elements(tile_id[*,0]) -jm = n_elements(tile_id[0,*]) - -dx = 360. / im -dy = 180. / jm - -x = indgen(im)*dx -180. + dx/2. -y = indgen(jm)*dy -90. + dy/2. - -data_grid = fltarr (im,jm) -data_grid (*,*) = !VALUES.F_NAN - -for j = 0l, jm -1l do begin - for i = 0l, im -1 do begin - if(tile_id[i,j] gt 0) then data_grid(i,j) = data(tile_id[i,j] -1) - endfor -endfor - -limits = [-60,-180,90,180] -if file_test ('limits.idl') then restore,'limits.idl' - -thisDevice = !D.Name -set_plot,'Z' -Device, Set_Resolution=[700,500], Z_Buffer=0 - -load_colors -colors = [27,26,25,24,23,22,21,20,40,41,42,43,44,45,46,47,48] -n_levels = n_elements (colors) -levels = [lwval,lwval+(upval-lwval)/(n_levels -1) +indgen(n_levels -1)*(upval-lwval)/(n_levels -1)] - -Erase,255 -!p.background = 255 - -!P.position=0 -!P.Multi = [0, 1, 1, 0, 1] - -MAP_SET,/CYLINDRICAL,/hires,color= 0,/NoErase,limit=limits,title = vname -contour, data_grid,x,y,levels = levels,c_colors=colors,/cell_fill,/overplot -MAP_CONTINENTS,/COASTS,color=0,MLINETHICK=2 - -alpha=fltarr(n_levels,2) -alpha(*,0)=levels -alpha(*,1)=levels -h=[0,1] -!P.position=[0.15, 0.0+0.005, 0.85, 0.015+0.005] -clev = levels -clev (*) = 1 -contour,alpha,levels,h,levels=levels,c_colors=colors,/fill,/xstyle,/ystyle, $ - /noerase,yticks=1,ytickname=[' ',' '] ,xrange=[min(levels),max(levels)], $ - xtitle=' ', color=0,xtickv=levels, $ - C_charsize=1.0, charsize=0.5 ,xtickformat = "(A1)" -contour,alpha,levels,h,levels=levels,color=0,/overplot,c_label=clev -if(vname eq 'COND') then begin - for k = 0,n_elements(levels) -1 do xyouts,levels[k],1.1, string(levels[k],'(e10.3)'),orientation=90,color=0 -endif else begin - if ((vname eq 'SOILDEPTH') or (vname eq 'ELEVATION')) then begin - for k = 0,n_elements(levels) -1 do xyouts,levels[k],1.1, string(levels[k],'(f5.0)'),orientation=90,color=0 - endif else begin - for k = 0,n_elements(levels) -1 do xyouts,levels[k],1.1, string(levels[k],'(f5.2)'),orientation=90,color=0 - endelse -endelse - -snapshot = TVRD() -TVLCT, r, g, b, /Get -Device, Z_Buffer=1 -Set_Plot, thisDevice -image24 = BytArr(3, 700, 500) -image24[0,*,*] = r[snapshot] -image24[1,*,*] = g[snapshot] -image24[2,*,*] = b[snapshot] -Write_JPEG, vname + '.jpg', image24, True=1, Quality=100 - -END - -;======================================================================== -; Check ars and arw parameters -;======================================================================== - -PRO check_satparam - -arw1=0. -arw2=0. -arw3=0. -arw4=0. -ars1=0. -ars2=0. -ars3=0. -cti_mean=0. -cti_std =0. -cti_min =0. -cti_max =0. -cti_skew=0. -BEE =0. -PSIS =0. -POROS=0. -COND =0. -WPWET=0. -soildepth=0. -nbdep=0 -nbdepl=0 -wmin0=0. -cdcr1=0. -cdcr2=0. - -file3='file.0000001' -openr,12,file3 -readf,12,cti_mean, cti_std,cti_min, cti_max, cti_skew -readf,12,BEE, PSIS,POROS,COND,WPWET,soildepth -readf,12,nbdep,nbdepl,wmin0,cdcr1,cdcr2 - -catdef = fltarr(nbdep) -ar1 = fltarr(nbdep) -wmin = fltarr(nbdep) - -readf,12,catdef -readf,12,ar1 -readf,12,wmin -readf,12,ars1,ars2,ars3 -readf,12,arw1,arw2,arw3,arw4 -close,12 - -thisDevice = !D.Name -set_plot,'Z' -Device, Set_Resolution=[700,500], Z_Buffer=0 - -load_colors -colors = [27,26,25,24,23,22,21,20,40,41,42,43,44,45,46,47,48] -n_levels = n_elements (colors) - -Erase,255 -!p.background = 255 - -!P.position=0 -!P.Multi = [0, 1, 1, 0, 1] - -ntot=nbdep -x=indgen(ntot) -y = fltarr(ntot) - -plot,x,y,xrange=[0.,max(catdef)],yrange=[0.,1.],linestyle=0,title='WMIN and AR1', color =0 -oplot,catdef,wmin,color = 30 -oplot,[cdcr1,cdcr1],[0.,1], color = 100 -oplot,[cdcr2,cdcr2],[0.,1], color = 100 - -;ntot=fix(catdef(nbdep-1))+ 1. -ntot =fix(cdcr1)+ 1. -ntot2=fix(cdcr2)+ 1. - -x=indgen(ntot2) -y=fltarr(ntot) -y2=fltarr(ntot2) -for n =0,ntot2-1 do begin - - if (n lt ntot) then y(n) = arw4 + (1.- arw4)*(1.+ arw1*x(n))/(1.+ arw2*x(n)+ arw3*x(n)*x(n)) - y2(n) = (1.+ ars1*x(n))/(1.+ ars2*x(n)+ ars3*x(n)*x(n)) -endfor - -oplot,x(0:ntot-1),y,color = 0, linestyle = 1 -oplot,catdef,ar1,color = 220 -oplot,x,y2,color = 0, linestyle = 1 - -snapshot = TVRD() -TVLCT, r, g, b, /Get -Device, Z_Buffer=1 -Set_Plot, thisDevice -image24 = BytArr(3, 700, 500) -image24[0,*,*] = r[snapshot] -image24[1,*,*] = g[snapshot] -image24[2,*,*] = b[snapshot] -Write_JPEG,'img.0000001.jpg', image24, True=1, Quality=100 - -end - -;======================================================================== -; Process JPL Canopy Height -;======================================================================== - -PRO canop_Height, nc, nr, tileid_plot, gfile, path - -CanopH=read_tiff('/discover/nobackup/projects/gmao/bcs_shared/make_bcs_inputs/land/veg/veg_height/v1/Simard_Pinto_3DGlobalVeg_JGR.tif') -im=n_elements(CanopH(*,0)) -jm=n_elements(CanopH(0,*)) -CanopH = reverse(CanopH,2,/overwrite) - -yh= dblarr(jm) -for i = 0l,jm -1l do yh(i) = i*1./120 -90. + 1./240. -xh = dblarr(im) -for i = 0l,im -1l do xh(i) = i*1./120 -180. + 1./240. - -N_tiles = 0l - -openr,1,'../catchment.def' -readf,1,N_tiles -close,1 - -canop_tiles = fltarr (N_tiles) -count_pix = fltarr (N_tiles) - -canop_tiles (*) = 0.01 -count_pix (*) = 0. - -dx = IM/NC -dy = JM/NR - -catrow = lonarr (nc) -tile_id = lonarr (NC, nr) -rst_file= path + '/rst/' + gfile+'*.rst' - -openr,1,rst_file,/F77_UNFORMATTED - -for j = 0l, NR -1l do begin - readu,1,catrow - tile_id(*,j) = catrow(*) - for i=0l, nc-1l do begin - subset = CanopH (i*dx: (i+1)*dx -1,j*dy: (j+1)*dy -1) - if ((catrow(i) ge 1) and (catrow(i) le N_tiles)) then begin - canop_tiles (catrow(i) -1) = canop_tiles (catrow(i) -1) + mean (subset) - count_pix (catrow(i) -1) = count_pix (catrow(i) -1) + 1. - endif - endfor -endfor - -close,1 - -canop_tiles (where (count_pix gt 0.)) = canop_tiles/count_pix -canop_tiles (where (canop_tiles lt 0.01)) = 0.01 - -openw,1,'Simard_Pinto_3DGlobalVeg_JGR.dat' - -for k = 0l,n_tiles -1l do begin - printf,1,format='(f7.3)',canop_tiles(k) -endfor - -close,1 - -;openw,1,'../Simard_Pinto_3DGlobalVeg_JGR.bin',/F77_UNFORMATTED -;writeu,1,canop_tiles -;close,1 - -lwval = min(0.) - -ip = n_elements(tileid_plot[*,0]) -jp = n_elements(tileid_plot[0,*]) - -dx = 360. / ip -dy = 180. / jp - -x = indgen(ip)*dx -180. + dx/2. -y = indgen(jp)*dy -90. + dy/2. - -data_grid = fltarr (ip,jp) -data_grid (*,*) = !VALUES.F_NAN - -for j = 0l, jp -1l do begin - for i = 0l, ip -1 do begin - if((tileid_plot[i,j] gt 0) and (tileid_plot[i,j] le N_tiles)) then data_grid(i,j) = canop_tiles(tileid_plot[i,j] -1) - endfor -endfor - -upval = max(canop_tiles) - -limits = [-60,-180,90,180] - -colors = [27,26,25,24,23,22,21,20,40,41,42,43,44,45,46,47,48] -colors = reverse (colors) -n_levels = n_elements (colors) - -levels = [lwval,lwval+(upval-lwval)/(n_levels -1) +indgen(n_levels -1)*(upval-lwval)/(n_levels -1)] - -thisDevice = !D.Name -set_plot,'Z' -Device, Set_Resolution=[800,400], Z_Buffer=0 -load_colors -Erase,255 -!p.background = 255 -!P.position=0 -!P.Multi = [0, 1, 1, 0, 0] - -MAP_SET,/CYLINDRICAL,/hires,color= 0,/NoErase,limit=limits,/ISOTROPIC,/NOBORDER -contour, data_grid, x, y,levels = levels,c_colors=colors,/cell_fill,/overplot -MAP_CONTINENTS,/COASTS,color=0,MLINETHICK=2 - -alpha=fltarr(n_levels,2) -alpha(*,0)=levels -alpha(*,1)=levels -h=[0,1] - -dx = (240.)/(n_levels-1) - -clev = levels -clev (*) = 1 - - k = 0 - for l = 0,n_levels -2 do begin - k = l - xbox = [-120. + k*dx,-120. + k*dx, -120. + (k+1)*dx, -120. + (k+1)*dx,-120. + k*dx] - ybox = [-65., -55.,-55.,-65.,-65.] - polyfill, xbox,ybox,color=colors [k] - xyouts,xbox[1],ybox[2]+0.05,string(levels[l],format='(f5.2)'),color =0, orientation =90,charsize =0.8 - k = k + 1 - endfor - - for l = n_levels -1,n_levels -1 do begin - xyouts,-120. + l*dx,ybox[2]+0.05,string(levels[l],format='(f5.2)'),color =0, orientation =90,charsize =0.8 - - endfor - -snapshot = TVRD() -TVLCT, r, g, b, /Get -Device, Z_Buffer=1 -Set_Plot, thisDevice -image24 = BytArr(3, 800,400) -image24[0,*,*] = r[snapshot] -image24[1,*,*] = g[snapshot] -image24[2,*,*] = b[snapshot] -Write_JPEG, 'Canopy_Height_onTiles.jpg', image24, True=1, Quality=100 - -spawn, "paste ../mosaic_veg_typs_fracs Simard_Pinto_3DGlobalVeg_JGR.dat > new_mos" -spawn, "/bin/mv new_mos ../mosaic_veg_typs_fracs" -spawn, "/bin/rm Simard_Pinto_3DGlobalVeg_JGR.dat" - -tmp_data = read_ascii ("../mosaic_veg_typs_fracs") -openw,1,'../vegdyn.data',/F77_UNFORMATTED -writeu,1,tmp_data.field1(2,*) -writeu,1,tmp_data.field1(6,*) -close,1 - -END - -;_____________________________________________________________________ -;_____________________________________________________________________ - -PRO plot_three_vars2, ncat, tile_id, data1, data2, data3 - -im = n_elements(tile_id[*,0]) -jm = n_elements(tile_id[0,*]) - -dx = 360. / im -dy = 180. / jm - -x = indgen(im)*dx -180. + dx/2. -y = indgen(jm)*dy -90. + dy/2. -;stop -data_grid1 = fltarr (im,jm) -data_grid1 (*,*) = !VALUES.F_NAN -data_grid2 = fltarr (im,jm) -data_grid2 (*,*) = !VALUES.F_NAN -data_grid3 = fltarr (im,jm) -data_grid3 (*,*) = !VALUES.F_NAN - -for j = 0l, jm -1l do begin - for i = 0l, im -1 do begin - if(tile_id[i,j] gt 0) then data_grid1(i,j) = data1(tile_id[i,j] -1) - if(tile_id[i,j] gt 0) then data_grid2(i,j) = data2(tile_id[i,j] -1) - if(tile_id[i,j] gt 0) then data_grid3(i,j) = data3(tile_id[i,j] -1) - endfor -endfor - -limits = [-60,-180,90,180] -if file_test ('limits.idl') then restore,'limits.idl' - -colors = [27,26,25,24,23,22,21,20,40,41,42,43,44,45,46,47,48] -n_levels = n_elements (colors) - -thisDevice = !D.Name -set_plot,'Z' -Device, Set_Resolution=[720,900], Z_Buffer=0 -load_colors -Erase,255 -!p.background = 255 - -!P.position=0 -!P.Multi = [0, 1, 3, 0, 1] - -for n = 0,2 do begin - -if (n eq 0) then begin - upval = 350. - lwval = 0. - data = data_grid1 -endif - -if (n eq 1) then begin - upval = 300. - lwval = 250. - data = data_grid2 -endif - -if (n eq 2) then begin - upval = 300. - lwval = 250. - data = data_grid3 -endif - -levels = [lwval,lwval+(upval-lwval)/(n_levels -1) +indgen(n_levels -1)*(upval-lwval)/(n_levels -1)] -if(n eq 0) then levels = [indgen(15)*4.,65.,350.] -if(n eq 0) then MAP_SET,/CYLINDRICAL,/hires,color= 0,/NoErase,limit=limits,/NOBORDER -if(n gt 0) then MAP_SET,/CYLINDRICAL,/hires,color= 0,/NoErase,limit=limits,/ADVANCE,/NOBORDER -contour, data,x,y,levels = levels,c_colors=colors,/cell_fill,/overplot -MAP_CONTINENTS,/COASTS,color=0,MLINETHICK=2 - -alpha=fltarr(n_levels,2) -alpha(*,0)=levels -alpha(*,1)=levels -h=[0,1] - -dx = (240.)/(n_levels-1) - -clev = levels -clev (*) = 1 - - k = 0 - for l = 0,n_levels -2 do begin - k = l - xbox = [-120. + k*dx,-120. + k*dx, -120. + (k+1)*dx, -120. + (k+1)*dx,-120. + k*dx] - ybox = [-65., -55.,-55.,-65.,-65.] - polyfill, xbox,ybox,color=colors [k] - xyouts,xbox[1],ybox[2]+0.05,string(levels[l],format='(f5.1)'),color =0, orientation =90,charsize =0.8 - k = k + 1 - endfor - - for l = n_levels -1,n_levels -1 do begin - xyouts,-120. + l*dx,ybox[2]+0.05,string(levels[l],format='(f5.1)'),color =0, orientation =90,charsize =0.8 - endfor - -endfor - -;stop -snapshot = TVRD() -TVLCT, r, g, b, /Get -Device, Z_Buffer=1 -Set_Plot, thisDevice -image24 = BytArr(3, 720, 900) -image24[0,*,*] = r[snapshot] -image24[1,*,*] = g[snapshot] -image24[2,*,*] = b[snapshot] -Write_JPEG, 'CLM_Ndep_T2m.jpg', image24, True=1, Quality=100 - -END - -;_____________________________________________________________________ -;_____________________________________________________________________ - -pro plot_soilalb, ncat, tile_id,VISDR, VISDF, NIRDR, NIRDF - - -thisDevice = !D.Name -set_plot,'Z' -Device, Set_Resolution=[720,500], Z_Buffer=0 -load_colors -Erase,255 -!p.background = 255 - -!P.position=0 -!P.Multi = [0, 2, 2, 0, 0] -limits = [-60,-180,90,180] - -lwval = 0. -upval = 0.65 - -im = n_elements(tile_id[*,0]) -jm = n_elements(tile_id[0,*]) - -dx = 360. / im -dy = 180. / jm - -x = indgen(im)*dx -180. + dx/2. -y = indgen(jm)*dy -90. + dy/2. - -colors = [27,26,25,24,23,22,21,20,40,41,42,43,44,45,46,47,48] -n_levels = n_elements (colors) - -for map = 1,4 do begin - - if (map eq 1) then data = VISDR - if (map eq 2) then data = VISDF - if (map eq 3) then data = NIRDR - if (map eq 4) then data = NIRDF - - if (map eq 1) then ctitle = 'VISDR' - if (map eq 2) then ctitle = 'VISDF' - if (map eq 3) then ctitle = 'NIRDR' - if (map eq 4) then ctitle = 'NIRDF' - - if (map ge 3) then upval = 1. - - levels = [lwval,lwval+(upval-lwval)/(n_levels -1) +indgen(n_levels -1)*(upval-lwval)/(n_levels -1)] - - data_grid = fltarr (im,jm) - data_grid (*,*) = !VALUES.F_NAN - - for j = 0l, jm -1l do begin - for i = 0l, im -1 do begin - if(tile_id[i,j] gt 0) then data_grid(i,j) = data(tile_id[i,j] -1) - endfor - endfor - - if(map eq 1) then begin - MAP_SET,/CYLINDRICAL,/hires,color= 0,/NoErase,limit=limits,/ISOTROPIC,/NOBORDER, title = ctitle - endif else begin - MAP_SET,/CYLINDRICAL,/hires,color= 0,/NoErase,limit=limits,/ADVANCE,/ISOTROPIC,/NOBORDER, title = ctitle - endelse - - contour, data_grid,x,y,levels = levels,c_colors=colors,/cell_fill,/overplot - MAP_CONTINENTS,/COASTS,color=0,MLINETHICK=2 - - if((map eq 1) or (map eq 3)) then begin - if(map eq 1) then !P.position=[0.25, 0.55, 0.75, 0.575] - if(map eq 3) then !P.position=[0.25, 0.05, 0.75, 0.075] - - alpha=fltarr(n_levels,2) - alpha(*,0)=levels - alpha(*,1)=levels - h=[0,1] - clev = levels - clev (*) = 1 - n=0 - k = 0 - fmt_string = '(f4.2)' - contour,alpha,levels,h,levels=levels,c_colors=colors,/fill,/xstyle,/ystyle, $ - /noerase,yticks=1,ytickname=[' ',' '] ,xrange=[min(levels),max(levels)], $ - xtitle=' ', color=0,xtickv=levels, $ - C_charsize=1.0, charsize=0.5 ,xtickformat = "(A1)" - contour,alpha,levels,h,levels=levels,color=0,/overplot,c_label=clev - for k = 0,n_elements(colors) -1 do xyouts,levels[k],1.1,string(levels[k],format=fmt_string) ,orientation=90,color=0,charsize =0.8 - !P.position=0 - endif -endfor - -snapshot = TVRD() -TVLCT, r, g, b, /Get -Device, Z_Buffer=1 -Set_Plot, thisDevice -image24 = BytArr(3, 720, 500) -image24[0,*,*] = r[snapshot] -image24[1,*,*] = g[snapshot] -image24[2,*,*] = b[snapshot] -Write_JPEG, 'SoilAlb.jpg', image24, True=1, Quality=100 - -end - -;_____________________________________________________________________ -;_____________________________________________________________________ - -pro create_vec_file - -dx = 1.d0/12. -dy = 1.d0/12. -DATELINE = 1 -global_bcs = 0 -WORKDIR = '' - -nc = long(360./dx) -nr = long(180./dy) - -openw,1,workdir + 'clsm/NLDAS-5arcmin_vec.data' - -if(NOT (boolean (global_bcs))) then begin - xylim = [35., -180., 80., -55.] - x = indgen (nc)*dx -180. + dx/2. - y = indgen (nr)*dy -90. + dy/2. - i1 = value_locate (x, xylim(1)) + 1 - i2 = value_locate (x, xylim(3)) - j1 = value_locate (y, xylim(0)) + 1 - j2 = value_locate (y, xylim(2)) - i_offset = i1 - j_offset = j1 - nc_domain = i2 - i1 + 1 - nr_domain = j2 - j1 + 1 - printf,1,format ='(2f8.4, i3, 4i5)', dx,dy, dateline, nc_domain,nr_domain,i_offset,j_offset -endif else begin - printf,1,dx,dy, dateline -endelse - -SRTM_maxcat = 291284 - -nc_esa = 129600l -nr_esa = 64800l - -nx = nc_esa/nc -ny = nr_esa/nr - -ncid = NCDF_OPEN('/discover/nobackup/projects/gmao/bcs_shared/make_bcs_inputs/shared/mask/GEOS5_10arcsec_mask.nc') -;NCDF_VARGET, ncid,0, y -;NCDF_VARGET, ncid,1, x - -n = 1l - -subset = lonarr (nc_esa,ny) -for j = 0l,nr -1l do begin - NCDF_VARGET, ncid,'CatchIndex', offset = [0,j*ny], count = [nc_esa,ny], SubSet - for i = 0l,nc -1l do begin -; NCDF_VARGET, ncid,'CatchIndex', offset = [i*nx,j*ny], count = [nx,ny], CatchIndex - CatchIndex = SubSet(i*nx:(i+1)*nx -1,*) - if(max(CatchIndex) gt SRTM_maxcat) then CatchIndex (where (CatchIndex gt SRTM_maxcat)) = 0 - if (max (CatchIndex) ge 1) then begin - if(boolean (global_bcs)) then begin - printf,1,format ='(i7,2(1x,f10.5),2(1x,I5))',n,j*dy -90. + dy/2.,i*dx -180. + dx/2.,I+1,J+1 - n = n + 1 - endif else begin - if(IS_IN_DOMAIN(xylim, i*dx -180. + dx/2.,j*dy -90. + dy/2.)) then begin - printf,1,format ='(i7,2(1x,f10.5),2(1x,I5))',n,j*dy -90. + dy/2.,i*dx -180. + dx/2.,I+1 - i_offset,J+1 - j_offset - n = n + 1 - endif - endelse - endif - endfor -endfor -close,1 -ncdf_close,ncid - - -end -;_________________________________________________________________ -;_________________________________________________________________ - - -PRO plot_three_vars1, ncat, tile_id, data1, data2, data3 - -im = n_elements(tile_id[*,0]) -jm = n_elements(tile_id[0,*]) - -dx = 360. / im -dy = 180. / jm - -x = indgen(im)*dx -180. + dx/2. -y = indgen(jm)*dy -90. + dy/2. -;stop -data_grid1 = fltarr (im,jm) -data_grid1 (*,*) = !VALUES.F_NAN -data_grid2 = fltarr (im,jm) -data_grid2 (*,*) = !VALUES.F_NAN -data_grid3 = fltarr (im,jm) -data_grid3 (*,*) = !VALUES.F_NAN - -for j = 0l, jm -1l do begin - for i = 0l, im -1 do begin - if(tile_id[i,j] gt 0) then data_grid1(i,j) = data1(tile_id[i,j] -1) - if(tile_id[i,j] gt 0) then data_grid2(i,j) = data2(tile_id[i,j] -1) - if(tile_id[i,j] gt 0) then data_grid3(i,j) = data3(tile_id[i,j] -1) - endfor -endfor - -limits = [-60,-180,90,180] -if file_test ('limits.idl') then restore,'limits.idl' - -colors = [27,26,25,24,23,22,21,20,40,41,42,43,44,45,46,47,48] -n_levels = n_elements (colors) - -thisDevice = !D.Name -set_plot,'Z' -Device, Set_Resolution=[720,900], Z_Buffer=0 -Erase,255 -!p.background = 255 - -!P.position=0 -!P.Multi = [0, 1, 3, 0, 1] - -for n = 0,2 do begin - -if (n eq 0) then begin - upval = 14. - lwval = 6. - data = data_grid1 -endif - -if (n eq 1) then begin - upval = 4. - lwval = 0. - data = data_grid2 -endif - -if (n eq 2) then begin - upval = 2.5 - lwval = -2.5 - data = data_grid3 -endif - -levels = [lwval,lwval+(upval-lwval)/(n_levels -1) +indgen(n_levels -1)*(upval-lwval)/(n_levels -1)] -if(n eq 0) then MAP_SET,/CYLINDRICAL,/hires,color= 0,/NoErase,limit=limits,/NOBORDER -if(n gt 0) then MAP_SET,/CYLINDRICAL,/hires,color= 0,/NoErase,limit=limits,/ADVANCE,/NOBORDER -contour, data,x,y,levels = levels,c_colors=colors,/cell_fill,/overplot -MAP_CONTINENTS,/COASTS,color=0,MLINETHICK=2 - -alpha=fltarr(n_levels,2) -alpha(*,0)=levels -alpha(*,1)=levels -h=[0,1] - -dx = (240.)/(n_levels-1) - -clev = levels -clev (*) = 1 - - k = 0 - for l = 0,n_levels -2 do begin - k = l - xbox = [-120. + k*dx,-120. + k*dx, -120. + (k+1)*dx, -120. + (k+1)*dx,-120. + k*dx] - ybox = [-65., -55.,-55.,-65.,-65.] - polyfill, xbox,ybox,color=colors [k] - if (n eq 0) then xyouts,xbox[1],ybox[2]+0.05,string(levels[l],format='(f5.2)'),color =0, orientation =90,charsize =0.8 - if (n eq 1) then xyouts,xbox[1],ybox[2]+0.05,string(levels[l],format='(f5.2)'),color =0, orientation =90,charsize =0.8 - if (n eq 2) then xyouts,xbox[1],ybox[2]+0.05,string(levels[l],format='(f6.2)'),color =0, orientation =90,charsize =0.8 - k = k + 1 - endfor - - for l = n_levels -1,n_levels -1 do begin - if (n eq 0) then xyouts,-120. + l*dx,ybox[2]+0.05,string(levels[l],format='(f5.2)'),color =0, orientation =90,charsize =0.8 - if (n eq 1) then xyouts,-120. + l*dx,ybox[2]+0.05,string(levels[l],format='(f5.2)'),color =0, orientation =90,charsize =0.8 - if (n eq 2) then xyouts,-120. + l*dx,ybox[2]+0.05,string(levels[l],format='(f6.2)'),color =0, orientation =90,charsize =0.8 - endfor - -endfor - -;stop -snapshot = TVRD() -TVLCT, r, g, b, /Get -Device, Z_Buffer=1 -Set_Plot, thisDevice -image24 = BytArr(3, 720, 900) -image24[0,*,*] = r[snapshot] -image24[1,*,*] = g[snapshot] -image24[2,*,*] = b[snapshot] -Write_JPEG, 'cti.jpg', image24, True=1, Quality=100 - -END -;_____________________________________________________________________ -;_____________________________________________________________________ - -pro plot_lai, ncat, tile_id - -lwval = 0. -upval = 7. - -im = n_elements(tile_id[*,0]) -jm = n_elements(tile_id[0,*]) - -dx = 360. / im -dy = 180. / jm - -x = indgen(im)*dx -180. + dx/2. -y = indgen(jm)*dy -90. + dy/2. - -limits = [-60,-180,90,180] -if file_test ('limits.idl') then restore,'limits.idl' - -r_in = [253,224,255,238,205,193,152, 0,124, 0, 0, 0, 0, 0, 0, 48,110, 85] -g_in = [253,238,255,238,205,255,251,255,252,255,238,205,139,128,100,128,139,107] -b_in = [253,224, 0, 0, 0,193,152,127, 0, 0, 0, 0, 0, 0, 0, 20, 61, 47] - -n_levels = n_elements (r_in) -levels=[0.,0.25,0.5,0.75,1.,1.25,1.5,10. * indgen(11)*0.05+2.] -red = intarr (256) -green= intarr (256) -blue = intarr (256) - -red (255) = 255 -green(255) = 255 -blue (255) = 255 - -for k = 0, N_levels -1 do begin - red (k+1) = r_in (k) - green(k+1) = g_in (k) - blue (k+1) = b_in (k) -endfor - -thisDevice = !D.Name -set_plot,'Z' -Device, Set_Resolution=[1080,600], Z_Buffer=0 - -TVLCT,red,green,blue - -colors = indgen (N_levels) + 1 - - -Erase,255 -!p.background = 255 - -!P.position=0 -!P.Multi = [0, 3, 4, 0, 0] - -file = '../lai.dat' - -yr = 0. -mn = 0. -dy = 0. -dum = 0. -yr1 = 0. -mn1 = 0. -dy1 = 0. -yrg = 0. -mng = 0. -lai = fltarr (ncat) -lai1 = fltarr (ncat) -lai2 = fltarr (ncat) -mdays = [31,28,31,30,31,30,31,31,30,31,30,31] -mname = ['JAN','FEB','MAR','APR','MAY','JUN','JUL','AUG','SEP','OCT','NOV','DEC'] - -openr,1,file,/F77_UNFORMATTED -readu,1,yr,mn,dy,dum,dum,dum,yr1,mn1,dy1 - -readu,1,lai1 -dofyr_b4 = ((float(julday(mn1,dy1,2001+yr1)-julday(12,31,2000))) - (float(julday(mn,dy,2001+yr)-julday(12,31,2000))))/2 + $ - float(julday(mn,dy,2001+yr)-julday(12,31,2000)) - -readu,1,yr,mn,dy,dum,dum,dum,yr1,mn1,dy1 - -dofyr_nxt = ((float(julday(mn1,dy1,2001+yr1)-julday(12,31,2000))) - (float(julday(mn,dy,2001+yr)-julday(12,31,2000))))/2 + $ - float(julday(mn,dy,2001+yr)-julday(12,31,2000)) -readu,1,lai2 - -for month = 1,12 do begin - lai_month = fltarr (ncat) - for day =1,mdays[month -1] do begin - dofyr_now = float(julday(month,day,2001+yr)-julday(12,31,2000)) - fac1 = (dofyr_now - dofyr_b4 )/(dofyr_nxt - dofyr_b4) - fac2 = (dofyr_nxt - dofyr_now)/(dofyr_nxt - dofyr_b4) - - lai = fac1*lai2 + fac2*lai1 - lai_month(*) = lai_month(*) + lai (*)/mdays[month -1] - - if(dofyr_now + 0.5 ge dofyr_nxt) then begin - lai1 = lai2 - dofyr_b4 = dofyr_nxt - readu,1,yr,mn,dy,dum,dum,dum,yr1,mn1,dy1 - - dofyr_nxt = ((float(julday(mn1,dy1,2001+yr1)-julday(12,31,2000))) - (float(julday(mn,dy,2001+yr)-julday(12,31,2000))))/2 + $ - float(julday(mn,dy,2001+yr)-julday(12,31,2000)) - if((month eq 12) and (yr eq 2)) then yr = yr -1 - readu,1,lai2 - endif - endfor - - data_grid = fltarr (im,jm) - data_grid (*,*) = !VALUES.F_NAN - - for j = 0l, jm -1l do begin - for i = 0l, im -1 do begin - if(tile_id[i,j] gt 0) then data_grid(i,j) = lai_month(tile_id[i,j] -1) - endfor - endfor - if(month gt 1) then begin - MAP_SET,/CYLINDRICAL,/hires,color= 0,/NoErase,limit=limits,/ADVANCE,/NOBORDER,title=mname(month-1) - endif else begin - MAP_SET,/CYLINDRICAL,/hires,color= 0,/NoErase,limit=limits,/NOBORDER,title=mname(month-1) - endelse - - contour, data_grid,x,y,levels = levels,c_colors=colors,/cell_fill,/overplot - MAP_CONTINENTS,/COASTS,color=0,MLINETHICK=2 -endfor - -close,1 - -!P.position=[0.15, 0.005, 0.85, 0.025] - -alpha=fltarr(n_levels,2) -alpha(*,0)=levels -alpha(*,1)=levels -h=[0,1] - -dx = (240.)/(n_levels-1) - -clev = levels -clev (*) = 1 -contour,alpha,levels,h,levels=levels,c_colors=colors,/fill,/xstyle,/ystyle, $ - /noerase,yticks=1,ytickname=[' ',' '] ,xrange=[min(levels),max(levels)], $ - xtitle=' ', color=0,xtickv=levels, $ - C_charsize=1.0, charsize=0.5 ,xtickformat = "(A1)" -contour,alpha,levels,h,levels=levels,color=0,/overplot,c_label=clev - for k = 0,n_elements(colors) -1 do xyouts,levels[k],1.1,string(levels[k],format='(f4.2)') ,orientation=90,color=0,charsize =0.8 -!P.position=0 -snapshot = TVRD() -TVLCT, r, g, b, /Get -Device, Z_Buffer=1 -Set_Plot, thisDevice -image24 = BytArr(3, 1080, 600) -image24[0,*,*] = r[snapshot] -image24[1,*,*] = g[snapshot] -image24[2,*,*] = b[snapshot] -Write_JPEG, 'lai.jpg', image24, True=1, Quality=100 - -!P.Multi = 0 -!P.position=0 - -end - -;_____________________________________________________________________ - -pro load_random_colors - -R = shuffle(indgen(256)) -G = shuffle(indgen(256)) -B = shuffle(indgen(256)) - -R (255) = 255 -G (255) = 255 -B (255) = 255 -R (0) = 0 -G (0) = 0 -B (0) = 0 - -TVLCT,R ,G ,B - -end - - - -;_____________________________________________________________________ - -pro load_colors - -R = intarr (256) -G = intarr (256) -B = intarr (256) - -R (*) = 255 -G (*) = 255 -B (*) = 255 - -r_drought = [0, 0, 0, 0, 47, 200, 255, 255, 255, 255, 249, 197] -g_drought = [0, 115, 159, 210, 255, 255, 255, 255, 219, 157, 0, 0] -b_drought = [0, 0, 0, 0, 67, 130, 255, 0, 0, 0, 0, 0] - -colors = indgen (11) + 1 -R (0:11) = r_drought -G (0:11) = g_drought -B (0:11) = b_drought - -r_green = [200, 150, 47, 60, 0, 0, 0, 0] -g_green = [255, 255, 255, 230, 219, 187, 159, 131] -b_green = [200, 150, 67, 15, 0, 0, 0, 0] - -r_blue = [ 55, 0, 0, 0, 0, 0, 0, 0, 0, 0] -g_blue = [255, 255, 227, 195, 167, 115, 83, 0, 0, 0] -b_blue = [199, 255, 255, 255, 255, 255, 255, 255, 200, 130] - -r_red = [255, 240, 255, 255, 255, 255, 255, 233, 197] -g_red = [255, 255, 219, 187, 159, 131, 51, 23, 0] -b_red = [153, 15, 0, 0, 0, 0, 0, 0, 0] - -r_grey = [245, 225, 205, 185, 165, 145, 125, 105, 85] -g_grey = [245, 225, 205, 185, 165, 145, 125, 105, 85] -b_grey = [245, 225, 205, 185, 165, 145, 125, 105, 85] - -r_type = [255,106,202,251, 0, 29, 77,109,142,233,255,255,255,127,164,164,217,217,204,104, 0] -g_type = [245, 91,178,154, 85,115,145,165,185, 23,131,131,191, 39, 53, 53, 72, 72,204,104, 70] -b_type = [215,154,214,153, 0, 0, 0, 0, 13, 0, 0,200, 0, 4, 3,200, 1,200,204,200,200] - -r_lct2 = [ 0, 0, 0, 0, 0, 0, 0, 0, 0, 55, 120, 190, 240, 255, 255, 255, 255, 255, 233, 197, 158] -g_lct2 = [ 0, 0, 0, 83, 115, 167, 195, 227, 255, 255, 255, 255, 255, 219, 187, 159, 131, 51, 23, 0, 0] -b_lct2 = [130, 200, 255, 255, 255, 255, 255, 255, 255, 199, 135, 67, 15, 0, 0, 0, 0 , 0, 0, 0, 0] - -r_veg = [233,255,255,255,210, 0, 0, 0,204,170,255,220,205, 0, 0,170, 0, 40,120,140,190,150,255,255, 0, 0, 0,195,255, 0] -g_veg = [ 23,131,191,255,255,255,155, 0,204,240,255,240,205,100,160,200, 60,100,130,160,150,100,180,235,120,150,220, 20,245, 70] -b_veg = [ 0, 0, 0,178,255,255,255,200,204,240,100,100,102, 0, 0, 0, 0, 0, 0, 0, 0, 0, 50,175, 90,120,130, 0,215,200] - -r_grads_rb = [160, 110, 30, 0, 0, 0, 0, 160, 230, 230, 240, 250, 240] -g_grads_rb = [ 0, 0, 60, 150, 200, 210, 220, 230, 220, 175, 130, 60, 0] -b_grads_rb = [200, 220, 255, 255, 200, 140, 0, 50, 50, 45, 40, 60, 130] - -R (20:27) = r_green -G (20:27) = g_green -B (20:27) = b_green - -R (30:39) = r_blue -G (30:39) = g_blue -B (30:39) = b_blue - -R (40:48) = r_red -G (40:48) = g_red -B (40:48) = b_red - -R (50:58) = r_grey -G (50:58) = g_grey -B (50:58) = b_grey - -R (60:80) = r_type -G (60:80) = g_type -B (60:80) = b_type - -R (90:119) = r_veg -G (90:119) = g_veg -B (90:119) = b_veg - -R (120:132) = r_grads_rb -G (120:132) = g_grads_rb -B (120:132) = b_grads_rb - -R (140:160) = r_lct2 -G (140:160) = g_lct2 -B (140:160) = b_lct2 -TVLCT,R ,G ,B - -end - -; ----------------------------------------------------------------------- - -pro jpl_tif2nc4 - -CanopH=read_tiff('/discover/nobackup/projects/gmao/bcs_shared/make_bcs_inputs/land/veg/veg_height/v1/Simard_Pinto_3DGlobalVeg_JGR.tif') -im=n_elements(CanopH(*,0)) -jm=n_elements(CanopH(0,*)) -CanopH = reverse(CanopH,2,/overwrite) - -yh= dblarr(jm) -for i = 0l,jm -1l do yh(i) = i*1./120 -90. + 1./240. -xh = dblarr(im) -for i = 0l,im -1l do xh(i) = i*1./120 -180. + 1./240. - -id = NCDF_CREATE('/discover/nobackup/projects/gmao/bcs_shared/make_bcs_inputs/land/veg/veg_height/v1/Simard_Pinto_3DGlobalVeg_JGR.nc4', /clobber, /NETCDF4_FORMAT) -xid = NCDF_DIMDEF(id, 'N_lon' , im) ;Define x-dimension -yid = NCDF_DIMDEF(id, 'N_lat' , jm) ;Define y-dimension -NCDF_ATTPUT,id, 'CreatedBy', 'NASA GSFC GMAO Land Group',/global -NCDF_ATTPUT,id, 'Contact', 'NASA GSFC GMAO Land Group',/global - -str_date=systime() -NCDF_ATTPUT,id, 'Date', str_date,/global -vid = NCDF_VARDEF(id,'longitude' , [xid], /DOUBLE) -vid = NCDF_VARDEF(id,'latitude' , [yid], /DOUBLE) -vid = NCDF_VARDEF(id,'CanopyHeight',[xid,yid], /SHORT) - -NCDF_CONTROL, id, /ENDEF - -NCDF_VARPUT, id,'longitude',xh -NCDF_VARPUT, id,'latitude', yh - -for j = 0, jm -1 do begin - NCDF_VARPUT, id,'CanopyHeight',offset=[0,j],count=[im,1],CanopH(*,j) -endfor - -NCDF_CLOSE, id - -end - -; ----------------------------------------------------------------------- - -pro plot_canoph, z2, tileid_plot -N_tiles = 0l - -openr,1,'../catchment.def' -readf,1,N_tiles -close,1 -ip = n_elements(tileid_plot[*,0]) -jp = n_elements(tileid_plot[0,*]) - -dx = 360. / ip -dy = 180. / jp - -x = indgen(ip)*dx -180. + dx/2. -y = indgen(jp)*dy -90. + dy/2. - -data_grid = fltarr (ip,jp) -data_grid (*,*) = !VALUES.F_NAN - -for j = 0l, jp -1l do begin - for i = 0l, ip -1 do begin - if((tileid_plot[i,j] gt 0) and (tileid_plot[i,j] le N_tiles)) then data_grid(i,j) = z2(tileid_plot[i,j] -1) - endfor -endfor - -upval = max(z2) -lwval = min(z2) - -limits = [-60,-180,90,180] - -colors = [27,26,25,24,23,22,21,20,40,41,42,43,44,45,46,47,48] -colors = reverse (colors) -n_levels = n_elements (colors) - -levels = [lwval,lwval+(upval-lwval)/(n_levels -1) +indgen(n_levels -1)*(upval-lwval)/(n_levels -1)] - -thisDevice = !D.Name -set_plot,'Z' -Device, Set_Resolution=[800,400], Z_Buffer=0 -load_colors -Erase,255 -!p.background = 255 -!P.position=0 -!P.Multi = [0, 1, 1, 0, 0] - -MAP_SET,/CYLINDRICAL,/hires,color= 0,/NoErase,limit=limits,/ISOTROPIC,/NOBORDER -contour, data_grid, x, y,levels = levels,c_colors=colors,/cell_fill,/overplot -MAP_CONTINENTS,/COASTS,color=0,MLINETHICK=2 - -alpha=fltarr(n_levels,2) -alpha(*,0)=levels -alpha(*,1)=levels -h=[0,1] - -dx = (240.)/(n_levels-1) - -clev = levels -clev (*) = 1 - - k = 0 - for l = 0,n_levels -2 do begin - k = l - xbox = [-120. + k*dx,-120. + k*dx, -120. + (k+1)*dx, -120. + (k+1)*dx,-120. + k*dx] - ybox = [-65., -55.,-55.,-65.,-65.] - polyfill, xbox,ybox,color=colors [k] - xyouts,xbox[1],ybox[2]+0.05,string(levels[l],format='(f5.2)'),color =0, orientation =90,charsize =0.8 - k = k + 1 - endfor - - for l = n_levels -1,n_levels -1 do begin - xyouts,-120. + l*dx,ybox[2]+0.05,string(levels[l],format='(f5.2)'),color =0, orientation =90,charsize =0.8 - - endfor - -snapshot = TVRD() -TVLCT, r, g, b, /Get -Device, Z_Buffer=1 -Set_Plot, thisDevice -image24 = BytArr(3, 800,400) -image24[0,*,*] = r[snapshot] -image24[1,*,*] = g[snapshot] -image24[2,*,*] = b[snapshot] -Write_JPEG, 'Canopy_Height_onTiles.jpg', image24, True=1, Quality=100 - -end - -; ==================================================================================== -pro country_codes, tile_id - -im = n_elements(tile_id[*,0]) -jm = n_elements(tile_id[0,*]) - -dx = 360. / im -dy = 180. / jm - -x = indgen(im)*dx -180. + dx/2. -y = indgen(jm)*dy -90. + dy/2. -cnt_grid = intarr (im,jm) -cnt_grid (*,*) = !VALUES.F_NAN - -N_tiles = 0l -openr,1,'../catchment.def' -readf,1,N_tiles -close,1 -cnt_code = intarr (N_tiles) -st_code = intarr (N_tiles) - -openr,1,"../country_and_state_code.data" -k = 0l -i1 = 0 -i2 = 0 - -for n = 0l, N_Tiles -1l do begin -readf,1,k,i1,i2 -cnt_code (n) = i1 -st_code (n) = i2 -endfor -close,1 -us_ind = where (cnt_code eq 243) -cnt_code (us_ind) = st_code (us_ind) -cnt_code (where (cnt_code eq 257)) = !VALUES.F_NAN -tmp_data = 0 - -for j = 0l, jm -1l do begin - for i = 0l, im -1 do begin - if(tile_id[i,j] gt 0) then begin - cnt_grid(i,j) = cnt_code(tile_id[i,j] -1) + 1 - endif - endfor -endfor - -colors = indgen(256) -levels = colors -limits = [-60,-180,90,180] -thisDevice = !D.Name -set_plot,'Z' -Device, Set_Resolution=[800,400], Z_Buffer=0 -load_random_colors -Erase,255 -!p.background = 255 -!P.position=0 -!P.Multi = [0, 1, 1, 0, 0] - -MAP_SET,/CYLINDRICAL,/hires,color= 0,/NoErase,limit=limits,/ISOTROPIC,/NOBORDER -for j = 0l, jm -1l do begin - for i = 0l, im -1 do begin - if((cnt_grid[i,j] gt 0) and (cnt_grid[i,j] le 255)) then begin - yu = -90. + j*dy + dy - yl = -90. + j*dy - xl= -180. + i*dx - xr= -180. + i*dx +dx - xx=fltarr(5) - yy=fltarr(5) - xx=[xl,xl,xr,xr,xl] - yy=[yu,yl,yl,yu,yu] - oplot,[xl,xr],[yl,yl],color =cnt_grid[i,j] - endif - endfor -endfor - -MAP_CONTINENTS,/COASTS,color=0,MLINETHICK=2 -snapshot = TVRD() -TVLCT, r, g, b, /Get -Device, Z_Buffer=1 -Set_Plot, thisDevice -image24 = BytArr(3, 800,400) -image24[0,*,*] = r[snapshot] -image24[1,*,*] = g[snapshot] -image24[2,*,*] = b[snapshot] -Write_JPEG, 'Country_codes.jpg', image24, True=1, Quality=100 -end -; ==================================================================================== - -pro compute_zo, pname, SCALE4Z0, ASZ0, Z2CH, tile_id - -ncat = n_elements (Z2CH) - -; Reading LAI and computing Z0 -; ---------------------------- - -im = n_elements(tile_id[*,0]) -jm = n_elements(tile_id[0,*]) - -dx = 360. / im -dy = 180. / jm - -x = indgen(im)*dx -180. + dx/2. -y = indgen(jm)*dy -90. + dy/2. - -mdays = [31,28,31,30,31,30,31,31,30,31,30,31] - -zo_vec = fltarr (ncat, 4) -ndvi_vec = fltarr (ncat, 4) -ZOT = fltarr (NCAT) - -if (pname eq 'ascat') then goto, skip_lai - -lai_file = '../lai.dat' -ndvi_file = '../ndvi.dat' - -yr = 0. -mn = 0. -dy = 0. -dum = 0. -yr1 = 0. -mn1 = 0. -dy1 = 0. -yrg = 0. -mng = 0. -lai = fltarr (ncat) -lai1 = fltarr (ncat) -lai2 = fltarr (ncat) -ndvi = fltarr (ncat) -ndvi1 = fltarr (ncat) -ndvi2 = fltarr (ncat) - -openr,1,lai_file,/F77_UNFORMATTED -openr,2,ndvi_file,/F77_UNFORMATTED - -readu,1,yr,mn,dy,dum,dum,dum,yr1,mn1,dy1 -readu,1,lai1 -dofyr_b4 = ((float(julday(mn1,dy1,2001+yr1)-julday(12,31,2000))) - (float(julday(mn,dy,2001+yr)-julday(12,31,2000))))/2 + $ - float(julday(mn,dy,2001+yr)-julday(12,31,2000)) - -readu,1,yr,mn,dy,dum,dum,dum,yr1,mn1,dy1 -dofyr_nxt = ((float(julday(mn1,dy1,2001+yr1)-julday(12,31,2000))) - (float(julday(mn,dy,2001+yr)-julday(12,31,2000))))/2 + $ - float(julday(mn,dy,2001+yr)-julday(12,31,2000)) -readu,1,lai2 - -readu,2,yr,mn,dy,dum,dum,dum,yr1,mn1,dy1 -readu,2,ndvi1 -ndvi_b4 = ((float(julday(mn1,dy1,2001+yr1)-julday(12,31,2000))) - (float(julday(mn,dy,2001+yr)-julday(12,31,2000))))/2 + $ - float(julday(mn,dy,2001+yr)-julday(12,31,2000)) - -readu,2,yr,mn,dy,dum,dum,dum,yr1,mn1,dy1 -ndvi_nxt = ((float(julday(mn1,dy1,2001+yr1)-julday(12,31,2000))) - (float(julday(mn,dy,2001+yr)-julday(12,31,2000))))/2 + $ - float(julday(mn,dy,2001+yr)-julday(12,31,2000)) -readu,2,ndvi2 - - -for month = 1,12 do begin - lai_month = fltarr (ncat) - for day =1,mdays[month -1] do begin - dofyr_now = float(julday(month,day,2001+yr)-julday(12,31,2000)) - fac1 = (dofyr_now - dofyr_b4 )/(dofyr_nxt - dofyr_b4) - fac2 = (dofyr_nxt - dofyr_now)/(dofyr_nxt - dofyr_b4) - lai = fac1*lai2 + fac2*lai1 - - fac1 = (dofyr_now - ndvi_b4 )/(ndvi_nxt - ndvi_b4) - fac2 = (ndvi_nxt - dofyr_now)/(ndvi_nxt - ndvi_b4) - ndvi = fac1*ndvi2 + fac2*ndvi1 - -; ========================================================================================== -; Here is the roughness length parameterization -; ========================================================================================== - - for n = 0l,ncat -1l do ZOT(n) = Z0_VALUE(Z2CH(n), lai(n), SCALE4Z0) - - if((month eq 1) or (month eq 2) or (month eq 12)) then zo_vec (*,0) = zo_vec (*,0) + zot (*)/total (mdays ([11, 0, 1])) - if((month eq 3) or (month eq 4) or (month eq 5)) then zo_vec (*,1) = zo_vec (*,1) + zot (*)/total (mdays ([ 2, 3, 4])) - if((month eq 6) or (month eq 7) or (month eq 8)) then zo_vec (*,2) = zo_vec (*,2) + zot (*)/total (mdays ([ 5, 6, 7])) - if((month eq 9) or (month eq 10) or (month eq 11)) then zo_vec (*,3) = zo_vec (*,3) + zot (*)/total (mdays ([ 8, 9,10])) - - if((month eq 1) or (month eq 2) or (month eq 12)) then ndvi_vec (*,0) = ndvi_vec (*,0) + ndvi (*)/total (mdays ([11, 0, 1])) - if((month eq 3) or (month eq 4) or (month eq 5)) then ndvi_vec (*,1) = ndvi_vec (*,1) + ndvi (*)/total (mdays ([ 2, 3, 4])) - if((month eq 6) or (month eq 7) or (month eq 8)) then ndvi_vec (*,2) = ndvi_vec (*,2) + ndvi (*)/total (mdays ([ 5, 6, 7])) - if((month eq 9) or (month eq 10) or (month eq 11)) then ndvi_vec (*,3) = ndvi_vec (*,3) + ndvi (*)/total (mdays ([ 8, 9,10])) - - if(dofyr_now + 0.5 ge dofyr_nxt) then begin - lai1 = lai2 - dofyr_b4 = dofyr_nxt - readu,1,yr,mn,dy,dum,dum,dum,yr1,mn1,dy1 - dofyr_nxt = ((float(julday(mn1,dy1,2001+yr1)-julday(12,31,2000))) - (float(julday(mn,dy,2001+yr)-julday(12,31,2000))))/2 + $ - float(julday(mn,dy,2001+yr)-julday(12,31,2000)) - if((month eq 12) and (yr eq 2)) then yr = yr -1 - readu,1,lai2 - endif - - if(dofyr_now + 0.5 ge ndvi_nxt) then begin - ndvi1 = ndvi2 - ndvi_b4 = ndvi_nxt - readu,2,yr,mn,dy,dum,dum,dum,yr1,mn1,dy1 - ndvi_nxt = ((float(julday(mn1,dy1,2001+yr1)-julday(12,31,2000))) - (float(julday(mn,dy,2001+yr)-julday(12,31,2000))))/2 + $ - float(julday(mn,dy,2001+yr)-julday(12,31,2000)) - if((month eq 12) and (yr eq 2)) then yr = yr -1 - readu,2,ndvi2 - endif - - endfor -endfor - -close,1 -close,2 - -skip_lai: - -; now plotting -;------------- - -sea_label = ['DJF','MAM','JJA','SON'] - -thisDevice = !D.Name -set_plot,'Z' -Device, Set_Resolution=[720,600], Z_Buffer=0 -;Device, Set_Resolution=[720,500], Z_Buffer=0 -load_colors -Erase,255 -!p.background = 255 - -!P.position=0 -!P.Multi = [0, 1, 2, 0, 0] -;!P.Multi = [0, 1, 1, 0, 0] -;!P.Multi = [0, 2, 2, 0, 0] -limits = [-60,-180,90,180] - -colors = [74,77,35,34,33,32,25,24,23,22,21,20,41,42,43,44,45,46,47,48] -levels = [0.02,0.05,0.07,0.1,0.3,0.5,1,2,4,6,8,10,50,100,500,1000,2000,3000,4000,5000] -n_levels = n_elements (levels) - -for season = 0,3,2 do begin - - data_grid = fltarr (im,jm) - data_grid (*,*) = !VALUES.F_NAN - - for j = 0l, jm -1l do begin - for i = 0l, im -1 do begin - if(tile_id[i,j] gt 0) then begin - if (pname eq 'ascat') then data_grid(i,j) = asz0(tile_id[i,j] -1) - if (pname eq 'icarus') then data_grid(i,j) = 1000.*zo_vec(tile_id[i,j] -1, season) - if (pname eq 'merged') then begin - data_grid(i,j) = 1000.*zo_vec(tile_id[i,j] -1, season) - if(ndvi_vec(tile_id[i,j]-1, season) le 0.2) then data_grid(i,j) = asz0(tile_id[i,j] -1) - endif - endif - endfor - endfor - - if(season ge 1) then begin - MAP_SET,/CYLINDRICAL,/hires,color= 0,/NoErase,limit=limits,/ADVANCE,/NOBORDER,title=pname +' : '+ sea_label (season) - endif else begin - MAP_SET,/CYLINDRICAL,/hires,color= 0,/NoErase,limit=limits,/NOBORDER,title=pname +' : '+ sea_label (season) - endelse - - contour, data_grid,x,y,levels = levels,c_colors=colors,/cell_fill,/overplot - - alpha=fltarr(n_levels,2) - alpha(*,0)=levels - alpha(*,1)=levels - h=[0,1] - clev = levels - clev (*) = 1 - dx = (240.)/(n_levels-1) - - clev = levels - clev (*) = 1 - - k = 0 - for l = 0,n_levels -2 do begin - k = l - xbox = [-120. + k*dx,-120. + k*dx, -120. + (k+1)*dx, -120. + (k+1)*dx,-120. + k*dx] - ybox = [-65., -55.,-55.,-65.,-65.] - polyfill, xbox,ybox,color=colors [k] - if (l le 5) then xyouts,xbox[1],ybox[2]+0.05,string(levels[l],format='(f4.2)'),color =0, orientation =90,charsize =0.8 - if (l gt 5) then xyouts,xbox[1],ybox[2]+0.05,string(levels[l],format='(i4)'),color =0, orientation =90,charsize =0.8 - k = k + 1 - endfor - - for l = n_levels -1,n_levels -1 do begin - xyouts,-120. + l*dx,ybox[2]+0.05,string(levels[l],format='(i4)'),color =0, orientation =90,charsize =0.8 - endfor - -endfor - -snapshot = TVRD() -TVLCT, r, g, b, /Get -Device, Z_Buffer=1 -Set_Plot, thisDevice -image24 = BytArr(3, 720, 600) -image24[0,*,*] = r[snapshot] -image24[1,*,*] = g[snapshot] -image24[2,*,*] = b[snapshot] -Write_JPEG, pname + '_Z0.jpg', image24, True=1, Quality=100 - -end - -; ------------------------------------ - -;; This program is being deprecated, we don't have IDATA valid path -;pro proc_glass -; -; -;;IDATA = '/gpfsm/dnb43/projects/p03/RS_DATA/GLASS/LAI/AVHRR/V4/HDF/' -;;ODATA = '/discover/nobackup/projects/gmao/bcs_shared/make_bcs_inputs/land/veg/lai_grn/v4/GLASS-LAI/AVHRR.v4/' -;;LABEL = 'GLASS01B02.V04.A' -;;yearb = 1981 -;;YEARe = 2017 -; -;IDATA = '/gpfsm/dnb43/projects/p03/RS_DATA/GLASS/LAI/MODIS/V4/HDF/' -;ODATA = '/discover/nobackup/projects/gmao/bcs_shared/make_bcs_inputs/land/veg/lai_grn/v4/GLASS-LAI/MODIS.v4/' -;LABEL = 'GLASS01B01.V04.A' -;yearb = 2000 -;YEARe = 2017 -; -;nc = 7200 -;nr = 3600 -;nyrs = YEARe - yearb + 1 -; -;lwval = 0. -;upval = 7. -; -;im = nc -;jm = nr -; -;dx = 360. / im -;dy = 180. / jm -; -;x = indgen(im)*dx -180. + dx/2. -;y = indgen(jm)*dy -90. + dy/2. -;r_in = [253,224,255,238,205,193,152, 0,124, 0, 0, 0, 0, 0, 0, 48,110, 85] -;g_in = [253,238,255,238,205,255,251,255,252,255,238,205,139,128,100,128,139,107] -;b_in = [253,224, 0, 0, 0,193,152,127, 0, 0, 0, 0, 0, 0, 0, 20, 61, 47] -; -;n_levels = n_elements (r_in) -;levels=[0.,0.25,0.5,0.75,1.,1.25,1.5,10. * indgen(11)*0.05+2.] -;red = intarr (256) -;green= intarr (256) -;blue = intarr (256) -; -;red (255) = 255 -;green(255) = 255 -;blue (255) = 255 -; -;for k = 0, N_levels -1 do begin -; red (k+1) = r_in (k) -; green(k+1) = g_in (k) -; blue (k+1) = b_in (k) -;endfor -;thisDevice = !D.Name -;set_plot,'Z' -;Device, Set_Resolution=[800,500], Z_Buffer=0 -;TVLCT,red,green,blue -;colors = indgen (N_levels) + 1 -; -;limits = [-60,-180,90,180] -; -;Erase,255 -;!p.background = 255 -; -;;file1 = '/gpfsm/dnb43/projects/p03/RS_DATA/GLASS/LAI/MODIS/V4/HDF/2008/GLASS01B01.V04.A2008185.hdf' -;file1 = '/discover/nobackup/projects/gmao/bcs_shared/make_bcs_inputs/land/veg/lai_grn/v4/GLASS-LAI/MODIS.v4/GLASS01B01.V04.AYYYY105.nc4' -;ncid = ncdf_open (file1) -;NCDF_VARGET, ncid,'LAI', adum -;ncdf_close,ncid -; -;;FileID=HDF_SD_Start(file1, /read) -;;sds_id = hdf_sd_select(FileID, 0) -;;hdf_sd_getdata, sds_id,adum -;;HDF_SD_END, FileID -;adum (where (adum eq 2550)) = !VALUES.F_NAN -;adum = adum /100. -; -; -;MAP_SET,/CYLINDRICAL,/hires,color= 0,/NoErase,limit=limits -;MAP_CONTINENTS,/COASTS,color=0,MLINETHICK=2,/USA -;;contour, adum,x,y,levels = levels,c_colors=colors,/cell_fill -; -;snapshot = TVRD() -;TVLCT, r, g, b, /Get -;Device, Z_Buffer=1 -;Set_Plot, thisDevice -;image24 = BytArr(3, 800, 500) -;image24[0,*,*] = r[snapshot] -;image24[1,*,*] = g[snapshot] -;image24[2,*,*] = b[snapshot] -;Write_JPEG, 'global_map.jpg', image24, True=1, Quality=100 -;stop -; -;for DOY = 1,361,8 do begin -; LAI = intarr (nc,nr,nyrs) -; LAI (*,*,*) = 2550 -; DDD = string (DOY,'(i3.3)') -; for year = yearB, yearE do begin -; YYYY = string (year, '(i4.4)') -; filename = IDATA + YYYY + '/' + LABEL + yyyy + DDD + '.hdf' -; FileID=HDF_SD_Start(filename, /read) -; sds_id = hdf_sd_select(FileID, 0) -; hdf_sd_getdata, sds_id,adum -; adum = adum *10 -; HDF_SD_END, FileID -; print, year,min(adum), max(adum) -; LAI (*,*,year - yearB) = adum -; -; endfor -; -;indata = intarr (nc,nr) -;indata (*,*) = 2550 -; -;for j = 0, nr -1 do begin -; for i = 0, nc -1 do begin -; if(min (LAI (i,j,*)) lt 2550) then begin -; syears = where (LAI (i,j,*) lt 2550) -; indata (i,j) = mean (LAI (i,j,syears)) -; ; if(mean (LAI (i,j,syears)) gt 500.) then stop -; ; print, n_elements (syears), mean (LAI (i,j,syears)) -; endif -; endfor -;endfor -; -;print, min (indata), max(indata) -; -;ofile = ODATA + LABEL + 'YYYY' + DDD + '.nc4' -;write_glass_output, indata, ofile -; -;endfor -; -;end -; -;; ---------------------------------------------------------------- -; -; -;; This program is being deprecated, since it needs "pro proc_glass" - -;pro write_glass_output,indata,ofile -; -;nc = 7200 -;nr = 3600 -; -;id = NCDF_CREATE(ofile, /clobber) ;Create netCDF output file -;xid = NCDF_DIMDEF(id, 'N_lon', nc) ;Define x-dimension -;yid = NCDF_DIMDEF(id, 'N_lat', nr) ;Define y-dimension -;NCDF_ATTPUT,id, 'CellSize_arcmin' , 3,/global -;NCDF_ATTPUT,id, 'CreatedBy', 'Sarith Mahanama GSFC/NASA',/global -;NCDF_ATTPUT,id, 'Contact', 'Anyone from GMAO Land Group',/global -;str_date=systime() -;NCDF_ATTPUT,id, 'Date', str_date,/global -;vid = NCDF_VARDEF(id, 'lat', yid, /DOUBLE) ;Define latitude variable -;vid = NCDF_VARDEF(id, 'lon', xid, /DOUBLE) ;Define longitude variable -;vid = NCDF_VARDEF(id, 'LAI', [xid, yid], /SHORT) -;NCDF_ATTPUT, id, vid, 'LongName','Leaf Area Index 8-Day 0.05-degrees GEO Grid climatology' -;NCDF_ATTPUT, id, vid, 'units', 'm^2/m^2' -;NCDF_ATTPUT, id, vid, 'scale_factor',0.01 -;NCDF_ATTPUT, id, vid, 'valid_range','0 1000' -;NCDF_ATTPUT, id, vid, '_FillValue', 2550 -; -;NCDF_CONTROL, id, /ENDEF -; -;dxy = 360.d/7200.d -; -;x = indgen (nc)*dxy -180. + dxy/2.d -;y = indgen (nr)*dxy -90. + dxy/2.d -; -;NCDF_VARPUT, id,'lat', y -;NCDF_VARPUT, id,'lon', x -;for j =0, nr -1 do begin -;NCDF_VARPUT, id, 'LAI',offset=[0,nr-1 -j],count=[nc,1] , nint(indata [*,j]) -;endfor -;NCDF_CLOSE, id -; -;end - -; ------------------------------------------------------------------- - pro irrig_method, ncat, tile_id - -; Rerad 0.25-degree GRIPC and MIRCA data - -filename = '../irrig.dat' -limits = [-60.,-180.,90.,-180.] -if file_test ('limits.idl') then restore,'limits.idl' - -id = NCDF_OPEN (filename, /NOWRITE) - -NCDF_VARGET, id,'SPRINKLERFR',SPRINKLERV -NCDF_VARGET, id,'DRIPFR',DRIPV -NCDF_VARGET, id,'FLOODFR',FLOODV - -NCDF_CLOSE, id - -SPRINKLERV(where (SPRINKLERV gt 1.)) = !VALUES.F_NAN -DRIPV (where (DRIPV gt 1.)) = !VALUES.F_NAN -FLOODV (where (FLOODV gt 1.)) = !VALUES.F_NAN - -im = n_elements(tile_id[*,0]) -jm = n_elements(tile_id[0,*]) - -dx = 360. / im -dy = 180. / jm - -x = indgen(im)*dx -180. + dx/2. -y = indgen(jm)*dy -90. + dy/2. - -SPRINKLER = REPLICATE (!VALUES.F_NAN,IM, JM) -DRIP = REPLICATE (!VALUES.F_NAN,IM, JM) -FLOOD = REPLICATE (!VALUES.F_NAN,IM, JM) - -for j = 0l, jm -1l do begin - for i = 0l, im -1 do begin - if(tile_id[i,j] gt 0) then begin - SPRINKLER(i,j) = SPRINKLERV (tile_id[i,j] -1) - DRIP (i,j) = DRIPV (tile_id[i,j] -1) - FLOOD (i,j) = FLOODV (tile_id[i,j] -1) - endif - endfor -endfor - -SPRINKLER(where (SPRINKLER eq 0.)) = !VALUES.F_NAN -DRIP (where (DRIP eq 0.)) = !VALUES.F_NAN -FLOOD (where (FLOOD eq 0.)) = !VALUES.F_NAN - -colors = indgen (21) + 140 -levels = indgen (21)*0.1/2. - -position_row1 = [0.02, 0.70, 0.98, 0.95] -position_row2 = [0.02, 0.40, 0.98, 0.65] -position_row3 = [0.02, 0.10, 0.98, 0.35] - -position_col = [0.20, 0.02, 0.80, 0.05] - -thisDevice = !D.Name -set_plot,'Z' -Device, Set_Resolution=[850,1100], Z_Buffer=0,SET_FONT='Helvetica Bold', /TT_FONT -load_colors -;set_plot,'PS' -!P.font=0 -;Device, FILENAME= plotdir + 'IrrigMethod.ps',/color,/PORTRAIT,xsi=0.9*8.2, ysi=0.9*11.7, xoff=.7, yoff=.5, _extra=_extra,/INCHES -Erase,255 -!p.background = 255 -!P.position=0 - -MAP_SET,/CYLINDRICAL,/hires,color= 0,/NoErase,limit=limits , charsize = .9, title = 'SPRINKLER FRACTION', /noborder,/isotropic, position = position_row1 -contour,sprinkler,x,y,levels = levels,c_colors=colors,/cell_fill,/overplot -MAP_CONTINENTS,/COASTS,color=0,MLINETHICK=2 - -MAP_SET,/CYLINDRICAL,/hires,color= 0,/NoErase,limit=limits , charsize = .9, title = 'DRIP FRACTION', /noborder,/isotropic, position = position_row2 -contour,drip,x,y,levels = levels,c_colors=colors,/cell_fill,/overplot -MAP_CONTINENTS,/COASTS,color=0,MLINETHICK=2 - -MAP_SET,/CYLINDRICAL,/hires,color= 0,/NoErase,limit=limits , charsize = .9, title = 'FLOOD FRACTION', /noborder,/isotropic, position = position_row3 -contour,flood,x,y,levels = levels,c_colors=colors,/cell_fill,/overplot -MAP_CONTINENTS,/COASTS,color=0,MLINETHICK=2 - -colorbar,n_levels = 21, levels = levels, colors = colors, labels = levels, position = position_col -;DEVICE, /CLOSE -;Set_Plot, thisDevice -snapshot = TVRD() -TVLCT, r, g, b, /Get -Device, Z_Buffer=1 -Set_Plot, thisDevice -image24 = BytArr(3, 850, 1100) -image24[0,*,*] = r[snapshot] -image24[1,*,*] = g[snapshot] -image24[2,*,*] = b[snapshot] -Write_PNG, 'IrrigMethod.png' , image24 - -end -; --------------------------------------------------------------------------------------------- - - pro plot_lai_minmax, ncat, tile_id - -; Rerad 0.25-degree GRIPC and MIRCA data - -filename = '../irrig.dat' -limits = [-60.,-180.,90.,-180.] -if file_test ('limits.idl') then restore,'limits.idl' - -id = NCDF_OPEN (filename, /NOWRITE) - -NCDF_VARGET, id,'LAIMIN',LAI_MNV -NCDF_VARGET, id,'LAIMAX',LAI_MXV - -NCDF_CLOSE, id - -LAI_MNV (where (LAI_MNV gt 100.)) = !VALUES.F_NAN -LAI_MXV (where (LAI_MXV gt 100.)) = !VALUES.F_NAN - -im = n_elements(tile_id[*,0]) -jm = n_elements(tile_id[0,*]) - -dx = 360. / im -dy = 180. / jm - -x = indgen(im)*dx -180. + dx/2. -y = indgen(jm)*dy -90. + dy/2. - -LAI_MN = REPLICATE (!VALUES.F_NAN,IM, JM) -LAI_MX = REPLICATE (!VALUES.F_NAN,IM, JM) -for j = 0l, jm -1l do begin - for i = 0l, im -1 do begin - if(tile_id[i,j] gt 0) then begin - LAI_MN(i,j) = LAI_MNV (tile_id[i,j] -1) - LAI_MX(i,j) = LAI_MXV (tile_id[i,j] -1) - endif - endfor -endfor -LAI_MN (where (LAI_MN eq 0.)) = !VALUES.F_NAN -LAI_MX (where (LAI_MX eq 0.)) = !VALUES.F_NAN - -thisDevice = !D.Name -set_plot,'Z' -Device, Set_Resolution=[850,1100], Z_Buffer=0,SET_FONT='Helvetica Bold', /TT_FONT - -load_colors -r_in = [253,224,255,238,205,193,152, 0,124, 0, 0, 0, 0, 0, 0, 48,110, 85] -g_in = [253,238,255,238,205,255,251,255,252,255,238,205,139,128,100,128,139,107] -b_in = [253,224, 0, 0, 0,193,152,127, 0, 0, 0, 0, 0, 0, 0, 20, 61, 47] - -n_levels = n_elements (r_in) -levels=[0.,0.25,0.5,0.75,1.,1.25,1.5,10. * indgen(11)*0.05+2.] -red = intarr (256) -green= intarr (256) -blue = intarr (256) - -red (255) = 255 -green(255) = 255 -blue (255) = 255 - -for k = 0, N_levels -1 do begin - red (k+1) = r_in (k) - green(k+1) = g_in (k) - blue (k+1) = b_in (k) -endfor - -TVLCT,red,green,blue - -colors = indgen (N_levels) + 1 - -position_row1 = [0.02, 0.50, 0.98, 0.95] -position_row2 = [0.02, 0.10, 0.98, 0.45] - -position_col = [0.20, 0.02, 0.80, 0.05] - - -Erase,255 -!p.background = 255 -!P.position=0 - -MAP_SET,/CYLINDRICAL,/hires,color= 0,/NoErase,limit=limits , charsize = 1.5, title = 'LAI Minimum', /noborder,/isotropic, position = position_row1 -contour,LAI_MN,x,y,levels = levels,c_colors=colors,/cell_fill,/overplot -MAP_CONTINENTS,/COASTS,color=0,MLINETHICK=2 - -MAP_SET,/CYLINDRICAL,/hires,color= 0,/NoErase,limit=limits , charsize = 1.5, title = 'LAI Maximum', /noborder,/isotropic, position = position_row2 -contour,LAI_MX,x,y,levels = levels, c_colors=colors,/cell_fill,/overplot -MAP_CONTINENTS,/COASTS,color=0,MLINETHICK=2 -!P.position= position_col -alpha=fltarr(n_levels,2) -alpha(*,0)=levels -alpha(*,1)=levels -h=[0,1] - -dx = (240.)/(n_levels-1) - -clev = levels -clev (*) = 1 -contour,alpha,levels,h,levels=levels,c_colors=colors,/fill,/xstyle,/ystyle, $ - /noerase,yticks=1,ytickname=[' ',' '] ,xrange=[min(levels),max(levels)], $ - xtitle=' ', color=0,xtickv=levels, $ - C_charsize=1.0, charsize=0.5 ,xtickformat = "(A1)" -contour,alpha,levels,h,levels=levels,color=0,/overplot,c_label=clev - for k = 0,n_elements(colors) -1 do xyouts,levels[k],1.1,string(levels[k],format='(f4.2)') ,orientation=90,color=0,charsize =0.8 - - -snapshot = TVRD() -TVLCT, r, g, b, /Get -Device, Z_Buffer=1 -Set_Plot, thisDevice -image24 = BytArr(3, 850, 1100) -image24[0,*,*] = r[snapshot] -image24[1,*,*] = g[snapshot] -image24[2,*,*] = b[snapshot] -Write_PNG, 'LAI_minmax.png' , image24 - -end -; --------------------------------------------------------------------------------------------- - - pro irrig_fractions, ncat, tile_id - -; Rerad 0.25-degree GRIPC and MIRCA data -filename = '../irrig.dat' -limits = [-60.,-180.,90.,-180.] -if file_test ('limits.idl') then restore,'limits.idl' - -id = NCDF_OPEN (filename, /NOWRITE) - -NCDF_VARGET, id,'IRRIGFRAC',IRRIGFRACV -NCDF_VARGET, id,'PADDYFRAC',PADDYFRACV -NCDF_VARGET, id,'RAINFEDFRAC',RAINFEDFRACV - -NCDF_CLOSE, id - -IRRIGFRACV (where (IRRIGFRACV gt 1.)) = !VALUES.F_NAN -PADDYFRACV (where (PADDYFRACV gt 1.)) = !VALUES.F_NAN -RAINFEDFRACV(where (RAINFEDFRACV gt 1.)) = !VALUES.F_NAN - -im = n_elements(tile_id[*,0]) -jm = n_elements(tile_id[0,*]) - -dx = 360. / im -dy = 180. / jm - -x = indgen(im)*dx -180. + dx/2. -y = indgen(jm)*dy -90. + dy/2. - -IRRIGFRAC = REPLICATE (!VALUES.F_NAN,IM, JM) -PADDYFRAC = REPLICATE (!VALUES.F_NAN,IM, JM) -RAINFEDFRAC = REPLICATE (!VALUES.F_NAN,IM, JM) - -for j = 0l, jm -1l do begin - for i = 0l, im -1 do begin - if(tile_id[i,j] gt 0) then begin - IRRIGFRAC (i,j) = IRRIGFRACV (tile_id[i,j] -1) - PADDYFRAC (i,j) = PADDYFRACV (tile_id[i,j] -1) - RAINFEDFRAC(i,j) = RAINFEDFRACV (tile_id[i,j] -1) - endif - endfor -endfor - -IRRIGFRAC (where (IRRIGFRAC eq 0.)) = !VALUES.F_NAN -PADDYFRAC (where (PADDYFRAC eq 0.)) = !VALUES.F_NAN -RAINFEDFRAC(where (RAINFEDFRAC eq 0.)) = !VALUES.F_NAN - -colors = indgen (21) + 140 -levels = indgen (21)*0.05/2. - -position_row1 = [0.02, 0.70, 0.98, 0.95] -position_row2 = [0.02, 0.40, 0.98, 0.65] -position_row3 = [0.02, 0.10, 0.98, 0.35] - -position_col = [0.20, 0.02, 0.80, 0.05] - -thisDevice = !D.Name -set_plot,'Z' -Device, Set_Resolution=[850,1100], Z_Buffer=0,SET_FONT='Helvetica Bold', /TT_FONT -Erase,255 -!p.background = 255 -!P.position=0 - -MAP_SET,/CYLINDRICAL,/hires,color= 0,/NoErase,limit=limits , charsize = 1.5, title = 'IRRIGATED CROP FRACTION', /noborder,/isotropic, position = position_row1 -contour,irrigfrac,x,y,levels = levels,c_colors=colors,/cell_fill,/overplot -MAP_CONTINENTS,/COASTS,color=0,MLINETHICK=2 - -MAP_SET,/CYLINDRICAL,/hires,color= 0,/NoErase,limit=limits , charsize = 1.5, title = 'PADDY FRACTION', /noborder,/isotropic, position = position_row2 -contour,paddyfrac,x,y,levels = levels, c_colors=colors,/cell_fill,/overplot -MAP_CONTINENTS,/COASTS,color=0,MLINETHICK=2 - -MAP_SET,/CYLINDRICAL,/hires,color= 0,/NoErase,limit=limits , charsize = 1.5, title = 'RAINFED FRACTION', /noborder,/isotropic, position = position_row3 -contour,rainfedfrac,x,y,levels = levels,c_colors=colors,/cell_fill,/overplot -MAP_CONTINENTS,/COASTS,color=0,MLINETHICK=2 - - -colorbar,n_levels = 21, levels = levels, colors = colors, labels = levels, position = position_col - -snapshot = TVRD() -TVLCT, r, g, b, /Get -Device, Z_Buffer=1 -Set_Plot, thisDevice -image24 = BytArr(3, 850, 1100) -image24[0,*,*] = r[snapshot] -image24[1,*,*] = g[snapshot] -image24[2,*,*] = b[snapshot] -Write_PNG, 'GIA-Hybrid_IrrigFracs.png' , image24 - -end - -; ------------------------------------------------------------------------------------------- - -pro plot_crop_times, ncat, tile_id - - -filename = '../irrig.dat' -limits = [-60.,-180.,90.,-180.] -if file_test ('limits.idl') then restore,'limits.idl' - -id = NCDF_OPEN (filename, /NOWRITE) - -NCDF_VARGET, id,'IRRIGPLANT',plantv -NCDF_VARGET, id,'IRRIGHARVEST',harvestv -NCDF_VARGET, id,'CROPIRRIGFRAC',Fracv -NCDF_VARGET, id,'IRRIGTYPE',irrigtypev -NCDF_VARGET, id,'CROPCLASSNAME',cropname -NCDF_CLOSE, id - -cropname = string (cropname) - -im = n_elements(tile_id[*,0]) -jm = n_elements(tile_id[0,*]) - -dx = 360. / im -dy = 180. / jm - -xx = indgen(im)*dx -180. + dx/2. -yy = indgen(jm)*dy -90. + dy/2. -x = fltarr (IM,JM) -y = fltarr (IM,JM) -PLANT = REPLICATE (!VALUES.F_NAN,IM, JM, 2, 26) -HARVEST = REPLICATE (!VALUES.F_NAN,IM, JM, 2, 26) -FRAC = REPLICATE (!VALUES.F_NAN,IM, JM, 26) -IRRIGTYPE = REPLICATE (!VALUES.F_NAN,IM, JM, 26) - -for j = 0l, jm -1l do begin - for i = 0l, im -1 do begin - x (i,j) = xx(i) - y (i,j) = yy(j) - if(tile_id[i,j] gt 0) then begin - PLANT (i,j,*,*) = PLANTV (tile_id[i,j] -1,*,*) - HARVEST (i,j,*,*) = HARVESTV (tile_id[i,j] -1,*,*) - FRAC (i,j,*) = FRACV (tile_id[i,j] -1,*) - IRRIGTYPE(i,j,*) = IRRIGTYPEV (tile_id[i,j] -1,*) - endif - endfor -endfor -;for n = 0, 25 do begin -; data1 = frac (*,*,n) -; data2 = plant (*,*,0,n) -; data3 = harvest (*,*,0,n) -; for j = 0, nr - 1 do begin -; for i = 0, nc -1 do begin -; if (mask (i,j) gt 0.5) then begin -; -; if((Plant (I,J,0,n) gt 400) and (frac (i,j,n) gt 0.)) then begin -; print , i,j, n,Plant (I,J,0,0:3), frac (i,j,0:3) -; if((data2 (I,J) gt 400) and (data1 (i,j) gt 0.)) then begin -; print , i,j, n,data2 (I,J), data1 (i,j) -; -; endif -; endif -; endfor -; endfor -;endfor - -;fmask = where (frac gt 0.) -;frac (where (frac eq 0.)) = !VALUES.F_NAN -;plant (where (plant gt 400)) = !VALUES.F_NAN -;harvest (where (harvest gt 400)) = !VALUES.F_NAN -;stop - -colors = indgen (21) + 140 -levels = indgen (21)*0.05/2. -DOY = [ 1, 32, 60, 91, 121, 152, 182, 213, 244, 274, 305, 335, 366, 370] -DOYM = [15, 46, 74, 105, 135, 166, 196, 227, 258, 288, 319, 349, 366, 370] -DOYL = [15, 46, 74, 105, 135, 166, 196, 227, 258, 288, 319, 349, 366, 370] -ITYP = [1,2,3,4] -colors2= [69, 145, 64, 66, 70, 71,73,75,76, 78, 80, 113, 114, 116, 117] -colors3 = [69, 64,80] -row_dims1 = [0.10, 0.32, 0.54, 0.76] -row_dims2 = [0.27, 0.49, 0.71, 0.96] -;col_dmis1 = [0.02, 0.34, 0.66] -;col_dmis2 = [0.34, 0.66, 0.98] -col_dmis1 = [0.02, 0.25, 0.50, 0.75] -col_dmis2 = [0.25, 0.50, 0.75, 0.98] - -;position_col1 = [0.04, 0.02, 0.32, 0.05] -;position_col2 = [0.38, 0.02, 0.92, 0.05] -position_col1 = [0.04, 0.02, 0.32, 0.05] -position_col2 = [0.38, 0.02, 0.68, 0.05] -position_col3 = [0.70, 0.02, 0.92, 0.05] - -page = 1 -Row = 1 -A=findgen(16)*(!PI*2/16.) -usersym,0.1*cos(a),0.1*sin(a),/fill -thisDevice = !D.Name - -set_plot,'Z' -Device, Set_Resolution=[850,1100], Z_Buffer=0,SET_FONT='Helvetica Bold', /TT_FONT -load_colors -;set_plot,'PS' -;!P.font=0 -;Device, FILENAME= plotdir + 'gia_irrig_params.ps',/color,/PORTRAIT,xsi=0.9*8.2, ysi=0.9*11.7, xoff=.7, yoff=.5, _extra=_extra,/INCHES -Erase,255 -!p.background = 255 -!P.position=0 - -for n = 0, 25 do begin - - if (row eq 1) then begin - thisDevice = !D.Name - set_plot,'Z' - Device, Set_Resolution=[850,1100], Z_Buffer=0,SET_FONT='Helvetica Bold', /TT_FONT - Erase,255 - !p.background = 255 - !P.position=0 - endif - - data1 = frac (*,*,n) - fmask = where (data1 gt 0.) - this = plant (*,*,0,n) - data2 = this (fmask) - this = harvest (*,*,0,n) - data3 = this (fmask) - this = irrigtype (*,*,n) - data4 = this (fmask) - lons = x (fmask) - lats = y (fmask) - - data1 (where (data1 le 0)) = !VALUES.F_NAN - - for col = 0,3 do begin - print, col - if (col eq 0) then begin - ptitle = ' : frac' - data_grid = data1 - endif - - if (col eq 1) then begin - ptitle = ' : DOY plant' - data_grid = data2 - endif - - if (col eq 2) then begin - ptitle = ' : DOY harvest' - data_grid = data3 - endif - - if (col eq 3) then begin - ptitle = ' : IRRIGTYPE' - data_grid = data4 - endif - - plot_position = [col_dmis1(col),row_dims1(row-1), col_dmis2(col),row_dims2(row-1)] - print, col, row, plot_position - MAP_SET,/CYLINDRICAL,/hires,color= 0,/NoErase,limit=limits , charsize = 0.8, title = cropname(n) + ptitle, /noborder, position = plot_position - - if(col eq 0) then begin - contour,data_grid,x,y,levels = levels,c_colors=colors,/cell_fill,/overplot - endif else if (col eq 3) then begin - for i = 0l, n_elements (data_grid) -1l do begin - if(data_grid(i) gt 0.) then oplot,[lons(i), lons(i)], [lats(i), lats(i)],psym=8,color= colors3(value_locate (ITYP,data_grid(i))) - endfor - endif else begin - for i = 0l, n_elements (data_grid) -1l do begin - if((data_grid(i) gt 0.) and (data_grid(i) le 366.)) then oplot,[lons(i), lons(i)], [lats(i), lats(i)],psym=8,color= colors2(value_locate (doy,data_grid(i))) - endfor - - endelse - - MAP_CONTINENTS,/COASTS,color=0,MLINETHICK=2 - - endfor - - row = row + 1 - - if (row eq 5) then begin - - colorbar,n_levels = 21, levels = levels, colors = colors, labels = levels, position = position_col1 - colorbar,n_levels = n_elements (DOY), levels = DOY, colors = colors2, labels = DOY, position = position_col2 - colorbar,n_levels = 4, levels = [1,2,3,4], colors = colors3, labels = ['Sprinkler', 'Drip', 'Flood',''], position = position_col3 -; ERASE - snapshot = TVRD() - TVLCT, r, g, b, /Get - Device, Z_Buffer=1 - Set_Plot, thisDevice - image24 = BytArr(3, 850, 1100) - image24[0,*,*] = r[snapshot] - image24[1,*,*] = g[snapshot] - image24[2,*,*] = b[snapshot] - Write_PNG, 'gia_irrig_params_' + string (page, '(i2.2)') + '.png' , image24 - - row = 1 - page = page + 1 - - endif - - this = plant (*,*,1,n) - data2 = this (fmask) - - if(max (data2) gt 0) then begin - if (row eq 1) then begin - thisDevice = !D.Name - set_plot,'Z' - Device, Set_Resolution=[850,1100], Z_Buffer=0,SET_FONT='Helvetica Bold', /TT_FONT - Erase,255 - !p.background = 255 - !P.position=0 - endif - - this = plant (*,*,1,n) - data2 = this (fmask) - this = harvest (*,*,1,n) - data3 = this (fmask) - - for col = 0,2 do begin - if (col eq 0) then begin - ptitle = ' : frac' - data_grid = data1 - endif - - if (col eq 1) then begin - ptitle = ' : DOY plant' - data_grid = data2 - endif - - if (col eq 2) then begin - ptitle = ' : DOY harvest' - data_grid = data3 - endif - - plot_position = [col_dmis1(col),row_dims1(row-1), col_dmis2(col),row_dims2(row-1)] - print, col, row, plot_position - MAP_SET,/CYLINDRICAL,/hires,color= 0,/NoErase,limit=limits , charsize = 0.8, title = cropname(n) + ptitle, /noborder, position = plot_position - if(col eq 0) then begin - contour,data_grid,x,y,levels = levels,c_colors=colors,/cell_fill,/overplot - endif else if (col eq 3) then begin - for i = 0l, n_elements (data_grid) -1l do begin - if(data_grid(i) gt 0.) then oplot,[lons(i), lons(i)], [lats(i), lats(i)],psym=8,color= colors3(value_locate (ITYP,data_grid(i))) - endfor - endif else begin - for i = 0l, n_elements (data_grid) -1l do begin - if((data_grid(i) gt 0.) and (data_grid(i) le 366.)) then oplot,[lons(i), lons(i)], [lats(i), lats(i)],psym=8,color= colors2(value_locate (doy,data_grid(i))) - endfor - endelse - - MAP_CONTINENTS,/COASTS,color=0,MLINETHICK=2 - - endfor - row = row + 1 - - if (row eq 5) then begin - - colorbar,n_levels = 21, levels = levels, colors = colors, labels = levels, position = position_col1 - colorbar,n_levels = n_elements (DOY), levels = DOY, colors = colors2, labels = DOY, position = position_col2 - colorbar,n_levels = 4, levels = [1,2,3,4], colors = colors3, labels = ['Sprinkler', 'Drip', 'Flood',''], position = position_col3 -; ERASE - snapshot = TVRD() - TVLCT, r, g, b, /Get - Device, Z_Buffer=1 - Set_Plot, thisDevice - image24 = BytArr(3, 850, 1100) - image24[0,*,*] = r[snapshot] - image24[1,*,*] = g[snapshot] - image24[2,*,*] = b[snapshot] - Write_PNG, 'gia_irrig_params_' + string (page, '(i2.2)') + '.png' , image24 - - row = 1 - page = page + 1 - - endif - endif -endfor - -;DEVICE, /CLOSE -;Set_Plot, thisDevice -end -; ========================================================================= - -pro colorbar,n_levels = n_levels, levels = levels, colors = colors, labels = labels,$ - position = position, vertical= vertical, horizontal = horizontal - - IF KEYWORD_SET(vertical) THEN BEGIN - - !P.position=[position(2) + 0.02, position(1) ,position(2) + 0.05, position(3)] - - alpha=fltarr(2,n_levels) - alpha(0,*)=levels - alpha(1,*)=levels - h=[-1,1] - clev = levels - clev (*) = 1 - k = 0 - - levelsx = indgen (N_levels) - - contour,alpha,h,levelsx,levels=levels,c_colors=colors,/fill,/xstyle,/ystyle, $ - /noerase,xticks=1, xtickname=[' ',' '] ,yrange=[min(levelsx),max(levelsx)], $ - ytitle=' ', color=0, $ - C_charsize=1.0, charsize=0.5 ,xtickformat = "(A1)",ytickformat = "(A1)" - contour,alpha,h,levelsx,levels=levels,color=0,/overplot,c_label=clev - for k = 0,n_elements(levels) -1 do xyouts,1.1, levelsx[k],labels(k) ,color=0,charsize =1.2 - - endif else begin - -; !P.position=[position(0) +0.1, position(1)-0.06 ,position(2) - 0.1, position(1)-0.04] - !P.position=[0.15, 0.01, 0.85, 0.04] - IF KEYWORD_SET(position) then !P.position=position ; - - alpha=fltarr(n_levels,2) - alpha(*,0)=levels - alpha(*,1)=levels - h=[0,1] - clev = levels - clev (*) = 1 - k = 0 - - levelsx = indgen (N_levels) - - contour,alpha,levelsx,h,levels=levels,c_colors=colors,/fill,/xstyle,/ystyle, $ - /noerase,yticks=1, ytickname=[' ',' '] ,xrange=[min(levelsx),max(levelsx)], $ - xtitle=' ', color=0, $ - C_charsize=1.0, charsize=0.5 ,xtickformat = "(A1)",ytickformat = "(A1)" - contour,alpha,levelsx,h,levels=levels,color=0,/overplot,c_label=clev - - if(n_levels eq 4) then begin - - for k = 0,n_elements(levels) -1 do xyouts, levelsx[k],1.1, strtrim(labels(k)), color=0,charsize =0.8,orientation=90 - endif else begin - if(max (labels) le 1.) then begin - for k = 0,n_elements(levels) -1 do xyouts, levelsx[k],1.1,string(labels(k),'(f5.2)') ,color=0,charsize =0.8,orientation=90 - - endif else begin - for k = 0,n_elements(levels) -1 do xyouts, levelsx[k],1.1,string(labels(k),'(i3.3)') ,color=0,charsize =0.8,orientation=90 - endelse - endelse - endelse - - !P.position=0 - -end From bc21abb3cb9407440314a2d2508595a7a1c9da92 Mon Sep 17 00:00:00 2001 From: bzhao Date: Mon, 15 Jun 2026 12:52:14 -0400 Subject: [PATCH 15/40] DataAtmosphere needs to skip this connection --- GEOS_GcmGridComp.F90 | 16 ++++++++-------- 1 file changed, 8 insertions(+), 8 deletions(-) diff --git a/GEOS_GcmGridComp.F90 b/GEOS_GcmGridComp.F90 index d7aa45d4d1..d090d5869e 100644 --- a/GEOS_GcmGridComp.F90 +++ b/GEOS_GcmGridComp.F90 @@ -575,15 +575,15 @@ subroutine SetServices ( GC, RC ) SRC_ID = AGCM, & RC=STATUS ) VERIFY_(STATUS) - endif - call MAPL_AddConnectivity ( GC, & - SHORT_NAME = (/'QLTOT', 'QITOT', 'QRTOT', & - 'QSTOT', 'QGTOT'/), & - DST_ID = AIAU, & - SRC_ID = AGCM, & - RC=STATUS ) - VERIFY_(STATUS) + call MAPL_AddConnectivity ( GC, & + SHORT_NAME = (/'QLTOT', 'QITOT', 'QRTOT', & + 'QSTOT', 'QGTOT'/), & + DST_ID = AIAU, & + SRC_ID = AGCM, & + RC=STATUS ) + VERIFY_(STATUS) + endif if (DO_CICE_THERMO == 2) then call MAPL_AddConnectivity ( GC, & From bb949bdf2437d39a30a241c07c236b973ca342ed Mon Sep 17 00:00:00 2001 From: William Putman Date: Mon, 15 Jun 2026 16:07:44 -0400 Subject: [PATCH 16/40] more ZD merging, still something about the SRF_TYPE_LAND section that I'm not happy about --- .../GEOS_GFDL_1M_InterfaceMod.F90 | 2 - .../GEOSmoist_GridComp/Process_Library.F90 | 231 +++++++++--------- 2 files changed, 110 insertions(+), 123 deletions(-) diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/GEOS_GFDL_1M_InterfaceMod.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/GEOS_GFDL_1M_InterfaceMod.F90 index ae499e991c..8a8ed8d784 100644 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/GEOS_GFDL_1M_InterfaceMod.F90 +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/GEOS_GFDL_1M_InterfaceMod.F90 @@ -325,8 +325,6 @@ subroutine GFDL_1M_Initialize (MAPL, CF, CLOCK, IMPORT, EXPORT, RC) call MAPL_GetResource( MAPL, SH_MD_DP , 'SH_MD_DP:' , DEFAULT= .TRUE., RC=STATUS); VERIFY_(STATUS) - call MAPL_GetResource( MAPL, constrain_modis_ice, 'constrain_modis_ice:', DEFAULT= .FALSE., RC=STATUS); VERIFY_(STATUS) - call MAPL_GetResource( MAPL, TURNRHCRIT_PARAM, 'TURNRHCRIT:' , DEFAULT= -9999., RC=STATUS); VERIFY_(STATUS) call MAPL_GetResource( MAPL, MAX_RH_CRIT , 'MAX_RH_CRIT:' , DEFAULT= 1.0000, RC=STATUS); VERIFY_(STATUS) call MAPL_GetResource( MAPL, MIN_RH_UNSTABLE , 'MIN_RH_UNSTABLE:' , DEFAULT= 0.9750, RC=STATUS); VERIFY_(STATUS) diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/Process_Library.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/Process_Library.F90 index 66c7adb8fd..3b080c9428 100644 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/Process_Library.F90 +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/Process_Library.F90 @@ -42,32 +42,56 @@ module GEOSmoist_Process_Library integer, parameter :: SRF_TYPE_LANDICE = 4 ! ICE_FRACTION constants - logical :: constrain_modis_ice = .FALSE. ! In anvil/convective clouds - real, parameter :: aT_ICE_ALL = 252.16 - real, parameter :: aT_ICE_MAX = 268.16 + real, parameter :: aT_ICE_ALL = 243.66 + real, parameter :: aT_ICE_MAX = 265.66 real, parameter :: aICEFRPWR = 2.0 - ! Over snow SRF_TYPE = 2 and over ice SRF_TYPE = 3 + ! Over Land Ice SRF_TYPE == 4 + real, parameter :: liT_ICE_ALL = 233.16 + real, parameter :: liT_ICE_MAX = 258.16 + real, parameter :: liICEFRPWR = 6.0 + ! Over Ice SRF_TYPE == 3 real, parameter :: iT_ICE_ALL = 236.16 real, parameter :: iT_ICE_MAX = 261.16 - real, parameter :: iICEFRPWR = 5.0 + real, parameter :: iICEFRPWR = 4.0 + ! Over Snow SRF_TYPE = 2 + real, parameter :: sT_ICE_ALL = 235.16 + real, parameter :: sT_ICE_MAX = 260.16 + real, parameter :: sICEFRPWR = 6.0 ! Over Land SRF_TYPE = 1 - real, parameter :: lT_ICE_ALL = 239.16 - real, parameter :: lT_ICE_MAX = 261.16 + real, parameter :: lT_ICE_ALL = 240.16 + real, parameter :: lT_ICE_MAX = 262.16 real, parameter :: lICEFRPWR = 2.0 ! Over Oceans SRF_TYPE = 0 real, parameter :: oT_ICE_ALL = 238.16 real, parameter :: oT_ICE_MAX = 263.16 - real, parameter :: oICEFRPWR = 4.0 - ! Jason + real, parameter :: oICEFRPWR = 3.0 + + ! Jason constants ! In anvil/convective clouds real, parameter :: JaT_ICE_ALL = 245.16 real, parameter :: JaT_ICE_MAX = 261.16 real, parameter :: JaICEFRPWR = 2.0 - ! Over snow/ice - real, parameter :: JiT_ICE_ALL = MAPL_TICE-40.0 - real, parameter :: JiT_ICE_MAX = MAPL_TICE - real, parameter :: JiICEFRPWR = 4.0 + ! Over Land Ice SRF_TYPE == 4 + real, parameter :: JliT_ICE_ALL = 236.16 + real, parameter :: JliT_ICE_MAX = 261.16 + real, parameter :: JliICEFRPWR = 5.0 + ! Over Ice SRF_TYPE == 3 + real, parameter :: JiT_ICE_ALL = 236.16 + real, parameter :: JiT_ICE_MAX = 261.16 + real, parameter :: JiICEFRPWR = 5.0 + ! Over Snow SRF_TYPE = 2 + real, parameter :: JsT_ICE_ALL = 236.16 + real, parameter :: JsT_ICE_MAX = 261.16 + real, parameter :: JsICEFRPWR = 5.0 + ! Over Land SRF_TYPE = 1 + real, parameter :: JlT_ICE_ALL = 239.16 + real, parameter :: JlT_ICE_MAX = 261.16 + real, parameter :: JlICEFRPWR = 2.0 + ! Over Oceans SRF_TYPE = 0 + real, parameter :: JoT_ICE_ALL = 238.16 + real, parameter :: JoT_ICE_MAX = 263.16 + real, parameter :: JoICEFRPWR = 4.0 ! parameters real, parameter :: EPSILON = MAPL_H2OMW/MAPL_AIRMW @@ -275,7 +299,6 @@ module GEOSmoist_Process_Library public :: AerPropsNew, copy_AerProp, init_AerProp public :: AeroPropsNew public :: CNV_Tracer_Type, CNV_Tracers, CNV_Tracers_Init - public :: constrain_modis_ice public :: SRF_TYPE_OCEAN, SRF_TYPE_LAND, SRF_TYPE_SNOW, SRF_TYPE_ICE, SRF_TYPE_LANDICE public :: ICE_FRACTION, EVAP3, SUBL3, LDRADIUS4, BUOYANCY, BUOYANCY2 public :: REDISTRIBUTE_CLOUDS_SCALAR, REDISTRIBUTE_CLOUDS, RADCOUPLE_SCALE_AWARE, RADCOUPLE, FIX_UP_CLOUDS @@ -650,6 +673,7 @@ function ICE_FRACTION_SC (TEMP,CNV_FRACTION,SRF_TYPE) RESULT(ICEFRCT) real :: ICEFRCT real :: tc, ptc real :: ICEFRCT_C, ICEFRCT_M, ICEFRCT_PHYS + real :: t_all_loc, t_max_loc, pwr_loc #ifdef USE_MODIS_ICE_POLY ! Use MODIS polynomial from Hu et al, DOI: (10.1029/2009JD012384) @@ -657,136 +681,101 @@ function ICE_FRACTION_SC (TEMP,CNV_FRACTION,SRF_TYPE) RESULT(ICEFRCT) ptc = 7.6725 + 1.0118*tc + 0.1422*tc**2 + 0.0106*tc**3 + 0.000339*tc**4 + 0.00000395*tc**5 ICEFRCT = 1.0 - (1.0/(1.0 + exp(-1*ptc))) #else - ! Use sigmoidal functions based on surface type from Hu et al, DOI: (10.1029/2009JD012384) - ! Anvil clouds - ! Anvil-Convective sigmoidal function like figure 6(right) - ! Sigmoidal functions Hu et al 2010, doi:10.1029/2009JD012384 + ! ------------------------------------------------------------------ + ! 1. Convective / Anvil Cloud Ice Fraction (ICEFRCT_C) + ! ------------------------------------------------------------------ + ! Select the correct constants based on parameterization if (ICE_RADII_PARAM == 1) then - ! Jason formula - ICEFRCT_C = 0.00 - if ( TEMP <= JaT_ICE_ALL ) then - ICEFRCT_C = 1.000 - else if ( (TEMP > JaT_ICE_ALL) .AND. (TEMP <= JaT_ICE_MAX) ) then - ICEFRCT_C = SIN( 0.5*MAPL_PI*( 1.00 - ( TEMP - JaT_ICE_ALL ) / ( JaT_ICE_MAX - JaT_ICE_ALL ) ) ) - end if + t_all_loc = JaT_ICE_ALL + t_max_loc = JaT_ICE_MAX + pwr_loc = JaICEFRPWR else - ICEFRCT_C = 0.00 - if ( TEMP <= aT_ICE_ALL ) then - ICEFRCT_C = 1.000 - else if ( (TEMP > aT_ICE_ALL) .AND. (TEMP <= aT_ICE_MAX) ) then - ICEFRCT_C = SIN( 0.5*MAPL_PI*( 1.00 - ( TEMP - aT_ICE_ALL ) / ( aT_ICE_MAX - aT_ICE_ALL ) ) ) - end if + t_all_loc = aT_ICE_ALL + t_max_loc = aT_ICE_MAX + pwr_loc = aICEFRPWR end if - ICEFRCT_C = MIN(ICEFRCT_C,1.00) - ICEFRCT_C = MAX(ICEFRCT_C,0.00) - ICEFRCT_C = ICEFRCT_C**aICEFRPWR - ! Sigmoidal functions like figure 6b/6c of Hu et al 2010, doi:10.1029/2009JD012384 + + ! Calculate ICEFRCT_C once + ICEFRCT_C = 0.00 + if ( TEMP <= t_all_loc ) then + ICEFRCT_C = 1.000 + else if ( TEMP <= t_max_loc ) then + ICEFRCT_C = SIN( 0.5*MAPL_PI*( 1.00 - ( TEMP - t_all_loc ) / ( t_max_loc - t_all_loc ) ) ) + end if + ICEFRCT_C = MAX(0.00, MIN(1.00, ICEFRCT_C)) ** pwr_loc + + ! ------------------------------------------------------------------ + ! 2. Grid-Scale / Mesh Cloud Ice Fraction (ICEFRCT_M) + ! ------------------------------------------------------------------ + ! Select the correct constants based on surface type and parameterization select case (nint(SRF_TYPE)) - case (SRF_TYPE_SNOW, SRF_TYPE_ICE, SRF_TYPE_LANDICE) - ! Over snow (SRF_TYPE == 2.0) and ice (SRF_TYPE >= 3.0) + case (SRF_TYPE_LANDICE) + t_all_loc = JliT_ICE_ALL + t_max_loc = JliT_ICE_MAX + pwr_loc = JliICEFRPWR ICEFRCT_M = 0.00 - if ( TEMP <= iT_ICE_ALL ) then + if ( TEMP <= t_all_loc ) then ICEFRCT_M = 1.000 - else if ( (TEMP > iT_ICE_ALL) .AND. (TEMP <= iT_ICE_MAX) ) then - ICEFRCT_M = SIN( 0.5*MAPL_PI*( 1.00 - ( TEMP - iT_ICE_ALL ) / ( iT_ICE_MAX - iT_ICE_ALL ) ) ) + else if ( (TEMP > t_all_loc) .AND. (TEMP <= t_max_loc) ) then + ICEFRCT_M = SIN( 0.5*MAPL_PI*( 1.00 - ( TEMP - t_all_loc ) / ( t_max_loc - t_all_loc ) ) ) end if - ICEFRCT_M = MIN(ICEFRCT_M,1.00) - ICEFRCT_M = MAX(ICEFRCT_M,0.00) - ICEFRCT_M = ICEFRCT_M**iICEFRPWR - case (SRF_TYPE_LAND) - ! Over Land (SRF_TYPE == 1) + ICEFRCT_M = MAX(0.00, MIN(1.00, ICEFRCT_M)) ** pwr_loc + case (SRF_TYPE_ICE) + t_all_loc = JiT_ICE_ALL + t_max_loc = JiT_ICE_MAX + pwr_loc = JiICEFRPWR ICEFRCT_M = 0.00 - if ( TEMP <= lT_ICE_ALL ) then + if ( TEMP <= t_all_loc ) then ICEFRCT_M = 1.000 - else if ( (TEMP > lT_ICE_ALL) .AND. (TEMP <= lT_ICE_MAX) ) then - ICEFRCT_M = SIN( 0.5*MAPL_PI*( 1.00 - ( TEMP - lT_ICE_ALL ) / ( lT_ICE_MAX - lT_ICE_ALL ) ) ) + else if ( (TEMP > t_all_loc) .AND. (TEMP <= t_max_loc) ) then + ICEFRCT_M = SIN( 0.5*MAPL_PI*( 1.00 - ( TEMP - t_all_loc ) / ( t_max_loc - t_all_loc ) ) ) end if - ICEFRCT_M = MIN(ICEFRCT_M,1.00) - ICEFRCT_M = MAX(ICEFRCT_M,0.00) - ICEFRCT_M = ICEFRCT_M**lICEFRPWR - case (SRF_TYPE_OCEAN) - ! Over Oceans (SRF_TYPE == 0) + ICEFRCT_M = MAX(0.00, MIN(1.00, ICEFRCT_M)) ** pwr_loc + case (SRF_TYPE_SNOW) + t_all_loc = JsT_ICE_ALL + t_max_loc = JsT_ICE_MAX + pwr_loc = JsICEFRPWR ICEFRCT_M = 0.00 - if ( TEMP <= oT_ICE_ALL ) then + if ( TEMP <= t_all_loc ) then ICEFRCT_M = 1.000 - else if ( (TEMP > oT_ICE_ALL) .AND. (TEMP <= oT_ICE_MAX) ) then - ICEFRCT_M = SIN( 0.5*MAPL_PI*( 1.00 - ( TEMP - oT_ICE_ALL ) / ( oT_ICE_MAX - oT_ICE_ALL ) ) ) + else if ( (TEMP > t_all_loc) .AND. (TEMP <= t_max_loc) ) then + ICEFRCT_M = SIN( 0.5*MAPL_PI*( 1.00 - ( TEMP - t_all_loc ) / ( t_max_loc - t_all_loc ) ) ) + end if + ICEFRCT_M = MAX(0.00, MIN(1.00, ICEFRCT_M)) ** pwr_loc + case (SRF_TYPE_LAND) + t_all_loc = JlT_ICE_ALL + t_max_loc = JlT_ICE_MAX + pwr_loc = JlICEFRPWR + ICEFRCT_M = 0.00 + if ( TEMP <= JlT_ICE_ALL ) then + ICEFRCT_M = 1.000 + else if ( (TEMP > JlT_ICE_ALL) .AND. (TEMP <= JlT_ICE_MAX) ) then + ICEFRCT_M = SIN( 0.5*MAPL_PI*( 1.00 - ( TEMP - JlT_ICE_ALL ) / ( JlT_ICE_MAX - JlT_ICE_ALL ) ) ) end if ICEFRCT_M = MIN(ICEFRCT_M,1.00) ICEFRCT_M = MAX(ICEFRCT_M,0.00) - ICEFRCT_M = ICEFRCT_M**oICEFRPWR + ICEFRCT_M = ICEFRCT_M**JlICEFRPWR + case (SRF_TYPE_OCEAN) + t_all_loc = JoT_ICE_ALL + t_max_loc = JoT_ICE_MAX + pwr_loc = JoICEFRPWR + ICEFRCT_M = 0.00 + if ( TEMP <= t_all_loc ) then + ICEFRCT_M = 1.000 + else if ( TEMP <= t_max_loc ) then + ICEFRCT_M = SIN( 0.5*MAPL_PI*( 1.00 - ( TEMP - t_all_loc ) / ( t_max_loc - t_all_loc ) ) ) + end if + ICEFRCT_M = MAX(0.00, MIN(1.00, ICEFRCT_M)) ** pwr_loc case default ! You should not be here print *, 'ICE_FRACTION_SC: Unknown SRF_TYPE = ',SRF_TYPE error stop end select + ! Combine the Convective and MODIS functions - ICEFRCT = ICEFRCT_M*(1.0-CNV_FRACTION) + ICEFRCT_C*(CNV_FRACTION) + ICEFRCT = ICEFRCT_M*(1.0-CNV_FRACTION) + ICEFRCT_C*(CNV_FRACTION) #endif - if (constrain_modis_ice) then - - ! ===================================================================== - ! NEW: Apply thermodynamic constraints - ! Ensures ice fraction doesn't violate physical laws while respecting - ! MODIS observations where physically reasonable - ! ===================================================================== - - ! Compute physics-based minimum ice fraction - ICEFRCT_PHYS = 0.0 - - if (TEMP < 235.0) then - ! Below -38°C: Homogeneous nucleation temperature - ! All supercooled liquid droplets freeze spontaneously - ! This is a thermodynamic law, not negotiable - ICEFRCT_PHYS = 1.0 - - elseif (TEMP < 238.0) then - ! -38°C to -35°C: Transition to 100% ice - ! Very rapid heterogeneous nucleation, essentially all ice - ICEFRCT_PHYS = 0.975 + 0.025 * (238.0 - TEMP) / 3.0 - - elseif (TEMP < 243.0) then - ! -35°C to -30°C: Should be 90-97.5% ice - ! Laboratory and aircraft observations show predominantly ice - ICEFRCT_PHYS = 0.90 + 0.075 * (243.0 - TEMP) / 5.0 - - elseif (TEMP < 248.0) then - ! -30°C to -25°C: Should be 80-90% ice - ! Mixed phase possible but ice dominant - ICEFRCT_PHYS = 0.80 + 0.10 * (248.0 - TEMP) / 5.0 - - elseif (TEMP < 253.0) then - ! -25°C to -20°C: Should be 65-80% ice - ! Active heterogeneous nucleation, ice favored - ICEFRCT_PHYS = 0.65 + 0.15 * (253.0 - TEMP) / 5.0 - - elseif (TEMP < 258.0) then - ! -20°C to -15°C: Should be 45-65% ice - ! True mixed phase regime - ICEFRCT_PHYS = 0.45 + 0.20 * (258.0 - TEMP) / 5.0 - - elseif (TEMP < 263.0) then - ! -15°C to -10°C: Should be 25-45% ice - ! Mixed phase, liquid becomes more common - ICEFRCT_PHYS = 0.25 + 0.20 * (263.0 - TEMP) / 5.0 - - elseif (TEMP < 268.0) then - ! -10°C to -5°C: Mixed phase, 10-25% ice - ! Supercooled liquid droplets stable - ICEFRCT_PHYS = 0.10 + 0.15 * (268.0 - TEMP) / 5.0 - - else - ! Above -5°C: MODIS parameterization is fine - ICEFRCT_PHYS = 0.0 - endif - - ! Take maximum of MODIS-based and physics-based ice fraction - ! This preserves MODIS accuracy where valid, applies constraints where needed - ICEFRCT = MAX(ICEFRCT, ICEFRCT_PHYS) - - endif - ! Final bounds check ICEFRCT = MIN(1.0, MAX(0.0, ICEFRCT)) From 66f1637c051bf5375daa2768fcd40f92e29890eb Mon Sep 17 00:00:00 2001 From: William Putman Date: Mon, 15 Jun 2026 16:21:09 -0400 Subject: [PATCH 17/40] UW updates ZD for L72 --- .../GEOS_UW_InterfaceMod.F90 | 409 +++++++++++------- .../GEOSmoist_GridComp/uwshcu.F90 | 12 +- 2 files changed, 263 insertions(+), 158 deletions(-) diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/GEOS_UW_InterfaceMod.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/GEOS_UW_InterfaceMod.F90 index 8c7aef153b..482f554ff4 100644 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/GEOS_UW_InterfaceMod.F90 +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/GEOS_UW_InterfaceMod.F90 @@ -140,22 +140,21 @@ subroutine UW_Initialize (MAPL, CF, CLOCK, IMPORT, EXPORT, RC) else call MAPL_GetResource(MAPL, SHLWPARAMS%WINDSRCAVG, 'WINDSRCAVG:' ,DEFAULT=1, RC=STATUS) ; VERIFY_(STATUS) call MAPL_GetResource(MAPL, SHLWPARAMS%MIXSCALE, 'MIXSCALE:' ,DEFAULT=3000.0, RC=STATUS) ; VERIFY_(STATUS) - call MAPL_GetResource(MAPL, SHLWPARAMS%MIXSCALE_HR, 'MIXSCALE_HR:' ,DEFAULT=3000.0, RC=STATUS) ; VERIFY_(STATUS) - call MAPL_GetResource(MAPL, SHLWPARAMS%CRIQC, 'CRIQC:' ,DEFAULT=0.9e-3, RC=STATUS) ; VERIFY_(STATUS) + call MAPL_GetResource(MAPL, SHLWPARAMS%CRIQC, 'CRIQC:' ,DEFAULT=3.0e-3, RC=STATUS) ; VERIFY_(STATUS) call MAPL_GetResource(MAPL, SHLWPARAMS%THLSRC_FAC, 'THLSRC_FAC:' ,DEFAULT= 1.0, RC=STATUS) ; VERIFY_(STATUS) call MAPL_GetResource(MAPL, SHLWPARAMS%QTSRC_FAC, 'QTSRC_FAC:' ,DEFAULT= 0.0, RC=STATUS) ; VERIFY_(STATUS) call MAPL_GetResource(MAPL, SHLWPARAMS%QTSRCHGT, 'QTSRCHGT:' ,DEFAULT= 0.0, RC=STATUS) ; VERIFY_(STATUS) - call MAPL_GetResource(MAPL, SHLWPARAMS%RKFRE, 'RKFRE:' ,DEFAULT= 1.0, RC=STATUS) ; VERIFY_(STATUS) - call MAPL_GetResource(MAPL, SHLWPARAMS%RKFRE_HR, 'RKFRE_HR:' ,DEFAULT= 1.0, RC=STATUS) ; VERIFY_(STATUS) - call MAPL_GetResource(MAPL, SHLWPARAMS%RKM, 'RKM:' ,DEFAULT= 12.0, RC=STATUS) ; VERIFY_(STATUS) + call MAPL_GetResource(MAPL, SHLWPARAMS%RKFRE, 'RKFRE:' ,DEFAULT= 1.5, RC=STATUS) ; VERIFY_(STATUS) + call MAPL_GetResource(MAPL, SHLWPARAMS%RKFRE_HR, 'RKFRE_HR:' ,DEFAULT= 0.75, RC=STATUS) ; VERIFY_(STATUS) + call MAPL_GetResource(MAPL, SHLWPARAMS%RKM, 'RKM:' ,DEFAULT= 8.0, RC=STATUS) ; VERIFY_(STATUS) call MAPL_GetResource(MAPL, SHLWPARAMS%RKM_HR, 'RKM_HR:' ,DEFAULT= 12.0, RC=STATUS) ; VERIFY_(STATUS) - call MAPL_GetResource(MAPL, SHLWPARAMS%RMAXFRAC, 'RMAXFRAC:' ,DEFAULT= 0.1, RC=STATUS) ; VERIFY_(STATUS) + call MAPL_GetResource(MAPL, SHLWPARAMS%RMAXFRAC, 'RMAXFRAC:' ,DEFAULT= 0.25, RC=STATUS) ; VERIFY_(STATUS) call MAPL_GetResource(MAPL, SHLWPARAMS%RMAXFRAC_HR, 'RMAXFRAC_HR:' ,DEFAULT= 0.1, RC=STATUS) ; VERIFY_(STATUS) call MAPL_GetResource(MAPL, SHLWPARAMS%FRC_RASN, 'FRC_RASN:' ,DEFAULT= 0.0, RC=STATUS) ; VERIFY_(STATUS) - call MAPL_GetResource(MAPL, SHLWPARAMS%RPEN, 'RPEN:' ,DEFAULT= 3.0, RC=STATUS) ; VERIFY_(STATUS) + call MAPL_GetResource(MAPL, SHLWPARAMS%RPEN, 'RPEN:' ,DEFAULT= 1.5, RC=STATUS) ; VERIFY_(STATUS) call MAPL_GetResource(MAPL, SCLM_SHALLOW, 'SCLM_SHALLOW:' ,DEFAULT= 1.0, RC=STATUS) ; VERIFY_(STATUS) call MAPL_GetResource(MAPL, SHLWPARAMS%NITER_XC, 'NITER_XC:' ,DEFAULT=2, RC=STATUS) ; VERIFY_(STATUS) - call MAPL_GetResource(MAPL, USE_EIS, 'UW_USE_EIS:' ,DEFAULT=.FALSE.,RC=STATUS) ; VERIFY_(STATUS) + call MAPL_GetResource(MAPL, USE_EIS, 'UW_USE_EIS:' ,DEFAULT=.TRUE., RC=STATUS) ; VERIFY_(STATUS) endif call MAPL_GetResource(MAPL, SHLWPARAMS%ITER_CIN, 'ITER_CIN:' ,DEFAULT=2, RC=STATUS) ; VERIFY_(STATUS) call MAPL_GetResource(MAPL, SHLWPARAMS%USE_CINCIN, 'USE_CINCIN:' ,DEFAULT=1, RC=STATUS) ; VERIFY_(STATUS) @@ -215,7 +214,7 @@ subroutine UW_Run (GC, IMPORT, EXPORT, CLOCK, RC) real, pointer, dimension(:,:) :: TPERT_SC, QPERT_SC, LTS, EIS real, pointer, dimension(:,:) :: CBMF_SC, PLCL_SC, PLFC_SC, & PINV_SC, PREL_SC, PBUP_SC, & - CLDTOP_SC + CLDTOP_SC, SC_QT, SC_MSE #ifdef UWDIAG real, pointer, dimension(:,:) :: CIN_SC, CNT_SC, CNB_SC, & WLCL_SC, QTSRC_SC, THLSRC_SC, & @@ -241,7 +240,7 @@ subroutine UW_Run (GC, IMPORT, EXPORT, CLOCK, RC) type (ESMF_TimeInterval) :: TINT real(ESMF_KIND_R8) :: DT_R8 real :: UW_DT, MOIST_DT - real :: SIG + real :: DX, SIG, mix2d_phys type(ESMF_Alarm) :: alarm logical :: alarm_is_ringing type( ESMF_VM ) :: VMG @@ -251,6 +250,7 @@ subroutine UW_Run (GC, IMPORT, EXPORT, CLOCK, RC) real :: fac_eis ! Estimated enversion strength 0:1 factor real :: rkfre_base ! Base fractional entrainment rate before EIS modification real :: rkm_base ! Base momentum entrainment rate before EIS modification + real :: rkm_scale_fac real :: mix2d_base ! Base mixing length scale before EIS modification real :: rmaxfrac_base ! Base maximum updraft area fraction before EIS modification real :: eis_rkfre_factor ! EIS modification factor for RKFRE [0-1] @@ -258,7 +258,7 @@ subroutine UW_Run (GC, IMPORT, EXPORT, CLOCK, RC) real :: eis_mix2d_factor ! EIS modification factor for MIX2D [0-1] real :: eis_rmaxfrac_factor ! EIS modification factor for RMAXFRAC [1.0-1.1] - integer :: I, J, L + integer :: I, J, L, K integer :: IM,JM,LM call MAPL_GetObjectFromGC ( GC, MAPL, RC=STATUS); VERIFY_(STATUS) @@ -351,8 +351,9 @@ subroutine UW_Run (GC, IMPORT, EXPORT, CLOCK, RC) call MAPL_pybridge_gcrun_with_internal( "pyMoist.fortran.param_interfaces.convection.UW_interface", MAPL, IMPORT, EXPORT, INTERNAL ) call CNV_Tracers_To_AOS() else - ! Internals - call MAPL_GetPointer(INTERNAL, CUSH, 'CUSH' , RC=STATUS); VERIFY_(STATUS) + ! Internals + call MAPL_GetPointer(INTERNAL, CUSH, 'CUSH' , RC=STATUS); VERIFY_(STATUS) + endif ! USE_PYMOIST_UW ! Imports call MAPL_GetPointer(IMPORT, FRLAND ,'FRLAND' ,RC=STATUS); VERIFY_(STATUS) @@ -380,15 +381,48 @@ subroutine UW_Run (GC, IMPORT, EXPORT, CLOCK, RC) ALLOCATE ( RMAXFRAC2D (IM,JM) ) ! Derived States - PKE = (PLE/MAPL_P00)**(MAPL_KAPPA) - PL = 0.5*(PLE(:,:,0:LM-1) + PLE(:,:,1:LM)) - PK = (PL/MAPL_P00)**(MAPL_KAPPA) - DO L=0,LM - ZLE0(:,:,L)= ZLE(:,:,L) - ZLE(:,:,LM) ! Edge Height (m) above the surface - END DO - ZL0 = 0.5*(ZLE0(:,:,0:LM-1) + ZLE0(:,:,1:LM) ) ! Layer Height (m) above the surface - DP = ( PLE(:,:,1:LM)-PLE(:,:,0:LM-1) ) - MASS = DP/MAPL_GRAV + !-------------------------------------------------------------- + + ! 1. Compute the top-of-atmosphere edge (k = 0) + !$OMP PARALLEL DO DEFAULT(NONE) & + !$OMP SHARED(IM, JM, LM, PKE, PLE, ZLE0, ZLE) & + !$OMP PRIVATE(i, j) + do j = 1, JM + !DIR$ IVDEP + do i = 1, IM + PKE(i,j,0) = (PLE(i,j,0) / MAPL_P00)**(MAPL_KAPPA) + ZLE0(i,j,0) = ZLE(i,j,0) - ZLE(i,j,LM) + end do + end do + !$OMP END PARALLEL DO + + ! 2. Compute the remaining edges and all layer variables (k = 1 to LM) + !$OMP PARALLEL DO DEFAULT(NONE) & + !$OMP SHARED(IM, JM, LM, PKE, PLE, PL, PK, & + !$OMP ZLE0, ZLE, ZL0, DP, MASS) & + !$OMP PRIVATE(i, j, k) + do k = 1, LM + do j = 1, JM + !DIR$ IVDEP + do i = 1, IM + + ! Edge variables + PKE(i,j,k) = (PLE(i,j,k) / MAPL_P00)**(MAPL_KAPPA) + ZLE0(i,j,k) = ZLE(i,j,k) - ZLE(i,j,LM) + + ! Layer variables + PL(i,j,k) = 0.5 * (PLE(i,j,k-1) + PLE(i,j,k)) + PK(i,j,k) = (PL(i,j,k) / MAPL_P00)**(MAPL_KAPPA) + + ZL0(i,j,k) = 0.5 * (ZLE0(i,j,k-1) + ZLE0(i,j,k)) + + DP(i,j,k) = PLE(i,j,k) - PLE(i,j,k-1) + MASS(i,j,k) = DP(i,j,k) / MAPL_GRAV + + end do + end do + end do + !$OMP END PARALLEL DO call ESMF_ClockGetAlarm(clock, 'UW_RunAlarm', alarm, RC=STATUS); VERIFY_(STATUS) alarm_is_ringing = ESMF_AlarmIsRinging(alarm, RC=STATUS); VERIFY_(STATUS) @@ -425,57 +459,82 @@ subroutine UW_Run (GC, IMPORT, EXPORT, CLOCK, RC) call MAPL_GetPointer(EXPORT, UFLX_SC, 'UFLX_SC' , ALLOC=.TRUE., RC=STATUS); VERIFY_(STATUS) call MAPL_GetPointer(EXPORT, VFLX_SC, 'VFLX_SC' , ALLOC=.TRUE., RC=STATUS); VERIFY_(STATUS) - if (JASON_UW) then - RKFRE = SHLWPARAMS%RKFRE - RKM2D = SHLWPARAMS%RKM - MIX2D = SHLWPARAMS%MIXSCALE - RMAXFRAC2D = SHLWPARAMS%RMAXFRAC - else - ! resolution dependent throttle on UW via TKE and scaling of cloud-base mass flux - call MAPL_GetPointer(IMPORT, PTR2D, 'AREA', RC=STATUS); VERIFY_(STATUS) - do J=1,JM - do I=1,IM - fac_eis = 0.0 - if (USE_EIS) fac_eis = get_fac_eis(EIS(i,j),srf_type(i,j)) ! Estimated inversion strength determine stable regime - SIG = SIGMA(SQRT(PTR2D(i,j))) ! Coarse -> Fine - - ! Base resolution-dependent parameters - ! Support for varying UW parameters by resolution ! Coarse*SIG -> Fine*(1.0-SIG) - rkfre_base = SHLWPARAMS%RKFRE *SIG + SHLWPARAMS%RKFRE_HR *(1.0-SIG) - rkm_base = SHLWPARAMS%RKM *SIG + SHLWPARAMS%RKM_HR *(1.0-SIG) - mix2d_base = SHLWPARAMS%MIXSCALE*SIG + SHLWPARAMS%MIXSCALE_HR*(1.0-SIG) - rmaxfrac_base = SHLWPARAMS%RMAXFRAC*SIG + SHLWPARAMS%RMAXFRAC_HR*(1.0-SIG) - - ! EIS-based regime modifications for marine stratocumulus enhancement - ! Reduce shallow convection activity in high EIS (stable inversion) regions - eis_rkfre_factor = 1.0 - 0.8*fac_eis ! Reduce RKFRE by up to 80% in stable regimes - eis_rkm_factor = 1.0 + 0.4*fac_eis ! Increase RKM by up to 40% in stable regimes - eis_mix2d_factor = 1.0 - 0.3*fac_eis ! Reduce mixing scale by up to 30% in stable regimes - eis_rmaxfrac_factor = 1.0 + 0.1*fac_eis ! INCREASE rmaxfrac in stable (high EIS) regimes - - ! Apply EIS modifications - RKFRE(i,j) = rkfre_base * eis_rkfre_factor - RKM2D(i,j) = rkm_base * eis_rkm_factor - MIX2D(i,j) = mix2d_base * eis_mix2d_factor - RMAXFRAC2D(i,j) = rmaxfrac_base * eis_rmaxfrac_factor - - ! Optional: Add minimum limits to prevent unrealistically low values - RKFRE(i,j) = max(RKFRE(i,j), 0.1) ! Minimum RKFRE threshold - RKM2D(i,j) = min(RKM2D(i,j), 14.0) ! Maximum RKM threshold - MIX2D(i,j) = max(MIX2D(i,j), 1500.0) ! Minimum mixing scale threshold - RMAXFRAC2D(i,j) = max(min(RMAXFRAC2D(i,j), 0.8), 0.05) ! Bounds: 5% to 80% - enddo - enddo - endif - - ! combine condensates for input (not updated within UW) + ! 1. Fetch all pointers first + !-------------------------------------------------------------- + call MAPL_GetPointer(IMPORT, PTR2D, 'AREA', RC=STATUS); VERIFY_(STATUS) call MAPL_GetPointer(EXPORT, QLTOT, 'QLTOT', ALLOC=.TRUE., RC=STATUS); VERIFY_(STATUS) call MAPL_GetPointer(EXPORT, QITOT, 'QITOT', ALLOC=.TRUE., RC=STATUS); VERIFY_(STATUS) - QLTOT = QLLS+QLCN - QITOT = QILS+QICN - DQLDT_SC = QLTOT - DQIDT_SC = QITOT - + + ! 2. 2D parameters for UW + !-------------------------------------------------------------- + !$OMP PARALLEL DO DEFAULT(NONE) & + !$OMP SHARED(IM, JM, JASON_UW, SHLWPARAMS, RKFRE, RKM2D, MIX2D, RMAXFRAC2D, & + !$OMP USE_EIS, EIS, srf_type, PTR2D, ZL0, KPBL_SC) & + !$OMP PRIVATE(i, j, fac_eis, DX, SIG, rkm_scale_fac, mix2d_phys, rkfre_base, rkm_base, & + !$OMP rmaxfrac_base, eis_rkfre_factor, eis_rkm_factor, eis_rmaxfrac_factor) + do j = 1, JM + !DIR$ IVDEP + do i = 1, IM + if (JASON_UW) then + RKFRE(i,j) = SHLWPARAMS%RKFRE + RKM2D(i,j) = SHLWPARAMS%RKM + MIX2D(i,j) = SHLWPARAMS%MIXSCALE + RMAXFRAC2D(i,j) = SHLWPARAMS%RMAXFRAC + else + fac_eis = 0.0 + if (USE_EIS) fac_eis = get_fac_eis(EIS(i,j), srf_type(i,j)) + DX = SQRT(PTR2D(i,j)) + SIG = SIGMA(DX) + + ! (If RKM=4.0, multiplier is 2.5. If RKM=8.0, multiplier is 5.0) + rkm_scale_fac = (SHLWPARAMS%RKM / 4.0) * 2.5 + + ! This ensures the dominant eddies scale with the PBL thickness and RKM + mix2d_phys = MAX(rkm_scale_fac * ZL0(i,j,KPBL_SC(i,j)), 1000.0 ) + + ! The subgrid mixing scale cannot exceed half the grid box + MIX2D(i,j) = MIN(0.5*DX, mix2d_phys, SHLWPARAMS%MIXSCALE) + + ! Base resolution-dependent parameters + rkfre_base = SHLWPARAMS%RKFRE * SIG + SHLWPARAMS%RKFRE_HR * (1.0 - SIG) + rkm_base = SHLWPARAMS%RKM * SIG + SHLWPARAMS%RKM_HR * (1.0 - SIG) + rmaxfrac_base = SHLWPARAMS%RMAXFRAC * SIG + SHLWPARAMS%RMAXFRAC_HR * (1.0 - SIG) + + ! EIS-based regime modifications + eis_rkfre_factor = 1.0 - 0.8 * fac_eis + eis_rkm_factor = 1.0 + 0.4 * fac_eis + eis_rmaxfrac_factor = 1.0 + 0.1 * fac_eis + + ! Apply EIS modifications + RKFRE(i,j) = rkfre_base * eis_rkfre_factor + RKM2D(i,j) = rkm_base * eis_rkm_factor + RMAXFRAC2D(i,j) = rmaxfrac_base * eis_rmaxfrac_factor + + ! Optional: Add minimum limits + RKFRE(i,j) = max(RKFRE(i,j), 0.1) + RKM2D(i,j) = min(RKM2D(i,j), 14.0) + RMAXFRAC2D(i,j) = max(min(RMAXFRAC2D(i,j), 0.8), 0.05) + end if + end do + end do + !$OMP END PARALLEL DO + + ! 3. Combine condensates for input (not updated within UW) + !-------------------------------------------------------------- + !$OMP PARALLEL DO DEFAULT(NONE) & + !$OMP SHARED(IM, JM, LM, QLTOT, QLLS, QLCN, QITOT, QILS, QICN) & + !$OMP PRIVATE(i, j, k) + do k = 1, LM + do j = 1, JM + !DIR$ IVDEP + do i = 1, IM + QLTOT(i,j,k) = QLLS(i,j,k) + QLCN(i,j,k) + QITOT(i,j,k) = QILS(i,j,k) + QICN(i,j,k) + end do + end do + end do + !$OMP END PARALLEL DO + ! Call UW shallow convection !---------------------------------------------------------------- call compute_uwshcu_inv(IM*JM, LM, UW_DT, & ! IN @@ -483,7 +542,7 @@ subroutine UW_Run (GC, IMPORT, EXPORT, CLOCK, RC) U, V, Q, QLTOT, QITOT, T, TKE, RKFRE, KPBL_SC,& SH, EVAP, CNPCPRATE, FRLAND, RKM2D, MIX2D, RMAXFRAC2D, & CUSH, & ! INOUT - UMF_SC, DCM_SC, DQVDT_SC, & ! OUT + UMF_SC, DCM_SC, DQVDT_SC, DQLDT_SC, DQIDT_SC, & ! OUT DTDT_SC, DUDT_SC, DVDT_SC, DQRDT_SC, & DQSDT_SC, CUFRC_SC, ENTR_SC, DETR_SC, & QLDET_SC, QIDET_SC, QLSUB_SC, QISUB_SC, & @@ -501,98 +560,146 @@ subroutine UW_Run (GC, IMPORT, EXPORT, CLOCK, RC) #endif USE_TRACER_TRANSP_UW) - ! Calculate detrained mass flux + ! 1. Fetch ALL pointers at the top !-------------------------------------------------------------- - if (JASON_MFD_SC) then - where (DETR_SC.ne.MAPL_UNDEF) - MFD_SC = 0.5*(UMF_SC(:,:,1:LM)+UMF_SC(:,:,0:LM-1))*DETR_SC*DP - elsewhere - MFD_SC = 0.0 - end where - else - MFD_SC = DCM_SC - endif - DQADT_SC= MFD_SC*SCLM_SHALLOW/MASS - ! Convert detrained water units before passing to cloud - !--------------------------------------------------------------- - call MAPL_GetPointer(EXPORT, QLENT_SC, 'QLENT_SC', ALLOC=.TRUE., RC=STATUS); VERIFY_(STATUS) - call MAPL_GetPointer(EXPORT, QIENT_SC, 'QIENT_SC', ALLOC=.TRUE., RC=STATUS); VERIFY_(STATUS) - QLENT_SC = 0. - QIENT_SC = 0. - WHERE (QLDET_SC.lt.0.) - QLENT_SC = QLDET_SC - QLDET_SC = 0. - END WHERE - WHERE (QIDET_SC.lt.0.) - QIENT_SC = QIDET_SC - QIDET_SC = 0. - END WHERE - ! scale the detrained fluxes before exporting - QLDET_SC = QLDET_SC*MASS - QIDET_SC = QIDET_SC*MASS - ! Precipitation + call MAPL_GetPointer(EXPORT, QLENT_SC, 'QLENT_SC', ALLOC=.TRUE., RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT, QIENT_SC, 'QIENT_SC', ALLOC=.TRUE., RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT, SC_QT, 'SC_QT', RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT, SC_MSE, 'SC_MSE', RC=STATUS); VERIFY_(STATUS) + + ! 2. Fused 3D Loop for Detrainment and Conversions !-------------------------------------------------------------- - call MAPL_GetPointer(EXPORT, PTR3D, 'SHLW_PRC3', ALLOC=.TRUE., RC=STATUS); VERIFY_(STATUS) - if (associated(PTR3D)) PTR3D = DQRDT_SC ! [kg/kg/s] - call MAPL_GetPointer(EXPORT, PTR3D, 'SHLW_SNO3', ALLOC=.TRUE., RC=STATUS); VERIFY_(STATUS) - if (associated(PTR3D)) PTR3D = DQSDT_SC ! [kg/kg/s] - - ! Additional exports - call MAPL_GetPointer(EXPORT, PTR2D, 'SC_QT', RC=STATUS); VERIFY_(STATUS) - if (associated(PTR2D)) then - ! column integral of UW total water tendency, for checking conservation - PTR2D = 0. - DO L = 1,LM - PTR2D = PTR2D + ( DQSDT_SC(:,:,L)+DQRDT_SC(:,:,L)+DQVDT_SC(:,:,L) & - + QLENT_SC(:,:,L)+QLSUB_SC(:,:,L)+QIENT_SC(:,:,L) & - + QISUB_SC(:,:,L) )*MASS(:,:,L) & - + QLDET_SC(:,:,L)+QIDET_SC(:,:,L) - END DO - end if - - call MAPL_GetPointer(EXPORT, PTR2D, 'SC_MSE', RC=STATUS); VERIFY_(STATUS) - if (associated(PTR2D)) then - ! column integral of UW moist static energy tendency - PTR2D = 0. - DO L = 1,LM - PTR2D = PTR2D + (MAPL_CP * DTDT_SC(:,:,L) & - + MAPL_ALHL*DQVDT_SC(:,:,L) & - - MAPL_ALHF*DQIDT_SC(:,:,L))*MASS(:,:,L) - END DO - end if - - call MAPL_GetPointer(EXPORT, PTR2D, 'CUSH_SC', RC=STATUS); VERIFY_(STATUS) - if (associated(PTR2D)) PTR2D = CUSH - - endif ! USE_PYMOIST_UW + !$OMP PARALLEL DO DEFAULT(NONE) & + !$OMP SHARED(IM, JM, LM, JASON_MFD_SC, DETR_SC, UMF_SC, DP, MFD_SC, & + !$OMP DCM_SC, DQADT_SC, SCLM_SHALLOW, MASS, QLENT_SC, QLDET_SC, QIENT_SC, QIDET_SC) & + !$OMP PRIVATE(i, j, k) + do k = 1, LM + do j = 1, JM + !DIR$ IVDEP + do i = 1, IM + ! Calculate detrained mass flux + if (JASON_MFD_SC) then + if (DETR_SC(i,j,k) /= MAPL_UNDEF) then + MFD_SC(i,j,k) = 0.5 * (UMF_SC(i,j,k) + UMF_SC(i,j,k-1)) * DETR_SC(i,j,k) * DP(i,j,k) + else + MFD_SC(i,j,k) = 0.0 + end if + else + MFD_SC(i,j,k) = DCM_SC(i,j,k) + end if + + DQADT_SC(i,j,k) = MFD_SC(i,j,k) * SCLM_SHALLOW / MASS(i,j,k) + + ! Convert detrained water units before passing to cloud + QLENT_SC(i,j,k) = 0.0 + QIENT_SC(i,j,k) = 0.0 + + if (QLDET_SC(i,j,k) < 0.0) then + QLENT_SC(i,j,k) = QLDET_SC(i,j,k) + QLDET_SC(i,j,k) = 0.0 + end if + + if (QIDET_SC(i,j,k) < 0.0) then + QIENT_SC(i,j,k) = QIDET_SC(i,j,k) + QIDET_SC(i,j,k) = 0.0 + end if + + ! Scale the detrained fluxes before exporting + QLDET_SC(i,j,k) = QLDET_SC(i,j,k) * MASS(i,j,k) + QIDET_SC(i,j,k) = QIDET_SC(i,j,k) * MASS(i,j,k) + end do + end do + end do + !$OMP END PARALLEL DO + + ! 3. Whole-array copies for direct 3D variables + !-------------------------------------------------------------- + call MAPL_GetPointer(EXPORT, PTR3D, 'SHLW_PRC3', ALLOC=.TRUE., RC=STATUS); VERIFY_(STATUS) + if (associated(PTR3D)) PTR3D = DQRDT_SC ! [kg/kg/s] + call MAPL_GetPointer(EXPORT, PTR3D, 'SHLW_SNO3', ALLOC=.TRUE., RC=STATUS); VERIFY_(STATUS) + if (associated(PTR3D)) PTR3D = DQSDT_SC ! [kg/kg/s] + call MAPL_GetPointer(EXPORT, PTR2D, 'CUSH_SC', RC=STATUS); VERIFY_(STATUS) + if (associated(PTR2D)) PTR2D = CUSH + + ! 4. Fused 2D Loop for Column Integrals + !-------------------------------------------------------------- + ! We parallelize over j,i and accumulate over k internally + !$OMP PARALLEL DO DEFAULT(NONE) & + !$OMP SHARED(IM, JM, LM, SC_QT, SC_MSE, DQSDT_SC, DQRDT_SC, DQVDT_SC, & + !$OMP QLENT_SC, QLSUB_SC, QIENT_SC, QISUB_SC, MASS, QLDET_SC, QIDET_SC, & + !$OMP DTDT_SC, DQIDT_SC) & + !$OMP PRIVATE(i, j, k) + do j = 1, JM + do i = 1, IM + if (associated(SC_QT)) SC_QT(i,j) = 0.0 + if (associated(SC_MSE)) SC_MSE(i,j) = 0.0 + + do k = 1, LM + if (associated(SC_QT)) then + SC_QT(i,j) = SC_QT(i,j) + & + ( DQSDT_SC(i,j,k) + DQRDT_SC(i,j,k) + DQVDT_SC(i,j,k) + & + QLENT_SC(i,j,k) + QLSUB_SC(i,j,k) + QIENT_SC(i,j,k) + & + QISUB_SC(i,j,k) ) * MASS(i,j,k) + & + QLDET_SC(i,j,k) + QIDET_SC(i,j,k) + end if + + if (associated(SC_MSE)) then + SC_MSE(i,j) = SC_MSE(i,j) + & + ( MAPL_CP * DTDT_SC(i,j,k) + & + MAPL_ALHL * DQVDT_SC(i,j,k) - & + MAPL_ALHF * DQIDT_SC(i,j,k) ) * MASS(i,j,k) + end if + end do + end do + end do + !$OMP END PARALLEL DO endif - ! Apply tendencies + + ! 1. Fetch all pointers FIRST before doing any math !-------------------------------------------------------------- - Q = Q + DQVDT_SC * MOIST_DT - T = T + DTDT_SC * MOIST_DT - U = U + DUDT_SC * MOIST_DT - V = V + DVDT_SC * MOIST_DT - ! Tiedtke-style cloud fraction !! - CLCN = MAX(0.0, MIN(CLCN + DQADT_SC*MOIST_DT, 1.0)) - ! add detrained shallow convective ice/liquid source call MAPL_GetPointer(EXPORT, QLDET_SC, 'QLDET_SC', ALLOC=.TRUE., RC=STATUS); VERIFY_(STATUS) - QLCN = MAX(0.0, QLCN + QLDET_SC*MOIST_DT/MASS) call MAPL_GetPointer(EXPORT, QIDET_SC, 'QIDET_SC', ALLOC=.TRUE., RC=STATUS); VERIFY_(STATUS) - QICN = MAX(0.0, QICN + QIDET_SC*MOIST_DT/MASS) - ! Apply condensate tendency from subsidence, and sink from - ! condensate entrained into shallow updraft. call MAPL_GetPointer(EXPORT, QLSUB_SC, 'QLSUB_SC', ALLOC=.TRUE., RC=STATUS); VERIFY_(STATUS) call MAPL_GetPointer(EXPORT, QLENT_SC, 'QLENT_SC', ALLOC=.TRUE., RC=STATUS); VERIFY_(STATUS) - QLLS = MAX(0.0, QLLS + (QLSUB_SC+QLENT_SC)*MOIST_DT) call MAPL_GetPointer(EXPORT, QISUB_SC, 'QISUB_SC', ALLOC=.TRUE., RC=STATUS); VERIFY_(STATUS) call MAPL_GetPointer(EXPORT, QIENT_SC, 'QIENT_SC', ALLOC=.TRUE., RC=STATUS); VERIFY_(STATUS) - QILS = MAX(0.0, QILS + (QISUB_SC+QIENT_SC)*MOIST_DT) - DQLDT_SC = (QLLS + QLCN - DQLDT_SC) / MOIST_DT - DQIDT_SC = (QILS + QICN - DQIDT_SC) / MOIST_DT - + ! 2. Apply tendencies in a single fused loop with OpenMP + !-------------------------------------------------------------- + !$OMP PARALLEL DO DEFAULT(NONE) & + !$OMP SHARED(IM, JM, LM, Q, DQVDT_SC, MOIST_DT, T, DTDT_SC, U, DUDT_SC, V, DVDT_SC, & + !$OMP CLCN, DQADT_SC, QLCN, QLDET_SC, MASS, QICN, QIDET_SC, & + !$OMP QLLS, QLSUB_SC, QLENT_SC, QILS, QISUB_SC, QIENT_SC) & + !$OMP PRIVATE(i, j, k) + do k = 1, LM + do j = 1, JM + !DIR$ IVDEP + !DIR$ VECTOR ALWAYS + do i = 1, IM + ! Apply tendencies + Q(i,j,k) = Q(i,j,k) + DQVDT_SC(i,j,k) * MOIST_DT + T(i,j,k) = T(i,j,k) + DTDT_SC(i,j,k) * MOIST_DT + U(i,j,k) = U(i,j,k) + DUDT_SC(i,j,k) * MOIST_DT + V(i,j,k) = V(i,j,k) + DVDT_SC(i,j,k) * MOIST_DT + + ! Tiedtke-style cloud fraction + CLCN(i,j,k) = MAX(0.0, MIN(CLCN(i,j,k) + DQADT_SC(i,j,k)*MOIST_DT, 1.0)) + + ! Add detrained shallow convective ice/liquid source + QLCN(i,j,k) = MAX(0.0, QLCN(i,j,k) + QLDET_SC(i,j,k)*MOIST_DT/MASS(i,j,k)) + QICN(i,j,k) = MAX(0.0, QICN(i,j,k) + QIDET_SC(i,j,k)*MOIST_DT/MASS(i,j,k)) + + ! Apply condensate tendency from subsidence, and sink from + ! condensate entrained into shallow updraft. + QLLS(i,j,k) = MAX(0.0, QLLS(i,j,k) + (QLSUB_SC(i,j,k)+QLENT_SC(i,j,k))*MOIST_DT) + QILS(i,j,k) = MAX(0.0, QILS(i,j,k) + (QISUB_SC(i,j,k)+QIENT_SC(i,j,k))*MOIST_DT) + end do + end do + end do + !$OMP END PARALLEL DO + ! Cleanup negative water species ! ------------------------------ call MAPL_GetPointer(EXPORT, DQVDT_FILL, 'DQVDT_FILL_SC', RC=STATUS); VERIFY_(STATUS) diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/uwshcu.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/uwshcu.F90 index 412400954b..dcb2b59636 100644 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/uwshcu.F90 +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/uwshcu.F90 @@ -28,11 +28,10 @@ module uwshcu real :: rpen ! Penentrative entrainment factor real :: rle real :: rkfre ! fraction_of_tke_associated_with_vertical_velocity - real :: rkm ! Factor controlling lateral mixing rate - real :: mixscale ! Controls vertical structure of mixing real :: rkfre_hr ! fraction_of_tke_associated_with_vertical_velocity High Resolution + real :: rkm ! Factor controlling lateral mixing rate real :: rkm_hr ! Factor controlling lateral mixing rate High Resolution - real :: mixscale_hr ! Controls vertical structure of mixing High Resolution + real :: mixscale ! Controls vertical structure of mixing real :: detrhgt ! Mixing rate increases above this height real :: rmaxfrac ! Maximum core updraft fraction real :: rmaxfrac_hr ! Maximum core updraft fraction High Resolution @@ -86,7 +85,7 @@ subroutine compute_uwshcu_inv(idim, k0, dt,pmid0_inv, & ! INPUT dp0_inv, u0_inv, v0_inv, qv0_inv, ql0_inv, qi0_inv, & t0_inv, tke_inv, rkfre, kpbl_inv, shfx,evap, cnvtr, frland, rkm2d, mix2d, rmaxfrac, & cush, & ! INOUT - umf_inv, dcm_inv, qvten_inv, tten_inv, & ! OUTPUT + umf_inv, dcm_inv, qvten_inv, qlten_inv, qiten_inv, tten_inv, & ! OUTPUT uten_inv, vten_inv, qrten_inv, qsten_inv, cufrc_inv, & fer_inv, fdr_inv, qldet_inv, qidet_inv, qlsub_inv, & qisub_inv, ndrop_inv, nice_inv, tpert_out, qpert_out, & @@ -136,10 +135,11 @@ subroutine compute_uwshcu_inv(idim, k0, dt,pmid0_inv, & ! INPUT real, intent(out) :: umf_inv(idim,k0+1) ! Updraft mass flux at interfaces [kg/m2/s] real, intent(out) :: dcm_inv(idim,k0) ! Detrained cloudy air mass real, intent(out) :: qvten_inv(idim,k0) ! Tendency of water vapor specific humidity [ kg/kg/s ] + real, intent(out) :: qlten_inv(idim,k0) ! Tendency of liquid water specific humidity [ kg/kg/s ] + real, intent(out) :: qiten_inv(idim,k0) ! Tendency of ice specific humidity [ kg/kg/s ] real, intent(out) :: tten_inv(idim,k0) ! Tendency of temperature [ K/s ] real, intent(out) :: uten_inv(idim,k0) ! Tendency of zonal wind [ m/s2 ] real, intent(out) :: vten_inv(idim,k0) ! Tendency of meridional wind [ m/s2 ] -! real, intent(out) :: trten_inv(idim,k0,ncnst) ! Tendency of tracers [ #/s, kg/kg/s ] real, intent(out) :: qrten_inv(idim,k0) ! Tendency of rain water specific humidity [ kg/kg/s ] real, intent(out) :: qsten_inv(idim,k0) ! Tendency of snow specific humidity [ kg/kg/s ] real, intent(out) :: cufrc_inv(idim,k0) ! Shallow cumulus cloud fraction at the layer mid-point [ fraction ] @@ -190,8 +190,6 @@ subroutine compute_uwshcu_inv(idim, k0, dt,pmid0_inv, & ! INPUT #endif !----- Local variables ----- - real :: qlten_inv(idim,k0) ! Tendency of liquid water specific humidity [ kg/kg/s ] - real :: qiten_inv(idim,k0) ! Tendency of ice specific humidity [ kg/kg/s ] real :: pifc0(idim,0:k0) ! Environmental pressure at the interfaces [ Pa ] real :: zifc0(idim,0:k0) ! Environmental height at the interfaces [ m ] real :: exnifc0(idim,0:k0) ! Exner function on interfaces From 11dcf1fcce5933b718bc7123c28dcee066b6053b Mon Sep 17 00:00:00 2001 From: William Putman Date: Tue, 16 Jun 2026 10:56:51 -0400 Subject: [PATCH 18/40] moved idim out of main UW routing to implement OpenMP from the main calling routine, Zero-Diff for stock config --- .../GEOSmoist_GridComp/uwshcu.F90 | 1589 +++++++++-------- 1 file changed, 808 insertions(+), 781 deletions(-) diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/uwshcu.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/uwshcu.F90 index dcb2b59636..ca611b60c5 100644 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/uwshcu.F90 +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/uwshcu.F90 @@ -204,7 +204,7 @@ subroutine compute_uwshcu_inv(idim, k0, dt,pmid0_inv, & ! INPUT real :: qi0(idim,k0) ! Environmental ice specific humidity [ kg/kg ] real :: th0(idim,k0) ! Environmental temperature [ K ] real :: tke(idim,0:k0) ! Turbulent kinetic energy [ m2 s-2 ] - real, allocatable :: tr0(:,:,:) ! Environmental tracers [ #, kg/kg ] + real, allocatable :: w_tr0(:,:) ! Environmental tracers [ #, kg/kg ] real :: umf(idim,0:k0) ! Updraft mass flux at the interfaces [ kg/m2/s ] real :: dcm(idim,k0) ! Detrained cloudy air mass real :: qvten(idim,k0) ! Tendency of water vapor specific humidity [ kg/kg/s ] @@ -233,30 +233,43 @@ subroutine compute_uwshcu_inv(idim, k0, dt,pmid0_inv, & ! INPUT !--------- Local, Diagnostic only --------- #ifdef UWDIAG -! real :: trten(idim,k0,ncnst) ! Tendency of tracers [ #/s, kg/kg/s ] - real :: qcu(idim,k0) ! Condensate water specific humidity within cumulus updraft + real :: w_qcu(idim,k0) ! Condensate water specific humidity within cumulus updraft ! at the layer mid-point [ kg/kg ] - real :: qlu(idim,k0) ! Liquid water specific humidity within cumulus updraft + real :: w_qlu(idim,k0) ! Liquid water specific humidity within cumulus updraft ! at the layer mid-point [ kg/kg ] - real :: qiu(idim,k0) ! Ice specific humidity within cumulus updraft + real :: w_qiu(idim,k0) ! Ice specific humidity within cumulus updraft ! at the layer mid-point [ kg/kg ] - real :: qc(idim,k0) ! Tendency of cumulus condensate detrained into the environment [ kg/kg/s ] - real :: cnt(idim) ! Cumulus top interface index, cnt = kpen [ no ] - real :: cnb(idim) ! Cumulus base interface index, cnb = krel - 1 [ no ] - real :: wu(idim,0:k0) - real :: qtu(idim,0:k0) - real :: thlu(idim,0:k0) - real :: thvu(idim,0:k0) - real :: uu(idim,0:k0) - real :: vu(idim,0:k0) - real :: xc(idim,k0) -! real :: trten_inv(idim,k0,ncnst) ! Tendency of tracers [ #/s, kg/kg/s ] + real :: w_qc(idim,k0) ! Tendency of cumulus condensate detrained into the environment [ kg/kg/s ] + real :: w_cnt(idim) ! Cumulus top interface index, cnt = kpen [ no ] + real :: w_cnb(idim) ! Cumulus base interface index, cnb = krel - 1 [ no ] + real :: w_wu(idim,0:k0) + real :: w_qtu(idim,0:k0) + real :: w_thlu(idim,0:k0) + real :: w_thvu(idim,0:k0) + real :: w_uu(idim,0:k0) + real :: w_vu(idim,0:k0) + real :: w_xc(idim,k0) #endif - + ! Thread-private 1D workspaces + real :: w_pifc0(0:k0), w_zifc0(0:k0), w_exnifc0(0:k0), w_tke(0:k0) + real :: w_pmid0(1:k0), w_zmid0(1:k0), w_exnmid0(1:k0), w_dp0(1:k0) + real :: w_u0(1:k0), w_v0(1:k0), w_qv0(1:k0), w_ql0(1:k0), w_qi0(1:k0), w_th0(1:k0) + + real :: w_umf(0:k0), w_dcm(1:k0), w_qvten(1:k0), w_qlten(1:k0), w_qiten(1:k0) + real :: w_sten(1:k0), w_uten(1:k0), w_vten(1:k0), w_qrten(1:k0), w_qsten(1:k0) + real :: w_cufrc(1:k0), w_fer(1:k0), w_fdr(1:k0), w_qldet(1:k0), w_qidet(1:k0) + real :: w_qlsub(1:k0), w_qisub(1:k0), w_ndrop(1:k0), w_nice(1:k0) + real :: w_qtflx(0:k0), w_slflx(0:k0), w_uflx(0:k0), w_vflx(0:k0) + + ! Scalar workspaces + integer :: w_kpbl + real :: w_frland, w_rkfre, w_rkm2d, w_mix2d, w_rmaxfrac + real :: w_cush, w_shfx, w_evap, w_cnvtrmax, w_tpert, w_qpert + real :: w_cbmf, w_plcl, w_plfc, w_pinv, w_prel, w_pbup, w_cldtop !---------- Indices ----------- - integer :: i ! Horizontal index for local fields [ no ] + integer :: i, ii, jj ! Horizontal index for local fields [ no ] integer :: k ! Vertical index for local fields [ no ] integer :: k_inv ! Vertical index for incoming fields [ no ] integer :: m ! Tracer index [ no ] @@ -266,150 +279,226 @@ subroutine compute_uwshcu_inv(idim, k0, dt,pmid0_inv, & ! INPUT ncnst = size(CNV_Tracers) IM = size(CNV_Tracers(1)%Q,1) JM = size(CNV_Tracers(1)%Q,2) - allocate(tr0(idim,k0,ncnst)) - - ! flip mid-level variables - do k = 1, k0 - k_inv = k0 + 1 - k - pmid0(:idim,k) = pmid0_inv(:idim,k_inv) - u0(:idim,k) = u0_inv(:idim,k_inv) - v0(:idim,k) = v0_inv(:idim,k_inv) - zmid0(:idim,k) = zmid0_inv(:idim,k_inv) - exnmid0(:idim,k) = exnmid0_inv(:idim,k_inv) - dp0(:idim,k) = dp0_inv(:idim,k_inv) - qv0(:idim,k) = qv0_inv(:idim,k_inv) - ql0(:idim,k) = ql0_inv(:idim,k_inv) - qi0(:idim,k) = qi0_inv(:idim,k_inv) - th0(:idim,k) = t0_inv(:idim,k_inv)/exnmid0_inv(:idim,k_inv) - do m = 1, ncnst - tr0(:idim,k,m) = reshape(CNV_Tracers(m)%Q(:,:,k_inv), (/idim/)) - enddo - enddo - - ! flip interface variables - tke(:,:) = 0. - pifc0(:,:) = 0. - zifc0(:,:) = 0. - exnifc0(:,:) = 0. - do k = 0, k0 - k_inv = k0 - k + 1 - tke(:idim,k) = tke_inv(:idim,k_inv) - pifc0(:idim,k) = pifc0_inv(:idim,k_inv) - zifc0(:idim,k) = zifc0_inv(:idim,k_inv) - exnifc0(:idim,k) = exnifc0_inv(:idim,k_inv) - end do - - kpbl = int(kpbl_inv) - - do i = 1,idim -! cnvtrmax(i) = min(300.,max(0.,maxval(cnvtr(i,:)))) - cnvtrmax(i) = min(1e-5,max(0.,cnvtr(i))) - if (frland(i)>0.5) cnvtrmax(i) = 0. - if (isnan(cnvtrmax(i))) cnvtrmax(i) = 0. - end do - - call compute_uwshcu( idim,k0, dt, ncnst,pifc0, zifc0, & - exnifc0, pmid0, zmid0, exnmid0, dp0, u0, v0, & - qv0, ql0, qi0, th0, tr0, kpbl, frland, tke, rkfre, rkm2d, mix2d, rmaxfrac, & - cush, umf, & - dcm, qvten, qlten, qiten, sten, uten, vten, & - qrten, qsten, cufrc, fer, fdr, qldet, qidet, & - qlsub, qisub, ndrop, nice, & - shfx, evap, cnvtrmax, tpert_out, qpert_out, & - qtflx, slflx, uflx, vflx, & - cbmf, plcl, plfc, pinv, prel, pbup, cldtop, & ! Diagnostic only + allocate(w_tr0(k0, ncnst)) + + !$OMP PARALLEL DO DEFAULT(NONE) & + !$OMP SHARED(idim, k0, dt, ncnst, IM, JM, dotransport, & + !$OMP pifc0_inv, zifc0_inv, exnifc0_inv, pmid0_inv, zmid0_inv, & + !$OMP exnmid0_inv, dp0_inv, u0_inv, v0_inv, qv0_inv, ql0_inv, & + !$OMP qi0_inv, t0_inv, tke_inv, rkfre, kpbl_inv, shfx, evap, & + !$OMP cnvtr, frland, rkm2d, mix2d, rmaxfrac, cush, umf_inv, & + !$OMP dcm_inv, qvten_inv, qlten_inv, qiten_inv, tten_inv, & + !$OMP uten_inv, vten_inv, qrten_inv, qsten_inv, cufrc_inv, & + !$OMP fer_inv, fdr_inv, qldet_inv, qidet_inv, qlsub_inv, & + !$OMP qisub_inv, ndrop_inv, nice_inv, tpert_out, qpert_out, & + !$OMP qtflx_inv, slflx_inv, uflx_inv, vflx_inv, cbmf, plcl, & + !$OMP plfc, pinv, prel, pbup, cldtop, CNV_Tracers & #ifdef UWDIAG - qcu, qlu, qiu, qc, cnt, cnb, cin, wlcl, qtsrc, & - thlsrc, thvlsrc, tkeavg, wu, qtu, & - thlu, thvu, uu, vu, xc, & ! trten, & + !$OMP , qcu_inv, qlu_inv, qiu_inv, qc_inv, cnt_inv, cnb_inv, & + !$OMP cin, wlcl, qtsrc, thlsrc, thvlsrc, tkeavg, wu_inv, & + !$OMP qtu_inv, thlu_inv, thvu_inv, uu_inv, vu_inv, xc_inv & #endif - dotransport ) - - ! Reverse again - + !$OMP ) & + !$OMP PRIVATE(i, ii, jj, k, k_inv, m, w_kpbl, w_frland, w_rkfre, w_rkm2d, & + !$OMP w_mix2d, w_rmaxfrac, w_cush, w_shfx, w_evap, w_cnvtrmax, w_tpert, & + !$OMP w_qpert, w_pifc0, w_zifc0, w_exnifc0, w_pmid0, w_zmid0, w_exnmid0, & + !$OMP w_dp0, w_u0, w_v0, w_qv0, w_ql0, w_qi0, w_th0, w_tke, w_tr0, w_umf, & + !$OMP w_dcm, w_qvten, w_qlten, w_qiten, w_sten, w_uten, w_vten, w_qrten, & + !$OMP w_qsten, w_cufrc, w_fer, w_fdr, w_qldet, w_qidet, w_qlsub, w_qisub, & + !$OMP w_ndrop, w_nice, w_qtflx, w_slflx, w_uflx, w_vflx, w_cbmf, w_plcl, & + !$OMP w_plfc, w_pinv, w_prel, w_pbup, w_cldtop & #ifdef UWDIAG - cnt_inv(:idim) = k0 + 1 - cnt(:idim) - cnb_inv(:idim) = k0 + 1 - cnb(:idim) + !$OMP , w_qcu, w_qlu, w_qiu, w_qc, w_cnt, w_cnb, w_cin, w_wlcl, & + !$OMP w_qtsrc, w_thlsrc, w_thvlsrc, w_tkeavg, w_wu, w_qtu, & + !$OMP w_thlu, w_thvu, w_uu, w_vu, w_xc & #endif + !$OMP ) + do i = 1, idim + + ! Calculate 2D grid coordinates from 1D flat index + ii = mod(i - 1, IM) + 1 + jj = (i - 1) / IM + 1 + + ! 1. Setup 1D Scalars for this column + w_cnvtrmax = min(1e-5, max(0.0, cnvtr(i))) + if (frland(i) > 0.5) w_cnvtrmax = 0.0 + if (isnan(w_cnvtrmax)) w_cnvtrmax = 0.0 + + w_kpbl = int(kpbl_inv(i)) + w_frland = frland(i) + w_rkfre = rkfre(i) + w_rkm2d = rkm2d(i) + w_mix2d = mix2d(i) + w_rmaxfrac = rmaxfrac(i) + w_cush = cush(i) + w_shfx = shfx(i) + w_evap = evap(i) + + ! 2. Load and flip the column into cache + do k = 1, k0 + k_inv = k0 + 1 - k + w_pmid0(k) = pmid0_inv(i,k_inv) + w_zmid0(k) = zmid0_inv(i,k_inv) + w_exnmid0(k) = exnmid0_inv(i,k_inv) + w_dp0(k) = dp0_inv(i,k_inv) + w_u0(k) = u0_inv(i,k_inv) + w_v0(k) = v0_inv(i,k_inv) + w_qv0(k) = qv0_inv(i,k_inv) + w_ql0(k) = ql0_inv(i,k_inv) + w_qi0(k) = qi0_inv(i,k_inv) + w_th0(k) = t0_inv(i,k_inv) / exnmid0_inv(i,k_inv) + ! Load Tracers directly without RESHAPE! + do m = 1, ncnst + w_tr0(k,m) = CNV_Tracers(m)%Q(ii,jj,k_inv) + end do + end do + + do k = 0, k0 + k_inv = k0 - k + 1 + w_tke(k) = tke_inv(i,k_inv) + w_pifc0(k) = pifc0_inv(i,k_inv) + w_zifc0(k) = zifc0_inv(i,k_inv) + w_exnifc0(k) = exnifc0_inv(i,k_inv) + end do - do k = 0, k0 - k_inv = k0 + 1 - k - umf_inv(:idim,k_inv) = umf(:idim,k) - qtflx_inv(:idim,k_inv) = qtflx(:idim,k) - slflx_inv(:idim,k_inv) = slflx(:idim,k) - uflx_inv(:idim,k_inv) = uflx(:idim,k) - vflx_inv(:idim,k_inv) = vflx(:idim,k) - + ! 3. Call physics WITHOUT the 'idim' argument + call compute_uwshcu( k0, dt, ncnst, w_pifc0, w_zifc0, & + w_exnifc0, w_pmid0, w_zmid0, w_exnmid0, w_dp0, w_u0, w_v0, & + w_qv0, w_ql0, w_qi0, w_th0, w_tr0, w_kpbl, w_frland, w_tke, & + w_rkfre, w_rkm2d, w_mix2d, w_rmaxfrac, w_cush, w_umf, & + w_dcm, w_qvten, w_qlten, w_qiten, w_sten, w_uten, w_vten, & + w_qrten, w_qsten, w_cufrc, w_fer, w_fdr, w_qldet, w_qidet, & + w_qlsub, w_qisub, w_ndrop, w_nice, w_shfx, w_evap, w_cnvtrmax, & + w_tpert, w_qpert, w_qtflx, w_slflx, w_uflx, w_vflx, & + w_cbmf, w_plcl, w_plfc, w_pinv, w_prel, w_pbup, w_cldtop, & #ifdef UWDIAG - wu_inv(:idim,k_inv) = wu(:idim,k) ! Diagnostic only - qtu_inv(:idim,k_inv) = qtu(:idim,k) - thlu_inv(:idim,k_inv) = thlu(:idim,k) - thvu_inv(:idim,k_inv) = thvu(:idim,k) - uu_inv(:idim,k_inv) = uu(:idim,k) - vu_inv(:idim,k_inv) = vu(:idim,k) + w_qcu, w_qlu, w_qiu, w_qc, w_cnt, w_cnb, w_cin, w_wlcl, w_qtsrc, & + w_thlsrc, w_thvlsrc, w_tkeavg, w_wu, w_qtu, & + w_thlu, w_thvu, w_uu, w_vu, w_xc, & #endif - end do + dotransport ) + + ! 4. Unflip and store results back to _inv arrays + cush(i) = w_cush + tpert_out(i) = w_tpert + qpert_out(i) = w_qpert + + ! Add diagnostic scalars here + cbmf(i) = w_cbmf + plcl(i) = w_plcl + plfc(i) = w_plfc + pinv(i) = w_pinv + prel(i) = w_prel + pbup(i) = w_pbup + cldtop(i) = w_cldtop + + do k = 1, k0 + k_inv = k0 + 1 - k + dcm_inv(i,k_inv) = w_dcm(k) + qvten_inv(i,k_inv) = w_qvten(k) + qlten_inv(i,k_inv) = w_qlten(k) + qiten_inv(i,k_inv) = w_qiten(k) + tten_inv(i,k_inv) = w_sten(k) / cp + uten_inv(i,k_inv) = w_uten(k) + vten_inv(i,k_inv) = w_vten(k) + qrten_inv(i,k_inv) = w_qrten(k) + qsten_inv(i,k_inv) = w_qsten(k) + cufrc_inv(i,k_inv) = w_cufrc(k) + fer_inv(i,k_inv) = w_fer(k) + fdr_inv(i,k_inv) = w_fdr(k) + qldet_inv(i,k_inv) = w_qldet(k) + qidet_inv(i,k_inv) = w_qidet(k) + qlsub_inv(i,k_inv) = w_qlsub(k) + qisub_inv(i,k_inv) = w_qisub(k) + ndrop_inv(i,k_inv) = w_ndrop(k) + nice_inv(i,k_inv) = w_nice(k) + + ! Store Tracers directly without RESHAPE! + if (dotransport == 1) then + do m = 1, ncnst + w_tr0(k,m) = MAX(mintracer, w_tr0(k,m)) + CNV_Tracers(m)%Q(ii,jj,k_inv) = w_tr0(k,m) + end do + end if + end do + + do k = 0, k0 + k_inv = k0 + 1 - k + umf_inv(i,k_inv) = w_umf(k) + qtflx_inv(i,k_inv) = w_qtflx(k) + slflx_inv(i,k_inv) = w_slflx(k) + uflx_inv(i,k_inv) = w_uflx(k) + vflx_inv(i,k_inv) = w_vflx(k) + end do + + dcm_inv(i,k0) = 0.0 - do k = 1, k0 - k_inv = k0 + 1 - k - dcm_inv(:idim,k_inv) = dcm(:idim,k) - qvten_inv(:idim,k_inv) = qvten(:idim,k) - qlten_inv(:idim,k_inv) = qlten(:idim,k) - qiten_inv(:idim,k_inv) = qiten(:idim,k) - tten_inv(:idim,k_inv) = sten(:idim,k) / cp - uten_inv(:idim,k_inv) = uten(:idim,k) - vten_inv(:idim,k_inv) = vten(:idim,k) - qrten_inv(:idim,k_inv) = qrten(:idim,k) - qsten_inv(:idim,k_inv) = qsten(:idim,k) - cufrc_inv(:idim,k_inv) = cufrc(:idim,k) - fer_inv(:idim,k_inv) = fer(:idim,k) - fdr_inv(:idim,k_inv) = fdr(:idim,k) - qldet_inv(:idim,k_inv) = qldet(:idim,k) - qidet_inv(:idim,k_inv) = qidet(:idim,k) - qlsub_inv(:idim,k_inv) = qlsub(:idim,k) - qisub_inv(:idim,k_inv) = qisub(:idim,k) - ndrop_inv(:idim,k_inv) = ndrop(:idim,k) - nice_inv(:idim,k_inv) = nice(:idim,k) -#ifdef UWDIAG - qcu_inv(:idim,k_inv) = qcu(:idim,k) ! Diagnostic only - qlu_inv(:idim,k_inv) = qlu(:idim,k) - qiu_inv(:idim,k_inv) = qiu(:idim,k) - qc_inv(:idim,k_inv) = qc(:idim,k) - xc_inv(:idim,k_inv) = xc(:idim,k) -#endif - if (dotransport.eq.1) then - do m = 1, ncnst - do i=1,idim - tr0(i,k,m) = MAX(mintracer,tr0(i,k,m)) - enddo - CNV_Tracers(m)%Q(:,:,k_inv) = reshape(tr0(:,k,m), (/IM,JM/)) #ifdef UWDIAG -! trten_inv(:idim,k_inv,m) = trten(:idim,k,m) + cnt_inv(i) = k0 + 1 - w_cnt(i) + cnb_inv(i) = k0 + 1 - w_cnb(i) + + cin(i) = w_cin + wlcl(i) = w_wlcl + qtsrc(i) = w_qtsrc + thlsrc(i) = w_thlsrc + thvlsrc(i) = w_thvlsrc + tkeavg(i) = w_tkeavg + + do k = 0, k0 + k_inv = k0 + 1 - k + wu_inv(i,k_inv) = w_wu(k) + qtu_inv(i,k_inv) = w_qtu(k) + thlu_inv(i,k_inv) = w_thlu(k) + thvu_inv(i,k_inv) = w_thvu(k) + uu_inv(i,k_inv) = w_uu(k) + vu_inv(i,k_inv) = w_vu(k) + end do + + do k = 1, k0 + k_inv = k0 + 1 - k + qcu_inv(i,k_inv) = w_qcu(k) ! Diagnostic only + qlu_inv(i,k_inv) = w_qlu(k) + qiu_inv(i,k_inv) = w_qiu(k) + qc_inv(i,k_inv) = w_qc(k) + xc_inv(i,k_inv) = w_xc(k) + end do #endif - enddo - endif + end do - dcm_inv(:idim,k0) = 0. + !$OMP END PARALLEL DO + ! Re-scale liquid/ice water sub-tendencies to enforce conservation - where(ABS(qldet_inv+qlsub_inv).gt.1e-12) - tmp2d = qlten_inv / (qldet_inv+qlsub_inv) - qldet_inv = tmp2d*qldet_inv - qlsub_inv = tmp2d*qlsub_inv - end where - where(ABS(qidet_inv+qisub_inv).gt.1e-12) - tmp2d = qiten_inv / (qidet_inv+qisub_inv) - qidet_inv = tmp2d*qidet_inv - qisub_inv = tmp2d*qisub_inv - end where + !$OMP PARALLEL DO DEFAULT(NONE) & + !$OMP SHARED(k0, idim, qldet_inv, qlsub_inv, qlten_inv, qidet_inv, & + !$OMP qisub_inv, qiten_inv, tmp2d) & + !$OMP PRIVATE(i, k) + do k = 1, k0 + !DIR$ IVDEP + do i = 1, idim + ! Liquid + if (abs(qldet_inv(i,k) + qlsub_inv(i,k)) > 1e-12) then + tmp2d(i,k) = qlten_inv(i,k) / (qldet_inv(i,k) + qlsub_inv(i,k)) + qldet_inv(i,k) = tmp2d(i,k) * qldet_inv(i,k) + qlsub_inv(i,k) = tmp2d(i,k) * qlsub_inv(i,k) + end if + ! Ice + if (abs(qidet_inv(i,k) + qisub_inv(i,k)) > 1e-12) then + tmp2d(i,k) = qiten_inv(i,k) / (qidet_inv(i,k) + qisub_inv(i,k)) + qidet_inv(i,k) = tmp2d(i,k) * qidet_inv(i,k) + qisub_inv(i,k) = tmp2d(i,k) * qisub_inv(i,k) + end if + end do + end do + !$OMP END PARALLEL DO end subroutine compute_uwshcu_inv - subroutine compute_uwshcu(idim, k0, dt,ncnst, pifc0_in,zifc0_in,& ! IN - exnifc0_in, pmid0_in, zmid0_in, exnmid0_in, dp0_in, & - u0_in, v0_in, qv0_in, ql0_in, qi0_in, th0_in, & - tr0_inout, kpbl_in, frland_in, tke_in, rkfre, rkm2d, mix2d, rmaxfrac, & - cush_inout, & ! OUT + subroutine compute_uwshcu(k0, dt,ncnst, pifc0,zifc0,& ! IN + exnifc0, pmid0, zmid0, exnmid0, dp0, & + u0, v0, qv0, ql0, qi0, th0, & + tr0, kpbl, frland, tke, rkfre, rkm2d, mix2d, rmaxfrac, & + cush_inout, & ! INOUT umf_out, dcm_out, qvten_out, qlten_out, qiten_out, & sten_out, uten_out, vten_out, qrten_out, & qsten_out, cufrc_out, fer_out, fdr_out, qldet_out, & @@ -449,122 +538,97 @@ subroutine compute_uwshcu(idim, k0, dt,ncnst, pifc0_in,zifc0_in,& ! IN ! ! ! ------------------------------------------------------------ ! - integer, intent(in) :: idim ! Number of columns integer, intent(in) :: k0 ! Number of vertical levels integer, intent(in) :: ncnst ! Number of tracers integer, intent(in) :: dotransport ! Transport tracers [1 true] real, intent(in) :: dt ! Timestep [s] - real, intent(in) :: pifc0_in( idim,0:k0 ) ! Environmental pressure at interfaces [Pa] - real, intent(in) :: zifc0_in( idim,0:k0 ) ! Environmental height at interfaces [m] - real, intent(in) :: exnifc0_in( idim,0:k0 ) ! Exner function at interfaces - real, intent(in) :: pmid0_in( idim,k0 ) ! Environmental pressure at midpoints [Pa] - real, intent(in) :: zmid0_in( idim,k0 ) ! Environmental height at midpoints [m] - real, intent(in) :: exnmid0_in( idim,k0 ) ! Exner function at midpoints - real, intent(in) :: dp0_in( idim,k0 ) ! Environmental layer pressure thickness - real, intent(in) :: u0_in ( idim,k0 ) ! Environmental zonal wind [m/s] - real, intent(in) :: v0_in ( idim,k0 ) ! Environmental meridional wind [m/s] - real, intent(in) :: qv0_in( idim,k0 ) ! Environmental specific humidity - real, intent(in) :: ql0_in( idim,k0 ) ! Environmental liquid water specific humidity - real, intent(in) :: qi0_in( idim,k0 ) ! Environmental ice specific humidity - real, intent(in) :: th0_in( idim,k0 ) ! Environmental potential temperature [K] - real, intent(in) :: tke_in( idim,0:k0 ) ! Turbulent kinetic energy at interfaces - real, intent(in) :: rkfre(idim) ! Resolution dependent Vertical velocity variance as fraction of tke. - real, intent(in) :: rkm2d(idim) ! Resolution dependent lateral mixing parameter - real, intent(in) :: mix2d(idim) ! Resolution dependent lateral mixing depth - real, intent(in) :: rmaxfrac(idim) ! Resolution dependent Maximum core updraft fraction - real, intent(in) :: shfx(idim) ! Surface sensible heat - real, intent(in) :: evap(idim) ! Surface evaporation - real, intent(in) :: cnvtr(idim) ! Convective tracer - real, intent(out) :: tpert_out(idim) ! Temperature perturbation - real, intent(out) :: qpert_out(idim) ! Humidity perturbation - real, intent(out) :: qtflx_out(idim, 0:k0 ) - real, intent(out) :: slflx_out(idim, 0:k0 ) - real, intent(out) :: uflx_out(idim, 0:k0 ) - real, intent(out) :: vflx_out(idim, 0:k0 ) - integer, intent(in) :: kpbl_in( idim ) ! Boundary layer top layer index - real, intent(in) :: frland_in( idim ) ! fraction of and in grid cell - - real, intent(inout) :: cush_inout( idim ) ! Convective scale height [m] - real, intent(inout) :: tr0_inout(idim,k0,ncnst) ! Environmental tracers [ #, kg/kg ] - - real, intent(out) :: umf_out(idim,0:k0) ! Updraft mass flux at the interfaces [ kg/m2/s ] - real, intent(out) :: dcm_out(idim,k0) ! Detrained cloudy air mass - real, intent(out) :: qvten_out(idim,k0) ! Tendency of water vapor specific humidity [ kg/kg/s ] - real, intent(out) :: qlten_out(idim,k0) ! Tendency of liquid water specific humidity [ kg/kg/s ] - real, intent(out) :: qiten_out(idim,k0) ! Tendency of ice specific humidity [ kg/kg/s ] - real, intent(out) :: sten_out(idim,k0) ! Tendency of dry static energy [ J/kg/s ] - real, intent(out) :: uten_out(idim,k0) ! Tendency of zonal wind [ m/s2 ] - real, intent(out) :: vten_out(idim,k0) ! Tendency of meridional wind [ m/s2 ] - real, intent(out) :: qrten_out(idim,k0) ! Tendency of rain water specific humidity [ kg/kg/s ] - real, intent(out) :: qsten_out(idim,k0) ! Tendency of snow specific humidity [ kg/kg/s ] - real, intent(out) :: cufrc_out(idim,k0) ! Shallow cumulus cloud fraction at the layer mid-point [ fraction ] - real, intent(out) :: fer_out(idim,k0) ! Fractional lateral entrainment rate [ 1/Pa ] - real, intent(out) :: fdr_out(idim,k0) ! Fractional lateral detrainment rate [ 1/Pa ] - - real, intent(out) :: qldet_out(idim,k0) - real, intent(out) :: qidet_out(idim,k0) - real, intent(out) :: qlsub_out(idim,k0) - real, intent(out) :: qisub_out(idim,k0) - real, intent(out) :: ndrop_out(idim,k0) - real, intent(out) :: nice_out(idim,k0) + real, intent(in) :: pifc0( 0:k0 ) ! Environmental pressure at interfaces [Pa] + real, intent(in) :: zifc0( 0:k0 ) ! Environmental height at interfaces [m] + real, intent(in) :: exnifc0( 0:k0 ) ! Exner function at interfaces + real, intent(in) :: pmid0( k0 ) ! Environmental pressure at midpoints [Pa] + real, intent(in) :: zmid0( k0 ) ! Environmental height at midpoints [m] + real, intent(in) :: exnmid0( k0 ) ! Exner function at midpoints + real, intent(in) :: dp0( k0 ) ! Environmental layer pressure thickness + real, intent(inout) :: u0( k0 ) ! Environmental zonal wind [m/s] + real, intent(inout) :: v0( k0 ) ! Environmental meridional wind [m/s] + real, intent(inout) :: qv0( k0 ) ! Environmental specific humidity + real, intent(inout) :: ql0( k0 ) ! Environmental liquid water specific humidity + real, intent(inout) :: qi0( k0 ) ! Environmental ice specific humidity + real, intent(in) :: th0( k0 ) ! Environmental potential temperature [K] + real, intent(in) :: tke( 0:k0 ) ! Turbulent kinetic energy at interfaces + real, intent(in) :: rkfre ! Resolution dependent Vertical velocity variance as fraction of tke. + real, intent(in) :: rkm2d ! Resolution dependent lateral mixing parameter + real, intent(in) :: mix2d ! Resolution dependent lateral mixing depth + real, intent(in) :: rmaxfrac ! Resolution dependent Maximum core updraft fraction + real, intent(in) :: shfx ! Surface sensible heat + real, intent(in) :: evap ! Surface evaporation + real, intent(in) :: cnvtr ! Convective tracer + real, intent(out) :: tpert_out ! Temperature perturbation + real, intent(out) :: qpert_out ! Humidity perturbation + real, intent(out) :: qtflx_out( 0:k0 ) + real, intent(out) :: slflx_out( 0:k0 ) + real, intent(out) :: uflx_out( 0:k0 ) + real, intent(out) :: vflx_out( 0:k0 ) + integer, intent(in) :: kpbl ! Boundary layer top layer index + real, intent(in) :: frland ! fraction of and in grid cell + + real, intent(inout) :: cush_inout ! Convective scale height [m] + real, intent(inout) :: tr0(k0,ncnst) ! Environmental tracers [ #, kg/kg ] + + real, intent(out) :: umf_out(0:k0) ! Updraft mass flux at the interfaces [ kg/m2/s ] + real, intent(out) :: dcm_out(k0) ! Detrained cloudy air mass + real, intent(out) :: qvten_out(k0) ! Tendency of water vapor specific humidity [ kg/kg/s ] + real, intent(out) :: qlten_out(k0) ! Tendency of liquid water specific humidity [ kg/kg/s ] + real, intent(out) :: qiten_out(k0) ! Tendency of ice specific humidity [ kg/kg/s ] + real, intent(out) :: sten_out(k0) ! Tendency of dry static energy [ J/kg/s ] + real, intent(out) :: uten_out(k0) ! Tendency of zonal wind [ m/s2 ] + real, intent(out) :: vten_out(k0) ! Tendency of meridional wind [ m/s2 ] + real, intent(out) :: qrten_out(k0) ! Tendency of rain water specific humidity [ kg/kg/s ] + real, intent(out) :: qsten_out(k0) ! Tendency of snow specific humidity [ kg/kg/s ] + real, intent(out) :: cufrc_out(k0) ! Shallow cumulus cloud fraction at the layer mid-point [ fraction ] + real, intent(out) :: fer_out(k0) ! Fractional lateral entrainment rate [ 1/Pa ] + real, intent(out) :: fdr_out(k0) ! Fractional lateral detrainment rate [ 1/Pa ] + + real, intent(out) :: qldet_out(k0) + real, intent(out) :: qidet_out(k0) + real, intent(out) :: qlsub_out(k0) + real, intent(out) :: qisub_out(k0) + real, intent(out) :: ndrop_out(k0) + real, intent(out) :: nice_out(k0) !--------- Diagnostic only ------------ - real, intent(out) :: cbmf_out(idim) ! Cloud base mass flux [kg/m2/s] - real, intent(out) :: pinv_out(idim) ! PBL top pressure [ Pa ] - real, intent(out) :: plfc_out(idim) ! LFC of source air [ Pa ] - real, intent(out) :: plcl_out(idim) ! LCL of source air [ Pa ] - real, intent(out) :: prel_out(idim) - real, intent(out) :: pbup_out(idim) - real, intent(out) :: cldhgt_out(idim) + real, intent(out) :: cbmf_out ! Cloud base mass flux [kg/m2/s] + real, intent(out) :: pinv_out ! PBL top pressure [ Pa ] + real, intent(out) :: plfc_out ! LFC of source air [ Pa ] + real, intent(out) :: plcl_out ! LCL of source air [ Pa ] + real, intent(out) :: prel_out + real, intent(out) :: pbup_out + real, intent(out) :: cldhgt_out #ifdef UWDIAG -! real, intent(out) :: trten_out(idim,k0,ncnst) ! Tendency of tracers [ #/s, kg/kg/s ] - real, intent(out) :: wu_out(idim,0:k0) ! Updraft vertical velocity - real, intent(out) :: qtu_out(idim,0:k0) ! Updraft qt [ kg/kg ] - real, intent(out) :: thlu_out(idim,0:k0) ! Updraft thl [ K ] - real, intent(out) :: thvu_out(idim,0:k0) ! Updraft thv [ K ] - real, intent(out) :: uu_out(idim,0:k0) ! Updraft zonal wind [ m/s ] - real, intent(out) :: vu_out(idim,0:k0) ! Updraft meridional wind [ m/s ] - real, intent(out) :: qcu_out(idim,k0) ! Condensate water specific humidity within cumulus updraft [ kg/kg ] - real, intent(out) :: qlu_out(idim,k0) ! Liquid water specific humidity within cumulus updraft [ kg/kg ] - real, intent(out) :: qiu_out(idim,k0) ! Ice specific humidity within cumulus updraft [ kg/kg ] - real, intent(out) :: qc_out(idim,k0) ! Tendency of detrained cumulus condensate - real, intent(out) :: cnt_out(idim) ! Cumulus top interface index - real, intent(out) :: cnb_out(idim) ! Cumulus base interface index - real, intent(out) :: cinh_out(idim) - real, intent(out) :: tkeavg_out(idim) ! Average tke over the PBL [ m2/s2 ] - real, intent(out) :: xc_out(idim,k0) + real, intent(out) :: wu_out(0:k0) ! Updraft vertical velocity + real, intent(out) :: qtu_out(0:k0) ! Updraft qt [ kg/kg ] + real, intent(out) :: thlu_out(0:k0) ! Updraft thl [ K ] + real, intent(out) :: thvu_out(0:k0) ! Updraft thv [ K ] + real, intent(out) :: uu_out(0:k0) ! Updraft zonal wind [ m/s ] + real, intent(out) :: vu_out(0:k0) ! Updraft meridional wind [ m/s ] + real, intent(out) :: qcu_out(k0) ! Condensate water specific humidity within cumulus updraft [ kg/kg ] + real, intent(out) :: qlu_out(k0) ! Liquid water specific humidity within cumulus updraft [ kg/kg ] + real, intent(out) :: qiu_out(k0) ! Ice specific humidity within cumulus updraft [ kg/kg ] + real, intent(out) :: qc_out(k0) ! Tendency of detrained cumulus condensate + real, intent(out) :: cnt_out ! Cumulus top interface index + real, intent(out) :: cnb_out ! Cumulus base interface index + real, intent(out) :: cinh_out + real, intent(out) :: tkeavg_out ! Average tke over the PBL [ m2/s2 ] + real, intent(out) :: xc_out(k0) #endif - ! - ! Internal Output Variables - ! -! real qtten_out(idim,k0) ! Tendency of qt [ kg/kg/s ] -! real slten_out(idim,k0) ! Tendency of sl [ J/kg/s ] -! real ufrc_out(idim,0:k0) ! Updraft fractional area at the interfaces [ fraction ] - - - !----------------------------------------------- ! One-dimensional variables at each grid point !----------------------------------------------- - ! Input variables - - real :: pifc0(0:k0) - real :: zifc0(0:k0) - real :: pmid0(k0) - real :: zmid0(k0) - real :: dp0(k0) - real :: u0(k0) - real :: v0(k0) - real :: tke(1:k0) - real :: qv0(k0) - real :: ql0(k0) - real :: qi0(k0) real :: cush - real :: tr0(k0,ncnst) ! Environmental variables derived from input variables @@ -581,8 +645,6 @@ subroutine compute_uwshcu(idim, k0, dt,ncnst, pifc0_in,zifc0_in,& ! IN real :: thv0top(k0) real :: thvl0bot(k0) real :: thvl0top(k0) - real :: exnmid0(k0) - real :: exnifc0(0:k0) real :: sstr0(k0,ncnst) ! 2-1. For preventing negative condensate at the provisional time step @@ -704,7 +766,7 @@ subroutine compute_uwshcu(idim, k0, dt,ncnst, pifc0_in,zifc0_in,& ! IN ! Other internal variables - integer kk, k, i, kp1, km1, mm, m + integer kk, k, kp1, km1, mm, m integer iter_scaleh, iter_xc integer id_check, status @@ -749,36 +811,36 @@ subroutine compute_uwshcu(idim, k0, dt,ncnst, pifc0_in,zifc0_in,& ! IN !----- Some diagnostic internal output variables #ifdef UWDIAG - real trflx_out(idim,0:k0,ncnst) ! Updraft/pen.entrainment tracer flux [ #/m2/s, kg/kg/m2/s ] - real ufrcinvbase_out(idim) ! Cumulus updraft fraction at the PBL top [ fraction ] - real ufrclcl_out(idim) ! Cumulus updraft fraction at the LCL + real trflx_out(0:k0,ncnst) ! Updraft/pen.entrainment tracer flux [ #/m2/s, kg/kg/m2/s ] + real ufrcinvbase_out ! Cumulus updraft fraction at the PBL top [ fraction ] + real ufrclcl_out ! Cumulus updraft fraction at the LCL ! ( or PBL top when LCL is below PBL top ) [ fraction ] - real winvbase_out(idim) ! Cumulus updraft velocity at the PBL top [ m/s ] - real wlcl_out(idim) ! Cumulus updraft velocity at the LCL + real winvbase_out ! Cumulus updraft velocity at the PBL top [ m/s ] + real wlcl_out ! Cumulus updraft velocity at the LCL ! ( or PBL top when LCL is below PBL top ) [ m/s ] -! real pbup_out(idim) ! Highest interface level of positive buoyancy [ Pa ] - real ppen_out(idim) ! Highest interface evel where Cu w = 0 [ Pa ] - real qtsrc_out(idim) ! Source air qt [ kg/kg ] - real thlsrc_out(idim) ! Source air thl [ K ] - real thvlsrc_out(idim) ! Source air thvl [ K ] - real emfkbup_out(idim) ! Penetrative downward mass flux at 'kbup' interface [ kg/m2/s ] - real cinlclh_out(idim) ! Convective INhibition upto LCL (CIN) [ J/kg = m2/s2 ] - real cbmflimit_out(idim) ! Cloud base mass flux limiter [ kg/m2/s ] - real zinv_out(idim) ! PBL top height [ m ] - real rcwp_out(idim) ! Layer mean Cumulus LWP+IWP [ kg/m2 ] - real rlwp_out(idim) ! Layer mean Cumulus LWP [ kg/m2 ] - real riwp_out(idim) ! Layer mean Cumulus IWP [ kg/m2 ] - - real qtu_emf_out(idim,0:k0) ! Penetratively entrained qt [ kg/kg ] - real thlu_emf_out(idim,0:k0) ! Penetratively entrained thl [ K ] - real uu_emf_out(idim,0:k0) ! Penetratively entrained u [ m/s ] - real vu_emf_out(idim,0:k0) ! Penetratively entrained v [ m/s ] - real uemf_out(idim,0:k0) ! Net upward mass flux +! real pbup_out ! Highest interface level of positive buoyancy [ Pa ] + real ppen_out ! Highest interface evel where Cu w = 0 [ Pa ] + real qtsrc_out ! Source air qt [ kg/kg ] + real thlsrc_out ! Source air thl [ K ] + real thvlsrc_out ! Source air thvl [ K ] + real emfkbup_out ! Penetrative downward mass flux at 'kbup' interface [ kg/m2/s ] + real cinlclh_out ! Convective INhibition upto LCL (CIN) [ J/kg = m2/s2 ] + real cbmflimit_out ! Cloud base mass flux limiter [ kg/m2/s ] + real zinv_out ! PBL top height [ m ] + real rcwp_out ! Layer mean Cumulus LWP+IWP [ kg/m2 ] + real rlwp_out ! Layer mean Cumulus LWP [ kg/m2 ] + real riwp_out ! Layer mean Cumulus IWP [ kg/m2 ] + + real qtu_emf_out(0:k0) ! Penetratively entrained qt [ kg/kg ] + real thlu_emf_out(0:k0) ! Penetratively entrained thl [ K ] + real uu_emf_out(0:k0) ! Penetratively entrained u [ m/s ] + real vu_emf_out(0:k0) ! Penetratively entrained v [ m/s ] + real uemf_out(0:k0) ! Net upward mass flux ! including penetrative entrainment (umf+emf) [ kg/m2/s ] - real dwten_out(idim,k0) - real diten_out(idim,k0) - real tru_out(idim,0:k0,ncnst) ! Updraft tracers [ #, kg/kg ] - real tru_emf_out(idim,0:k0,ncnst) ! Penetratively entrained tracers [ #, kg/kg ] + real dwten_out(k0) + real diten_out(k0) + real tru_out(0:k0,ncnst) ! Updraft tracers [ #, kg/kg ] + real tru_emf_out(0:k0,ncnst) ! Penetratively entrained tracers [ #, kg/kg ] real wu_s(0:k0) ! Same as above but for implicit CIN real qtu_s(0:k0) real thlu_s(0:k0) @@ -796,54 +858,54 @@ subroutine compute_uwshcu(idim, k0, dt,ncnst, pifc0_in,zifc0_in,& ! IN real dwten_s(k0) real diten_s(k0) - real excessu_arr_out(idim,k0) + real excessu_arr_out(k0) real excessu_arr(k0) real excessu_arr_s(k0) - real excess0_arr_out(idim,k0) + real excess0_arr_out(k0) real excess0_arr(k0) real excess0_arr_s(k0) - real xc_arr_out(idim,k0) + real xc_arr_out(k0) real xc_arr(k0) real xc_arr_s(k0) - real aquad_arr_out(idim,k0) + real aquad_arr_out(k0) real aquad_arr(k0) real aquad_arr_s(k0) - real bquad_arr_out(idim,k0) + real bquad_arr_out(k0) real bquad_arr(k0) real bquad_arr_s(k0) - real cquad_arr_out(idim,k0) + real cquad_arr_out(k0) real cquad_arr(k0) real cquad_arr_s(k0) - real bogbot_arr_out(idim,k0) + real bogbot_arr_out(k0) real bogbot_arr(k0) real bogbot_arr_s(k0) - real bogtop_arr_out(idim,k0) + real bogtop_arr_out(k0) real bogtop_arr(k0) real bogtop_arr_s(k0) #endif - real exit_ufrc(idim) - real exit_wtw(idim) - real exit_drycore(idim) - real exit_wu(idim) - real exit_cufilter(idim) - real exit_rei(idim) - real exit_kinv1(idim) - real exit_klfck0(idim) - real exit_klclk0(idim) - real exit_uwcu(idim) - real exit_conden(idim) - - real limit_cinlcl(idim) - real limit_cin(idim) - real ind_delcin(idim) - real limit_rei(idim) - real limit_shcu(idim) - real limit_negcon(idim) - real limit_ufrc(idim) - real limit_ppen(idim) - real limit_emf(idim) - real limit_cbmf(idim) + real exit_ufrc + real exit_wtw + real exit_drycore + real exit_wu + real exit_cufilter + real exit_rei + real exit_kinv1 + real exit_klfck0 + real exit_klclk0 + real exit_uwcu + real exit_conden + + real limit_cinlcl + real limit_cin + real ind_delcin + real limit_rei + real limit_shcu + real limit_negcon + real limit_ufrc + real limit_ppen + real limit_emf + real limit_cbmf real :: ufrcinvbase_s, ufrclcl_s, winvbase_s, wlcl_s, plcl_s, pinv_s, prel_s, plfc_s, & qtsrc_s, thlsrc_s, thvlsrc_s, emfkbup_s, cinlcl_s, pbup_s, ppen_s, cbmflimit_s, & @@ -1041,144 +1103,124 @@ subroutine compute_uwshcu(idim, k0, dt,ncnst, pifc0_in,zifc0_in,& ! IN ! Initialize output variables defined for all grid points ! ! ------------------------------------------------------- ! - umf_out(:idim,0:k0) = 0.0 - dcm_out(:idim,:k0) = 0.0 - cufrc_out(:idim,:k0) = 0.0 - fer_out(:idim,:k0) = MAPL_UNDEF - fdr_out(:idim,:k0) = MAPL_UNDEF - qldet_out(:idim,:k0) = 0.0 - qidet_out(:idim,:k0) = 0.0 - qlsub_out(:idim,:k0) = 0.0 - qisub_out(:idim,:k0) = 0.0 - ndrop_out(:idim,:k0) = 0.0 - nice_out(:idim,:k0) = 0.0 - qtflx_out(:idim,0:k0) = 0.0 - slflx_out(:idim,0:k0) = 0.0 - uflx_out(:idim,0:k0) = 0.0 - vflx_out(:idim,0:k0) = 0.0 - tpert_out(:idim) = 0.0 - qpert_out(:idim) = 0.0 - - cbmf_out(:idim) = 0.0 - plcl_out(:idim) = MAPL_UNDEF - pinv_out(:idim) = MAPL_UNDEF - plfc_out(:idim) = MAPL_UNDEF - prel_out(:idim) = MAPL_UNDEF - pbup_out(:idim) = MAPL_UNDEF - cldhgt_out(:idim) = MAPL_UNDEF + umf_out(0:k0) = 0.0 + dcm_out(:k0) = 0.0 + cufrc_out(:k0) = 0.0 + fer_out(:k0) = MAPL_UNDEF + fdr_out(:k0) = MAPL_UNDEF + qldet_out(:k0) = 0.0 + qidet_out(:k0) = 0.0 + qlsub_out(:k0) = 0.0 + qisub_out(:k0) = 0.0 + ndrop_out(:k0) = 0.0 + nice_out(:k0) = 0.0 + qtflx_out(0:k0) = 0.0 + slflx_out(0:k0) = 0.0 + uflx_out(0:k0) = 0.0 + vflx_out(0:k0) = 0.0 + tpert_out = 0.0 + qpert_out = 0.0 + + cbmf_out = 0.0 + plcl_out = MAPL_UNDEF + pinv_out = MAPL_UNDEF + plfc_out = MAPL_UNDEF + prel_out = MAPL_UNDEF + pbup_out = MAPL_UNDEF + cldhgt_out = MAPL_UNDEF #ifdef UWDIAG - cinh_out(:idim) = MAPL_UNDEF - cinlclh_out(:idim) = MAPL_UNDEF - qcu_out(:idim,:k0) = 0.0 - qlu_out(:idim,:k0) = 0.0 - qiu_out(:idim,:k0) = 0.0 - qc_out(:idim,:k0) = 0.0 - cnt_out(:idim) = real(k0) - cnb_out(:idim) = 0.0 - xc_out(:idim,:k0) = 0.0 -! ufrc_out(:idim,0:k0) = 0.0 -! uflx_out(:idim,0:k0) = 0.0 -! vflx_out(:idim,0:k0) = 0.0 - ppen_out(:idim) = 0.0 - ufrcinvbase_out(:idim) = 0.0 - ufrclcl_out(:idim) = 0.0 - winvbase_out(:idim) = 0.0 - wlcl_out(:idim) = 0.0 - qtsrc_out(:idim) = 0.0 - thlsrc_out(:idim) = 0.0 - thvlsrc_out(:idim) = 0.0 - emfkbup_out(:idim) = 0.0 - cbmflimit_out(:idim) = 0.0 - tkeavg_out(:idim) = 0.0 - zinv_out(:idim) = 0.0 - rcwp_out(:idim) = 0.0 - rlwp_out(:idim) = 0.0 - riwp_out(:idim) = 0.0 + cinh_out = MAPL_UNDEF + cinlclh_out = MAPL_UNDEF + qcu_out(:k0) = 0.0 + qlu_out(:k0) = 0.0 + qiu_out(:k0) = 0.0 + qc_out(:k0) = 0.0 + cnt_out = real(k0) + cnb_out = 0.0 + xc_out(:k0) = 0.0 +! ufrc_out(0:k0) = 0.0 +! uflx_out(0:k0) = 0.0 +! vflx_out(0:k0) = 0.0 + ppen_out = 0.0 + ufrcinvbase_out = 0.0 + ufrclcl_out = 0.0 + winvbase_out = 0.0 + wlcl_out = 0.0 + qtsrc_out = 0.0 + thlsrc_out = 0.0 + thvlsrc_out = 0.0 + emfkbup_out = 0.0 + cbmflimit_out = 0.0 + tkeavg_out = 0.0 + zinv_out = 0.0 + rcwp_out = 0.0 + rlwp_out = 0.0 + riwp_out = 0.0 - wu_out(:idim,0:k0) = MAPL_UNDEF - qtu_out(:idim,0:k0) = MAPL_UNDEF - thlu_out(:idim,0:k0) = MAPL_UNDEF - thvu_out(:idim,0:k0) = MAPL_UNDEF - uu_out(:idim,0:k0) = MAPL_UNDEF - vu_out(:idim,0:k0) = MAPL_UNDEF - qtu_emf_out(:idim,0:k0) = 0.0 - thlu_emf_out(:idim,0:k0) = 0.0 - uu_emf_out(:idim,0:k0) = 0.0 - vu_emf_out(:idim,0:k0) = 0.0 - uemf_out(:idim,0:k0) = 0.0 - - dwten_out(:idim,:k0) = 0.0 - diten_out(:idim,:k0) = 0.0 - -! trten_out(:idim,:k0,:ncnst) = 0.0 - trflx_out(:idim,0:k0,:ncnst) = 0.0 - tru_out(:idim,0:k0,:ncnst) = 0.0 - tru_emf_out(:idim,0:k0,:ncnst) = 0.0 - - excessu_arr_out(:idim,:k0) = 0.0 - excess0_arr_out(:idim,:k0) = 0.0 - xc_arr_out(:idim,:k0) = 0.0 - aquad_arr_out(:idim,:k0) = 0.0 - bquad_arr_out(:idim,:k0) = 0.0 - cquad_arr_out(:idim,:k0) = 0.0 - bogbot_arr_out(:idim,:k0) = 0.0 - bogtop_arr_out(:idim,:k0) = 0.0 + wu_out(0:k0) = MAPL_UNDEF + qtu_out(0:k0) = MAPL_UNDEF + thlu_out(0:k0) = MAPL_UNDEF + thvu_out(0:k0) = MAPL_UNDEF + uu_out(0:k0) = MAPL_UNDEF + vu_out(0:k0) = MAPL_UNDEF + qtu_emf_out(0:k0) = 0.0 + thlu_emf_out(0:k0) = 0.0 + uu_emf_out(0:k0) = 0.0 + vu_emf_out(0:k0) = 0.0 + uemf_out(0:k0) = 0.0 + + dwten_out(:k0) = 0.0 + diten_out(:k0) = 0.0 + +! trten_out(:k0,:ncnst) = 0.0 + trflx_out(0:k0,:ncnst) = 0.0 + tru_out(0:k0,:ncnst) = 0.0 + tru_emf_out(0:k0,:ncnst) = 0.0 + + excessu_arr_out(:k0) = 0.0 + excess0_arr_out(:k0) = 0.0 + xc_arr_out(:k0) = 0.0 + aquad_arr_out(:k0) = 0.0 + bquad_arr_out(:k0) = 0.0 + cquad_arr_out(:k0) = 0.0 + bogbot_arr_out(:k0) = 0.0 + bogtop_arr_out(:k0) = 0.0 #endif - exit_UWCu(:idim) = 0.0 - exit_conden(:idim) = 0.0 - exit_klclk0(:idim) = 0.0 - exit_klfck0(:idim) = 0.0 - exit_ufrc(:idim) = 0.0 - exit_wtw(:idim) = 0.0 - exit_drycore(:idim) = 0.0 - exit_wu(:idim) = 0.0 - exit_cufilter(:idim) = 0.0 - exit_kinv1(:idim) = 0.0 - exit_rei(:idim) = 0.0 - - limit_shcu(:idim) = 0.0 - limit_negcon(:idim) = 0.0 - limit_ufrc(:idim) = 0.0 - limit_ppen(:idim) = 0.0 - limit_emf(:idim) = 0.0 - limit_cinlcl(:idim) = 0.0 - limit_cin(:idim) = 0.0 - limit_cbmf(:idim) = 0.0 - limit_rei(:idim) = 0.0 - - ind_delcin(:idim) = 0.0 + exit_UWCu = 0.0 + exit_conden = 0.0 + exit_klclk0 = 0.0 + exit_klfck0 = 0.0 + exit_ufrc = 0.0 + exit_wtw = 0.0 + exit_drycore = 0.0 + exit_wu = 0.0 + exit_cufilter = 0.0 + exit_kinv1 = 0.0 + exit_rei = 0.0 + + limit_shcu = 0.0 + limit_negcon = 0.0 + limit_ufrc = 0.0 + limit_ppen = 0.0 + limit_emf = 0.0 + limit_cinlcl = 0.0 + limit_cin = 0.0 + limit_cbmf = 0.0 + limit_rei = 0.0 + + ind_delcin = 0.0 !======================== - ! Start column loop + ! column work !======================== - do i = 1, idim - id_exit = .false. frc_rasn = shlwparams%frc_rasn - pifc0(0:k0) = pifc0_in(i,0:k0) - zifc0(0:k0) = zifc0_in(i,0:k0) - pmid0(:k0) = pmid0_in(i,:k0) - zmid0(:k0) = zmid0_in(i,:k0) - dp0(:k0) = dp0_in(i,:k0) - u0(:k0) = u0_in(i,:k0) - v0(:k0) = v0_in(i,:k0) - qv0(:k0) = qv0_in(i,:k0) - ql0(:k0) = ql0_in(i,:k0) - qi0(:k0) = qi0_in(i,:k0) - tke(1:k0) = tke_in(i,1:k0) -! pblh = pblh_in(i) - cush = cush_inout(i) - - if (dotransport.eq.1) then - do m = 1,ncnst ! loop over tracers - tr0(:k0,m) = tr0_inout(i,:k0,m) - end do - endif + cush = cush_inout !------------------------------------------------------! ! Compute basic thermodynamic variables directly from ! @@ -1187,15 +1229,12 @@ subroutine compute_uwshcu(idim, k0, dt,ncnst, pifc0_in,zifc0_in,& ! IN ! Compute internal environmental variables - exnmid0(:k0) = exnmid0_in(i,:k0) - exnifc0(:k0) = exnifc0_in(i,:k0) - t0(:k0) = th0_in(i,:k0) * exnmid0(:k0) + t0(:k0) = th0(:k0) * exnmid0(:k0) s0(:k0) = g*zmid0(:k0) + cp*t0(:k0) qt0(:k0) = qv0(:k0) + ql0(:k0) + qi0(:k0) thl0(:k0) = ( t0(:k0) - xlv*ql0(:k0)/cp - xls*qi0(:k0)/cp ) / exnmid0(:k0) thvl0(:k0) = ( 1. + zvir*qt0(:k0) )*thl0(:k0) - ! Compute slopes of environmental variables in each layer ssthl0 = slope( k0, thl0, pmid0 ) @@ -1216,7 +1255,7 @@ subroutine compute_uwshcu(idim, k0, dt,ncnst, pifc0_in,zifc0_in,& ! IN qt0bot = qt0(k) + ssqt0(k)*(pifc0(k-1) - pmid0(k)) call conden( pifc0(k-1),thl0bot,qt0bot,thj,qvj,qlj,qij,qse,id_check ) if ( id_check .eq. 1 ) then - exit_conden(i) = 1.0 + exit_conden = 1.0 id_exit = .true. if (scverbose) then call write_parallel('------- UW ShCu: Exit, conden') @@ -1231,7 +1270,7 @@ subroutine compute_uwshcu(idim, k0, dt,ncnst, pifc0_in,zifc0_in,& ! IN if (k.lt.k0) then call conden( pifc0(k),thl0top,qt0top,thj,qvj,qlj,qij,qse,id_check ) if ( id_check .eq. 1 ) then - exit_conden(i) = 1.0 + exit_conden = 1.0 id_exit = .true. if (scverbose) then call write_parallel('------- UW ShCu: Exit, conden') @@ -1390,7 +1429,7 @@ subroutine compute_uwshcu(idim, k0, dt,ncnst, pifc0_in,zifc0_in,& ! IN ! of the iterative cin loop. ! ! ---------------------------------------------------------------------- ! - tscaleh = cush + tscaleh = cush cush = -1. tkeavg = 0. qtavg = 0. @@ -1419,8 +1458,8 @@ subroutine compute_uwshcu(idim, k0, dt,ncnst, pifc0_in,zifc0_in,& ! IN ! ----------------------------------------------------------------------- ! ! invert kpbl index - if (kpbl_in(i).gt.k0/2) then - kinv = k0 - kpbl_in(i) + 1 + if (kpbl.gt.k0/2) then + kinv = k0 - kpbl + 1 else kinv = 5 end if @@ -1428,7 +1467,7 @@ subroutine compute_uwshcu(idim, k0, dt,ncnst, pifc0_in,zifc0_in,& ! IN 15 continue if( kinv .le. 1 ) then - exit_kinv1(i) = 1. + exit_kinv1 = 1. id_exit = .true. if (scverbose) then call write_parallel('------- UW ShCu: Exit, kinv<=1') @@ -1480,16 +1519,6 @@ subroutine compute_uwshcu(idim, k0, dt,ncnst, pifc0_in,zifc0_in,& ! IN thvlavg = thvlavg/dpsum qtavg = qtavg/dpsum -! ! weighted average over lowest 20mb -! dpsum = 0. -! qtavg = 0. -! do k = 1,kinv -! dpi = max(0.,(2e3+pmid0(k)-pifc0(0))/2e3) -! qtavg = qtavg + dpi*qt0(k) -! dpsum = dpsum + dpi -! end do -! qtavg = qtavg/dpsum - ! Interpolate qt to specified height or the PBL edge height if (qtsrchgt > 1.0) then k = 1 @@ -1514,23 +1543,23 @@ subroutine compute_uwshcu(idim, k0, dt,ncnst, pifc0_in,zifc0_in,& ! IN if (windsrcavg) then zrho = pifc0(0)/(287.04*(t0(1)*(1.+0.608*qv0(1)))) - buoyflx = (-shfx(i)/cp-0.608*t0(1)*evap(i))/zrho ! K m s-1 -! delzg = (zifc0(1)-zifc0(0))*g - delzg = (50.0)*g ! assume 50m surface scale + buoyflx = (-shfx/cp-0.608*t0(1)*evap)/zrho ! K m s-1 + ! Use actual PBL depth for convective velocity scale + delzg = (zifc0(kinv-1) - zifc0(0)) * g + ! Put a 50m safety minimum just in case the PBL is extremely shallow + delzg = max(delzg, 50.0*g) wstar = max(0.,0.001-0.41*buoyflx*delzg/t0(1)) ! m3 s-3 - qpert_out(i) = 0.0 - tpert_out(i) = 0.0 + qpert_out = 0.0 + tpert_out = 0.0 if (wstar > 0.001) then wstar = 1.0*wstar**.3333 - tpert_out(i) = thlsrc_fac*shfx(i)/(zrho*wstar*cp) ! K - qpert_out(i) = qtsrc_fac*evap(i)/(zrho*wstar) ! kg kg-1 + tpert_out = thlsrc_fac*shfx/(zrho*wstar*cp) ! K + qpert_out = qtsrc_fac*evap/(zrho*wstar) ! kg kg-1 end if - qpert_out(i) = max(min(qpert_out(i),0.02*qt0(1)),0.) ! limit to 1% of QT - tpert_out(i) = 0.1+max(min(tpert_out(i),1.0),0.) ! limit to 1K - qtsrc = qtavg + qpert_out(i) -! qtsrc = qt0(1) + qpert_out(i) -! thvlsrc = thvlavg + tpert_out(i)*(1.0+zvir*qtsrc) !/exnmid0(1) - thvlsrc = thvlmin + tpert_out(i)*(1.0+zvir*qtsrc) !/exnmid0(1) + qpert_out = max(min(qpert_out,0.01*qt0(1)),0.) ! limit to 1% of QT + tpert_out = max(min(tpert_out,1.0),0.) + 0.1 ! limit to 1K and give a 0.1K bouyancy kick + qtsrc = qtavg + qpert_out + thvlsrc = thvlmin + tpert_out*(1.0+zvir*qtsrc) thlsrc = thvlsrc / ( 1. + zvir * qtsrc ) usrc = uavg vsrc = vavg @@ -1594,7 +1623,7 @@ subroutine compute_uwshcu(idim, k0, dt,ncnst, pifc0_in,zifc0_in,& ! IN klcl = max(1,klcl) if( plcl .lt. 60000. ) then - exit_klclk0(i) = 1. + exit_klclk0 = 1. id_exit = .true. if (scverbose) then call write_parallel('------- UW ShCu: exit, plcl<600mb') @@ -1614,7 +1643,7 @@ subroutine compute_uwshcu(idim, k0, dt,ncnst, pifc0_in,zifc0_in,& ! IN qt0lcl = qt0(klcl) + ssqt0(klcl) * ( plcl - pmid0(klcl) ) call conden(plcl,thl0lcl,qt0lcl,thj,qvj,qlj,qij,qse,id_check) if( id_check .eq. 1 ) then - exit_conden(i) = 1. + exit_conden = 1. id_exit = .true. go to 333 end if @@ -1680,14 +1709,14 @@ subroutine compute_uwshcu(idim, k0, dt,ncnst, pifc0_in,zifc0_in,& ! IN thvubot = thvlsrc thvutop = thvlsrc cin = cin + single_cin(pifc0(k-1),thv0bot(k),plcl,thv0lcl,thvubot,thvutop) - if( cin .lt. 0. ) limit_cinlcl(i) = 1. + if( cin .lt. 0. ) limit_cinlcl = 1. cinlcl = max(cin,0.) cin = cinlcl !----- LCL to Top thvubot = thvlsrc call conden(pifc0(k),thlsrc,qtsrc,thj,qvj,qlj,qij,qse,id_check) if( id_check .eq. 1 ) then - exit_conden(i) = 1. + exit_conden = 1. id_exit = .true. go to 333 end if @@ -1701,7 +1730,7 @@ subroutine compute_uwshcu(idim, k0, dt,ncnst, pifc0_in,zifc0_in,& ! IN thvubot = thvutop call conden(pifc0(k),thlsrc,qtsrc,thj,qvj,qlj,qij,qse,id_check) if( id_check .eq. 1 ) then - exit_conden(i) = 1. + exit_conden = 1. id_exit = .true. go to 333 end if @@ -1723,14 +1752,14 @@ subroutine compute_uwshcu(idim, k0, dt,ncnst, pifc0_in,zifc0_in,& ! IN do k = kinv, k0 - 1 call conden(pifc0(k-1),thlsrc,qtsrc,thj,qvj,qlj,qij,qse,id_check) if( id_check .eq. 1 ) then - exit_conden(i) = 1. + exit_conden = 1. id_exit = .true. go to 333 end if thvubot = thj * ( 1. + zvir*qvj - qlj - qij ) call conden(pifc0(k),thlsrc,qtsrc,thj,qvj,qlj,qij,qse,id_check) if( id_check .eq. 1 ) then - exit_conden(i) = 1. + exit_conden = 1. id_exit = .true. go to 333 end if @@ -1744,7 +1773,7 @@ subroutine compute_uwshcu(idim, k0, dt,ncnst, pifc0_in,zifc0_in,& ! IN endif ! End of CIN case selection 35 continue - if( cin .lt. 0. ) limit_cin(i) = 1. + if( cin .lt. 0. ) limit_cin = 1. cin = max(0.,cin) ! cin = max(cin,0.04*(lts-18.)) ! kludge to reduce UW in StCu regions @@ -1754,7 +1783,7 @@ subroutine compute_uwshcu(idim, k0, dt,ncnst, pifc0_in,zifc0_in,& ! IN if (scverbose) then call write_parallel('------ UWShCu: klfc >= k0') end if - exit_klfck0(i) = 1. + exit_klfck0 = 1. id_exit = .true. go to 333 endif @@ -1982,7 +2011,7 @@ subroutine compute_uwshcu(idim, k0, dt,ncnst, pifc0_in,zifc0_in,& ! IN ! Identifier showing whether explicit or implicit CIN is used ! ! ----------------------------------------------------------- ! - ind_delcin(i) = 1. + ind_delcin = 1. if (scverbose) then call write_parallel('------ UWShCu: del_CIN<0') end if @@ -1991,41 +2020,41 @@ subroutine compute_uwshcu(idim, k0, dt,ncnst, pifc0_in,zifc0_in,& ! IN ! Restore original output values of "iter_cin = 1" and exit ! ! --------------------------------------------------------- ! - umf_out(i,0:k0) = umf_s(0:k0) - umf_out(i,0:kinv-1) = umf_s(kinv-1)*zifc0(0:kinv-1)/zifc0(kinv-1) - - dcm_out(i,:k0) = dcm_s(:k0) - qvten_out(i,:k0) = qvten_s(:k0) - qlten_out(i,:k0) = qlten_s(:k0) - qiten_out(i,:k0) = qiten_s(:k0) - sten_out(i,:k0) = sten_s(:k0) - uten_out(i,:k0) = uten_s(:k0) - vten_out(i,:k0) = vten_s(:k0) - qrten_out(i,:k0) = qrten_s(:k0) - qsten_out(i,:k0) = qsten_s(:k0) - qldet_out(i,:k0) = qldet_s(:k0) - qidet_out(i,:k0) = qidet_s(:k0) - qlsub_out(i,:k0) = qlsub_s(:k0) - qisub_out(i,:k0) = qisub_s(:k0) - cush_inout(i) = cush_s - cufrc_out(i,:k0) = cufrc_s(:k0) - qtflx_out(i,0:k0) = qtflx_s(0:k0) - slflx_out(i,0:k0) = slflx_s(0:k0) - uflx_out(i,0:k0) = uflx_s(0:k0) - vflx_out(i,0:k0) = vflx_s(0:k0) - - cbmf_out(i) = cbmf_s + umf_out(0:k0) = umf_s(0:k0) + umf_out(0:kinv-1) = umf_s(kinv-1)*zifc0(0:kinv-1)/zifc0(kinv-1) + + dcm_out(:k0) = dcm_s(:k0) + qvten_out(:k0) = qvten_s(:k0) + qlten_out(:k0) = qlten_s(:k0) + qiten_out(:k0) = qiten_s(:k0) + sten_out(:k0) = sten_s(:k0) + uten_out(:k0) = uten_s(:k0) + vten_out(:k0) = vten_s(:k0) + qrten_out(:k0) = qrten_s(:k0) + qsten_out(:k0) = qsten_s(:k0) + qldet_out(:k0) = qldet_s(:k0) + qidet_out(:k0) = qidet_s(:k0) + qlsub_out(:k0) = qlsub_s(:k0) + qisub_out(:k0) = qisub_s(:k0) + cush_inout = cush_s + cufrc_out(:k0) = cufrc_s(:k0) + qtflx_out(0:k0) = qtflx_s(0:k0) + slflx_out(0:k0) = slflx_s(0:k0) + uflx_out(0:k0) = uflx_s(0:k0) + vflx_out(0:k0) = vflx_s(0:k0) + + cbmf_out = cbmf_s #ifdef UWDIAG - qcu_out(i,:k0) = qcu_s(:k0) - qlu_out(i,:k0) = qlu_s(:k0) - qiu_out(i,:k0) = qiu_s(:k0) - qc_out(i,:k0) = qc_s(:k0) - cnt_out(i) = cnt_s - cnb_out(i) = cnb_s + qcu_out(:k0) = qcu_s(:k0) + qlu_out(:k0) = qlu_s(:k0) + qiu_out(:k0) = qiu_s(:k0) + qc_out(:k0) = qc_s(:k0) + cnt_out = cnt_s + cnb_out = cnb_s ! if (dotransport.eq.1) then ! do m = 1, ncnst -! trten_out(i,:k0,m) = trten_s(:k0,m) +! trten_out(:k0,m) = trten_s(:k0,m) ! enddo ! end if #endif @@ -2035,61 +2064,61 @@ subroutine compute_uwshcu(idim, k0, dt,ncnst, pifc0_in,zifc0_in,& ! IN ! The order of vertical index is reversed for this internal diagnostic output. ! ! ------------------------------------------------------------------------------ ! - fer_out(i,1:k0) = fer_s(:k0) - fdr_out(i,1:k0) = fdr_s(:k0) - plcl_out(i) = plcl_s - pinv_out(i) = pinv_s - prel_out(i) = prel_s - plfc_out(i) = plfc_s - pbup_out(i) = pbup_s + fer_out(1:k0) = fer_s(:k0) + fdr_out(1:k0) = fdr_s(:k0) + plcl_out = plcl_s + pinv_out = pinv_s + prel_out = prel_s + plfc_out = plfc_s + pbup_out = pbup_s #ifdef UWDIAG - ufrcinvbase_out(i) = ufrcinvbase_s - ufrclcl_out(i) = ufrclcl_s - winvbase_out(i) = winvbase_s - wlcl_out(i) = wlcl_s - ppen_out(i) = ppen_s - qtsrc_out(i) = qtsrc_s - thlsrc_out(i) = thlsrc_s - thvlsrc_out(i) = thvlsrc_s - emfkbup_out(i) = emfkbup_s - cbmflimit_out(i) = cbmflimit_s - tkeavg_out(i) = tkeavg_s - zinv_out(i) = zinv_s - rcwp_out(i) = rcwp_s - rlwp_out(i) = rlwp_s - riwp_out(i) = riwp_s - - xc_out(i,1:k0) = xc_s(:k0) - cinh_out(i) = cin_s - cinlclh_out(i) = cinlcl_s - - wu_out(i,k0:0:-1) = wu_s(0:k0) - qtu_out(i,k0:0:-1) = qtu_s(0:k0) - thlu_out(i,k0:0:-1) = thlu_s(0:k0) - thvu_out(i,k0:0:-1) = thvu_s(0:k0) - uu_out(i,k0:0:-1) = uu_s(0:k0) - vu_out(i,k0:0:-1) = vu_s(0:k0) - qtu_emf_out(i,k0:0:-1) = qtu_emf_s(0:k0) - thlu_emf_out(i,k0:0:-1) = thlu_emf_s(0:k0) - uu_emf_out(i,k0:0:-1) = uu_emf_s(0:k0) - vu_emf_out(i,k0:0:-1) = vu_emf_s(0:k0) - uemf_out(i,k0:0:-1) = uemf_s(0:k0) - - excessu_arr_out(i,k0:1:-1) = excessu_arr_s(:k0) - excess0_arr_out(i,k0:1:-1) = excess0_arr_s(:k0) - xc_arr_out(i,k0:1:-1) = xc_arr_s(:k0) - aquad_arr_out(i,k0:1:-1) = aquad_arr_s(:k0) - bquad_arr_out(i,k0:1:-1) = bquad_arr_s(:k0) - cquad_arr_out(i,k0:1:-1) = cquad_arr_s(:k0) - bogbot_arr_out(i,k0:1:-1) = bogbot_arr_s(:k0) - bogtop_arr_out(i,k0:1:-1) = bogtop_arr_s(:k0) + ufrcinvbase_out = ufrcinvbase_s + ufrclcl_out = ufrclcl_s + winvbase_out = winvbase_s + wlcl_out = wlcl_s + ppen_out = ppen_s + qtsrc_out = qtsrc_s + thlsrc_out = thlsrc_s + thvlsrc_out = thvlsrc_s + emfkbup_out = emfkbup_s + cbmflimit_out = cbmflimit_s + tkeavg_out = tkeavg_s + zinv_out = zinv_s + rcwp_out = rcwp_s + rlwp_out = rlwp_s + riwp_out = riwp_s + + xc_out(1:k0) = xc_s(:k0) + cinh_out = cin_s + cinlclh_out = cinlcl_s + + wu_out(k0:0:-1) = wu_s(0:k0) + qtu_out(k0:0:-1) = qtu_s(0:k0) + thlu_out(k0:0:-1) = thlu_s(0:k0) + thvu_out(k0:0:-1) = thvu_s(0:k0) + uu_out(k0:0:-1) = uu_s(0:k0) + vu_out(k0:0:-1) = vu_s(0:k0) + qtu_emf_out(k0:0:-1) = qtu_emf_s(0:k0) + thlu_emf_out(k0:0:-1) = thlu_emf_s(0:k0) + uu_emf_out(k0:0:-1) = uu_emf_s(0:k0) + vu_emf_out(k0:0:-1) = vu_emf_s(0:k0) + uemf_out(k0:0:-1) = uemf_s(0:k0) + + excessu_arr_out(k0:1:-1) = excessu_arr_s(:k0) + excess0_arr_out(k0:1:-1) = excess0_arr_s(:k0) + xc_arr_out(k0:1:-1) = xc_arr_s(:k0) + aquad_arr_out(k0:1:-1) = aquad_arr_s(:k0) + bquad_arr_out(k0:1:-1) = bquad_arr_s(:k0) + cquad_arr_out(k0:1:-1) = cquad_arr_s(:k0) + bogbot_arr_out(k0:1:-1) = bogbot_arr_s(:k0) + bogtop_arr_out(k0:1:-1) = bogtop_arr_s(:k0) if (dotransport.eq.1) then do m = 1, ncnst - trflx_out(i,k0:0:-1,m) = trflx_s(0:k0,m) - tru_out(i,k0:0:-1,m) = tru_s(0:k0,m) - tru_emf_out(i,k0:0:-1,m) = tru_emf_s(0:k0,m) + trflx_out(k0:0:-1,m) = trflx_s(0:k0,m) + tru_out(k0:0:-1,m) = tru_s(0:k0,m) + tru_emf_out(k0:0:-1,m) = tru_emf_s(0:k0,m) enddo endif #endif @@ -2208,13 +2237,13 @@ subroutine compute_uwshcu(idim, k0, dt,ncnst, pifc0_in,zifc0_in,& ! IN ! 1. 'cbmf' constraint if (cbmf > 1.0e-12) then ! limit and normalize by raw cbmf [0.1 : 1.0] - rkfre_eff = min(rkfre(i), min(1.0,max(0.1,(0.9*dp0(kinv-1)/g/dt)/cbmf))) + rkfre_eff = min(rkfre, min(1.0,max(0.1,(0.9*dp0(kinv-1)/g/dt)/cbmf))) else ! When no cloud base mass flux, limit to rkfre only - rkfre_eff = min(rkfre(i), 1.0) + rkfre_eff = min(rkfre, 1.0) endif cbmf = rkfre_eff*cbmf - if( rkfre_eff .lt. 1.0 ) limit_cbmf(i) = 1. + if( rkfre_eff .lt. 1.0 ) limit_cbmf = 1. ! 2. limited sigmaw (solving for sigmaw using limited cbmf) sigmaw = 2.5066 * cbmf * exp(mu**2) / rho0inv ! 3. 'ufrcinv' constraint @@ -2222,17 +2251,17 @@ subroutine compute_uwshcu(idim, k0, dt,ncnst, pifc0_in,zifc0_in,& ! IN mu = max(max(mu,mumin0),mumin1) ! 4. 'ufrclcl' constraint mulcl = sqrt(max(0.0,2.*cinlcl*rbuoy))/1.4142/sigmaw - mulclstar = sqrt(max(0.,2.*(exp(-mu**2)/2.5066)**2*(1./erfc(mu)**2-0.25/rmaxfrac(i)**2))) + mulclstar = sqrt(max(0.,2.*(exp(-mu**2)/2.5066)**2*(1./erfc(mu)**2-0.25/rmaxfrac**2))) if( mulcl .gt. 1.e-8 .and. mulcl .gt. mulclstar ) then - mumin2 = compute_mumin2(mulcl,rmaxfrac(i),mu) + mumin2 = compute_mumin2(mulcl,rmaxfrac,mu) if( mu .gt. mumin2 ) then call write_parallel('Critical error in mu calculation in UW_ShCu') ! call endrun endif mu = max(mu,mumin2) - if( mu .eq. mumin2 ) limit_ufrc(i) = 1. + if( mu .eq. mumin2 ) limit_ufrc = 1. endif - if( mu .eq. mumin1 ) limit_ufrc(i) = 1. + if( mu .eq. mumin1 ) limit_ufrc = 1. ! ------------------------------------------------------------------- ! ! Calculate final ['cbmf','ufrcinv','winv'] at the PBL top interface. ! @@ -2260,7 +2289,7 @@ subroutine compute_uwshcu(idim, k0, dt,ncnst, pifc0_in,zifc0_in,& ! IN if (scverbose) then call write_parallel('wlcl < 0 at the LCL') end if - exit_wtw(i) = 1. + exit_wtw = 1. id_exit = .true. go to 333 endif @@ -2271,7 +2300,7 @@ subroutine compute_uwshcu(idim, k0, dt,ncnst, pifc0_in,zifc0_in,& ! IN if (scverbose) then call write_parallel( 'ufrclcl <= 0.0001' ) end if - exit_ufrc(i) = 1. + exit_ufrc = 1. id_exit = .true. go to 333 endif @@ -2312,7 +2341,7 @@ subroutine compute_uwshcu(idim, k0, dt,ncnst, pifc0_in,zifc0_in,& ! IN qtu(krel-1) = qtsrc call conden(prel,thlsrc,qtsrc,thj,qvj,qlj,qij,qse,id_check) if( id_check .eq. 1 ) then - exit_conden(i) = 1. + exit_conden = 1. id_exit = .true. if (scverbose) then call write_parallel('------- UW ShCu: exit, conden') @@ -2535,7 +2564,7 @@ subroutine compute_uwshcu(idim, k0, dt,ncnst, pifc0_in,zifc0_in,& ! IN call conden(pe,thle,qte,thj,qvj,qlj,qij,qse,id_check) if( id_check .eq. 1 ) then - exit_conden(i) = 1. + exit_conden = 1. id_exit = .true. if (scverbose) then call write_parallel('------- UW ShCu: exit, conden') @@ -2550,7 +2579,7 @@ subroutine compute_uwshcu(idim, k0, dt,ncnst, pifc0_in,zifc0_in,& ! IN call conden(pe,thlue,qtue,thj,qvj,qlj,qij,qse,id_check) if( id_check .eq. 1 ) then - exit_conden(i) = 1. + exit_conden = 1. id_exit = .true. if (scverbose) then call write_parallel('------- UW ShCu: exit, conden') @@ -2574,7 +2603,7 @@ subroutine compute_uwshcu(idim, k0, dt,ncnst, pifc0_in,zifc0_in,& ! IN endif call conden(pe,thlue,qtue,thj,qvj,qlj,qij,qse,id_check) if( id_check .eq. 1 ) then - exit_conden(i) = 1. + exit_conden = 1. id_exit = .true. if (scverbose) then call write_parallel('------- UW ShCu: exit, conden') @@ -2640,7 +2669,7 @@ subroutine compute_uwshcu(idim, k0, dt,ncnst, pifc0_in,zifc0_in,& ! IN qtxsat = qtue + xsat * ( qte - qtue ); call conden(pe,thlxsat,qtxsat,thj,qvj,qlj,qij,qse,id_check) if( id_check .eq. 1 ) then - exit_conden(i) = 1. + exit_conden = 1. id_exit = .true. if (scverbose) then call write_parallel('------- UW ShCu: exit, conden') @@ -2701,12 +2730,12 @@ subroutine compute_uwshcu(idim, k0, dt,ncnst, pifc0_in,zifc0_in,& ! IN ! ------------------------------------------------------------------------ ! ee2 = xc**2 ud2 = 1. - 2.*xc + xc**2 ! (1-xc)**2 - if (min(scaleh,mix2d(i)) .gt. tiny) then - rei(k) = ( (rkm2d(i)+max(0.,(zmid0(k)-detrhgt)/200.) ) / min(scaleh,mix2d(i)) / g / rhomid0j ) ! alternative + if (min(scaleh,mix2d) .gt. tiny) then + rei(k) = ( (rkm2d+max(0.,(zmid0(k)-detrhgt)/200.) ) / min(scaleh,mix2d) / g / rhomid0j ) ! alternative ! regression bug due to cnvtr -! WMP rei(k) = ( (rkm2d(i)+max(0.,(zmid0(k)-detrhgt)/200.)-max(0.,min(2.,(cnvtr(i))/2.5e-6))) / min(scaleh,mix2d(i)) / g / rhomid0j ) ! alternative +! WMP rei(k) = ( (rkm2d+max(0.,(zmid0(k)-detrhgt)/200.)-max(0.,min(2.,(cnvtr)/2.5e-6))) / min(scaleh,mix2d) / g / rhomid0j ) ! alternative else - rei(k) = ( 0.5 * rkm2d(i) / zmid0(k) / g /rhomid0j ) ! Jason-2_0 version + rei(k) = ( 0.5 * rkm2d / zmid0(k) / g /rhomid0j ) ! Jason-2_0 version end if ! overflow if( xc .gt. 0.5 ) rei(k) = min(rei(k),0.9*log(max(tiny,dp0(k)/g/dt/umf(km1) + 1.))/dpe/(2.*xc-1.)) @@ -2818,7 +2847,7 @@ subroutine compute_uwshcu(idim, k0, dt,ncnst, pifc0_in,zifc0_in,& ! IN call conden(pifc0(k),thlu(k),qtu(k),thj,qvj,qlj,qij,qse,id_check) if( id_check .eq. 1 ) then - exit_conden(i) = 1. + exit_conden = 1. id_exit = .true. if (scverbose) then call write_parallel('------- UW ShCu: exit, conden') @@ -2858,7 +2887,7 @@ subroutine compute_uwshcu(idim, k0, dt,ncnst, pifc0_in,zifc0_in,& ! IN ! ----------------------------------------------------------------- ! call conden(pifc0(k),thlu(k),qtu(k),thj,qvj,qlj,qij,qse,id_check) if( id_check .eq. 1 ) then - exit_conden(i) = 1. + exit_conden = 1. id_exit = .true. if (scverbose) then call write_parallel('------- UW ShCu: exit, conden') @@ -2976,7 +3005,7 @@ subroutine compute_uwshcu(idim, k0, dt,ncnst, pifc0_in,zifc0_in,& ! IN wu(k) = sqrt(wtw) ! Protected from NaN above if( wu(k) .gt. 100. ) then - exit_wu(i) = 1. + exit_wu = 1. id_exit = .true. if (scverbose) then call write_parallel('------- UW ShCu: exited, wu>100') @@ -3006,10 +3035,10 @@ subroutine compute_uwshcu(idim, k0, dt,ncnst, pifc0_in,zifc0_in,& ! IN rhoifc0j = pifc0(k) / ( r * 0.5 * ( thv0bot(k+1) + thv0top(k) )*exnifc0(k) ) ufrc(k) = umf(k) / ( rhoifc0j * wu(k) ) - if( ufrc(k) .gt. rmaxfrac(i) ) then - limit_ufrc(i) = 1. - ufrc(k) = rmaxfrac(i) - umf(k) = rmaxfrac(i) * rhoifc0j * wu(k) + if( ufrc(k) .gt. rmaxfrac ) then + limit_ufrc = 1. + ufrc(k) = rmaxfrac + umf(k) = rmaxfrac * rhoifc0j * wu(k) fdr(k) = fer(k) - log(max(tiny, umf(k) / umf(km1)) ) / dpe if (fdr(k).gt.fer_fdr_limit) then print *,"fdr(k) [updated] > ",fer_fdr_limit," ! fdr=",fdr(k)," dpe=",dpe/100.0 @@ -3107,7 +3136,7 @@ subroutine compute_uwshcu(idim, k0, dt,ncnst, pifc0_in,zifc0_in,& ! IN else ppen = compute_ppen(wtwb,drage,bogbot,bogtop,rhomid0j,dp0(kpen)) endif - if( ppen .eq. -dp0(kpen) .or. ppen .eq. 0. ) limit_ppen(i) = 1. + if( ppen .eq. -dp0(kpen) .or. ppen .eq. 0. ) limit_ppen = 1. ! -------------------------------------------------------------------- ! ! Re-calculate the amount of expelled condensate from cloud updraft ! @@ -3131,7 +3160,7 @@ subroutine compute_uwshcu(idim, k0, dt,ncnst, pifc0_in,zifc0_in,& ! IN call conden(pifc0(kpen-1)+ppen,thlu_top,qtu_top,thj,qvj,qlj,qij,qse,id_check) if( id_check .eq. 1 ) then - exit_conden(i) = 1. + exit_conden = 1. id_exit = .true. if (scverbose) then call write_parallel('------- UW ShCu: exit, conden') @@ -3171,10 +3200,10 @@ subroutine compute_uwshcu(idim, k0, dt,ncnst, pifc0_in,zifc0_in,& ! IN if( kbup .eq. krel ) then forcedCu = .true. - limit_shcu(i) = 1. + limit_shcu = 1. else forcedCu = .false. - limit_shcu(i) = 0. + limit_shcu = 0. endif ! ------------------------------------------------------------------ ! @@ -3196,7 +3225,7 @@ subroutine compute_uwshcu(idim, k0, dt,ncnst, pifc0_in,zifc0_in,& ! IN if (scverbose) then call write_parallel( 'forcedCu - did not overcome initial buoyancy barrier') end if - exit_cufilter(i) = 1. + exit_cufilter = 1. id_exit = .true. go to 333 end if @@ -3307,8 +3336,8 @@ subroutine compute_uwshcu(idim, k0, dt,ncnst, pifc0_in,zifc0_in,& ! IN ! penetratively entraining interface. ! ! -------------------------------------------------------------------- ! - if( ( umf(k)*ppen*rei(kpen)*rpen ) .lt. -0.1*rhoifc0j ) limit_emf(i) = 1. - if( ( umf(k)*ppen*rei(kpen)*rpen ) .lt. -0.9*dp0(kpen)/g/dt ) limit_emf(i) = 1. + if( ( umf(k)*ppen*rei(kpen)*rpen ) .lt. -0.1*rhoifc0j ) limit_emf = 1. + if( ( umf(k)*ppen*rei(kpen)*rpen ) .lt. -0.9*dp0(kpen)/g/dt ) limit_emf = 1. emf(k) = max( max( umf(k)*ppen*rei(kpen)*rpen, -0.1*rhoifc0j), -0.9*dp0(kpen)/g/dt) thlu_emf(k) = thl0(kpen) + ssthl0(kpen) * ( pifc0(k) - pmid0(kpen) ) @@ -3332,8 +3361,8 @@ subroutine compute_uwshcu(idim, k0, dt,ncnst, pifc0_in,zifc0_in,& ! IN if( use_cumpenent ) then ! Original Cumulative Penetrative Entrainment - if( ( emf(k+1)-umf(k)*dp0(k+1)*rei(k+1)*rpen ) .lt. -0.1*rhoifc0j ) limit_emf(i) = 1 - if( ( emf(k+1)-umf(k)*dp0(k+1)*rei(k+1)*rpen ) .lt. -0.9*dp0(k+1)/g/dt ) limit_emf(i) = 1 + if( ( emf(k+1)-umf(k)*dp0(k+1)*rei(k+1)*rpen ) .lt. -0.1*rhoifc0j ) limit_emf = 1 + if( ( emf(k+1)-umf(k)*dp0(k+1)*rei(k+1)*rpen ) .lt. -0.9*dp0(k+1)/g/dt ) limit_emf = 1 emf(k) = max(max(emf(k+1)-umf(k)*dp0(k+1)*rei(k+1)*rpen, -0.1*rhoifc0j), -0.9*dp0(k+1)/g/dt ) if( abs(emf(k)) .gt. abs(emf(k+1)) ) then thlu_emf(k) = ( thlu_emf(k+1) * emf(k+1) + thl0(k+1) * ( emf(k) - emf(k+1) ) ) / emf(k) @@ -3359,8 +3388,8 @@ subroutine compute_uwshcu(idim, k0, dt,ncnst, pifc0_in,zifc0_in,& ! IN else ! Alternative Non-Cumulative Penetrative Entrainment - if( ( -umf(k)*dp0(k+1)*rei(k+1)*rpen ) .lt. -0.1*rhoifc0j ) limit_emf(i) = 1 - if( ( -umf(k)*dp0(k+1)*rei(k+1)*rpen ) .lt. -0.9*dp0(k+1)/g/dt ) limit_emf(i) = 1 + if( ( -umf(k)*dp0(k+1)*rei(k+1)*rpen ) .lt. -0.1*rhoifc0j ) limit_emf = 1 + if( ( -umf(k)*dp0(k+1)*rei(k+1)*rpen ) .lt. -0.9*dp0(k+1)/g/dt ) limit_emf = 1 emf(k) = max(max(-umf(k)*dp0(k+1)*rei(k+1)*rpen, -0.1*rhoifc0j), -0.9*dp0(k+1)/g/dt ) thlu_emf(k) = thl0(k+1) qtu_emf(k) = qt0(k+1) @@ -3848,7 +3877,7 @@ subroutine compute_uwshcu(idim, k0, dt,ncnst, pifc0_in,zifc0_in,& ! IN elseif( k .eq. krel ) then call conden(prel,thlu(krel-1),qtu(krel-1),thj,qvj,qlj,qij,qse,id_check) if( id_check .eq. 1 ) then - exit_conden(i) = 1. + exit_conden = 1. id_exit = .true. if (scverbose) then call write_parallel('------- UW ShCu: exit, conden') @@ -3859,7 +3888,7 @@ subroutine compute_uwshcu(idim, k0, dt,ncnst, pifc0_in,zifc0_in,& ! IN qiubelow = qij call conden(pifc0(k),thlu(k),qtu(k),thj,qvj,qlj,qij,qse,id_check) if( id_check .eq. 1 ) then - exit_conden(i) = 1. + exit_conden = 1. id_exit = .true. if (scverbose) then call write_parallel('------- UW ShCu: exit, conden') @@ -3871,7 +3900,7 @@ subroutine compute_uwshcu(idim, k0, dt,ncnst, pifc0_in,zifc0_in,& ! IN elseif( k .eq. kpen ) then call conden(pifc0(k-1)+ppen,thlu_top,qtu_top,thj,qvj,qlj,qij,qse,id_check) if( id_check .eq. 1 ) then - exit_conden(i) = 1. + exit_conden = 1. id_exit = .true. if (scverbose) then call write_parallel('------- UW ShCu: exit, conden') @@ -3885,7 +3914,7 @@ subroutine compute_uwshcu(idim, k0, dt,ncnst, pifc0_in,zifc0_in,& ! IN else call conden(pifc0(k),thlu(k),qtu(k),thj,qvj,qlj,qij,qse,id_check) if( id_check .eq. 1 ) then - exit_conden(i) = 1. + exit_conden = 1. id_exit = .true. if (scverbose) then call write_parallel('------- UW ShCu: exit, conden') @@ -4030,7 +4059,7 @@ subroutine compute_uwshcu(idim, k0, dt,ncnst, pifc0_in,zifc0_in,& ! IN ! if( ( qv0(k) + qvten(k)*dt ) .lt. 0.0 .or. & ! ( ql0(k) + qlten(k)*dt ) .lt. 0.0 .or. & ! ( qi0(k) + qiten(k)*dt ) .lt. 0.0 ) then -! limit_negcon(i) = 1. +! limit_negcon = 1. ! end if slten(k) = sten(k) - xlv*qlten(k) - xls*qiten(k) slten(k) = slten(k) + xlv * qrten(k) + xls * qsten(k) @@ -4147,7 +4176,7 @@ subroutine compute_uwshcu(idim, k0, dt,ncnst, pifc0_in,zifc0_in,& ! IN call conden(prel,thlu(krel-1),qtu(krel-1),thj,qvj,qlj,qij,qse,id_check) if( id_check .eq. 1 ) then - exit_conden(i) = 1. + exit_conden = 1. id_exit = .true. if (scverbose) then call write_parallel('------- UW ShCu: exit, conden') @@ -4177,7 +4206,7 @@ subroutine compute_uwshcu(idim, k0, dt,ncnst, pifc0_in,zifc0_in,& ! IN call conden(pifc0(k),thlu(k),qtu(k),thj,qvj,qlj,qij,qse,id_check) endif if( id_check .eq. 1 ) then - exit_conden(i) = 1. + exit_conden = 1. id_exit = .true. if (scverbose) then call write_parallel('------- UW ShCu: exit, conden') @@ -4378,7 +4407,7 @@ subroutine compute_uwshcu(idim, k0, dt,ncnst, pifc0_in,zifc0_in,& ! IN qt0bot = qt0(k) + ssqt0(k) * ( pifc0(k-1) - pmid0(k) ) call conden(pifc0(k-1),thl0bot,qt0bot,thj,qvj,qlj,qij,qse,id_check) if( id_check .eq. 1 ) then - exit_conden(i) = 1. + exit_conden = 1. id_exit = .true. if (scverbose) then call write_parallel('------- UW ShCu: exit, conden') @@ -4392,7 +4421,7 @@ subroutine compute_uwshcu(idim, k0, dt,ncnst, pifc0_in,zifc0_in,& ! IN qt0top = qt0(k) + ssqt0(k) * ( pifc0(k) - pmid0(k) ) call conden(pifc0(k),thl0top,qt0top,thj,qvj,qlj,qij,qse,id_check) if( id_check .eq. 1 ) then - exit_conden(i) = 1. + exit_conden = 1. id_exit = .true. if (scverbose) then call write_parallel('------- UW ShCu: exit, conden') @@ -4414,36 +4443,36 @@ subroutine compute_uwshcu(idim, k0, dt,ncnst, pifc0_in,zifc0_in,& ! IN ! Update Output Variables ! ! ----------------------- ! - umf_out(i,0:k0) = umf(0:k0) - umf_out(i,0:kinv-1) = umf(kinv-1)*zifc0(0:kinv-1)/zifc0(kinv-1) -! umf_out(i,0:kinv-2) = uemf(0:kinv-2) - dcm_out(i,:k0) = dcm(:k0) + umf_out(0:k0) = umf(0:k0) + umf_out(0:kinv-1) = umf(kinv-1)*zifc0(0:kinv-1)/zifc0(kinv-1) +! umf_out(0:kinv-2) = uemf(0:kinv-2) + dcm_out(:k0) = dcm(:k0) !the indices are not reversed, these variables go into compute_mcshallow_inv - qvten_out(i,:k0) = qvten(:k0) - qlten_out(i,:k0) = qlten(:k0) - qiten_out(i,:k0) = qiten(:k0) - sten_out(i,:k0) = sten(:k0) - uten_out(i,:k0) = uten(:k0) - vten_out(i,:k0) = vten(:k0) - qrten_out(i,:k0) = qrten(:k0) - qsten_out(i,:k0) = qsten(:k0) - cufrc_out(i,:k0) = cufrc(:k0) - cush_inout(i) = cush - qldet_out(i,:k0) = qlten_det(:k0) - qidet_out(i,:k0) = qiten_det(:k0) - qlsub_out(i,:k0) = qlten_sink(:k0) - qisub_out(i,:k0) = qiten_sink(:k0) - ndrop_out(i,:k0) = qlten_det(:k0)/(4188.787*rdrop**3) -! ndrop_out(i,:k0) = qlten_det(:k0)/(4.19e-12) !(1.15e-11) ! /drop mass - nice_out(i,:k0) = qiten_det(:k0)/(3.0e-10) ! /crystal mass - qtflx_out(i,0:k0) = qtflx(0:k0) - slflx_out(i,0:k0) = slflx(0:k0) - uflx_out(i,0:k0) = uflx(0:k0) - vflx_out(i,0:k0) = vflx(0:k0) + qvten_out(:k0) = qvten(:k0) + qlten_out(:k0) = qlten(:k0) + qiten_out(:k0) = qiten(:k0) + sten_out(:k0) = sten(:k0) + uten_out(:k0) = uten(:k0) + vten_out(:k0) = vten(:k0) + qrten_out(:k0) = qrten(:k0) + qsten_out(:k0) = qsten(:k0) + cufrc_out(:k0) = cufrc(:k0) + cush_inout = cush + qldet_out(:k0) = qlten_det(:k0) + qidet_out(:k0) = qiten_det(:k0) + qlsub_out(:k0) = qlten_sink(:k0) + qisub_out(:k0) = qiten_sink(:k0) + ndrop_out(:k0) = qlten_det(:k0)/(4188.787*rdrop**3) +! ndrop_out(:k0) = qlten_det(:k0)/(4.19e-12) !(1.15e-11) ! /drop mass + nice_out(:k0) = qiten_det(:k0)/(3.0e-10) ! /crystal mass + qtflx_out(0:k0) = qtflx(0:k0) + slflx_out(0:k0) = slflx(0:k0) + uflx_out(0:k0) = uflx(0:k0) + vflx_out(0:k0) = vflx(0:k0) if (dotransport.eq.1) then do m = 1, ncnst - tr0_inout(i,:k0,m) = tr0_inout(i,:k0,m) + trten(:k0,m) * dt + tr0(:k0,m) = tr0(:k0,m) + trten(:k0,m) * dt enddo endif @@ -4452,86 +4481,86 @@ subroutine compute_uwshcu(idim, k0, dt,ncnst, pifc0_in,zifc0_in,& ! IN ! analysis of cumulus scheme ! ! ------------------------------------------------- ! - fer_out(i,1:kpen) = fer(:kpen) - fdr_out(i,1:kpen) = fdr(:kpen) + fer_out(1:kpen) = fer(:kpen) + fdr_out(1:kpen) = fdr(:kpen) - cldhgt_out(i) = cldhgt - cbmf_out(i) = cbmf - plcl_out(i) = plcl - pinv_out(i) = pifc0(kinv-1) - plfc_out(i) = plfc - prel_out(i) = prel - pbup_out(i) = pifc0(kbup) + cldhgt_out = cldhgt + cbmf_out = cbmf + plcl_out = plcl + pinv_out = pifc0(kinv-1) + plfc_out = plfc + prel_out = prel + pbup_out = pifc0(kbup) #ifdef UWDIAG - cnt_out(i) = cnt - cnb_out(i) = cnb - qcu_out(i,:k0) = qcu(:k0) - qlu_out(i,:k0) = qlu(:k0) - qiu_out(i,:k0) = qiu(:k0) - qc_out(i,:k0) = qc(:k0) - xc_out(i,1:k0) = xco(:k0) - cinh_out(i) = cin - cinlclh_out(i) = cinlcl -! qtten_out(i,1:k0) = qtten(:k0) -! slten_out(i,1:k0) = slten(:k0) -! ufrc_out(i,0:k0) = ufrc(0:k0) -! uflx_out(i,0:k0) = uflx(0:k0) -! vflx_out(i,0:k0) = vflx(0:k0) + cnt_out = cnt + cnb_out = cnb + qcu_out(:k0) = qcu(:k0) + qlu_out(:k0) = qlu(:k0) + qiu_out(:k0) = qiu(:k0) + qc_out(:k0) = qc(:k0) + xc_out(1:k0) = xco(:k0) + cinh_out = cin + cinlclh_out = cinlcl +! qtten_out(1:k0) = qtten(:k0) +! slten_out(1:k0) = slten(:k0) +! ufrc_out(0:k0) = ufrc(0:k0) +! uflx_out(0:k0) = uflx(0:k0) +! vflx_out(0:k0) = vflx(0:k0) - ufrcinvbase_out(i) = ufrcinvbase - ufrclcl_out(i) = ufrclcl - winvbase_out(i) = winvbase - wlcl_out(i) = wlcl - ppen_out(i) = pifc0(kpen-1) + ppen - qtsrc_out(i) = qtsrc - thlsrc_out(i) = thlsrc - thvlsrc_out(i) = thvlsrc - emfkbup_out(i) = emf(kbup) - cbmflimit_out(i) = cbmflimit - tkeavg_out(i) = tkeavg - zinv_out(i) = zifc0(kinv-1) - rcwp_out(i) = rcwp - rlwp_out(i) = rlwp - riwp_out(i) = riwp - - wu_out(i,0:k0) = wu(0:k0) - qtu_out(i,0:k0) = qtu(0:k0) - thlu_out(i,0:k0) = thlu(0:k0) - thvu_out(i,0:k0) = thvu(0:k0) - uu_out(i,0:k0) = uu(0:k0) - vu_out(i,0:k0) = vu(0:k0) - qtu_emf_out(i,0:k0) = qtu_emf(0:k0) - thlu_emf_out(i,0:k0) = thlu_emf(0:k0) - uu_emf_out(i,0:k0) = uu_emf(0:k0) - vu_emf_out(i,0:k0) = vu_emf(0:k0) - uemf_out(i,0:k0) = uemf(0:k0) - - dwten_out(i,1:k0) = dwten(:k0) - diten_out(i,1:k0) = diten(:k0) - - excessu_arr_out(i,1:k0) = excessu_arr(:k0) - excess0_arr_out(i,1:k0) = excess0_arr(:k0) - xc_arr_out(i,1:k0) = xc_arr(:k0) - aquad_arr_out(i,1:k0) = aquad_arr(:k0) - bquad_arr_out(i,1:k0) = bquad_arr(:k0) - cquad_arr_out(i,1:k0) = cquad_arr(:k0) - bogbot_arr_out(i,1:k0) = bogbot_arr(:k0) - bogtop_arr_out(i,1:k0) = bogtop_arr(:k0) + ufrcinvbase_out = ufrcinvbase + ufrclcl_out = ufrclcl + winvbase_out = winvbase + wlcl_out = wlcl + ppen_out = pifc0(kpen-1) + ppen + qtsrc_out = qtsrc + thlsrc_out = thlsrc + thvlsrc_out = thvlsrc + emfkbup_out = emf(kbup) + cbmflimit_out = cbmflimit + tkeavg_out = tkeavg + zinv_out = zifc0(kinv-1) + rcwp_out = rcwp + rlwp_out = rlwp + riwp_out = riwp + + wu_out(0:k0) = wu(0:k0) + qtu_out(0:k0) = qtu(0:k0) + thlu_out(0:k0) = thlu(0:k0) + thvu_out(0:k0) = thvu(0:k0) + uu_out(0:k0) = uu(0:k0) + vu_out(0:k0) = vu(0:k0) + qtu_emf_out(0:k0) = qtu_emf(0:k0) + thlu_emf_out(0:k0) = thlu_emf(0:k0) + uu_emf_out(0:k0) = uu_emf(0:k0) + vu_emf_out(0:k0) = vu_emf(0:k0) + uemf_out(0:k0) = uemf(0:k0) + + dwten_out(1:k0) = dwten(:k0) + diten_out(1:k0) = diten(:k0) + + excessu_arr_out(1:k0) = excessu_arr(:k0) + excess0_arr_out(1:k0) = excess0_arr(:k0) + xc_arr_out(1:k0) = xc_arr(:k0) + aquad_arr_out(1:k0) = aquad_arr(:k0) + bquad_arr_out(1:k0) = bquad_arr(:k0) + cquad_arr_out(1:k0) = cquad_arr(:k0) + bogbot_arr_out(1:k0) = bogbot_arr(:k0) + bogtop_arr_out(1:k0) = bogtop_arr(:k0) ! if (dotransport.eq.1) then ! do m = 1, ncnst -! trten_out(i,:k0,m) = trten(:k0,m) -! trflx_out(i,0:k0,m) = trflx(0:k0,m) -! tru_out(i,0:k0,m) = tru(0:k0,m) -! tru_emf_out(i,0:k0,m) = tru_emf(0:k0,m) +! trten_out(:k0,m) = trten(:k0,m) +! trflx_out(0:k0,m) = trflx(0:k0,m) +! tru_out(0:k0,m) = tru(0:k0,m) +! tru_emf_out(0:k0,m) = tru_emf(0:k0,m) ! enddo ! endif #endif 333 if (id_exit) then - exit_uwcu(i) = 1. + exit_uwcu = 1. if (scverbose) then call write_parallel('------- UW ShCu: Exited!') end if @@ -4540,106 +4569,104 @@ subroutine compute_uwshcu(idim, k0, dt,ncnst, pifc0_in,zifc0_in,& ! IN ! Initialize output variables when cumulus convection was not performed.! ! --------------------------------------------------------------------- ! - umf_out(i,0:k0) = 0. - dcm_out(i,:k0) = 0. - qvten_out(i,:k0) = 0. - qlten_out(i,:k0) = 0. - qiten_out(i,:k0) = 0. - sten_out(i,:k0) = 0. - uten_out(i,:k0) = 0. - vten_out(i,:k0) = 0. - qrten_out(i,:k0) = 0. - qsten_out(i,:k0) = 0. - cufrc_out(i,:k0) = 0. - cush_inout(i) = -1. - qldet_out(i,:k0) = 0. - qidet_out(i,:k0) = 0. - qtflx_out(i,0:k0) = 0. - slflx_out(i,0:k0) = 0. - uflx_out(i,0:k0) = 0. - vflx_out(i,0:k0) = 0. - - fer_out(i,1:k0) = MAPL_UNDEF - fdr_out(i,1:k0) = MAPL_UNDEF - - cbmf_out(i) = 0. - plcl_out(i) = MAPL_UNDEF - pinv_out(i) = MAPL_UNDEF - prel_out(i) = MAPL_UNDEF - plfc_out(i) = MAPL_UNDEF - pbup_out(i) = MAPL_UNDEF - cldhgt_out(i) = MAPL_UNDEF + umf_out(0:k0) = 0. + dcm_out(:k0) = 0. + qvten_out(:k0) = 0. + qlten_out(:k0) = 0. + qiten_out(:k0) = 0. + sten_out(:k0) = 0. + uten_out(:k0) = 0. + vten_out(:k0) = 0. + qrten_out(:k0) = 0. + qsten_out(:k0) = 0. + cufrc_out(:k0) = 0. + cush_inout = -1. + qldet_out(:k0) = 0. + qidet_out(:k0) = 0. + qtflx_out(0:k0) = 0. + slflx_out(0:k0) = 0. + uflx_out(0:k0) = 0. + vflx_out(0:k0) = 0. + + fer_out(1:k0) = MAPL_UNDEF + fdr_out(1:k0) = MAPL_UNDEF + + cbmf_out = 0. + plcl_out = MAPL_UNDEF + pinv_out = MAPL_UNDEF + prel_out = MAPL_UNDEF + plfc_out = MAPL_UNDEF + pbup_out = MAPL_UNDEF + cldhgt_out = MAPL_UNDEF #ifdef UWDIAG - cnt_out(i) = 1. - cnb_out(i) = real(k0) - qcu_out(i,:k0) = 0. - qlu_out(i,:k0) = 0. - qiu_out(i,:k0) = 0. - qc_out(i,:k0) = 0. - xc_out(i,1:k0) = MAPL_UNDEF - cinh_out(i) = cin - cinlclh_out(i) = cinlcl -! qtten_out(i,k0:1:-1) = 0. -! slten_out(i,k0:1:-1) = 0. -! ufrc_out(i,k0:0:-1) = 0. -! uflx_out(i,k0:0:-1) = 0. -! vflx_out(i,k0:0:-1) = 0. - - ufrcinvbase_out(i) = 0. - ufrclcl_out(i) = 0. - winvbase_out(i) = 0. - wlcl_out(i) = MAPL_UNDEF - ppen_out(i) = MAPL_UNDEF - qtsrc_out(i) = MAPL_UNDEF - thlsrc_out(i) = MAPL_UNDEF - thvlsrc_out(i) = MAPL_UNDEF - emfkbup_out(i) = 0. - cbmflimit_out(i) = 0. - tkeavg_out(i) = tkeavg - zinv_out(i) = 0. - rcwp_out(i) = 0. - rlwp_out(i) = 0. - riwp_out(i) = 0. - - wu_out(i,k0:0:-1) = MAPL_UNDEF - qtu_out(i,k0:0:-1) = MAPL_UNDEF - thlu_out(i,k0:0:-1) = MAPL_UNDEF - thvu_out(i,k0:0:-1) = MAPL_UNDEF - uu_out(i,k0:0:-1) = MAPL_UNDEF - vu_out(i,k0:0:-1) = MAPL_UNDEF - qtu_emf_out(i,k0:0:-1) = MAPL_UNDEF - thlu_emf_out(i,k0:0:-1) = MAPL_UNDEF - uu_emf_out(i,k0:0:-1) = MAPL_UNDEF - vu_emf_out(i,k0:0:-1) = MAPL_UNDEF - uemf_out(i,k0:0:-1) = MAPL_UNDEF + cnt_out = 1. + cnb_out = real(k0) + qcu_out(:k0) = 0. + qlu_out(:k0) = 0. + qiu_out(:k0) = 0. + qc_out(:k0) = 0. + xc_out(1:k0) = MAPL_UNDEF + cinh_out = cin + cinlclh_out = cinlcl +! qtten_out(k0:1:-1) = 0. +! slten_out(k0:1:-1) = 0. +! ufrc_out(k0:0:-1) = 0. +! uflx_out(k0:0:-1) = 0. +! vflx_out(k0:0:-1) = 0. + + ufrcinvbase_out = 0. + ufrclcl_out = 0. + winvbase_out = 0. + wlcl_out = MAPL_UNDEF + ppen_out = MAPL_UNDEF + qtsrc_out = MAPL_UNDEF + thlsrc_out = MAPL_UNDEF + thvlsrc_out = MAPL_UNDEF + emfkbup_out = 0. + cbmflimit_out = 0. + tkeavg_out = tkeavg + zinv_out = 0. + rcwp_out = 0. + rlwp_out = 0. + riwp_out = 0. + + wu_out(k0:0:-1) = MAPL_UNDEF + qtu_out(k0:0:-1) = MAPL_UNDEF + thlu_out(k0:0:-1) = MAPL_UNDEF + thvu_out(k0:0:-1) = MAPL_UNDEF + uu_out(k0:0:-1) = MAPL_UNDEF + vu_out(k0:0:-1) = MAPL_UNDEF + qtu_emf_out(k0:0:-1) = MAPL_UNDEF + thlu_emf_out(k0:0:-1) = MAPL_UNDEF + uu_emf_out(k0:0:-1) = MAPL_UNDEF + vu_emf_out(k0:0:-1) = MAPL_UNDEF + uemf_out(k0:0:-1) = MAPL_UNDEF - dwten_out(i,k0:1:-1) = 0. - diten_out(i,k0:1:-1) = 0. - - excessu_arr_out(i,k0:1:-1) = 0. - excess0_arr_out(i,k0:1:-1) = 0. - xc_arr_out(i,k0:1:-1) = 0. - aquad_arr_out(i,k0:1:-1) = 0. - bquad_arr_out(i,k0:1:-1) = 0. - cquad_arr_out(i,k0:1:-1) = 0. - bogbot_arr_out(i,k0:1:-1) = 0. - bogtop_arr_out(i,k0:1:-1) = 0. + dwten_out(k0:1:-1) = 0. + diten_out(k0:1:-1) = 0. + + excessu_arr_out(k0:1:-1) = 0. + excess0_arr_out(k0:1:-1) = 0. + xc_arr_out(k0:1:-1) = 0. + aquad_arr_out(k0:1:-1) = 0. + bquad_arr_out(k0:1:-1) = 0. + cquad_arr_out(k0:1:-1) = 0. + bogbot_arr_out(k0:1:-1) = 0. + bogtop_arr_out(k0:1:-1) = 0. ! if (dotransport.eq.1) then ! do m = 1, ncnst -! trten_out(i,:k0,m) = 0. -! trflx_out(i,k0:0:-1,m) = 0. -! tru_out(i,k0:0:-1,m) = 0. -! tru_emf_out(i,k0:0:-1,m) = 0. +! trten_out(:k0,m) = 0. +! trflx_out(k0:0:-1,m) = 0. +! tru_out(k0:0:-1,m) = 0. +! tru_emf_out(k0:0:-1,m) = 0. ! enddo ! endif #endif end if - end do ! column i loop - return end subroutine compute_uwshcu From f2e3fbe00e2fe43958658656c65a769159c3c780 Mon Sep 17 00:00:00 2001 From: William Putman Date: Tue, 16 Jun 2026 11:45:08 -0400 Subject: [PATCH 19/40] final ZD for stock changes for ice_fraction computations --- .../GEOSmoist_GridComp/GEOS_MoistGridComp.F90 | 8 +- .../GEOSmoist_GridComp/Process_Library.F90 | 119 ++++++++++-------- 2 files changed, 76 insertions(+), 51 deletions(-) diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/GEOS_MoistGridComp.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/GEOS_MoistGridComp.F90 index 5d958b2ae7..0bad14a8f1 100644 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/GEOS_MoistGridComp.F90 +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/GEOS_MoistGridComp.F90 @@ -189,14 +189,20 @@ subroutine SetServices ( GC, RC ) call MAPL_GetResource( CF, DEBUG_MST, Label="DEBUG_MST:", default=.false., RC=STATUS) ; VERIFY_(STATUS) call MAPL_GetResource( CF, DEBUG_TQ_ERRORS, Label="DEBUG_TQ_ERRORS:", default=.false., RC=STATUS) ; VERIFY_(STATUS) - !***********Aerosol-Cloud related + !***********Aerosol-Cloud related call MAPL_GetResource( CF, USE_NCLOUD_CLIM, Label='USE_NCLOUD_CLIM:', default=.FALSE., RC=STATUS) VERIFY_(STATUS) call MAPL_GetResource( CF, WSUB_OPTION, Label='WSUB_OPTION:', default= 1, RC=STATUS) !0- param 1- Use Wsub climatology 2-USE WNET` VERIFY_(STATUS) + if (adjustl(CLDMICR_OPTION)=="BACM_1M") then + call MAPL_GetResource( CF, USE_JASON_ICE_FRACTIONS, Label="USE_JASON_ICE_FRACTIONS:", default=.TRUE., RC=STATUS) ; VERIFY_(STATUS) + else + call MAPL_GetResource( CF, USE_JASON_ICE_FRACTIONS, Label="USE_JASON_ICE_FRACTIONS:", default=.FALSE., RC=STATUS) ; VERIFY_(STATUS) + endif + ! NOTE: Binary restarts expect Q to be the first field in the moist_internal_rst. Thus, ! the first MAPL_AddInternalSpec call must be from the microphysics diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/Process_Library.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/Process_Library.F90 index 3b080c9428..dc6f14260c 100644 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/Process_Library.F90 +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/Process_Library.F90 @@ -41,6 +41,8 @@ module GEOSmoist_Process_Library integer, parameter :: SRF_TYPE_ICE = 3 integer, parameter :: SRF_TYPE_LANDICE = 4 + logical :: USE_JASON_ICE_FRACTIONS = .true. + ! ICE_FRACTION constants ! In anvil/convective clouds real, parameter :: aT_ICE_ALL = 243.66 @@ -299,6 +301,7 @@ module GEOSmoist_Process_Library public :: AerPropsNew, copy_AerProp, init_AerProp public :: AeroPropsNew public :: CNV_Tracer_Type, CNV_Tracers, CNV_Tracers_Init + public :: USE_JASON_ICE_FRACTIONS public :: SRF_TYPE_OCEAN, SRF_TYPE_LAND, SRF_TYPE_SNOW, SRF_TYPE_ICE, SRF_TYPE_LANDICE public :: ICE_FRACTION, EVAP3, SUBL3, LDRADIUS4, BUOYANCY, BUOYANCY2 public :: REDISTRIBUTE_CLOUDS_SCALAR, REDISTRIBUTE_CLOUDS, RADCOUPLE_SCALE_AWARE, RADCOUPLE, FIX_UP_CLOUDS @@ -668,7 +671,7 @@ function ICE_FRACTION_1D (TEMP,CNV_FRACTION,SRF_TYPE) RESULT(ICEFRCT) enddo end function ICE_FRACTION_1D -function ICE_FRACTION_SC (TEMP,CNV_FRACTION,SRF_TYPE) RESULT(ICEFRCT) + function ICE_FRACTION_SC (TEMP,CNV_FRACTION,SRF_TYPE) RESULT(ICEFRCT) real, intent(in) :: TEMP,CNV_FRACTION,SRF_TYPE real :: ICEFRCT real :: tc, ptc @@ -707,72 +710,88 @@ function ICE_FRACTION_SC (TEMP,CNV_FRACTION,SRF_TYPE) RESULT(ICEFRCT) ! ------------------------------------------------------------------ ! 2. Grid-Scale / Mesh Cloud Ice Fraction (ICEFRCT_M) ! ------------------------------------------------------------------ - ! Select the correct constants based on surface type and parameterization + ! Select the correct constants based on surface type and Jason flag select case (nint(SRF_TYPE)) case (SRF_TYPE_LANDICE) - t_all_loc = JliT_ICE_ALL - t_max_loc = JliT_ICE_MAX - pwr_loc = JliICEFRPWR - ICEFRCT_M = 0.00 - if ( TEMP <= t_all_loc ) then - ICEFRCT_M = 1.000 - else if ( (TEMP > t_all_loc) .AND. (TEMP <= t_max_loc) ) then - ICEFRCT_M = SIN( 0.5*MAPL_PI*( 1.00 - ( TEMP - t_all_loc ) / ( t_max_loc - t_all_loc ) ) ) + if (USE_JASON_ICE_FRACTIONS) then + t_all_loc = JliT_ICE_ALL + t_max_loc = JliT_ICE_MAX + pwr_loc = JliICEFRPWR + else + t_all_loc = liT_ICE_ALL + t_max_loc = liT_ICE_MAX + pwr_loc = liICEFRPWR end if - ICEFRCT_M = MAX(0.00, MIN(1.00, ICEFRCT_M)) ** pwr_loc case (SRF_TYPE_ICE) - t_all_loc = JiT_ICE_ALL - t_max_loc = JiT_ICE_MAX - pwr_loc = JiICEFRPWR - ICEFRCT_M = 0.00 - if ( TEMP <= t_all_loc ) then - ICEFRCT_M = 1.000 - else if ( (TEMP > t_all_loc) .AND. (TEMP <= t_max_loc) ) then - ICEFRCT_M = SIN( 0.5*MAPL_PI*( 1.00 - ( TEMP - t_all_loc ) / ( t_max_loc - t_all_loc ) ) ) + if (USE_JASON_ICE_FRACTIONS) then + t_all_loc = JiT_ICE_ALL + t_max_loc = JiT_ICE_MAX + pwr_loc = JiICEFRPWR + else + t_all_loc = iT_ICE_ALL + t_max_loc = iT_ICE_MAX + pwr_loc = iICEFRPWR end if - ICEFRCT_M = MAX(0.00, MIN(1.00, ICEFRCT_M)) ** pwr_loc case (SRF_TYPE_SNOW) - t_all_loc = JsT_ICE_ALL - t_max_loc = JsT_ICE_MAX - pwr_loc = JsICEFRPWR - ICEFRCT_M = 0.00 - if ( TEMP <= t_all_loc ) then - ICEFRCT_M = 1.000 - else if ( (TEMP > t_all_loc) .AND. (TEMP <= t_max_loc) ) then - ICEFRCT_M = SIN( 0.5*MAPL_PI*( 1.00 - ( TEMP - t_all_loc ) / ( t_max_loc - t_all_loc ) ) ) + if (USE_JASON_ICE_FRACTIONS) then + t_all_loc = JsT_ICE_ALL + t_max_loc = JsT_ICE_MAX + pwr_loc = JsICEFRPWR + else + t_all_loc = sT_ICE_ALL + t_max_loc = sT_ICE_MAX + pwr_loc = sICEFRPWR end if - ICEFRCT_M = MAX(0.00, MIN(1.00, ICEFRCT_M)) ** pwr_loc case (SRF_TYPE_LAND) - t_all_loc = JlT_ICE_ALL - t_max_loc = JlT_ICE_MAX - pwr_loc = JlICEFRPWR - ICEFRCT_M = 0.00 - if ( TEMP <= JlT_ICE_ALL ) then - ICEFRCT_M = 1.000 - else if ( (TEMP > JlT_ICE_ALL) .AND. (TEMP <= JlT_ICE_MAX) ) then - ICEFRCT_M = SIN( 0.5*MAPL_PI*( 1.00 - ( TEMP - JlT_ICE_ALL ) / ( JlT_ICE_MAX - JlT_ICE_ALL ) ) ) + if (USE_JASON_ICE_FRACTIONS) then + t_all_loc = JlT_ICE_ALL + t_max_loc = JlT_ICE_MAX + pwr_loc = JlICEFRPWR + else + t_all_loc = lT_ICE_ALL + t_max_loc = lT_ICE_MAX + pwr_loc = lICEFRPWR end if - ICEFRCT_M = MIN(ICEFRCT_M,1.00) - ICEFRCT_M = MAX(ICEFRCT_M,0.00) - ICEFRCT_M = ICEFRCT_M**JlICEFRPWR case (SRF_TYPE_OCEAN) - t_all_loc = JoT_ICE_ALL - t_max_loc = JoT_ICE_MAX - pwr_loc = JoICEFRPWR - ICEFRCT_M = 0.00 - if ( TEMP <= t_all_loc ) then - ICEFRCT_M = 1.000 - else if ( TEMP <= t_max_loc ) then - ICEFRCT_M = SIN( 0.5*MAPL_PI*( 1.00 - ( TEMP - t_all_loc ) / ( t_max_loc - t_all_loc ) ) ) + if (USE_JASON_ICE_FRACTIONS) then + t_all_loc = JoT_ICE_ALL + t_max_loc = JoT_ICE_MAX + pwr_loc = JoICEFRPWR + else + t_all_loc = oT_ICE_ALL + t_max_loc = oT_ICE_MAX + pwr_loc = oICEFRPWR end if - ICEFRCT_M = MAX(0.00, MIN(1.00, ICEFRCT_M)) ** pwr_loc case default ! You should not be here print *, 'ICE_FRACTION_SC: Unknown SRF_TYPE = ',SRF_TYPE error stop end select - ! Combine the Convective and MODIS functions + ! Calculate ICEFRCT_M + if ((nint(SRF_TYPE) == SRF_TYPE_LAND) .and. USE_JASON_ICE_FRACTIONS) then + ! Exact sequence required to maintain zero-diff for LAND + ICEFRCT_M = 0.00 + if ( TEMP <= JlT_ICE_ALL ) then + ICEFRCT_M = 1.000 + else if ( (TEMP > JlT_ICE_ALL) .AND. (TEMP <= JlT_ICE_MAX) ) then + ICEFRCT_M = SIN( 0.5*MAPL_PI*( 1.00 - ( TEMP - JlT_ICE_ALL ) / ( JlT_ICE_MAX - JlT_ICE_ALL ) ) ) + end if + ICEFRCT_M = MIN(ICEFRCT_M,1.00) + ICEFRCT_M = MAX(ICEFRCT_M,0.00) + ICEFRCT_M = ICEFRCT_M**JlICEFRPWR + else + ! Cleaned up sequence for all other surface types + ICEFRCT_M = 0.00 + if ( TEMP <= t_all_loc ) then + ICEFRCT_M = 1.000 + else if ( TEMP <= t_max_loc ) then + ICEFRCT_M = SIN( 0.5*MAPL_PI*( 1.00 - ( TEMP - t_all_loc ) / ( t_max_loc - t_all_loc ) ) ) + end if + ICEFRCT_M = MAX(0.00, MIN(1.00, ICEFRCT_M)) ** pwr_loc + end if + + ! Combine the Convective and Mesh functions ICEFRCT = ICEFRCT_M*(1.0-CNV_FRACTION) + ICEFRCT_C*(CNV_FRACTION) #endif From b57e846aa91e9c1bcba313071352028513141f5a Mon Sep 17 00:00:00 2001 From: William Putman Date: Tue, 16 Jun 2026 15:08:40 -0400 Subject: [PATCH 20/40] housekeeping for aerosol activation code and separating cldmicro options outside of MoistGC --- .../GEOSmoist_GridComp/CMakeLists.txt | 2 +- .../GEOS_BACM_1M_InterfaceMod.F90 | 16 ++ .../GEOS_GFDL_1M_InterfaceMod.F90 | 15 +- .../GEOS_MGB2_2M_InterfaceMod.F90 | 15 +- .../GEOSmoist_GridComp/GEOS_MoistGridComp.F90 | 194 ++++++------------ .../GEOS_NSSL_2M_InterfaceMod.F90 | 12 +- .../GEOS_THOM_1M_InterfaceMod.F90 | 12 +- .../GEOSmoist_GridComp/Process_Library.F90 | 68 +----- .../aer_actv_single_moment.F90 | 34 +-- .../GEOSmoist_GridComp/aer_cloud.F90 | 40 ++-- .../GEOSmoist_GridComp/cloudnew.F90 | 1 - 11 files changed, 165 insertions(+), 244 deletions(-) diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/CMakeLists.txt b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/CMakeLists.txt index 6e6388f309..47431d0d01 100644 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/CMakeLists.txt +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/CMakeLists.txt @@ -67,7 +67,7 @@ endif () esma_add_library (${this} SRCS ${srcs} - DEPENDENCIES GEOS_Shared GMAO_mpeu MAPL Chem_Shared Chem_Base ESMF::ESMF BLAS::BLAS LAPACK::LAPACK TYPE SHARED) + DEPENDENCIES GEOS_Shared GMAO_mpeu MAPL Chem_Shared Chem_Base ESMF::ESMF BLAS::BLAS LAPACK::LAPACK OpenMP::OpenMP_Fortran TYPE SHARED) file (GLOB_RECURSE rc_files CONFIGURE_DEPENDS RELATIVE ${CMAKE_CURRENT_SOURCE_DIR} *.rc *.yaml) foreach ( file ${rc_files} ) diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/GEOS_BACM_1M_InterfaceMod.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/GEOS_BACM_1M_InterfaceMod.F90 index d6c2d1f670..0933fe3c76 100644 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/GEOS_BACM_1M_InterfaceMod.F90 +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/GEOS_BACM_1M_InterfaceMod.F90 @@ -15,6 +15,8 @@ module GEOS_BACM_1M_InterfaceMod use GEOS_UtilsMod use GEOSmoist_Process_Library use CLOUDNEW, only: CLDPARAMS, PROGNO_CLOUD + use aer_cloud + use Aer_Actv_Single_Moment implicit none @@ -269,6 +271,20 @@ subroutine BACM_1M_Initialize (MAPL, RC) call MAPL_GetResource( MAPL, CNV_FRACTION_MIN, 'CNV_FRACTION_MIN:', DEFAULT= 500.0, RC=STATUS); VERIFY_(STATUS) call MAPL_GetResource( MAPL, CNV_FRACTION_MAX, 'CNV_FRACTION_MAX:', DEFAULT= 1500.0, RC=STATUS); VERIFY_(STATUS) + call MAPL_GetResource( MAPL, USE_JASON_ICE_FRACTIONS, Label="USE_JASON_ICE_FRACTIONS:", default=.TRUE., RC=STATUS) ; VERIFY_(STATUS) + + call MAPL_GetResource( MAPL, USE_AEROSOL_NN , 'USE_AEROSOL_NN:' , DEFAULT=USE_AEROSOL_NN, RC=STATUS); VERIFY_(STATUS) + call MAPL_GetResource( MAPL, USE_BERGERON , 'USE_BERGERON:' , DEFAULT=USE_BERGERON , RC=STATUS); VERIFY_(STATUS) + + call MAPL_GetResource( MAPL, NN_MIN_ICE, 'NN_MIN_ICE:', DEFAULT= 100.0e6, RC=STATUS); VERIFY_(STATUS) + call MAPL_GetResource( MAPL, NN_MAX_ICE, 'NN_MAX_ICE:', DEFAULT= 500.0e6, RC=STATUS); VERIFY_(STATUS) + + if (USE_AEROSOL_NN) then + ! NOTE: For now we hard code in .false. for use_wnet as that is only an option with MG and will be handled there + call aer_cloud_init(use_wnet = .false.) + call WRITE_PARALLEL ("INITIALIZED aer_cloud_init") + endif + end subroutine BACM_1M_Initialize diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/GEOS_GFDL_1M_InterfaceMod.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/GEOS_GFDL_1M_InterfaceMod.F90 index 8a8ed8d784..6b1a940f95 100644 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/GEOS_GFDL_1M_InterfaceMod.F90 +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/GEOS_GFDL_1M_InterfaceMod.F90 @@ -15,7 +15,7 @@ module GEOS_GFDL_1M_InterfaceMod use GEOS_UtilsMod use GEOS_RadarMod use GEOSmoist_Process_Library - use Aer_Actv_Single_Moment + use aer_cloud use gfdl2_cloud_microphys_mod, only : gfdl_cloud_microphys_init, gfdl_cloud_microphys_driver, ICE_LSC_VFALL_PARAM, ICE_CNV_VFALL_PARAM use gfdl_mp_mod, only : gfdl_mp_init, gfdl_mp_driver, do_ref, do_hail, do_sedi_heat, do_sedi_melt_qi, do_sedi_melt_qs, do_sedi_melt_qg, ifflag @@ -48,7 +48,6 @@ module GEOS_GFDL_1M_InterfaceMod real :: MIN_RH_CRIT, MAX_RH_CRIT, MIN_RH_UNSTABLE, MIN_RH_STABLE real :: TAU_EVAP, CCW_EVAP_EFF real :: TAU_SUBL, CCI_EVAP_EFF - integer :: PDFSHAPE real :: ANV_ICEFALL real :: LS_ICEFALL real :: FAC_RL @@ -343,9 +342,6 @@ subroutine GFDL_1M_Initialize (MAPL, CF, CLOCK, IMPORT, EXPORT, RC) call MAPL_GetResource( MAPL, MIN_RL , 'MIN_RL:' , DEFAULT= 2.5e-6, RC=STATUS); VERIFY_(STATUS) call MAPL_GetResource( MAPL, MAX_RL , 'MAX_RL:' , DEFAULT=60.0e-6, RC=STATUS); VERIFY_(STATUS) - ! USE_BERGERON should be .TRUE. only when USE_AEROSOL_NN is also .TRUE. - call MAPL_GetResource( MAPL, USE_BERGERON , 'USE_BERGERON:' , DEFAULT=USE_AEROSOL_NN, RC=STATUS); VERIFY_(STATUS) - CCW_EVAP_EFF = 4.e-3 call MAPL_GetResource( MAPL, CCW_EVAP_EFF, 'CCW_EVAP_EFF:', DEFAULT= CCW_EVAP_EFF, RC=STATUS); VERIFY_(STATUS) @@ -355,6 +351,15 @@ subroutine GFDL_1M_Initialize (MAPL, CF, CLOCK, IMPORT, EXPORT, RC) call MAPL_GetResource( MAPL, CNV_FRACTION_MIN, 'CNV_FRACTION_MIN:', DEFAULT= 500.0, RC=STATUS); VERIFY_(STATUS) call MAPL_GetResource( MAPL, CNV_FRACTION_MAX, 'CNV_FRACTION_MAX:', DEFAULT= 2500.0, RC=STATUS); VERIFY_(STATUS) + call MAPL_GetResource( MAPL, USE_AEROSOL_NN , 'USE_AEROSOL_NN:' , DEFAULT=USE_AEROSOL_NN, RC=STATUS); VERIFY_(STATUS) + call MAPL_GetResource( MAPL, USE_BERGERON , 'USE_BERGERON:' , DEFAULT=USE_AEROSOL_NN, RC=STATUS); VERIFY_(STATUS) + + if (USE_AEROSOL_NN) then + ! NOTE: For now we hard code in .false. for use_wnet as that is only an option with MG and will be handled there + call aer_cloud_init(use_wnet = .false.) + call WRITE_PARALLEL ("INITIALIZED aer_cloud_init") + endif + call MAPL_GetResource( MAPL, GFDL_MP_KLID , 'GFDL_MP_KLID:' , DEFAULT= -999.0, RC=STATUS); VERIFY_(STATUS) end subroutine GFDL_1M_Initialize diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/GEOS_MGB2_2M_InterfaceMod.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/GEOS_MGB2_2M_InterfaceMod.F90 index af20ed686b..5ff6e1a079 100644 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/GEOS_MGB2_2M_InterfaceMod.F90 +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/GEOS_MGB2_2M_InterfaceMod.F90 @@ -55,7 +55,6 @@ module GEOS_MGB2_2M_InterfaceMod real :: MINRHCRIT real :: CCW_EVAP_EFF real :: CCI_EVAP_EFF - integer :: PDFSHAPE real :: MIN_RL real :: MAX_RL real :: FAC_RI @@ -64,7 +63,6 @@ module GEOS_MGB2_2M_InterfaceMod real :: MAX_RI logical :: USE_AV_V logical :: SECOND_HYSTPDF, DO_UPD_CLD - logical :: USE_NCLOUD_CLIM logical :: MAKE_SNOW_ICE @@ -79,7 +77,7 @@ module GEOS_MGB2_2M_InterfaceMod DTST, RHC_STRAT_SCALE - INTEGER :: WSUB_OPTION, ST_OPTION, ITER_METHOD + INTEGER :: ST_OPTION, ITER_METHOD public :: MGB2_2M_Setup, MGB2_2M_Initialize, MGB2_2M_Run public :: MGVERSION @@ -100,6 +98,9 @@ subroutine MGB2_2M_Setup (GC, CF, RC) call ESMF_ConfigGetAttribute( CF, MGVERSION, Label="MGVERSION:", default=3, __RC__) + call MAPL_GetResource( CF, WSUB_OPTION, 'WSUB_OPTION:', DEFAULT= 1 , __RC__) !0- param 1- Use Wsub climatology 2-Wnet + call MAPL_GetResource( CF, USE_NCLOUD_CLIM, 'USE_NCLOUD_CLIM:', DEFAULT= .FALSE., __RC__) !0- param 1- Use Wsub climatology 2-Wnet + ! !INTERNAL STATE: FRIENDLIES%QV = "DYNAMICS:TURBULENCE:CHEMISTRY:ANALYSIS" @@ -418,8 +419,6 @@ subroutine MGB2_2M_Initialize (MAPL, RC) call MAPL_GetResource(MAPL, MUI_CST, 'MUI_CST:', DEFAULT= -1. ,__RC__) !value of the dispersion exponent in ice size dist. call MAPL_GetResource(MAPL, SED_STEP_SC, 'SED_STEP_SC:', DEFAULT= 1. ,__RC__) !scales the number of sedimentation substeps - call MAPL_GetResource(MAPL, WSUB_OPTION, 'WSUB_OPTION:', DEFAULT= 1 , __RC__) !0- param 1- Use Wsub climatology 2-Wnet - call MAPL_GetResource(MAPL, USE_NCLOUD_CLIM, 'USE_NCLOUD_CLIM:', DEFAULT= .FALSE., __RC__) !0- param 1- Use Wsub climatology 2-Wnet call MAPL_GetResource(MAPL, SECOND_HYSTPDF, 'SECOND_HYSTPDF:', DEFAULT= .FALSE. ,RC=STATUS) !TRUE to call hyspdf after the microphysics call MAPL_GetResource(MAPL, ITER_METHOD, 'ITER_METHOD:', DEFAULT= 1 ,RC=STATUS) !iteration method in hystpdf 1-Fixed point 2-Bisection call MAPL_GetResource(MAPL, DO_UPD_CLD, 'DO_UPD_CLD:', DEFAULT= .TRUE. ,RC=STATUS) !Udate cloud fraction after micro using top hat approx @@ -459,8 +458,12 @@ subroutine MGB2_2M_Initialize (MAPL, RC) use_wnet = .TRUE. call WRITE_PARALLEL ('Using Wnet***************') end if - + + call MAPL_GetResource( MAPL, USE_AEROSOL_NN , 'USE_AEROSOL_NN:' , DEFAULT=USE_AEROSOL_NN, RC=STATUS); VERIFY_(STATUS) + call MAPL_GetResource( MAPL, USE_BERGERON , 'USE_BERGERON:' , DEFAULT=USE_BERGERON , RC=STATUS); VERIFY_(STATUS) + call aer_cloud_init(use_wnet) + call WRITE_PARALLEL ("INITIALIZED aer_cloud_init") call WRITE_PARALLEL ("INITIALIZED MGB2_2M microphysics in non-generic GC INIT") diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/GEOS_MoistGridComp.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/GEOS_MoistGridComp.F90 index 0bad14a8f1..25f6cad505 100644 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/GEOS_MoistGridComp.F90 +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/GEOS_MoistGridComp.F90 @@ -28,7 +28,6 @@ module GEOS_MoistGridCompMod use GEOS_GF_InterfaceMod use GEOS_UW_InterfaceMod - use aer_cloud use Aer_Actv_Single_Moment use Lightning_mod, only: HEMCO_FlashRate use GEOSmoist_Process_Library @@ -49,7 +48,6 @@ module GEOS_MoistGridCompMod real :: CCN_LND real :: DETRAIN_INACTIVE_CNV real :: TAU_DETRAIN_CNV - logical :: USE_NCLOUD_CLIM ! !PUBLIC MEMBER FUNCTIONS: @@ -110,8 +108,6 @@ subroutine SetServices ( GC, RC ) logical :: LSHALLOW logical :: LCLDMICR - integer ::PDFSHAPE, WSUB_OPTION - !============================================================================= ! Begin... @@ -184,24 +180,15 @@ subroutine SetServices ( GC, RC ) _ASSERT( LCLDMICR, 'Unsupported Cloud Microphysics Option' ) - call MAPL_GetResource( CF, PDFSHAPE, Label="PDFSHAPE:", default=1, RC=STATUS) ; VERIFY_(STATUS) - call MAPL_GetResource( CF, DEBUG_MST, Label="DEBUG_MST:", default=.false., RC=STATUS) ; VERIFY_(STATUS) call MAPL_GetResource( CF, DEBUG_TQ_ERRORS, Label="DEBUG_TQ_ERRORS:", default=.false., RC=STATUS) ; VERIFY_(STATUS) - !***********Aerosol-Cloud related - call MAPL_GetResource( CF, USE_NCLOUD_CLIM, Label='USE_NCLOUD_CLIM:', default=.FALSE., RC=STATUS) - VERIFY_(STATUS) - call MAPL_GetResource( CF, WSUB_OPTION, Label='WSUB_OPTION:', default= 1, RC=STATUS) !0- param 1- Use Wsub climatology 2-USE WNET` - VERIFY_(STATUS) - - - if (adjustl(CLDMICR_OPTION)=="BACM_1M") then - call MAPL_GetResource( CF, USE_JASON_ICE_FRACTIONS, Label="USE_JASON_ICE_FRACTIONS:", default=.TRUE., RC=STATUS) ; VERIFY_(STATUS) - else - call MAPL_GetResource( CF, USE_JASON_ICE_FRACTIONS, Label="USE_JASON_ICE_FRACTIONS:", default=.FALSE., RC=STATUS) ; VERIFY_(STATUS) - endif + ! MAT These have to be defined as they are passed into Aer_Activate below and are intent(in) + ! Note: It's possible these aren't *used* if USE_AEROSOL_NN=.TRUE. but they are still passed + ! in so they have to be defined + call MAPL_GetResource( CF, CCN_OCN, 'NCCN_OCN:', DEFAULT= 100., RC=STATUS); VERIFY_(STATUS) + call MAPL_GetResource( CF, CCN_LND, 'NCCN_LND:', DEFAULT= 300., RC=STATUS); VERIFY_(STATUS) ! NOTE: Binary restarts expect Q to be the first field in the moist_internal_rst. Thus, ! the first MAPL_AddInternalSpec call must be from the microphysics @@ -560,11 +547,8 @@ subroutine SetServices ( GC, RC ) RC=STATUS ) VERIFY_(STATUS) - - if ((adjustl(CLDMICR_OPTION)=="MGB2_2M")) then ! subgrid scale vertical velocity options - - if (WSUB_OPTION .eq. 0) then - + select case (WSUB_OPTION) + case (0) call MAPL_AddImportSpec(GC, & LONG_NAME = 'Blackadar_length_scale_for_scalars', & UNITS = 'm', & @@ -574,61 +558,58 @@ subroutine SetServices ( GC, RC ) RC=STATUS ) VERIFY_(STATUS) - call MAPL_AddImportSpec(GC, & - SHORT_NAME = 'TAUOROX', & + call MAPL_AddImportSpec(GC, & + SHORT_NAME = 'TAUOROX', & LONG_NAME = 'surface_eastward_orographic_gravity_wave_stress', & - UNITS = 'N m-2', & - RESTART = MAPL_RestartSkip, & - DIMS = MAPL_DimsHorzOnly, & + UNITS = 'N m-2', & + RESTART = MAPL_RestartSkip, & + DIMS = MAPL_DimsHorzOnly, & VLOCATION = MAPL_VLocationNone, RC=STATUS ) VERIFY_(STATUS) - call MAPL_AddImportSpec(GC, & - SHORT_NAME = 'TAUOROY', & + call MAPL_AddImportSpec(GC, & + SHORT_NAME = 'TAUOROY', & LONG_NAME = 'surface_northward_orographic_gravity_wave_stress', & - UNITS = 'N m-2', & - RESTART = MAPL_RestartSkip, & - DIMS = MAPL_DimsHorzOnly, & + UNITS = 'N m-2', & + RESTART = MAPL_RestartSkip, & + DIMS = MAPL_DimsHorzOnly, & VLOCATION = MAPL_VLocationNone, RC=STATUS ) - VERIFY_(STATUS) - - - - elseif (WSUB_OPTION .eq. 1) then + VERIFY_(STATUS) - call MAPL_AddImportSpec ( GC, & - SHORT_NAME = 'WSUB_CLIM', & - LONG_NAME = 'stdev in vertical velocity', & - UNITS = 'm s-1', & - RESTART = MAPL_RestartSkip, & ! Read WSUB from a climatology - DIMS = MAPL_DimsHorzVert, & + case (1) + call MAPL_AddImportSpec ( GC, & + SHORT_NAME = 'WSUB_CLIM', & + LONG_NAME = 'stdev in vertical velocity', & + UNITS = 'm s-1', & + RESTART = MAPL_RestartSkip, & ! Read WSUB from a climatology + DIMS = MAPL_DimsHorzVert, & VLOCATION = MAPL_VLocationCenter, RC=STATUS ) - VERIFY_(STATUS) - - else + VERIFY_(STATUS) - call MAPL_AddImportSpec ( GC, & - LONG_NAME = 'total_momentum_diffusivity', & - UNITS = 'm+2 s-1', & - SHORT_NAME = 'KM', & - DIMS = MAPL_DimsHorzVert, & - RESTART = MAPL_RestartSkip, & - VLOCATION = MAPL_VLocationEdge, & + case (2) + call MAPL_AddImportSpec ( GC, & + LONG_NAME = 'total_momentum_diffusivity', & + UNITS = 'm+2 s-1', & + SHORT_NAME = 'KM', & + DIMS = MAPL_DimsHorzVert, & + RESTART = MAPL_RestartSkip, & + VLOCATION = MAPL_VLocationEdge, & RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddImportSpec ( GC, & - LONG_NAME = 'Richardson_number_from_Louis', & - UNITS = '1', & - SHORT_NAME = 'RI', & - DIMS = MAPL_DimsHorzVert, & - RESTART = MAPL_RestartSkip, & - VLOCATION = MAPL_VLocationEdge, & + VERIFY_(STATUS) + + call MAPL_AddImportSpec ( GC, & + LONG_NAME = 'Richardson_number_from_Louis', & + UNITS = '1', & + SHORT_NAME = 'RI', & + DIMS = MAPL_DimsHorzVert, & + RESTART = MAPL_RestartSkip, & + VLOCATION = MAPL_VLocationEdge, & RC=STATUS ) VERIFY_(STATUS) - end if - end if + case default + ! Do nothing + end select IF (USE_NCLOUD_CLIM) then call MAPL_AddImportSpec ( GC, & @@ -650,7 +631,6 @@ subroutine SetServices ( GC, RC ) VERIFY_(STATUS) end if - call MAPL_AddImportSpec ( gc, & SHORT_NAME = 'DTDTDYN', & LONG_NAME = 'tendency_of_air_temperature_due_to_dynamics', & @@ -5583,8 +5563,6 @@ subroutine Initialize ( GC, IMPORT, EXPORT, CLOCK, RC ) type (ESMF_Config) :: CF - logical :: initialize_aer_cloud - type (ESMF_Alarm ) :: ALARM type (ESMF_TimeInterval) :: TINT real(ESMF_KIND_R8) :: DT_R8 @@ -5623,25 +5601,6 @@ subroutine Initialize ( GC, IMPORT, EXPORT, CLOCK, RC ) call MAPL_GetResource( MAPL, LDIAGNOSE_PRECIP_TYPE, Label="DIAGNOSE_PRECIP_TYPE:", default=.FALSE., RC=STATUS); VERIFY_(STATUS) call MAPL_GetResource( MAPL, LUPDATE_PRECIP_TYPE, Label="UPDATE_PRECIP_TYPE:", default=.FALSE., RC=STATUS); VERIFY_(STATUS) - call MAPL_GetResource( MAPL, USE_AEROSOL_NN , 'USE_AEROSOL_NN:' , DEFAULT=USE_AEROSOL_NN, RC=STATUS); VERIFY_(STATUS) - call MAPL_GetResource( MAPL, USE_BERGERON , 'USE_BERGERON:' , DEFAULT=USE_BERGERON , RC=STATUS); VERIFY_(STATUS) - - ! If you use MGB2_2M, then aer_cloud_init is done in MGB2_2M_Initialize, otherwise we need to do it here if USE_AEROSOL_NN is true - ! and *not* MG - - initialize_aer_cloud = USE_AEROSOL_NN .AND. (adjustl(CLDMICR_OPTION) /= "MGB2_2M") - - if (initialize_aer_cloud) then - ! NOTE: For now we hard code in .false. for use_wnet as that is only an option with MG and will be handled there - call aer_cloud_init(use_wnet = .false.) - call WRITE_PARALLEL ("INITIALIZED aer_cloud_init") - endif - ! MAT These have to be defined as they are passed into Aer_Activate below and are intent(in) - ! Note: It's possible these aren't *used* if USE_AEROSOL_NN=.TRUE. but they are still passed - ! in so they have to be defined - call MAPL_GetResource( MAPL, CCN_OCN, 'NCCN_OCN:', DEFAULT= 100., RC=STATUS); VERIFY_(STATUS) - call MAPL_GetResource( MAPL, CCN_LND, 'NCCN_LND:', DEFAULT= 300., RC=STATUS); VERIFY_(STATUS) - call MAPL_GetResource( MAPL, DETRAIN_INACTIVE_CNV, Label="DETRAIN_INACTIVE_CNV:", default=0.0, RC=STATUS); VERIFY_(STATUS) call MAPL_GetResource( MAPL, TAU_DETRAIN_CNV, Label="TAU_DETRAIN_CNV:", default=1800.0, RC=STATUS); VERIFY_(STATUS) @@ -5749,7 +5708,6 @@ subroutine RUN ( GC, IMPORT, EXPORT, CLOCK, RC ) real, pointer, dimension(:,:) :: FRLAND, FRLANDICE, FRACI, SNOMAS real, pointer, dimension(:,:) :: SH, TS, EVAP, KPBL real, pointer, dimension(:,:,:) :: KH, TKE, OMEGA - real, pointer, dimension(:,:,:) :: NCPL_CLIM, NCPI_CLIM integer :: n_modes type(ESMF_State) :: AERO type(ESMF_FieldBundle) :: TR @@ -5847,11 +5805,6 @@ subroutine RUN ( GC, IMPORT, EXPORT, CLOCK, RC ) call MAPL_GetPointer(IMPORT, SNOMAS, 'SNOMAS' , RC=STATUS); VERIFY_(STATUS) call MAPL_GetPointer(EXPORT, SRF_TYPE, 'SRF_TYPE' , ALLOC=.TRUE., RC=STATUS); VERIFY_(STATUS) - if (USE_NCLOUD_CLIM) then - call MAPL_GetPointer(IMPORT, NCPL_CLIM, 'NCPL_CLIM' , RC=STATUS); VERIFY_(STATUS) - call MAPL_GetPointer(IMPORT, NCPI_CLIM, 'NCPI_CLIM' , RC=STATUS); VERIFY_(STATUS) - end if - where (FRLANDICE > 0.5) SRF_TYPE = SRF_TYPE_LANDICE elsewhere (FRACI > 0.5) @@ -6048,42 +6001,31 @@ subroutine RUN ( GC, IMPORT, EXPORT, CLOCK, RC ) ! Get aerosol activation properties call MAPL_TimerOn (MAPL,"---AERO_ACTIVATE") - - if ((USE_AEROSOL_NN) .and. .not. (USE_NCLOUD_CLIM)) then - ! get veritical velocity - if (all(W == 0.0)) then - TMP3D = -OMEGA/(MAPL_GRAV*PLmb*100.0/(MAPL_RGAS*T)) - else - TMP3D = W - endif - ! Pressures in Pa - call Aer_Activation(MAPL, IM,JM,LM, Q, T, PLmb*100.0, PLE, TKE, TMP3D, FRLAND, & - AeroPropsNew, AERO, NACTL, NACTI, NWFA, CCN_LND*1.e6, CCN_OCN*1.e6, & - (adjustl(CLDMICR_OPTION)=="MGB2_2M"), __RC__) -! Temporary -! call MAPL_MaxMin('MST: NWFA ', NWFA *1.e-6) -! call MAPL_MaxMin('MST: NACTL ', NACTL*1.e-6) -! call MAPL_MaxMin('MST: NACTI ', NACTI*1.e-6) -! Temporary - + if (USE_NCLOUD_CLIM) then !Setup ND/NI climatology from GiOcean + call MAPL_GetPointer(IMPORT, PTR3D, 'NCPL_CLIM', RC=STATUS); VERIFY_(STATUS) + NACTL = PTR3D + call MAPL_GetPointer(IMPORT, PTR3D, 'NCPI_CLIM', RC=STATUS); VERIFY_(STATUS) + NACTI = PTR3D else - - - if (USE_NCLOUD_CLIM) then !Setup ND/NI climatology from GiOcean - - NACTL = NCPL_CLIM - NACTI = NCPI_CLIM - else - do L=1,LM - NACTL(:,:,L) = (CCN_LND*FRLAND + CCN_OCN*(1.0-FRLAND))*1.e6 ! #/m^3 - NACTI(:,:,L) = (CCN_LND*FRLAND + CCN_OCN*(1.0-FRLAND))*1.e6 ! #/m^3 - end do - - end if + if (USE_AEROSOL_NN) then + ! get veritical velocity + if (all(W == 0.0)) then + TMP3D = -OMEGA/(MAPL_GRAV*PLmb*100.0/(MAPL_RGAS*T)) + else + TMP3D = W + endif + ! Pressures in Pa + call Aer_Activation(MAPL, IM,JM,LM, Q, T, PLmb*100.0, PLE, TKE, TMP3D, FRLAND, & + AERO, NACTL, NACTI, NWFA, CCN_LND*1.e6, CCN_OCN*1.e6, & + (adjustl(CLDMICR_OPTION)=="MGB2_2M"), __RC__) + else + do L=1,LM + NACTL(:,:,L) = (CCN_LND*FRLAND + CCN_OCN*(1.0-FRLAND))*1.e6 ! #/m^3 + NACTI(:,:,L) = (CCN_LND*FRLAND + CCN_OCN*(1.0-FRLAND))*1.e6 ! #/m^3 + end do + endif endif - - call MAPL_GetPointer(EXPORT, PTR3D, 'NCCN_LIQ', RC=STATUS); VERIFY_(STATUS) if (associated(PTR3D)) PTR3D = NACTL*1.e-6 call MAPL_GetPointer(EXPORT, PTR3D, 'NCCN_ICE', RC=STATUS); VERIFY_(STATUS) diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/GEOS_NSSL_2M_InterfaceMod.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/GEOS_NSSL_2M_InterfaceMod.F90 index 5e16f87203..95eecb7249 100644 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/GEOS_NSSL_2M_InterfaceMod.F90 +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/GEOS_NSSL_2M_InterfaceMod.F90 @@ -14,7 +14,7 @@ module GEOS_NSSL_2M_InterfaceMod use MAPL use GEOS_UtilsMod use GEOSmoist_Process_Library - use Aer_Actv_Single_Moment + use aer_cloud use module_mp_nssl_2mom implicit none @@ -48,7 +48,6 @@ module GEOS_NSSL_2M_InterfaceMod real :: TURNRHCRIT_PARAM real :: TAU_EVAP, CCW_EVAP_EFF real :: TAU_SUBL, CCI_EVAP_EFF - integer :: PDFSHAPE real :: ANV_ICEFALL real :: LS_ICEFALL real :: FAC_RL @@ -364,6 +363,15 @@ subroutine NSSL_2M_Initialize (MAPL, RC) call MAPL_GetResource( MAPL, CNV_FRACTION_MIN, 'CNV_FRACTION_MIN:', DEFAULT= 200.0, RC=STATUS); VERIFY_(STATUS) call MAPL_GetResource( MAPL, CNV_FRACTION_MAX, 'CNV_FRACTION_MAX:', DEFAULT= 4000.0, RC=STATUS); VERIFY_(STATUS) + call MAPL_GetResource( MAPL, USE_AEROSOL_NN , 'USE_AEROSOL_NN:' , DEFAULT=USE_AEROSOL_NN, RC=STATUS); VERIFY_(STATUS) + call MAPL_GetResource( MAPL, USE_BERGERON , 'USE_BERGERON:' , DEFAULT=USE_BERGERON , RC=STATUS); VERIFY_(STATUS) + + if (USE_AEROSOL_NN) then + ! NOTE: For now we hard code in .false. for use_wnet as that is only an option with MG and will be handled there + call aer_cloud_init(use_wnet = .false.) + call WRITE_PARALLEL ("INITIALIZED aer_cloud_init") + endif + end subroutine NSSL_2M_Initialize subroutine NSSL_2M_Run (GC, IMPORT, EXPORT, CLOCK, RC) diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/GEOS_THOM_1M_InterfaceMod.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/GEOS_THOM_1M_InterfaceMod.F90 index 54b2deadc9..6cede2e41a 100644 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/GEOS_THOM_1M_InterfaceMod.F90 +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/GEOS_THOM_1M_InterfaceMod.F90 @@ -14,7 +14,7 @@ module GEOS_THOM_1M_InterfaceMod use MAPL use GEOS_UtilsMod use GEOSmoist_Process_Library - use Aer_Actv_Single_Moment + use aer_cloud use module_mp_thompson implicit none @@ -49,7 +49,6 @@ module GEOS_THOM_1M_InterfaceMod real :: TURNRHCRIT_PARAM real :: CCW_EVAP_EFF real :: CCI_EVAP_EFF - integer :: PDFSHAPE real :: ANV_ICEFALL real :: LS_ICEFALL real :: FAC_RL @@ -289,6 +288,15 @@ subroutine THOM_1M_Initialize (MAPL, RC) call MAPL_GetResource( MAPL, CNV_FRACTION_MIN, 'CNV_FRACTION_MIN:', DEFAULT= 200.0, RC=STATUS); VERIFY_(STATUS) call MAPL_GetResource( MAPL, CNV_FRACTION_MAX, 'CNV_FRACTION_MAX:', DEFAULT= 4000.0, RC=STATUS); VERIFY_(STATUS) + call MAPL_GetResource( MAPL, USE_AEROSOL_NN , 'USE_AEROSOL_NN:' , DEFAULT=USE_AEROSOL_NN, RC=STATUS); VERIFY_(STATUS) + call MAPL_GetResource( MAPL, USE_BERGERON , 'USE_BERGERON:' , DEFAULT=USE_BERGERON , RC=STATUS); VERIFY_(STATUS) + + if (USE_AEROSOL_NN) then + ! NOTE: For now we hard code in .false. for use_wnet as that is only an option with MG and will be handled there + call aer_cloud_init(use_wnet = .false.) + call WRITE_PARALLEL ("INITIALIZED aer_cloud_init") + endif + end subroutine THOM_1M_Initialize subroutine THOM_1M_Run (GC, IMPORT, EXPORT, CLOCK, RC) diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/Process_Library.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/Process_Library.F90 index dc6f14260c..ef48b0b81c 100644 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/Process_Library.F90 +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/Process_Library.F90 @@ -41,7 +41,7 @@ module GEOSmoist_Process_Library integer, parameter :: SRF_TYPE_ICE = 3 integer, parameter :: SRF_TYPE_LANDICE = 4 - logical :: USE_JASON_ICE_FRACTIONS = .true. + logical :: USE_JASON_ICE_FRACTIONS = .false. ! ICE_FRACTION constants ! In anvil/convective clouds @@ -95,6 +95,13 @@ module GEOSmoist_Process_Library real, parameter :: JoT_ICE_MAX = 263.16 real, parameter :: JoICEFRPWR = 4.0 + logical :: USE_BERGERON = .FALSE. + logical :: USE_AEROSOL_NN = .TRUE. + logical :: USE_NCLOUD_CLIM = .FALSE. + + integer :: WSUB_OPTION = -1 + integer :: PDFSHAPE = 1 + ! parameters real, parameter :: EPSILON = MAPL_H2OMW/MAPL_AIRMW real, parameter :: K_COND = 2.4e-2 ! J m**-1 s**-1 K**-1 @@ -246,15 +253,12 @@ module GEOSmoist_Process_Library ! option for cloud liq/ice radii integer :: LIQ_RADII_PARAM = 1 integer :: ICE_RADII_PARAM = 1 - integer, parameter :: nsmx_par = 15 ! defined to determine CNV_FRACTION real :: CNV_FRACTION_MIN = 500.0 real :: CNV_FRACTION_MAX = 1500.0 real :: CNV_FRACTION_EXP = 1.0 - ! Storage of aerosol properties for activation - ! Tracer Bundle things for convection type CNV_Tracer_Type real, pointer :: Q(:,:,:) => null() @@ -277,30 +281,9 @@ module GEOSmoist_Process_Library public :: DEBUG_TQ_ERRORS - type :: AerPropsNew - integer :: nmods ! total number of modes (nmods---------------------------------------------------------------------------------------------------------------------- !>---------------------------------------------------------------------------------------------------------------------- SUBROUTINE Aer_Activation(MAPL, IM,JM,LM, q, t, plo, ple, tke, vvel, FRLAND, & - AeroPropsNew, aero_aci, NACTL, NACTI, NWFA, & + aero_aci, NACTL, NACTI, NWFA, & NN_LAND, NN_OCEAN, need_extra_fields, rc) IMPLICIT NONE type (MAPL_MetaComp), pointer :: MAPL integer, intent(in)::IM,JM,LM - TYPE(AerPropsNew), dimension (:), intent(inout) :: AeroPropsNew type(ESMF_State) ,intent(inout) :: aero_aci real, dimension (IM,JM,LM) ,intent(in ) :: plo ! Pa real, dimension (IM,JM,0:LM),intent(in ) :: ple ! Pa @@ -75,16 +73,6 @@ SUBROUTINE Aer_Activation(MAPL, IM,JM,LM, q, t, plo, ple, tke, vvel, FRLAND, & NWFA = 0.0 - if (.not. USE_AEROSOL_NN) then - - do k = 1, LM - NACTL(:,:,k) = NN_LAND*FRLAND + NN_OCEAN*(1.0-FRLAND) - NACTI(:,:,k) = NN_LAND*FRLAND + NN_OCEAN*(1.0-FRLAND) - end do - - RETURN_(ESMF_SUCCESS) - end if - call ESMF_AttributeGet(aero_aci, name='number_of_aerosol_modes', value=n_modes, __RC__) if (n_modes == 0) then @@ -195,7 +183,7 @@ SUBROUTINE Aer_Activation(MAPL, IM,JM,LM, q, t, plo, ple, tke, vvel, FRLAND, & !$OMP parallel do default(none) & !$OMP shared(IM, JM, LM, n_modes, T, plo, vvel, tke, AeroPropsNew, & - !$OMP NACTL, NACTI) & + !$OMP NACTL, NACTI, NN_MIN_LIQ, NN_MAX_LIQ, NN_MIN_ICE, NN_MAX_ICE) & !$OMP private(k, n, i, j, tk, press, air_den, wupdraft, ni, rg, bibar, & !$OMP sig0, nact, numbinit) DO k=1,LM diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/aer_cloud.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/aer_cloud.F90 index 7a0d6dbffa..25a8222a62 100644 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/aer_cloud.F90 +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/aer_cloud.F90 @@ -13,7 +13,25 @@ MODULE aer_cloud implicit none private - + + integer, parameter :: nsmx_par = 20 !maximum number of modes allowed + integer, parameter :: npgauss = 10 + + ! Storage of aerosol properties for activation + type :: AerPropsNew + integer :: nmods ! total number of modes (nmods Date: Mon, 22 Jun 2026 11:15:49 -0400 Subject: [PATCH 21/40] Zero-Diff for L72 ICE_FRACTION updates --- .../GEOSmoist_GridComp/Process_Library.F90 | 145 +++++++++--------- 1 file changed, 75 insertions(+), 70 deletions(-) diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/Process_Library.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/Process_Library.F90 index ef48b0b81c..bab58423a1 100644 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/Process_Library.F90 +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/Process_Library.F90 @@ -662,77 +662,81 @@ function ICE_FRACTION_SC (TEMP,CNV_FRACTION,SRF_TYPE) RESULT(ICEFRCT) ! ------------------------------------------------------------------ ! 2. Grid-Scale / Mesh Cloud Ice Fraction (ICEFRCT_M) ! ------------------------------------------------------------------ - ! Select the correct constants based on surface type and Jason flag - select case (nint(SRF_TYPE)) - case (SRF_TYPE_LANDICE) - if (USE_JASON_ICE_FRACTIONS) then - t_all_loc = JliT_ICE_ALL - t_max_loc = JliT_ICE_MAX - pwr_loc = JliICEFRPWR - else - t_all_loc = liT_ICE_ALL - t_max_loc = liT_ICE_MAX - pwr_loc = liICEFRPWR - end if - case (SRF_TYPE_ICE) - if (USE_JASON_ICE_FRACTIONS) then - t_all_loc = JiT_ICE_ALL - t_max_loc = JiT_ICE_MAX - pwr_loc = JiICEFRPWR - else - t_all_loc = iT_ICE_ALL - t_max_loc = iT_ICE_MAX - pwr_loc = iICEFRPWR - end if - case (SRF_TYPE_SNOW) - if (USE_JASON_ICE_FRACTIONS) then - t_all_loc = JsT_ICE_ALL - t_max_loc = JsT_ICE_MAX - pwr_loc = JsICEFRPWR - else - t_all_loc = sT_ICE_ALL - t_max_loc = sT_ICE_MAX - pwr_loc = sICEFRPWR - end if - case (SRF_TYPE_LAND) - if (USE_JASON_ICE_FRACTIONS) then - t_all_loc = JlT_ICE_ALL - t_max_loc = JlT_ICE_MAX - pwr_loc = JlICEFRPWR - else - t_all_loc = lT_ICE_ALL - t_max_loc = lT_ICE_MAX - pwr_loc = lICEFRPWR - end if - case (SRF_TYPE_OCEAN) - if (USE_JASON_ICE_FRACTIONS) then - t_all_loc = JoT_ICE_ALL - t_max_loc = JoT_ICE_MAX - pwr_loc = JoICEFRPWR - else - t_all_loc = oT_ICE_ALL - t_max_loc = oT_ICE_MAX - pwr_loc = oICEFRPWR - end if - case default - ! You should not be here - print *, 'ICE_FRACTION_SC: Unknown SRF_TYPE = ',SRF_TYPE - error stop - end select - - ! Calculate ICEFRCT_M - if ((nint(SRF_TYPE) == SRF_TYPE_LAND) .and. USE_JASON_ICE_FRACTIONS) then - ! Exact sequence required to maintain zero-diff for LAND - ICEFRCT_M = 0.00 - if ( TEMP <= JlT_ICE_ALL ) then - ICEFRCT_M = 1.000 - else if ( (TEMP > JlT_ICE_ALL) .AND. (TEMP <= JlT_ICE_MAX) ) then - ICEFRCT_M = SIN( 0.5*MAPL_PI*( 1.00 - ( TEMP - JlT_ICE_ALL ) / ( JlT_ICE_MAX - JlT_ICE_ALL ) ) ) - end if - ICEFRCT_M = MIN(ICEFRCT_M,1.00) - ICEFRCT_M = MAX(ICEFRCT_M,0.00) - ICEFRCT_M = ICEFRCT_M**JlICEFRPWR + + if (USE_JASON_ICE_FRACTIONS) then + + ! Sigmoidal functions like figure 6b/6c of Hu et al 2010, doi:10.1029/2009JD012384 + select case (nint(SRF_TYPE)) + case (SRF_TYPE_SNOW, SRF_TYPE_ICE, SRF_TYPE_LANDICE) + ! Over snow (SRF_TYPE == 2.0) and ice (SRF_TYPE >= 3.0) + ICEFRCT_M = 0.00 + if ( TEMP <= JiT_ICE_ALL ) then + ICEFRCT_M = 1.000 + else if ( (TEMP > JiT_ICE_ALL) .AND. (TEMP <= JiT_ICE_MAX) ) then + ICEFRCT_M = SIN( 0.5*MAPL_PI*( 1.00 - ( TEMP - JiT_ICE_ALL ) / ( JiT_ICE_MAX - JiT_ICE_ALL ) ) ) + end if + ICEFRCT_M = MIN(ICEFRCT_M,1.00) + ICEFRCT_M = MAX(ICEFRCT_M,0.00) + ICEFRCT_M = ICEFRCT_M**JiICEFRPWR + case (SRF_TYPE_LAND) + ! Over Land (SRF_TYPE == 1) + ICEFRCT_M = 0.00 + if ( TEMP <= JlT_ICE_ALL ) then + ICEFRCT_M = 1.000 + else if ( (TEMP > JlT_ICE_ALL) .AND. (TEMP <= JlT_ICE_MAX) ) then + ICEFRCT_M = SIN( 0.5*MAPL_PI*( 1.00 - ( TEMP - JlT_ICE_ALL ) / ( JlT_ICE_MAX - JlT_ICE_ALL ) ) ) + end if + ICEFRCT_M = MIN(ICEFRCT_M,1.00) + ICEFRCT_M = MAX(ICEFRCT_M,0.00) + ICEFRCT_M = ICEFRCT_M**JlICEFRPWR + case (SRF_TYPE_OCEAN) + ! Over Oceans (SRF_TYPE == 0) + ICEFRCT_M = 0.00 + if ( TEMP <= JoT_ICE_ALL ) then + ICEFRCT_M = 1.000 + else if ( (TEMP > JoT_ICE_ALL) .AND. (TEMP <= JoT_ICE_MAX) ) then + ICEFRCT_M = SIN( 0.5*MAPL_PI*( 1.00 - ( TEMP - JoT_ICE_ALL ) / ( JoT_ICE_MAX - JoT_ICE_ALL ) ) ) + end if + ICEFRCT_M = MIN(ICEFRCT_M,1.00) + ICEFRCT_M = MAX(ICEFRCT_M,0.00) + ICEFRCT_M = ICEFRCT_M**JoICEFRPWR + case default + ! You should not be here + print *, 'ICE_FRACTION_SC: Unknown SRF_TYPE = ',SRF_TYPE + error stop + end select + else + + ! Select the correct constants based on surface type + select case (nint(SRF_TYPE)) + case (SRF_TYPE_LANDICE) + t_all_loc = liT_ICE_ALL + t_max_loc = liT_ICE_MAX + pwr_loc = liICEFRPWR + case (SRF_TYPE_ICE) + t_all_loc = iT_ICE_ALL + t_max_loc = iT_ICE_MAX + pwr_loc = iICEFRPWR + case (SRF_TYPE_SNOW) + t_all_loc = sT_ICE_ALL + t_max_loc = sT_ICE_MAX + pwr_loc = sICEFRPWR + case (SRF_TYPE_LAND) + t_all_loc = lT_ICE_ALL + t_max_loc = lT_ICE_MAX + pwr_loc = lICEFRPWR + case (SRF_TYPE_OCEAN) + t_all_loc = oT_ICE_ALL + t_max_loc = oT_ICE_MAX + pwr_loc = oICEFRPWR + case default + ! You should not be here + print *, 'ICE_FRACTION_SC: Unknown SRF_TYPE = ',SRF_TYPE + error stop + end select + + ! Calculate ICEFRCT_M ! Cleaned up sequence for all other surface types ICEFRCT_M = 0.00 if ( TEMP <= t_all_loc ) then @@ -741,6 +745,7 @@ function ICE_FRACTION_SC (TEMP,CNV_FRACTION,SRF_TYPE) RESULT(ICEFRCT) ICEFRCT_M = SIN( 0.5*MAPL_PI*( 1.00 - ( TEMP - t_all_loc ) / ( t_max_loc - t_all_loc ) ) ) end if ICEFRCT_M = MAX(0.00, MIN(1.00, ICEFRCT_M)) ** pwr_loc + end if ! Combine the Convective and Mesh functions From c2d56ec96fe53133d201490d416fa45f71085a87 Mon Sep 17 00:00:00 2001 From: William Putman Date: Tue, 23 Jun 2026 14:33:40 -0400 Subject: [PATCH 22/40] what should actually be ZeroDiff for L72 --- .../GEOS_BACM_1M_InterfaceMod.F90 | 2 +- .../GEOS_GFDL_1M_InterfaceMod.F90 | 3 +- .../GEOS_MGB2_2M_InterfaceMod.F90 | 2 + .../GEOS_NSSL_2M_InterfaceMod.F90 | 2 + .../GEOS_THOM_1M_InterfaceMod.F90 | 2 + .../GEOSmoist_GridComp/Process_Library.F90 | 107 ++++++++++-------- .../GEOSmoist_GridComp/gfdl_mp.F90 | 60 ++++++---- 7 files changed, 110 insertions(+), 68 deletions(-) diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/GEOS_BACM_1M_InterfaceMod.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/GEOS_BACM_1M_InterfaceMod.F90 index 0933fe3c76..ddd2961e73 100644 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/GEOS_BACM_1M_InterfaceMod.F90 +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/GEOS_BACM_1M_InterfaceMod.F90 @@ -271,7 +271,7 @@ subroutine BACM_1M_Initialize (MAPL, RC) call MAPL_GetResource( MAPL, CNV_FRACTION_MIN, 'CNV_FRACTION_MIN:', DEFAULT= 500.0, RC=STATUS); VERIFY_(STATUS) call MAPL_GetResource( MAPL, CNV_FRACTION_MAX, 'CNV_FRACTION_MAX:', DEFAULT= 1500.0, RC=STATUS); VERIFY_(STATUS) - call MAPL_GetResource( MAPL, USE_JASON_ICE_FRACTIONS, Label="USE_JASON_ICE_FRACTIONS:", default=.TRUE., RC=STATUS) ; VERIFY_(STATUS) + call MAPL_GetResource( MAPL, ICE_FRACTION_POLYNOMIAL, Label="ICE_FRACTION_POLYNOMIAL:", default=JASON_ICE_POLYNOMIAL, RC=STATUS) ; VERIFY_(STATUS) call MAPL_GetResource( MAPL, USE_AEROSOL_NN , 'USE_AEROSOL_NN:' , DEFAULT=USE_AEROSOL_NN, RC=STATUS); VERIFY_(STATUS) call MAPL_GetResource( MAPL, USE_BERGERON , 'USE_BERGERON:' , DEFAULT=USE_BERGERON , RC=STATUS); VERIFY_(STATUS) diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/GEOS_GFDL_1M_InterfaceMod.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/GEOS_GFDL_1M_InterfaceMod.F90 index 6b1a940f95..4d5b01ac0d 100644 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/GEOS_GFDL_1M_InterfaceMod.F90 +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/GEOS_GFDL_1M_InterfaceMod.F90 @@ -308,7 +308,6 @@ subroutine GFDL_1M_Initialize (MAPL, CF, CLOCK, IMPORT, EXPORT, RC) if (DT_R8 <= 150.0) do_sedi_melt_qi = .true. if (DT_R8 <= 150.0) do_sedi_melt_qs = .true. if (DT_R8 <= 150.0) do_sedi_melt_qg = .true. - if (DT_R8 <= 150.0) ifflag = 1 if (GFDL_MP3) then call gfdl_mp_init(LHYDROSTATIC,DT_MOIST) @@ -351,6 +350,8 @@ subroutine GFDL_1M_Initialize (MAPL, CF, CLOCK, IMPORT, EXPORT, RC) call MAPL_GetResource( MAPL, CNV_FRACTION_MIN, 'CNV_FRACTION_MIN:', DEFAULT= 500.0, RC=STATUS); VERIFY_(STATUS) call MAPL_GetResource( MAPL, CNV_FRACTION_MAX, 'CNV_FRACTION_MAX:', DEFAULT= 2500.0, RC=STATUS); VERIFY_(STATUS) + call MAPL_GetResource( MAPL, ICE_FRACTION_POLYNOMIAL, Label="ICE_FRACTION_POLYNOMIAL:", default=V12_ICE_POLYNOMIAL, RC=STATUS) ; VERIFY_(STATUS) + call MAPL_GetResource( MAPL, USE_AEROSOL_NN , 'USE_AEROSOL_NN:' , DEFAULT=USE_AEROSOL_NN, RC=STATUS); VERIFY_(STATUS) call MAPL_GetResource( MAPL, USE_BERGERON , 'USE_BERGERON:' , DEFAULT=USE_AEROSOL_NN, RC=STATUS); VERIFY_(STATUS) diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/GEOS_MGB2_2M_InterfaceMod.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/GEOS_MGB2_2M_InterfaceMod.F90 index 5ff6e1a079..9076c811c7 100644 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/GEOS_MGB2_2M_InterfaceMod.F90 +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/GEOS_MGB2_2M_InterfaceMod.F90 @@ -477,6 +477,8 @@ subroutine MGB2_2M_Initialize (MAPL, RC) call MAPL_GetResource( MAPL, CNV_FRACTION_MAX, 'CNV_FRACTION_MAX:', DEFAULT= 1500.0, RC=STATUS); VERIFY_(STATUS) call MAPL_GetResource( MAPL, CNV_FRACTION_EXP, 'CNV_FRACTION_EXP:', DEFAULT= 1.0, RC=STATUS); VERIFY_(STATUS) + call MAPL_GetResource( MAPL, ICE_FRACTION_POLYNOMIAL, Label="ICE_FRACTION_POLYNOMIAL:", default=V12_ICE_POLYNOMIAL, RC=STATUS) ; VERIFY_(STATUS) + end subroutine MGB2_2M_Initialize subroutine MGB2_2M_Run (GC, IMPORT, EXPORT, CLOCK, RC) diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/GEOS_NSSL_2M_InterfaceMod.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/GEOS_NSSL_2M_InterfaceMod.F90 index 95eecb7249..6a2c5f558f 100644 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/GEOS_NSSL_2M_InterfaceMod.F90 +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/GEOS_NSSL_2M_InterfaceMod.F90 @@ -363,6 +363,8 @@ subroutine NSSL_2M_Initialize (MAPL, RC) call MAPL_GetResource( MAPL, CNV_FRACTION_MIN, 'CNV_FRACTION_MIN:', DEFAULT= 200.0, RC=STATUS); VERIFY_(STATUS) call MAPL_GetResource( MAPL, CNV_FRACTION_MAX, 'CNV_FRACTION_MAX:', DEFAULT= 4000.0, RC=STATUS); VERIFY_(STATUS) + call MAPL_GetResource( MAPL, ICE_FRACTION_POLYNOMIAL, Label="ICE_FRACTION_POLYNOMIAL:", default=V12_ICE_POLYNOMIAL, RC=STATUS) ; VERIFY_(STATUS) + call MAPL_GetResource( MAPL, USE_AEROSOL_NN , 'USE_AEROSOL_NN:' , DEFAULT=USE_AEROSOL_NN, RC=STATUS); VERIFY_(STATUS) call MAPL_GetResource( MAPL, USE_BERGERON , 'USE_BERGERON:' , DEFAULT=USE_BERGERON , RC=STATUS); VERIFY_(STATUS) diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/GEOS_THOM_1M_InterfaceMod.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/GEOS_THOM_1M_InterfaceMod.F90 index 6cede2e41a..2cc8837398 100644 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/GEOS_THOM_1M_InterfaceMod.F90 +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/GEOS_THOM_1M_InterfaceMod.F90 @@ -288,6 +288,8 @@ subroutine THOM_1M_Initialize (MAPL, RC) call MAPL_GetResource( MAPL, CNV_FRACTION_MIN, 'CNV_FRACTION_MIN:', DEFAULT= 200.0, RC=STATUS); VERIFY_(STATUS) call MAPL_GetResource( MAPL, CNV_FRACTION_MAX, 'CNV_FRACTION_MAX:', DEFAULT= 4000.0, RC=STATUS); VERIFY_(STATUS) + call MAPL_GetResource( MAPL, ICE_FRACTION_POLYNOMIAL, Label="ICE_FRACTION_POLYNOMIAL:", default=V12_ICE_POLYNOMIAL, RC=STATUS) ; VERIFY_(STATUS) + call MAPL_GetResource( MAPL, USE_AEROSOL_NN , 'USE_AEROSOL_NN:' , DEFAULT=USE_AEROSOL_NN, RC=STATUS); VERIFY_(STATUS) call MAPL_GetResource( MAPL, USE_BERGERON , 'USE_BERGERON:' , DEFAULT=USE_BERGERON , RC=STATUS); VERIFY_(STATUS) diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/Process_Library.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/Process_Library.F90 index bab58423a1..312a904eeb 100644 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/Process_Library.F90 +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/Process_Library.F90 @@ -41,7 +41,10 @@ module GEOSmoist_Process_Library integer, parameter :: SRF_TYPE_ICE = 3 integer, parameter :: SRF_TYPE_LANDICE = 4 - logical :: USE_JASON_ICE_FRACTIONS = .false. + integer, parameter :: RAW_MODIS_POLYNOMIAL = 1 + integer, parameter :: JASON_ICE_POLYNOMIAL = 2 + integer, parameter :: V12_ICE_POLYNOMIAL = 3 + integer :: ICE_FRACTION_POLYNOMIAL = 3 ! ICE_FRACTION constants ! In anvil/convective clouds @@ -284,7 +287,8 @@ module GEOSmoist_Process_Library public :: WSUB_OPTION, PDFSHAPE public :: CNV_Tracer_Type, CNV_Tracers, CNV_Tracers_Init public :: USE_BERGERON, USE_AEROSOL_NN, USE_NCLOUD_CLIM - public :: USE_JASON_ICE_FRACTIONS + public :: RAW_MODIS_POLYNOMIAL, JASON_ICE_POLYNOMIAL, V12_ICE_POLYNOMIAL + public :: ICE_FRACTION_POLYNOMIAL public :: SRF_TYPE_OCEAN, SRF_TYPE_LAND, SRF_TYPE_SNOW, SRF_TYPE_ICE, SRF_TYPE_LANDICE public :: ICE_FRACTION, EVAP3, SUBL3, LDRADIUS4, BUOYANCY, BUOYANCY2 public :: REDISTRIBUTE_CLOUDS_SCALAR, REDISTRIBUTE_CLOUDS, RADCOUPLE_SCALE_AWARE, RADCOUPLE, FIX_UP_CLOUDS @@ -630,43 +634,34 @@ function ICE_FRACTION_SC (TEMP,CNV_FRACTION,SRF_TYPE) RESULT(ICEFRCT) real :: ICEFRCT_C, ICEFRCT_M, ICEFRCT_PHYS real :: t_all_loc, t_max_loc, pwr_loc -#ifdef USE_MODIS_ICE_POLY - ! Use MODIS polynomial from Hu et al, DOI: (10.1029/2009JD012384) - tc = MAX(-46.0,MIN(TEMP-MAPL_TICE,46.0)) ! convert to celcius and limit range from -46:46 C - ptc = 7.6725 + 1.0118*tc + 0.1422*tc**2 + 0.0106*tc**3 + 0.000339*tc**4 + 0.00000395*tc**5 - ICEFRCT = 1.0 - (1.0/(1.0 + exp(-1*ptc))) -#else - ! ------------------------------------------------------------------ - ! 1. Convective / Anvil Cloud Ice Fraction (ICEFRCT_C) - ! ------------------------------------------------------------------ - ! Select the correct constants based on parameterization - if (ICE_RADII_PARAM == 1) then - t_all_loc = JaT_ICE_ALL - t_max_loc = JaT_ICE_MAX - pwr_loc = JaICEFRPWR - else - t_all_loc = aT_ICE_ALL - t_max_loc = aT_ICE_MAX - pwr_loc = aICEFRPWR - end if + select case (ICE_FRACTION_POLYNOMIAL) + case (RAW_MODIS_POLYNOMIAL) - ! Calculate ICEFRCT_C once - ICEFRCT_C = 0.00 - if ( TEMP <= t_all_loc ) then - ICEFRCT_C = 1.000 - else if ( TEMP <= t_max_loc ) then - ICEFRCT_C = SIN( 0.5*MAPL_PI*( 1.00 - ( TEMP - t_all_loc ) / ( t_max_loc - t_all_loc ) ) ) - end if - ICEFRCT_C = MAX(0.00, MIN(1.00, ICEFRCT_C)) ** pwr_loc + ! Use MODIS polynomial from Hu et al, DOI: (10.1029/2009JD012384) + tc = MAX(-46.0,MIN(TEMP-MAPL_TICE,46.0)) ! convert to celcius and limit range from -46:46 C + ptc = 7.6725 + 1.0118*tc + 0.1422*tc**2 + 0.0106*tc**3 + 0.000339*tc**4 + 0.00000395*tc**5 + ICEFRCT = 1.0 - (1.0/(1.0 + exp(-1*ptc))) - ! ------------------------------------------------------------------ - ! 2. Grid-Scale / Mesh Cloud Ice Fraction (ICEFRCT_M) - ! ------------------------------------------------------------------ - - if (USE_JASON_ICE_FRACTIONS) then + case (JASON_ICE_POLYNOMIAL) + ! ------------------------------------------------------------------ + ! 1. Convective / Anvil Cloud Ice Fraction (ICEFRCT_C) + ! ------------------------------------------------------------------ + ICEFRCT_C = 0.00 + if ( TEMP <= JaT_ICE_ALL ) then + ICEFRCT_C = 1.000 + else if ( (TEMP > JaT_ICE_ALL) .AND. (TEMP <= JaT_ICE_MAX) ) then + ICEFRCT_C = SIN( 0.5*MAPL_PI*( 1.00 - ( TEMP - JaT_ICE_ALL ) / ( JaT_ICE_MAX - JaT_ICE_ALL ) ) ) + end if + ICEFRCT_C = MIN(ICEFRCT_C,1.00) + ICEFRCT_C = MAX(ICEFRCT_C,0.00) + ICEFRCT_C = ICEFRCT_C**aICEFRPWR + + ! ------------------------------------------------------------------ + ! 2. Grid-Scale / Mesh Cloud Ice Fraction (ICEFRCT_M) + ! ------------------------------------------------------------------ ! Sigmoidal functions like figure 6b/6c of Hu et al 2010, doi:10.1029/2009JD012384 - select case (nint(SRF_TYPE)) + select case (NINT(SRF_TYPE)) case (SRF_TYPE_SNOW, SRF_TYPE_ICE, SRF_TYPE_LANDICE) ! Over snow (SRF_TYPE == 2.0) and ice (SRF_TYPE >= 3.0) ICEFRCT_M = 0.00 @@ -705,11 +700,28 @@ function ICE_FRACTION_SC (TEMP,CNV_FRACTION,SRF_TYPE) RESULT(ICEFRCT) print *, 'ICE_FRACTION_SC: Unknown SRF_TYPE = ',SRF_TYPE error stop end select - - else + + ! Combine the Convective and Mesh functions + ICEFRCT = ICEFRCT_M*(1.0-CNV_FRACTION) + ICEFRCT_C*(CNV_FRACTION) + + case (V12_ICE_POLYNOMIAL) + ! ------------------------------------------------------------------ + ! 1. Convective / Anvil Cloud Ice Fraction (ICEFRCT_C) + ! ------------------------------------------------------------------ + ICEFRCT_C = 0.00 + if ( TEMP <= aT_ICE_ALL ) then + ICEFRCT_C = 1.000 + else if ( TEMP <= aT_ICE_MAX ) then + ICEFRCT_C = SIN( 0.5*MAPL_PI*( 1.00 - ( TEMP - aT_ICE_ALL ) / ( aT_ICE_MAX - aT_ICE_ALL ) ) ) + end if + ICEFRCT_C = MAX(0.00, MIN(1.00, ICEFRCT_C)) ** aICEFRPWR + + ! ------------------------------------------------------------------ + ! 2. Grid-Scale / Mesh Cloud Ice Fraction (ICEFRCT_M) + ! ------------------------------------------------------------------ ! Select the correct constants based on surface type - select case (nint(SRF_TYPE)) + select case (NINT(SRF_TYPE)) case (SRF_TYPE_LANDICE) t_all_loc = liT_ICE_ALL t_max_loc = liT_ICE_MAX @@ -737,7 +749,7 @@ function ICE_FRACTION_SC (TEMP,CNV_FRACTION,SRF_TYPE) RESULT(ICEFRCT) end select ! Calculate ICEFRCT_M - ! Cleaned up sequence for all other surface types + ! Sigmoidal functions like figure 6b/6c of Hu et al 2010, doi:10.1029/2009JD012384 ICEFRCT_M = 0.00 if ( TEMP <= t_all_loc ) then ICEFRCT_M = 1.000 @@ -745,15 +757,18 @@ function ICE_FRACTION_SC (TEMP,CNV_FRACTION,SRF_TYPE) RESULT(ICEFRCT) ICEFRCT_M = SIN( 0.5*MAPL_PI*( 1.00 - ( TEMP - t_all_loc ) / ( t_max_loc - t_all_loc ) ) ) end if ICEFRCT_M = MAX(0.00, MIN(1.00, ICEFRCT_M)) ** pwr_loc - - end if - ! Combine the Convective and Mesh functions - ICEFRCT = ICEFRCT_M*(1.0-CNV_FRACTION) + ICEFRCT_C*(CNV_FRACTION) -#endif + ! Combine the Convective and Mesh functions + ICEFRCT = ICEFRCT_M*(1.0-CNV_FRACTION) + ICEFRCT_C*(CNV_FRACTION) + + case default + ! You should not be here + print *, 'ICE_FRACTION_SC: Unknown ICE_FRACTION_POLYNOMIAL = ',ICE_FRACTION_POLYNOMIAL + error stop + end select - ! Final bounds check - ICEFRCT = MIN(1.0, MAX(0.0, ICEFRCT)) + ! Final bounds check + ICEFRCT = MIN(1.0, MAX(0.0, ICEFRCT)) end function ICE_FRACTION_SC diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/gfdl_mp.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/gfdl_mp.F90 index 9dd21c1277..883a696908 100644 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/gfdl_mp.F90 +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/gfdl_mp.F90 @@ -227,7 +227,7 @@ module gfdl_mp_mod ! 3: WSM6 with 0 at 0 C and fixed value at - 10 C ! 4: combination of 1 and 3 - integer :: ifflag = 3 ! ice fall scheme + integer :: ifflag = 1 ! ice fall scheme ! 1: Deng and Mace (2008) ! 2: Heymsfield and Donner (1990) ! 3: Combination of Deng and Mace (2008) and Mishra et al (2014, JGR) @@ -2598,24 +2598,44 @@ subroutine term_ice (ks, ke, tz, q, den, v_fac, v_min, v_max, const_v, vt) ! ----------------------------------------------------------- ! 1. Calculate Base Fall Speeds based on chosen formulation ! ----------------------------------------------------------- - if (ifflag .eq. 1) then - qden = q (k) * den (k) * 1.e3 - viLSC = 10.0**(log10(qden) * (tc (k) * (aaL * tc (k) + bbL) + ccL) + ddL * tc (k) + eeL) - viCNV = 10.0**(log10(qden) * (tc (k) * (aaC * tc (k) + bbC) + ccC) + ddC * tc (k) + eeC) - vt (k) = 0.01 * (viLSC*(1.0-cnv_fraction) + viCNV*(cnv_fraction)) - endif - - if (ifflag .eq. 2) then - qden = q (k) * den (k) - vt (k) = 3.29 * exp (0.16 * log (qden)) - endif - - if (ifflag .eq. 3) then - qden = q (k) * den (k) * 1.e3 - viLSC = 10.0**(log10(qden) * (tc (k) * (aaL * tc (k) + bbL) + ccL) + ddL * tc (k) + eeL) - viCNV = MAX(10.0,(1.119*tc (k) + 14.21*log10(qden*1.e3) + 68.85)) - vt (k) = 0.01 * (viLSC*(1.0-cnv_fraction) + viCNV*(cnv_fraction)) - endif + select case (ifflag) + + case (1) + ! Pure Deng and Mace (2008) + qden = q (k) * den (k) * 1.e3 + viLSC = 10.0**(log10(qden) * (tc (k) * (aaL * tc (k) + bbL) + ccL) + ddL * tc (k) + eeL) + viCNV = 10.0**(log10(qden) * (tc (k) * (aaC * tc (k) + bbC) + ccC) + ddC * tc (k) + eeC) + vt (k) = 0.01 * (viLSC*(1.0-cnv_fraction) + viCNV*(cnv_fraction)) + + case (2) + ! Pure Heymsfield and Donner (1990) + qden = q (k) * den (k) + vt (k) = 3.29 * exp (0.16 * log (qden)) + + case (3) + ! Pure Mishra et al (2014, JGR) + qden = q (k) * den (k) * 1.e3 + ! Synoptic Vm: a=1.411, b=11.71, c=82.35 + viLSC = MAX(10.0, (1.411*tc (k) + 11.71*log10(qden*1.e3) + 82.35)) + ! Anvil Vm: a=1.119, b=14.21, c=68.85 + viCNV = MAX(10.0, (1.119*tc (k) + 14.21*log10(qden*1.e3) + 68.85)) + vt (k) = 0.01 * (viLSC*(1.0-cnv_fraction) + viCNV*(cnv_fraction)) + + case (4) + ! Combination: Deng & Mace (2008) LSC + Mishra et al (2014) Anvil CNV + qden = q (k) * den (k) * 1.e3 + viLSC = 10.0**(log10(qden) * (tc (k) * (aaL * tc (k) + bbL) + ccL) + ddL * tc (k) + eeL) + ! Anvil Vm: a=1.119, b=14.21, c=68.85 + viCNV = MAX(10.0, (1.119*tc (k) + 14.21*log10(qden*1.e3) + 68.85)) + vt (k) = 0.01 * (viLSC*(1.0-cnv_fraction) + viCNV*(cnv_fraction)) + + case default + ! Fail execution if an invalid flag is provided + print *, "ERROR: Invalid ifflag (", ifflag, ") provided for ice fall scheme." + print *, "Valid options are 1, 2, 3, or 4." + stop "Execution halted in ice settling code due to invalid ifflag." + + end select ! ----------------------------------------------------------- ! 2. Apply Universal Pressure Scaling (Accelerates high-alt ice) @@ -4899,7 +4919,7 @@ subroutine pwbf (ks, ke, dts, qa, qv, ql, qr, qi, qs, qg, dp, tz, cvm, te8, den, real :: tc, tin, sink, dqdt, qsw, qsi, qim, tmp, fac_wbf real :: tau_wbf_eff - real, parameter :: wbf_coarse_mult = 3.0 ! How much slower WBF is at 50km vs 2km + real, parameter :: wbf_coarse_mult = 9.0 ! How much slower WBF is at 50km vs 2km if (.not. do_wbf) return From dde822dd2f85ee2cfa64ef603f9f0a7d19be7a5b Mon Sep 17 00:00:00 2001 From: Matthew Thompson Date: Wed, 24 Jun 2026 14:35:32 -0400 Subject: [PATCH 23/40] Remove cumulus_type from OMP declaration --- .../GEOSphysics_GridComp/GEOSmoist_GridComp/ConvPar_GF2020.F90 | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/ConvPar_GF2020.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/ConvPar_GF2020.F90 index 1fa200a1ed..3fcf052e1e 100644 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/ConvPar_GF2020.F90 +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/ConvPar_GF2020.F90 @@ -821,7 +821,7 @@ SUBROUTINE GF2020_DRV( & !$OMP icumulus_gf, cum_hei_down_land, cum_hei_down_ocean, & !$OMP cum_hei_updf_land, cum_hei_updf_ocean, cum_min_edt_land, & !$OMP cum_min_edt_ocean, cum_max_edt_land, cum_max_edt_ocean, & - !$OMP cum_fadj_massflx, cum_use_excess, cumulus_type, closure_choice, & + !$OMP cum_fadj_massflx, cum_use_excess, closure_choice, & !$OMP cum_entr_rate, cum_cap_maxs, FIX_NEGATIVES, USE_MOMENTUM_TRANSP, & !$OMP CONVECTION_TRACER, do_this_column, & !$OMP ierr4d, jmin4d, klcl4d, k224d, kbcon4d, ktop4d, kstabi4d, kstabm4d, & From 034dda72b20c62f90b94e2aafc708339ba3bb70d Mon Sep 17 00:00:00 2001 From: William Putman Date: Wed, 24 Jun 2026 15:40:53 -0400 Subject: [PATCH 24/40] Final ZD updates to get buda diagnostics ZD from UW --- .../GEOS_UW_InterfaceMod.F90 | 18 +++++++++++++++--- 1 file changed, 15 insertions(+), 3 deletions(-) diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/GEOS_UW_InterfaceMod.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/GEOS_UW_InterfaceMod.F90 index 482f554ff4..e70ff5033c 100644 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/GEOS_UW_InterfaceMod.F90 +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/GEOS_UW_InterfaceMod.F90 @@ -196,6 +196,7 @@ subroutine UW_Run (GC, IMPORT, EXPORT, CLOCK, RC) real, allocatable, dimension(:,:,:) :: ZLE0, ZL0 real, allocatable, dimension(:,:,:) :: PL, PK, PKE, DP real, allocatable, dimension(:,:,:) :: MASS + real, allocatable, dimension(:,:,:) :: DQLDT_SC_, DQIDT_SC_ real, allocatable, dimension(:,:) :: RKM2D, RKFRE, MIX2D, RMAXFRAC2D real, allocatable, dimension(:,:,:) :: TMP3D @@ -374,6 +375,9 @@ subroutine UW_Run (GC, IMPORT, EXPORT, CLOCK, RC) ALLOCATE ( PK (IM,JM,LM ) ) ALLOCATE ( DP (IM,JM,LM ) ) ALLOCATE ( MASS (IM,JM,LM ) ) + ! Temporary UW exports + ALLOCATE ( DQLDT_SC_(IM,JM,LM ) ) + ALLOCATE ( DQIDT_SC_(IM,JM,LM ) ) ! 2D Variables ALLOCATE ( RKFRE (IM,JM) ) ALLOCATE ( RKM2D (IM,JM) ) @@ -522,7 +526,8 @@ subroutine UW_Run (GC, IMPORT, EXPORT, CLOCK, RC) ! 3. Combine condensates for input (not updated within UW) !-------------------------------------------------------------- !$OMP PARALLEL DO DEFAULT(NONE) & - !$OMP SHARED(IM, JM, LM, QLTOT, QLLS, QLCN, QITOT, QILS, QICN) & + !$OMP SHARED(IM, JM, LM, QLTOT, DQLDT_SC, QLLS, QLCN, & + !$OMP QITOT, DQIDT_SC, QILS, QICN) & !$OMP PRIVATE(i, j, k) do k = 1, LM do j = 1, JM @@ -530,6 +535,9 @@ subroutine UW_Run (GC, IMPORT, EXPORT, CLOCK, RC) do i = 1, IM QLTOT(i,j,k) = QLLS(i,j,k) + QLCN(i,j,k) QITOT(i,j,k) = QILS(i,j,k) + QICN(i,j,k) + ! Initialize tendencies + DQLDT_SC(i,j,k) = QLTOT(i,j,k) + DQIDT_SC(i,j,k) = QITOT(i,j,k) end do end do end do @@ -542,7 +550,7 @@ subroutine UW_Run (GC, IMPORT, EXPORT, CLOCK, RC) U, V, Q, QLTOT, QITOT, T, TKE, RKFRE, KPBL_SC,& SH, EVAP, CNPCPRATE, FRLAND, RKM2D, MIX2D, RMAXFRAC2D, & CUSH, & ! INOUT - UMF_SC, DCM_SC, DQVDT_SC, DQLDT_SC, DQIDT_SC, & ! OUT + UMF_SC, DCM_SC, DQVDT_SC, DQLDT_SC_, DQIDT_SC_, & ! OUT DTDT_SC, DUDT_SC, DVDT_SC, DQRDT_SC, & DQSDT_SC, CUFRC_SC, ENTR_SC, DETR_SC, & QLDET_SC, QIDET_SC, QLSUB_SC, QISUB_SC, & @@ -670,7 +678,7 @@ subroutine UW_Run (GC, IMPORT, EXPORT, CLOCK, RC) !-------------------------------------------------------------- !$OMP PARALLEL DO DEFAULT(NONE) & !$OMP SHARED(IM, JM, LM, Q, DQVDT_SC, MOIST_DT, T, DTDT_SC, U, DUDT_SC, V, DVDT_SC, & - !$OMP CLCN, DQADT_SC, QLCN, QLDET_SC, MASS, QICN, QIDET_SC, & + !$OMP CLCN, DQADT_SC, QLCN, QLDET_SC, DQLDT_SC, MASS, QICN, QIDET_SC, DQIDT_SC, & !$OMP QLLS, QLSUB_SC, QLENT_SC, QILS, QISUB_SC, QIENT_SC) & !$OMP PRIVATE(i, j, k) do k = 1, LM @@ -695,6 +703,10 @@ subroutine UW_Run (GC, IMPORT, EXPORT, CLOCK, RC) ! condensate entrained into shallow updraft. QLLS(i,j,k) = MAX(0.0, QLLS(i,j,k) + (QLSUB_SC(i,j,k)+QLENT_SC(i,j,k))*MOIST_DT) QILS(i,j,k) = MAX(0.0, QILS(i,j,k) + (QISUB_SC(i,j,k)+QIENT_SC(i,j,k))*MOIST_DT) + + ! Get export QL/QI tendencies + DQLDT_SC(i,j,k) = (QLLS(i,j,k) + QLCN(i,j,k) - DQLDT_SC(i,j,k)) / MOIST_DT + DQIDT_SC(i,j,k) = (QILS(i,j,k) + QICN(i,j,k) - DQIDT_SC(i,j,k)) / MOIST_DT end do end do end do From 2f55f19f9aaeac895cfddb2ee88eeabf0cd74213 Mon Sep 17 00:00:00 2001 From: William Putman Date: Thu, 2 Jul 2026 09:06:03 -0400 Subject: [PATCH 25/40] v12 GWD tuning update to produce better polar vortex breakup --- .../GEOSgwd_GridComp/GEOS_GwdGridComp.F90 | 10 ++++++---- .../GEOSgwd_GridComp/ncar_gwd/gw_convect.F90 | 10 ++++------ 2 files changed, 10 insertions(+), 10 deletions(-) diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSgwd_GridComp/GEOS_GwdGridComp.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSgwd_GridComp/GEOS_GwdGridComp.F90 index a34270591f..d5eed04ee1 100644 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSgwd_GridComp/GEOS_GwdGridComp.F90 +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSgwd_GridComp/GEOS_GwdGridComp.F90 @@ -379,10 +379,10 @@ subroutine Initialize ( GC, IMPORT, EXPORT, CLOCK, RC ) call MAPL_GetResource( MAPL, NCAR_BKG_GW_DC, Label="NCAR_BKG_GW_DC:", default=2.5, _RC) call MAPL_GetResource( MAPL, NCAR_BKG_FCRIT2, Label="NCAR_BKG_FCRIT2:", default=1.0, _RC) call MAPL_GetResource( MAPL, NCAR_BKG_WAVELENGTH, Label="NCAR_BKG_WAVELENGTH:", default=1.e5, _RC) - call MAPL_GetResource( MAPL, NCAR_TR_EFF, Label="NCAR_TR_EFF:", default=1.0, _RC) + call MAPL_GetResource( MAPL, NCAR_TR_EFF, Label="NCAR_TR_EFF:", default=0.75, _RC) call MAPL_GetResource( MAPL, NCAR_ET_EFF, Label="NCAR_ET_EFF:", default=1.0, _RC) - call MAPL_GetResource( MAPL, NCAR_ET_TAUBGND, Label="NCAR_ET_TAUBGND:", default=6.4, _RC) - call MAPL_GetResource( MAPL, NCAR_ET_USE_DQCDT, Label="NCAR_ET_USE_DQCDT:", default=.FALSE., _RC) + call MAPL_GetResource( MAPL, NCAR_ET_TAUBGND, Label="NCAR_ET_TAUBGND:", default=10.0, _RC) + call MAPL_GetResource( MAPL, NCAR_ET_USE_DQCDT, Label="NCAR_ET_USE_DQCDT:", default=.TRUE., _RC) call MAPL_GetResource( MAPL, NCAR_BKG_TNDMAX, Label="NCAR_BKG_TNDMAX:", default=250.0, _RC) NCAR_BKG_TNDMAX = NCAR_BKG_TNDMAX/86400.0 ! Beres DeepCu @@ -685,7 +685,9 @@ subroutine Gwd_Driver(RC) !call MAPL_TimerOn(MAPL,"-INTR_NCAR") if ( (self%NCAR_EFFGWORO /= 0.0) .OR. (self%NCAR_EFFGWBKG /= 0.0) ) then DO L=1, LM - TMP3D(:,:,L) = (1.0-CNV_FRC)*(DQLDT(:,:,L)+DQIDT(:,:,L)) + ! Raising the mask to the 4th power aggressively suppresses + ! tendencies in regions with even modest CNV_FRC values + TMP3D(:,:,L) = ((1.0-CNV_FRC)**4) * (DQLDT(:,:,L)+DQIDT(:,:,L)) END DO if(associated(DQCDT_LS)) DQCDT_LS = TMP3D thread = MAPL_get_current_thread() diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSgwd_GridComp/ncar_gwd/gw_convect.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSgwd_GridComp/ncar_gwd/gw_convect.F90 index 5b35c7aebb..36537d065b 100644 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSgwd_GridComp/ncar_gwd/gw_convect.F90 +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSgwd_GridComp/ncar_gwd/gw_convect.F90 @@ -184,7 +184,7 @@ subroutine gw_beres_init (file_name, band, desc, pgwv, gw_dc, fcrit2, wavelength ! Include dependence on latitude: latdeg = lats(i)*rad2deg if (desc%et_bkg_dqcdt_forcing) then - flat_gw = 0.15 + flat_gw = 0.05 ! weak background forcing else if (ABS(latdeg) < 60.) then flat_gw = max(0.15,0.50*exp(-((abs(latdeg)-60.)/23.)**2)) @@ -482,7 +482,7 @@ subroutine gw_beres_src(ncol, pver, band, desc, pint, u, v, & topi(i) = desc%k(i) else ! Find largest condensate change level, for frontal detection - ! condensate tendencies from microphysics will be negative + ! Using POSITIVE tendencies which correctly align with precipitation fronts q0(i) = 0.0 do k = desc%k(i), 1, -1 ! tend-level to the surface [avoid convective overlap] if (dqcdt(i,k) > q0(i)) then ! Find largest positive DQCDT tendency @@ -490,10 +490,8 @@ subroutine gw_beres_src(ncol, pver, band, desc, pint, u, v, & endif end do ! include forced background stress in extra tropical large-scale systems - ! Set the phase speeds and wave numbers in the direction of the source wind. - ! Set the source stress magnitude (positive only, note that the sign of the - ! stress is the same as (c-u). - tau(i,:,desc%k(i)+1) = desc%taubck(i,:) * MIN(10.0,MAX(1.0,abs(q0(i)/1.e-9))) + ! Using 1.e-8 so that values of 100-1000 (scaled) provide 10x multiplier + tau(i,:,desc%k(i)+1) = desc%taubck(i,:) * MIN(10.0,MAX(1.0,q0(i)/1.e-8)) topi(i) = desc%k(i) endif From 1cece64916193a11b7efe3b406653f6459eee44b Mon Sep 17 00:00:00 2001 From: William Putman Date: Thu, 2 Jul 2026 09:06:48 -0400 Subject: [PATCH 26/40] v12 stability update for thin surface layers, should be 0-diff for L72 --- .../GEOSland_GridComp/GEOScatch_GridComp/GEOS_CatchGridComp.F90 | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatch_GridComp/GEOS_CatchGridComp.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatch_GridComp/GEOS_CatchGridComp.F90 index 5ba1873b4b..ebcd67a43a 100644 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatch_GridComp/GEOS_CatchGridComp.F90 +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatch_GridComp/GEOS_CatchGridComp.F90 @@ -3620,7 +3620,7 @@ subroutine RUN1 ( GC, IMPORT, EXPORT, CLOCK, RC ) ENDIF D0T = D0_BY_ZVEG*ZVG - DZE = max(DZ - D0T, 10.) + DZE = max(DZ - D0T, min(0.5*DZ,10.0)) ! was previously capped at 10m [problematic for L137/L181 with thinner surface layers] if(associated(Z0 )) Z0 = Z0T(:,N) if(associated(D0 )) D0 = D0T From 1740620f3f384bc7a7da0afd0a4d822f9202d899 Mon Sep 17 00:00:00 2001 From: William Putman Date: Thu, 9 Jul 2026 13:09:10 -0400 Subject: [PATCH 27/40] ZeroDiff for L72: other levels updated tuning for BKG GWD and GFDL-MP reduce supercooled QL over ice/snow surfaces --- GEOSagcm_GridComp/GEOS_AgcmGridComp.F90 | 4 +- .../GEOSgwd_GridComp/GEOS_GwdGridComp.F90 | 19 ++-- .../GEOSgwd_GridComp/GWD_StateSpecs.rc | 31 +++---- .../GEOSgwd_GridComp/ncar_gwd/gw_convect.F90 | 88 ++++++++++++------- .../GEOSgwd_GridComp/ncar_gwd/gw_drag.F90 | 7 +- .../GEOSmoist_GridComp/Process_Library.F90 | 67 +++++++------- .../GEOSmoist_GridComp/gfdl_mp.F90 | 33 ++++++- .../GEOS_SuperdynGridComp.F90 | 6 ++ 8 files changed, 163 insertions(+), 92 deletions(-) diff --git a/GEOSagcm_GridComp/GEOS_AgcmGridComp.F90 b/GEOSagcm_GridComp/GEOS_AgcmGridComp.F90 index 3c2e807059..5dc0e43421 100644 --- a/GEOSagcm_GridComp/GEOS_AgcmGridComp.F90 +++ b/GEOSagcm_GridComp/GEOS_AgcmGridComp.F90 @@ -1077,13 +1077,13 @@ subroutine SetServices ( GC, RC ) call MAPL_AddConnectivity ( GC, & SRC_NAME = (/'U ','V ','TH ','T ', & 'ZLE ','PS ','TA ','QA ', & - 'US ','VS ', & + 'US ','VS ','WSPD_STABLE300M ', & 'SPEED ','DZ ','PLE ','W ', & 'PREF ','TROPP_BLENDED','S ','PLK ', & 'PV ','TROPK_BLENDED','OMEGA ','PKE '/), & DST_NAME = (/'U ','V ','TH ','T ', & 'ZLE ','PS ','TA ','QA ', & - 'UA ','VA ', & + 'UA ','VA ','WSPD_STABLE300M', & 'SPEED ','DZ ','PLE ','W ', & 'PREF ','TROPP ','S ','PLK ', & 'PV ','TROPK ','OMEGA ','PKE '/), & diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSgwd_GridComp/GEOS_GwdGridComp.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSgwd_GridComp/GEOS_GwdGridComp.F90 index d5eed04ee1..990f6a49de 100644 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSgwd_GridComp/GEOS_GwdGridComp.F90 +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSgwd_GridComp/GEOS_GwdGridComp.F90 @@ -260,6 +260,7 @@ subroutine Initialize ( GC, IMPORT, EXPORT, CLOCK, RC ) real :: NCAR_ET_EFF ! Frontal region efficiency factor real :: NCAR_ET_TAUBGND ! Extratropical background frontal forcing logical :: NCAR_ET_USE_DQCDT + logical :: NCAR_ET_USE_SPEED logical :: NCAR_DC_BERES integer :: GEOS_PGWV real :: NCAR_EFFGWBKG @@ -379,10 +380,18 @@ subroutine Initialize ( GC, IMPORT, EXPORT, CLOCK, RC ) call MAPL_GetResource( MAPL, NCAR_BKG_GW_DC, Label="NCAR_BKG_GW_DC:", default=2.5, _RC) call MAPL_GetResource( MAPL, NCAR_BKG_FCRIT2, Label="NCAR_BKG_FCRIT2:", default=1.0, _RC) call MAPL_GetResource( MAPL, NCAR_BKG_WAVELENGTH, Label="NCAR_BKG_WAVELENGTH:", default=1.e5, _RC) - call MAPL_GetResource( MAPL, NCAR_TR_EFF, Label="NCAR_TR_EFF:", default=0.75, _RC) + call MAPL_GetResource( MAPL, NCAR_TR_EFF, Label="NCAR_TR_EFF:", default=0.625, _RC) call MAPL_GetResource( MAPL, NCAR_ET_EFF, Label="NCAR_ET_EFF:", default=1.0, _RC) - call MAPL_GetResource( MAPL, NCAR_ET_TAUBGND, Label="NCAR_ET_TAUBGND:", default=10.0, _RC) + call MAPL_GetResource( MAPL, NCAR_ET_USE_DQCDT, Label="NCAR_ET_USE_DQCDT:", default=.TRUE., _RC) + call MAPL_GetResource( MAPL, NCAR_ET_USE_SPEED, Label="NCAR_ET_USE_SPEED:", default=.TRUE., _RC) + + ! 1. Default to classic rigid latitude tuning + NCAR_ET_TAUBGND = 6.4 + ! 2. Set baselines for independent runs + if (NCAR_ET_USE_DQCDT .or. NCAR_ET_USE_SPEED) NCAR_ET_TAUBGND = 6.75 + call MAPL_GetResource( MAPL, NCAR_ET_TAUBGND, Label="NCAR_ET_TAUBGND:", default=NCAR_ET_TAUBGND, _RC) + call MAPL_GetResource( MAPL, NCAR_BKG_TNDMAX, Label="NCAR_BKG_TNDMAX:", default=250.0, _RC) NCAR_BKG_TNDMAX = NCAR_BKG_TNDMAX/86400.0 ! Beres DeepCu @@ -397,7 +406,7 @@ subroutine Initialize ( GC, IMPORT, EXPORT, CLOCK, RC ) self%workspaces(thread)%beres_dc_desc, & NCAR_BKG_PGWV, NCAR_BKG_GW_DC, NCAR_BKG_FCRIT2, & NCAR_BKG_WAVELENGTH, NCAR_DC_BERES_SRC_LEVEL, & - 1000.0, .TRUE., NCAR_TR_EFF, NCAR_ET_EFF, NCAR_ET_TAUBGND, NCAR_ET_USE_DQCDT, & + 1000.0, .TRUE., NCAR_TR_EFF, NCAR_ET_EFF, NCAR_ET_TAUBGND, NCAR_ET_USE_DQCDT, NCAR_ET_USE_SPEED, & NCAR_BKG_TNDMAX, NCAR_DC_BERES, & IM*JM_thread, LATS(:,bounds(thread+1)%min:bounds(thread+1)%max)) end do @@ -407,7 +416,7 @@ subroutine Initialize ( GC, IMPORT, EXPORT, CLOCK, RC ) self%workspaces(0)%beres_dc_desc, & NCAR_BKG_PGWV, NCAR_BKG_GW_DC, NCAR_BKG_FCRIT2, & NCAR_BKG_WAVELENGTH, NCAR_DC_BERES_SRC_LEVEL, & - 1000.0, .TRUE., NCAR_TR_EFF, NCAR_ET_EFF, NCAR_ET_TAUBGND, NCAR_ET_USE_DQCDT, & + 1000.0, .TRUE., NCAR_TR_EFF, NCAR_ET_EFF, NCAR_ET_TAUBGND, NCAR_ET_USE_DQCDT, NCAR_ET_USE_SPEED, & NCAR_BKG_TNDMAX, NCAR_DC_BERES, & IM*JM, LATS ) endif @@ -696,7 +705,7 @@ subroutine Gwd_Driver(RC) workspace%beres_dc_desc, & workspace%beres_band, workspace%oro_band, workspace%rdg_band, & PLE, T, U, V, & - HT_dc, TMP3D, & + HT_dc, TMP3D, WSPD_STABLE300M, & SGH, MXDIS, HWDTH, CLNGT, ANGLL, & ANIXY, GBXAR_TMP, KWVRDG, EFFRDG, PREF, & PMID, PDEL, RPDEL, PILN, ZM, LATS, & diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSgwd_GridComp/GWD_StateSpecs.rc b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSgwd_GridComp/GWD_StateSpecs.rc index fb80c1dcd1..09ef41bd12 100644 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSgwd_GridComp/GWD_StateSpecs.rc +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSgwd_GridComp/GWD_StateSpecs.rc @@ -20,23 +20,24 @@ category: IMPORT #------------------------------------------------------------------------------------------------------- # VARIABLE | DIMENSIONS | Additional Metadata #------------------------------------------------------------------------------------------------------- - NAME | ALIAS | UNITS | DIMS | VLOC | RESTART | LONG NAME + NAME | ALIAS | UNITS | DIMS | VLOC | RESTART | LONG NAME #------------------------------------------------------------------------------------------------------- - PLE | | Pa | xyz | E | SKIP | air_pressure - T | | K | xyz | C | SKIP | air_temperature - Q | | kg kg-1 | xyz | C | SKIP | specific_humidity - U | | m s-1 | xyz | C | SKIP | eastward_wind - V | | m s-1 | xyz | C | SKIP | northward_wind - PHIS | | m+2 s-2 | xy | N | SKIP | surface geopotential height - SGH | | m | xy | N | SKIP | standard_deviation_of_topography - VARFLT | | m+2 | xy | N | SKIP | variance_of_the_filtered_topography - PREF | | Pa | z | E | SKIP | reference_air_pressure - AREA | | m^2 | xy | N | SKIP | grid_box_area + PLE | | Pa | xyz | E | SKIP | air_pressure + T | | K | xyz | C | SKIP | air_temperature + Q | | kg kg-1 | xyz | C | SKIP | specific_humidity + U | | m s-1 | xyz | C | SKIP | eastward_wind + V | | m s-1 | xyz | C | SKIP | northward_wind + PHIS | | m+2 s-2 | xy | N | SKIP | surface geopotential height + SGH | | m | xy | N | SKIP | standard_deviation_of_topography + VARFLT | | m+2 | xy | N | SKIP | variance_of_the_filtered_topography + PREF | | Pa | z | E | SKIP | reference_air_pressure + AREA | | m^2 | xy | N | SKIP | grid_box_area + WSPD_STABLE300M | | m s-1 | xy | N | SKIP | max_wind_speed_in_stable_cold_surface_layer #-from-moist- - DTDT_DC | HT_dc | K s-1 | xyz | C | | T tendency due to deep convection - DQLDT | | kg kg-1 s-1 | xyz | C | | total_liq_water_tendency_due_to_moist - DQIDT | | kg kg-1 s-1 | xyz | C | | total_ice_water_tendency_due_to_moist - CNV_FRC | | 1 | xy | N | | convective_fraction + DTDT_DC | HT_dc | K s-1 | xyz | C | | T tendency due to deep convection + DQLDT | | kg kg-1 s-1 | xyz | C | | total_liq_water_tendency_due_to_moist + DQIDT | | kg kg-1 s-1 | xyz | C | | total_ice_water_tendency_due_to_moist + CNV_FRC | | 1 | xy | N | | convective_fraction category: EXPORT #------------------------------------------------------------------------------------------------------- diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSgwd_GridComp/ncar_gwd/gw_convect.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSgwd_GridComp/ncar_gwd/gw_convect.F90 index 36537d065b..46e4360ac6 100644 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSgwd_GridComp/ncar_gwd/gw_convect.F90 +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSgwd_GridComp/ncar_gwd/gw_convect.F90 @@ -47,6 +47,7 @@ module gw_convect ! Efficiency TR:ET function real, allocatable :: effbck(:) logical :: et_bkg_dqcdt_forcing + logical :: et_bkg_speed_forcing end type BeresSourceDesc @@ -57,7 +58,7 @@ module gw_convect !------------------------------------ subroutine gw_beres_init (file_name, band, desc, pgwv, gw_dc, fcrit2, wavelength, & spectrum_source, min_hdepth, storm_shift, eff_tr, eff_et, & - tau_et, et_use_dqcdt, tndmax, & + tau_et, et_use_dqcdt, et_use_speed, tndmax, & active, ncol, lats) #include @@ -69,7 +70,7 @@ subroutine gw_beres_init (file_name, band, desc, pgwv, gw_dc, fcrit2, wavelength integer, intent(in) :: pgwv, ncol real, intent(in) :: gw_dc, fcrit2, wavelength real, intent(in) :: spectrum_source, min_hdepth, eff_tr, eff_et, tau_et, tndmax - logical, intent(in) :: storm_shift, active, et_use_dqcdt + logical, intent(in) :: storm_shift, active, et_use_dqcdt, et_use_speed real, intent(in) :: lats(ncol) ! Stuff for Beres convective gravity wave source. @@ -178,24 +179,30 @@ subroutine gw_beres_init (file_name, band, desc, pgwv, gw_dc, fcrit2, wavelength enddo cw = cw*(sum(cw4)/sum(cw)) desc%et_bkg_dqcdt_forcing = et_use_dqcdt + desc%et_bkg_speed_forcing = et_use_speed do i=1,ncol ! include forced background stress in extra tropics ! Determine the background stress at c=0 - ! Include dependence on latitude: - latdeg = lats(i)*rad2deg - if (desc%et_bkg_dqcdt_forcing) then + if (desc%et_bkg_dqcdt_forcing .or. desc%et_bkg_speed_forcing) then flat_gw = 0.05 ! weak background forcing + ! Scale the extratropical stress to account for changes in tropical efficiency + ! (e.g., if tau_et=8.0, eff_et=1.0, eff_tr=0.625, tau_et_scaled becomes 12.8) + desc%taubck(i,:) = tau_et*(eff_et/eff_tr)*0.001*flat_gw*cw + ! efficiency function (now constant based on QBO tuning) + desc%effbck(i) = eff_tr else + ! Include dependence on latitude: + latdeg = lats(i)*rad2deg if (ABS(latdeg) < 60.) then flat_gw = max(0.15,0.50*exp(-((abs(latdeg)-60.)/23.)**2)) elseif (ABS(latdeg) >= 60.) then flat_gw = 0.50*exp(-((abs(latdeg)-60.)/70.)**2) endif + desc%taubck(i,:) = tau_et*0.001*flat_gw*cw + ! efficiency function + desc%effbck(i) = eff_tr*cos(lats(i))**2 + & + eff_et*sin(lats(i))**2 endif - desc%taubck(i,:) = tau_et*0.001*flat_gw*cw - ! efficiency function - desc%effbck(i) = eff_tr*cos(lats(i))**2 + & - eff_et*sin(lats(i))**2 enddo deallocate( cw, cw4 ) end if @@ -205,7 +212,7 @@ end subroutine gw_beres_init !------------------------------------ subroutine gw_beres_src(ncol, pver, band, desc, pint, u, v, & netdt, zm, src_level, tend_level, tau, ubm, ubi, xv, yv, & - c, hdepth, maxq0, lats, dqcdt) + c, hdepth, maxq0, dqcdt, speed) !----------------------------------------------------------------------- ! Driver for multiple gravity wave drag parameterization. ! @@ -239,8 +246,6 @@ subroutine gw_beres_src(ncol, pver, band, desc, pint, u, v, & real, intent(in) :: netdt(:,:) ! Midpoint altitudes. real, intent(in) :: zm(ncol,pver) - ! latitudes. - real, intent(in) :: lats(ncol) ! Indices of top gravity wave source level and lowest level where wind ! tendencies are allowed. @@ -260,8 +265,9 @@ subroutine gw_beres_src(ncol, pver, band, desc, pint, u, v, & ! Heating depth [m] and maximum heating in each column. real, intent(out) :: hdepth(ncol), maxq0(ncol) - ! Condensate tendency due to large-scale (kg kg-1 s-1) + ! Frontal and Jet proxy inputs real, intent(in) :: dqcdt(ncol,pver) ! Condensate tendency due to large-scale (kg kg-1 s-1) + real, intent(in) :: speed(ncol) ! Katabatic proxy: Max wind speed in lowest 300m stable layer (m s-1) !---------------------------Local Storage------------------------------- ! Column and level indices. @@ -272,6 +278,7 @@ subroutine gw_beres_src(ncol, pver, band, desc, pint, u, v, & ! Maximum heating rate. real(GW_PRC) :: q0(ncol) + real(GW_PRC) :: moist_mult, dry_mult, phys_mult ! Bottom/top heating range index. integer :: boti(ncol), topi(ncol) @@ -472,7 +479,36 @@ subroutine gw_beres_src(ncol, pver, band, desc, pint, u, v, & else tau(i,:,:) = 0.0 - if (.not. desc%et_bkg_dqcdt_forcing) then + if (desc%et_bkg_dqcdt_forcing .or. desc%et_bkg_speed_forcing) then + ! ----------------------------------------------------------------- + ! Frontal Detection via Combined Physical Proxies + ! 1. DQCDT_LS captures the wet, lifting cores of the storm tracks. + ! 2. SPEED captures dry katabatic winds and broad, windy storm flanks. + ! ----------------------------------------------------------------- + ! Proxy 1: The Moist Condensate (Precipitation) + if (desc%et_bkg_dqcdt_forcing) then + q0(i) = 0.0 + do k = desc%k(i), 1, -1 + if (dqcdt(i,k) > q0(i)) q0(i) = dqcdt(i,k) + end do + ! Scale moist multiplier (using the optimized * 5.e8 factor) + moist_mult = MAX(1.0, MIN(10.0,q0(i) * 5.e8)) + else + moist_mult = 1.0 + endif + ! Proxy 2: The Dry Wind (Katabatic winds) + if (desc%et_bkg_speed_forcing) then + ! A baseline 5 m/s wind yields a 1.0x multiplier (no extra drag). + ! A linear 5 to 25 m/s ramp (1 - 20)x + ! A howling +25 m/s katabatic wind yields 20.0x drag. + dry_mult = MAX(1.0, MIN(20.0,1.0 + (speed(i) - 5.0) * (19.0 / 20.0))) + else + dry_mult = 1.0 + endif + phys_mult = MAX(1.0, moist_mult+dry_mult-1.0) + tau(i,:,desc%k(i)+1) = desc%taubck(i,:) * phys_mult + topi(i) = desc%k(i) + else ! use latitudinal dependence ! include forced background stress in extra tropical large-scale systems ! Set the phase speeds and wave numbers in the direction of the source wind. @@ -480,21 +516,8 @@ subroutine gw_beres_src(ncol, pver, band, desc, pint, u, v, & ! stress is the same as (c-u). tau(i,:,desc%k(i)+1) = desc%taubck(i,:) topi(i) = desc%k(i) - else - ! Find largest condensate change level, for frontal detection - ! Using POSITIVE tendencies which correctly align with precipitation fronts - q0(i) = 0.0 - do k = desc%k(i), 1, -1 ! tend-level to the surface [avoid convective overlap] - if (dqcdt(i,k) > q0(i)) then ! Find largest positive DQCDT tendency - q0(i) = dqcdt(i,k) - endif - end do - ! include forced background stress in extra tropical large-scale systems - ! Using 1.e-8 so that values of 100-1000 (scaled) provide 10x multiplier - tau(i,:,desc%k(i)+1) = desc%taubck(i,:) * MIN(10.0,MAX(1.0,q0(i)/1.e-8)) - topi(i) = desc%k(i) endif - + endif enddo @@ -520,8 +543,8 @@ subroutine gw_beres_ifc( band, & ncol, pver, dt, effgw_dp, & u, v, t, pref, pint, delp, rdelp, piln, & zm, zi, nm, ni, rhoi, kvtt, & - netdt,desc,lats, alpha, & - utgw,vtgw,ttgw,flx_heat,dqcdt) + netdt,desc, alpha, & + utgw,vtgw,ttgw,flx_heat,dqcdt,speed) type(BeresSourceDesc), intent(inout) :: desc type(GWBand), intent(in) :: band ! I hate this variable ... it just hides information from view @@ -546,7 +569,6 @@ subroutine gw_beres_ifc( band, & real, intent(in) :: rhoi(ncol,pver+1) ! Interface density (kg m-3). real, intent(in) :: kvtt(ncol,pver+1) ! Molecular thermal diffusivity. - real, intent(in) :: lats(ncol) ! latitudes real, intent(in) :: alpha(:) real, intent(out) :: utgw(ncol,pver) ! zonal wind tendency @@ -555,6 +577,7 @@ subroutine gw_beres_ifc( band, & real, intent(inout) :: flx_heat(ncol) ! Energy change real, intent(in) :: dqcdt(ncol,pver) ! Condensate tendency due to large-scale (kg kg-1 s-1) + real, intent(in) :: speed(ncol) ! max_wind_speed_in_stable_cold_surface_layer_to_300m (m s-1) !---------------------------Local storage------------------------------- @@ -613,7 +636,8 @@ subroutine gw_beres_ifc( band, & ! Determine wave sources for Beres deep scheme call gw_beres_src(ncol, pver, band, desc, pint, & u, v, netdt, zm, src_level, tend_level, tau, & - ubm, ubi, xv, yv, c, hdepth, maxq0, lats, dqcdt=dqcdt) + ubm, ubi, xv, yv, c, hdepth, maxq0, & + dqcdt=dqcdt, speed=speed) ! Solve for the drag profile with convective sources. call gw_drag_prof(ncol, pver, band, pint, delp, rdelp, & diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSgwd_GridComp/ncar_gwd/gw_drag.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSgwd_GridComp/ncar_gwd/gw_drag.F90 index 49e8f050e1..6c10e00e24 100644 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSgwd_GridComp/ncar_gwd/gw_drag.F90 +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSgwd_GridComp/ncar_gwd/gw_drag.F90 @@ -58,7 +58,7 @@ module gw_drag_ncar subroutine gw_intr_ncar(pcols, pver, dt, nrdg, & beres_dc_desc, beres_band, oro_band, rdg_band, & pint_dev, t_dev, u_dev, v_dev, & - ht_dc_dev, dqcdt_dev, & + ht_dc_dev, dqcdt_dev, speed_dev, & sgh_dev, mxdis_dev, hwdth_dev, clngt_dev, angll_dev, & anixy_dev, gbxar_dev, kwvrdg_dev, effrdg_dev, pref_dev, & pmid_dev, pdel_dev, rpdel_dev, lnpint_dev, zm_dev, rlat_dev, & @@ -92,6 +92,7 @@ subroutine gw_intr_ncar(pcols, pver, dt, nrdg, real, intent(in ) :: v_dev(pcols,pver) ! meridional wind at layers real, intent(in ) :: ht_dc_dev(pcols,pver) ! DeepCu heating in layers real, intent(in ) :: dqcdt_dev(pcols,pver) ! Condensate tendencies due to large-scale + real, intent(in ) :: speed_dev(pcols,pver) ! max_wind_speed_in_stable_cold_surface_layer_to_300m real, intent(in ) :: sgh_dev(pcols) ! standard deviation of orography !++jtb 01/25/21 New topo vars real, intent(in ) :: mxdis_dev(pcols,nrdg) ! obstacle/ridge height @@ -211,8 +212,8 @@ subroutine gw_intr_ncar(pcols, pver, dt, nrdg, pdel_dev , rpdel_dev, lnpint_dev, & zm_dev, zi, & nm, ni, rhoi, kvtt, & - ht_dc_dev,beres_dc_desc,rlat_dev, alpha, & - utgw, vtgw, ttgw, flx_heat, dqcdt_dev) + ht_dc_dev,beres_dc_desc, alpha, & + utgw, vtgw, ttgw, flx_heat, dqcdt_dev, speed_dev) dudt_gwd_dev = dudt_gwd_dev + utgw dvdt_gwd_dev = dvdt_gwd_dev + vtgw dtdt_gwd_dev = dtdt_gwd_dev + ttgw diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/Process_Library.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/Process_Library.F90 index 312a904eeb..93ab600cc6 100644 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/Process_Library.F90 +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/Process_Library.F90 @@ -50,53 +50,56 @@ module GEOSmoist_Process_Library ! In anvil/convective clouds real, parameter :: aT_ICE_ALL = 243.66 real, parameter :: aT_ICE_MAX = 265.66 - real, parameter :: aICEFRPWR = 2.0 - ! Over Land Ice SRF_TYPE == 4 - real, parameter :: liT_ICE_ALL = 233.16 - real, parameter :: liT_ICE_MAX = 258.16 - real, parameter :: liICEFRPWR = 6.0 - ! Over Ice SRF_TYPE == 3 - real, parameter :: iT_ICE_ALL = 236.16 - real, parameter :: iT_ICE_MAX = 261.16 - real, parameter :: iICEFRPWR = 4.0 - ! Over Snow SRF_TYPE = 2 - real, parameter :: sT_ICE_ALL = 235.16 - real, parameter :: sT_ICE_MAX = 260.16 - real, parameter :: sICEFRPWR = 6.0 - ! Over Land SRF_TYPE = 1 + real, parameter :: aT_ICE_PWR = 2.0 + ! Over Land Ice SRF_TYPE == 4 (Antarctica / Greenland) + ! OLD: 233.16 / 258.16 / 6.0 + real, parameter :: liT_ICE_ALL = 245.16 ! 100% ice at -28C (was -40C) + real, parameter :: liT_ICE_MAX = 268.16 ! Ice starts at -5C (was -15C) + real, parameter :: liT_ICE_PWR = 1.5 ! Linear-quadratic transition (was 6.0) + ! Over Ice SRF_TYPE == 3 (Arctic Sea Ice) + ! OLD: 236.16 / 261.16 / 4.0 + real, parameter :: iT_ICE_ALL = 246.16 ! 100% ice at -27C (was -37C) + real, parameter :: iT_ICE_MAX = 268.16 ! Ice starts at -5C (was -12C) + real, parameter :: iT_ICE_PWR = 1.5 ! (was 4.0) + ! Over Snow SRF_TYPE = 2 (Winter high-latitude land) + ! OLD: 235.16 / 260.16 / 6.0 + real, parameter :: sT_ICE_ALL = 245.16 ! 100% ice at -28C (was -38C) + real, parameter :: sT_ICE_MAX = 268.16 ! Ice starts at -5C (was -13C) + real, parameter :: sT_ICE_PWR = 1.5 ! (was 6.0) + ! Over Land SRF_TYPE = 1 (Keep default or lower power slightly) real, parameter :: lT_ICE_ALL = 240.16 real, parameter :: lT_ICE_MAX = 262.16 - real, parameter :: lICEFRPWR = 2.0 + real, parameter :: lT_ICE_PWR = 1.5 ! (was 2.0) ! Over Oceans SRF_TYPE = 0 real, parameter :: oT_ICE_ALL = 238.16 real, parameter :: oT_ICE_MAX = 263.16 - real, parameter :: oICEFRPWR = 3.0 + real, parameter :: oT_ICE_PWR = 3.0 ! Jason constants ! In anvil/convective clouds real, parameter :: JaT_ICE_ALL = 245.16 real, parameter :: JaT_ICE_MAX = 261.16 - real, parameter :: JaICEFRPWR = 2.0 + real, parameter :: JaT_ICE_PWR = 2.0 ! Over Land Ice SRF_TYPE == 4 real, parameter :: JliT_ICE_ALL = 236.16 real, parameter :: JliT_ICE_MAX = 261.16 - real, parameter :: JliICEFRPWR = 5.0 + real, parameter :: JliT_ICE_PWR = 5.0 ! Over Ice SRF_TYPE == 3 real, parameter :: JiT_ICE_ALL = 236.16 real, parameter :: JiT_ICE_MAX = 261.16 - real, parameter :: JiICEFRPWR = 5.0 + real, parameter :: JiT_ICE_PWR = 5.0 ! Over Snow SRF_TYPE = 2 real, parameter :: JsT_ICE_ALL = 236.16 real, parameter :: JsT_ICE_MAX = 261.16 - real, parameter :: JsICEFRPWR = 5.0 + real, parameter :: JsT_ICE_PWR = 5.0 ! Over Land SRF_TYPE = 1 real, parameter :: JlT_ICE_ALL = 239.16 real, parameter :: JlT_ICE_MAX = 261.16 - real, parameter :: JlICEFRPWR = 2.0 + real, parameter :: JlT_ICE_PWR = 2.0 ! Over Oceans SRF_TYPE = 0 real, parameter :: JoT_ICE_ALL = 238.16 real, parameter :: JoT_ICE_MAX = 263.16 - real, parameter :: JoICEFRPWR = 4.0 + real, parameter :: JoT_ICE_PWR = 4.0 logical :: USE_BERGERON = .FALSE. logical :: USE_AEROSOL_NN = .TRUE. @@ -655,7 +658,7 @@ function ICE_FRACTION_SC (TEMP,CNV_FRACTION,SRF_TYPE) RESULT(ICEFRCT) end if ICEFRCT_C = MIN(ICEFRCT_C,1.00) ICEFRCT_C = MAX(ICEFRCT_C,0.00) - ICEFRCT_C = ICEFRCT_C**aICEFRPWR + ICEFRCT_C = ICEFRCT_C**aT_ICE_PWR ! ------------------------------------------------------------------ ! 2. Grid-Scale / Mesh Cloud Ice Fraction (ICEFRCT_M) @@ -672,7 +675,7 @@ function ICE_FRACTION_SC (TEMP,CNV_FRACTION,SRF_TYPE) RESULT(ICEFRCT) end if ICEFRCT_M = MIN(ICEFRCT_M,1.00) ICEFRCT_M = MAX(ICEFRCT_M,0.00) - ICEFRCT_M = ICEFRCT_M**JiICEFRPWR + ICEFRCT_M = ICEFRCT_M**JiT_ICE_PWR case (SRF_TYPE_LAND) ! Over Land (SRF_TYPE == 1) ICEFRCT_M = 0.00 @@ -683,7 +686,7 @@ function ICE_FRACTION_SC (TEMP,CNV_FRACTION,SRF_TYPE) RESULT(ICEFRCT) end if ICEFRCT_M = MIN(ICEFRCT_M,1.00) ICEFRCT_M = MAX(ICEFRCT_M,0.00) - ICEFRCT_M = ICEFRCT_M**JlICEFRPWR + ICEFRCT_M = ICEFRCT_M**JlT_ICE_PWR case (SRF_TYPE_OCEAN) ! Over Oceans (SRF_TYPE == 0) ICEFRCT_M = 0.00 @@ -694,7 +697,7 @@ function ICE_FRACTION_SC (TEMP,CNV_FRACTION,SRF_TYPE) RESULT(ICEFRCT) end if ICEFRCT_M = MIN(ICEFRCT_M,1.00) ICEFRCT_M = MAX(ICEFRCT_M,0.00) - ICEFRCT_M = ICEFRCT_M**JoICEFRPWR + ICEFRCT_M = ICEFRCT_M**JoT_ICE_PWR case default ! You should not be here print *, 'ICE_FRACTION_SC: Unknown SRF_TYPE = ',SRF_TYPE @@ -715,7 +718,7 @@ function ICE_FRACTION_SC (TEMP,CNV_FRACTION,SRF_TYPE) RESULT(ICEFRCT) else if ( TEMP <= aT_ICE_MAX ) then ICEFRCT_C = SIN( 0.5*MAPL_PI*( 1.00 - ( TEMP - aT_ICE_ALL ) / ( aT_ICE_MAX - aT_ICE_ALL ) ) ) end if - ICEFRCT_C = MAX(0.00, MIN(1.00, ICEFRCT_C)) ** aICEFRPWR + ICEFRCT_C = MAX(0.00, MIN(1.00, ICEFRCT_C)) ** aT_ICE_PWR ! ------------------------------------------------------------------ ! 2. Grid-Scale / Mesh Cloud Ice Fraction (ICEFRCT_M) @@ -725,23 +728,23 @@ function ICE_FRACTION_SC (TEMP,CNV_FRACTION,SRF_TYPE) RESULT(ICEFRCT) case (SRF_TYPE_LANDICE) t_all_loc = liT_ICE_ALL t_max_loc = liT_ICE_MAX - pwr_loc = liICEFRPWR + pwr_loc = liT_ICE_PWR case (SRF_TYPE_ICE) t_all_loc = iT_ICE_ALL t_max_loc = iT_ICE_MAX - pwr_loc = iICEFRPWR + pwr_loc = iT_ICE_PWR case (SRF_TYPE_SNOW) t_all_loc = sT_ICE_ALL t_max_loc = sT_ICE_MAX - pwr_loc = sICEFRPWR + pwr_loc = sT_ICE_PWR case (SRF_TYPE_LAND) t_all_loc = lT_ICE_ALL t_max_loc = lT_ICE_MAX - pwr_loc = lICEFRPWR + pwr_loc = lT_ICE_PWR case (SRF_TYPE_OCEAN) t_all_loc = oT_ICE_ALL t_max_loc = oT_ICE_MAX - pwr_loc = oICEFRPWR + pwr_loc = oT_ICE_PWR case default ! You should not be here print *, 'ICE_FRACTION_SC: Unknown SRF_TYPE = ',SRF_TYPE diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/gfdl_mp.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/gfdl_mp.F90 index 883a696908..c0132f6c14 100644 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/gfdl_mp.F90 +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/gfdl_mp.F90 @@ -4919,7 +4919,15 @@ subroutine pwbf (ks, ke, dts, qa, qv, ql, qr, qi, qs, qg, dp, tz, cvm, te8, den, real :: tc, tin, sink, dqdt, qsw, qsi, qim, tmp, fac_wbf real :: tau_wbf_eff - real, parameter :: wbf_coarse_mult = 9.0 ! How much slower WBF is at 50km vs 2km + real, parameter :: wbf_coarse_mult = 2.5 ! How much slower WBF is at 50km vs 2km + + ! Change from parameter to variable + real :: pwbf_qi_crt_eff, ramp_factor + + ! Linear ramp parameters (tc = Tfreezing - T) + real, parameter :: tc_warm = 5.0 ! Start ramping down at -5C + real, parameter :: tc_cold = 20.0 ! Fully ramped down at -20C + real, parameter :: min_scale = 0.25 ! Minimum scale factor (25% of default) if (.not. do_wbf) return @@ -4944,11 +4952,30 @@ subroutine pwbf (ks, ke, dts, qa, qv, ql, qr, qi, qs, qg, dp, tz, cvm, te8, den, ! heterogeneity and allow WBF to operate in large-scale updrafts ! when the environment is supersaturated with respect to ice (qv > qsi) ! and there is both liquid and ice present - if (tc .gt. 0. .and. ql (k) .gt. qcmin .and. qi (k) .gt. qcmin .and. & + ! Bypassed qi > qcmin constraint for colder temperatures to ensure initiation + if (tc .gt. 0. .and. ql (k) .gt. qcmin .and. & + (qi (k) .gt. qcmin .or. tc .gt. 15.0) .and. & qv (k) .gt. qsi) then + ! --- Smooth Linear Temperature Ramp --- + if (tc .le. tc_warm) then + ramp_factor = 1.0 + else if (tc .ge. tc_cold) then + ramp_factor = min_scale + else + ramp_factor = 1.0 - (1.0 - min_scale) * ((tc - tc_warm) / (tc_cold - tc_warm)) + endif + ! 1. Dynamically shrink the threshold (forces ice to precipitate as snow) + pwbf_qi_crt_eff = pwbf_qi_crt * ramp_factor + ! 2. Dynamically accelerate the timescale (shorter tau = faster QL destruction) + ! At tc_cold, this drops tau_wbf to 60s and completely removes the coarse multiplier bias + tau_wbf_eff = tau_wbf * (wbf_coarse_mult * (1.0 - onemsig) + onemsig) * ramp_factor + ! 3. Final timescale factor + fac_wbf = 1. - exp (- dts / tau_wbf_eff) + ! -------------------------------------- + sink = min (fac_wbf * ql (k), tc / icpk (k)) - qim = pwbf_qi_crt / den (k) + qim = pwbf_qi_crt_eff / den (k) tmp = min (sink, dim (qim, qi (k))) mppfw = mppfw + sink * dp (k) * convt diff --git a/GEOSagcm_GridComp/GEOSsuperdyn_GridComp/GEOS_SuperdynGridComp.F90 b/GEOSagcm_GridComp/GEOSsuperdyn_GridComp/GEOS_SuperdynGridComp.F90 index 9d10e6eafc..a70b3fa4b0 100644 --- a/GEOSagcm_GridComp/GEOSsuperdyn_GridComp/GEOS_SuperdynGridComp.F90 +++ b/GEOSagcm_GridComp/GEOSsuperdyn_GridComp/GEOS_SuperdynGridComp.F90 @@ -361,6 +361,12 @@ subroutine SetServices ( GC, RC ) RC=STATUS ) VERIFY_(STATUS) + call MAPL_AddExportSpec ( GC , & + SHORT_NAME = 'WSPD_STABLE300M', & + CHILD_ID = DYN, & + RC=STATUS ) + VERIFY_(STATUS) + call MAPL_AddExportSpec ( GC , & SHORT_NAME = 'TROPP_BLENDED', & CHILD_ID = DYN, & From 5ef069c5617da592548ad603675a4d42bc74ebfc Mon Sep 17 00:00:00 2001 From: William Putman Date: Thu, 9 Jul 2026 15:31:46 -0400 Subject: [PATCH 28/40] removed QL changes to test separately --- .../GEOSmoist_GridComp/Process_Library.F90 | 24 +++++++-------- .../GEOSmoist_GridComp/gfdl_mp.F90 | 29 ++----------------- 2 files changed, 13 insertions(+), 40 deletions(-) diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/Process_Library.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/Process_Library.F90 index 93ab600cc6..7b0d60c514 100644 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/Process_Library.F90 +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/Process_Library.F90 @@ -52,24 +52,22 @@ module GEOSmoist_Process_Library real, parameter :: aT_ICE_MAX = 265.66 real, parameter :: aT_ICE_PWR = 2.0 ! Over Land Ice SRF_TYPE == 4 (Antarctica / Greenland) - ! OLD: 233.16 / 258.16 / 6.0 - real, parameter :: liT_ICE_ALL = 245.16 ! 100% ice at -28C (was -40C) - real, parameter :: liT_ICE_MAX = 268.16 ! Ice starts at -5C (was -15C) - real, parameter :: liT_ICE_PWR = 1.5 ! Linear-quadratic transition (was 6.0) + real, parameter :: liT_ICE_ALL = 233.16 + real, parameter :: liT_ICE_MAX = 258.16 + real, parameter :: liT_ICE_PWR = 6.0 ! Over Ice SRF_TYPE == 3 (Arctic Sea Ice) ! OLD: 236.16 / 261.16 / 4.0 - real, parameter :: iT_ICE_ALL = 246.16 ! 100% ice at -27C (was -37C) - real, parameter :: iT_ICE_MAX = 268.16 ! Ice starts at -5C (was -12C) - real, parameter :: iT_ICE_PWR = 1.5 ! (was 4.0) + real, parameter :: iT_ICE_ALL = 236.16 + real, parameter :: iT_ICE_MAX = 261.16 + real, parameter :: iT_ICE_PWR = 4.0 ! Over Snow SRF_TYPE = 2 (Winter high-latitude land) - ! OLD: 235.16 / 260.16 / 6.0 - real, parameter :: sT_ICE_ALL = 245.16 ! 100% ice at -28C (was -38C) - real, parameter :: sT_ICE_MAX = 268.16 ! Ice starts at -5C (was -13C) - real, parameter :: sT_ICE_PWR = 1.5 ! (was 6.0) - ! Over Land SRF_TYPE = 1 (Keep default or lower power slightly) + real, parameter :: sT_ICE_ALL = 235.16 + real, parameter :: sT_ICE_MAX = 260.16 + real, parameter :: sT_ICE_PWR = 6.0 + ! Over Land SRF_TYPE = 1 real, parameter :: lT_ICE_ALL = 240.16 real, parameter :: lT_ICE_MAX = 262.16 - real, parameter :: lT_ICE_PWR = 1.5 ! (was 2.0) + real, parameter :: lT_ICE_PWR = 2.0 ! Over Oceans SRF_TYPE = 0 real, parameter :: oT_ICE_ALL = 238.16 real, parameter :: oT_ICE_MAX = 263.16 diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/gfdl_mp.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/gfdl_mp.F90 index c0132f6c14..cc9786eb50 100644 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/gfdl_mp.F90 +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/gfdl_mp.F90 @@ -4919,15 +4919,7 @@ subroutine pwbf (ks, ke, dts, qa, qv, ql, qr, qi, qs, qg, dp, tz, cvm, te8, den, real :: tc, tin, sink, dqdt, qsw, qsi, qim, tmp, fac_wbf real :: tau_wbf_eff - real, parameter :: wbf_coarse_mult = 2.5 ! How much slower WBF is at 50km vs 2km - - ! Change from parameter to variable - real :: pwbf_qi_crt_eff, ramp_factor - - ! Linear ramp parameters (tc = Tfreezing - T) - real, parameter :: tc_warm = 5.0 ! Start ramping down at -5C - real, parameter :: tc_cold = 20.0 ! Fully ramped down at -20C - real, parameter :: min_scale = 0.25 ! Minimum scale factor (25% of default) + real, parameter :: wbf_coarse_mult = 9.0 ! How much slower WBF is at 50km vs 2km if (.not. do_wbf) return @@ -4957,25 +4949,8 @@ subroutine pwbf (ks, ke, dts, qa, qv, ql, qr, qi, qs, qg, dp, tz, cvm, te8, den, (qi (k) .gt. qcmin .or. tc .gt. 15.0) .and. & qv (k) .gt. qsi) then - ! --- Smooth Linear Temperature Ramp --- - if (tc .le. tc_warm) then - ramp_factor = 1.0 - else if (tc .ge. tc_cold) then - ramp_factor = min_scale - else - ramp_factor = 1.0 - (1.0 - min_scale) * ((tc - tc_warm) / (tc_cold - tc_warm)) - endif - ! 1. Dynamically shrink the threshold (forces ice to precipitate as snow) - pwbf_qi_crt_eff = pwbf_qi_crt * ramp_factor - ! 2. Dynamically accelerate the timescale (shorter tau = faster QL destruction) - ! At tc_cold, this drops tau_wbf to 60s and completely removes the coarse multiplier bias - tau_wbf_eff = tau_wbf * (wbf_coarse_mult * (1.0 - onemsig) + onemsig) * ramp_factor - ! 3. Final timescale factor - fac_wbf = 1. - exp (- dts / tau_wbf_eff) - ! -------------------------------------- - sink = min (fac_wbf * ql (k), tc / icpk (k)) - qim = pwbf_qi_crt_eff / den (k) + qim = pwbf_qi_crt / den (k) tmp = min (sink, dim (qim, qi (k))) mppfw = mppfw + sink * dp (k) * convt From 082e0dc0d164b46ae87afd4187f756677b77e2cd Mon Sep 17 00:00:00 2001 From: Matthew Thompson Date: Fri, 10 Jul 2026 10:18:58 -0400 Subject: [PATCH 29/40] Fix for GNU --- GEOSagcm_GridComp/GEOS_AgcmGridComp.F90 | 44 ++++++++++++++----------- 1 file changed, 24 insertions(+), 20 deletions(-) diff --git a/GEOSagcm_GridComp/GEOS_AgcmGridComp.F90 b/GEOSagcm_GridComp/GEOS_AgcmGridComp.F90 index 5dc0e43421..993e5cbf19 100644 --- a/GEOSagcm_GridComp/GEOS_AgcmGridComp.F90 +++ b/GEOSagcm_GridComp/GEOS_AgcmGridComp.F90 @@ -1074,19 +1074,23 @@ subroutine SetServices ( GC, RC ) ! Set internal connections between the childrens IMPORTS and EXPORTS ! ------------------------------------------------------------------ - call MAPL_AddConnectivity ( GC, & - SRC_NAME = (/'U ','V ','TH ','T ', & - 'ZLE ','PS ','TA ','QA ', & - 'US ','VS ','WSPD_STABLE300M ', & - 'SPEED ','DZ ','PLE ','W ', & - 'PREF ','TROPP_BLENDED','S ','PLK ', & - 'PV ','TROPK_BLENDED','OMEGA ','PKE '/), & - DST_NAME = (/'U ','V ','TH ','T ', & - 'ZLE ','PS ','TA ','QA ', & - 'UA ','VA ','WSPD_STABLE300M', & - 'SPEED ','DZ ','PLE ','W ', & - 'PREF ','TROPP ','S ','PLK ', & - 'PV ','TROPK ','OMEGA ','PKE '/), & + ! Set the length of the character array constructor to + ! the length of the longest string in the array + call MAPL_AddConnectivity ( GC, & + SRC_NAME = [character(len=15) :: & + 'U', 'V', 'TH', 'T', & + 'ZLE', 'PS', 'TA', 'QA', & + 'US', 'VS', 'WSPD_STABLE300M', & + 'SPEED', 'DZ', 'PLE', 'W', & + 'PREF', 'TROPP_BLENDED', 'S', 'PLK', & + 'PV', 'TROPK_BLENDED', 'OMEGA', 'PKE'], & + DST_NAME = [character(len=15) :: & + 'U', 'V', 'TH', 'T', & + 'ZLE', 'PS', 'TA', 'QA', & + 'UA', 'VA', 'WSPD_STABLE300M', & + 'SPEED', 'DZ', 'PLE', 'W', & + 'PREF', 'TROPP', 'S', 'PLK', & + 'PV', 'TROPK', 'OMEGA', 'PKE'], & DST_ID = PHYS, & SRC_ID = SDYN, & RC=STATUS ) @@ -1623,9 +1627,9 @@ subroutine Run ( GC, IMPORT, EXPORT, CLOCK, RC ) real, pointer, dimension(:,:) :: TQV => null() real, pointer, dimension(:,:) :: TQI => null() real, pointer, dimension(:,:) :: TQL => null() - real, pointer, dimension(:,:) :: TQR => null() - real, pointer, dimension(:,:) :: TQS => null() - real, pointer, dimension(:,:) :: TQG => null() + real, pointer, dimension(:,:) :: TQR => null() + real, pointer, dimension(:,:) :: TQS => null() + real, pointer, dimension(:,:) :: TQG => null() real, pointer, dimension(:,:) :: TOX => null() real, pointer, dimension(:,:) :: TROPP1 => null() real, pointer, dimension(:,:) :: TROPP2 => null() @@ -2668,11 +2672,11 @@ subroutine Run ( GC, IMPORT, EXPORT, CLOCK, RC ) VERIFY_(STATUS) call MAPL_GetPointer ( EXPORT, TQL , 'TQL' , rc=STATUS ) VERIFY_(STATUS) - call MAPL_GetPointer ( EXPORT, TQR , 'TQR' , rc=STATUS ) + call MAPL_GetPointer ( EXPORT, TQR , 'TQR' , rc=STATUS ) VERIFY_(STATUS) - call MAPL_GetPointer ( EXPORT, TQS , 'TQS' , rc=STATUS ) + call MAPL_GetPointer ( EXPORT, TQS , 'TQS' , rc=STATUS ) VERIFY_(STATUS) - call MAPL_GetPointer ( EXPORT, TQG , 'TQG' , rc=STATUS ) + call MAPL_GetPointer ( EXPORT, TQG , 'TQG' , rc=STATUS ) VERIFY_(STATUS) call MAPL_GetPointer ( EXPORT, QLTOT , 'QLTOT' , rc=STATUS ) VERIFY_(STATUS) @@ -2828,7 +2832,7 @@ subroutine Run ( GC, IMPORT, EXPORT, CLOCK, RC ) ! Rain ! ------------ if(NAMES(K)=='QRAIN') then - call FILL_Friendly ( Q,DP,QFILL,QINT ) + call FILL_Friendly ( Q,DP,QFILL,QINT ) if(associated(QRFILL)) QRFILL = QRFILL + QFILL if(associated(QTFILL)) QTFILL = QTFILL + QFILL if(associated(DQRDTPHYINT)) DQRDTPHYINT = DQRDTPHYINT + QFILL From b1bfb333e850c2f89f95f017bfc7d7ac20fe46d3 Mon Sep 17 00:00:00 2001 From: biljanaorescanin Date: Fri, 10 Jul 2026 10:19:14 -0400 Subject: [PATCH 30/40] fix stretched grid only area diagnostic --- .../utils_topo/generate_scrip_cube.F90 | 67 ++++++++++++++----- 1 file changed, 51 insertions(+), 16 deletions(-) diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/preproc/topography/utils_topo/generate_scrip_cube.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/preproc/topography/utils_topo/generate_scrip_cube.F90 index b4db17591b..c5a21d2d44 100644 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/preproc/topography/utils_topo/generate_scrip_cube.F90 +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/preproc/topography/utils_topo/generate_scrip_cube.F90 @@ -147,6 +147,7 @@ program ESMF_GenerateCSGridDescription real(ESMF_KIND_R8) :: epsilon integer :: l real(ESMF_KIND_R8) :: global_max_area, global_min_area,ratio + real(ESMF_KIND_R8) :: area_sum_local, area_sum_global, area_err real(ESMF_KIND_R8), allocatable :: my_corner_lat(:,:), my_corner_lon(:,:) real(ESMF_KIND_R8), allocatable :: A_uniform(:) real(ESMF_KIND_R8) :: max_rrfac_allowed @@ -582,12 +583,13 @@ program ESMF_GenerateCSGridDescription p3(1) = modulo(p3(1), 2.0d0*pi) p4(1) = modulo(p4(1), 2.0d0*pi) - ! compute area - area_signed = get_signed_area_spherical_polygon(p1,p2,p3,p4) - if (area_signed <= 0.d0 .or. abs(area_signed) < 1.0d-12) then - area_signed = 1.0d-12 - end if - SCRIP_Area(n) = abs(area_signed) + ! compute positive spherical area using the same robust method + ! used by the regular-grid path + SCRIP_Area(n) = get_area_spherical_polygon(p1,p2,p3,p4) + + if (SCRIP_Area(n) /= SCRIP_Area(n) .or. SCRIP_Area(n) <= 0.0d0) then + SCRIP_Area(n) = 1.0d-12 + end if ! write fallback into SCRIP arrays SCRIP_CornerLon(:,n) = modulo([p1(1),p2(1),p3(1),p4(1)]*(180._8/pi),360.0_8) @@ -662,32 +664,46 @@ program ESMF_GenerateCSGridDescription ! 4) Reorder hull consistently -> p1,p2,p3,p4 call safe_reorder_hull(node_xy_tmp, hull, p1, p2, p3, p4, n, i, j) - area_signed = get_signed_area_spherical_polygon(p1, p2, p3, p4) - + ! Use signed-area routine only as an orientation test. + ! Do NOT use it as the final cell area for stretched grids. + area_signed = get_signed_area_spherical_polygon(p1, p2, p3, p4) + SCRIP_Area(n) = get_area_spherical_polygon(p1, p2, p3, p4) + ! If NaN/inf/tiny/huge area, rebuild a tiny CCW square and recompute - if (area_signed /= area_signed .or. abs(area_signed) < 1.0d-12 .or. abs(area_signed) > 1.0d10) then + if (area_signed /= area_signed .or. & + SCRIP_Area(n) /= SCRIP_Area(n) .or. & + SCRIP_Area(n) < 1.0d-12 .or. SCRIP_Area(n) > 1.0d10) then + clon = tmp_center_lons(i,j) clat = tmp_center_lats(i,j) tiny_dlon = 1.0d-4 * pi/180._8 tiny_dlat = 1.0d-4 * pi/180._8 + p1 = [modulo(clon-tiny_dlon,2*pi), clat-tiny_dlat] p2 = [modulo(clon+tiny_dlon,2*pi), clat-tiny_dlat] p3 = [modulo(clon+tiny_dlon,2*pi), clat+tiny_dlat] p4 = [modulo(clon-tiny_dlon,2*pi), clat+tiny_dlat] - area_signed = get_signed_area_spherical_polygon(p1, p2, p3, p4) + + area_signed = get_signed_area_spherical_polygon(p1, p2, p3, p4) + SCRIP_Area(n) = get_area_spherical_polygon(p1, p2, p3, p4) fallback_mask(n) = .true. end if - - ! Enforce CCW orientation for SCRIP (positive signed area) + + ! Enforce CCW orientation for SCRIP, preserving current stretched-grid convention. if (area_signed < 0.0d0) then swap_p = p2; p2 = p4; p4 = swap_p - area_signed = -area_signed endif - - ! Write CCW corners and POSITIVE area + + ! Write CCW corners and robust positive spherical area. SCRIP_CornerLon(:,n) = modulo([p1(1),p2(1),p3(1),p4(1)]*(180._8/pi), 360.0_8) SCRIP_CornerLat(:,n) = [p1(2),p2(2),p3(2),p4(2)]*(180._8/pi) - SCRIP_Area(n) = area_signed + + SCRIP_Area(n) = get_area_spherical_polygon(p1, p2, p3, p4) + + if (SCRIP_Area(n) /= SCRIP_Area(n) .or. SCRIP_Area(n) <= 0.0d0) then + SCRIP_Area(n) = 1.0d-12 + fallback_mask(n) = .true. + endif else ! ----- Regular grid path: enforce CLOCKWISE corners ----- @@ -772,6 +788,25 @@ program ESMF_GenerateCSGridDescription write(*,*) 'Finished per-cell geometry/length pass' call MPI_Barrier(mpiC, mpi_err) + !---------------- Global SCRIP area closure check ---------------- + area_sum_local = sum(SCRIP_Area(n_start:n_end)) + + call MPI_Allreduce(area_sum_local, area_sum_global, 1, MPI_DOUBLE_PRECISION, MPI_SUM, mpiC, mpi_err) + _VERIFY(mpi_err) + + area_err = abs(area_sum_global - 4.0d0*pi) + + if (localPet == 0) then + write(*,*) "SCRIP grid_area global sum:", area_sum_global + write(*,*) "Expected 4*pi:", 4.0d0*pi + write(*,*) "Absolute area error:", area_err + endif + + if (area_err > 1.0d-6) then + if (localPet == 0) write(*,*) "ERROR: SCRIP grid_area does not close to 4*pi" + ! call MPI_Abort(mpiC, 1, mpi_err) + endif + !---------------- Global min/max of per-cell length ---------------- local_max_length = maxval(local_max_length_all) local_min_length = minval(local_min_length_all) From f034083639ac14dbe6ef38dd9737b7f3df952d8f Mon Sep 17 00:00:00 2001 From: biljanaorescanin Date: Fri, 10 Jul 2026 11:42:31 -0400 Subject: [PATCH 31/40] fix comment --- .../preproc/topography/utils_topo/generate_scrip_cube.F90 | 5 ++--- 1 file changed, 2 insertions(+), 3 deletions(-) diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/preproc/topography/utils_topo/generate_scrip_cube.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/preproc/topography/utils_topo/generate_scrip_cube.F90 index c5a21d2d44..5a143a2e0d 100644 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/preproc/topography/utils_topo/generate_scrip_cube.F90 +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/preproc/topography/utils_topo/generate_scrip_cube.F90 @@ -583,8 +583,7 @@ program ESMF_GenerateCSGridDescription p3(1) = modulo(p3(1), 2.0d0*pi) p4(1) = modulo(p4(1), 2.0d0*pi) - ! compute positive spherical area using the same robust method - ! used by the regular-grid path + ! compute positive spherical area using the same method used by the regular-grid path SCRIP_Area(n) = get_area_spherical_polygon(p1,p2,p3,p4) if (SCRIP_Area(n) /= SCRIP_Area(n) .or. SCRIP_Area(n) <= 0.0d0) then @@ -804,7 +803,7 @@ program ESMF_GenerateCSGridDescription if (area_err > 1.0d-6) then if (localPet == 0) write(*,*) "ERROR: SCRIP grid_area does not close to 4*pi" - ! call MPI_Abort(mpiC, 1, mpi_err) + call MPI_Abort(mpiC, 1, mpi_err) endif !---------------- Global min/max of per-cell length ---------------- From 3e80bcd6ea530fe974c5dc87151b94cd561ccf4e Mon Sep 17 00:00:00 2001 From: biljanaorescanin Date: Fri, 10 Jul 2026 11:44:37 -0400 Subject: [PATCH 32/40] orig comment was less confusing --- .../preproc/topography/utils_topo/generate_scrip_cube.F90 | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/preproc/topography/utils_topo/generate_scrip_cube.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/preproc/topography/utils_topo/generate_scrip_cube.F90 index 5a143a2e0d..3292704109 100644 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/preproc/topography/utils_topo/generate_scrip_cube.F90 +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/preproc/topography/utils_topo/generate_scrip_cube.F90 @@ -693,7 +693,7 @@ program ESMF_GenerateCSGridDescription swap_p = p2; p2 = p4; p4 = swap_p endif - ! Write CCW corners and robust positive spherical area. + !Write CCW corners and POSITIVE area SCRIP_CornerLon(:,n) = modulo([p1(1),p2(1),p3(1),p4(1)]*(180._8/pi), 360.0_8) SCRIP_CornerLat(:,n) = [p1(2),p2(2),p3(2),p4(2)]*(180._8/pi) From 916398f28dbecca9538a86aa1a64469976e4fc1c Mon Sep 17 00:00:00 2001 From: Aaron Stubblefield <63247428+agstub@users.noreply.github.com> Date: Fri, 10 Jul 2026 13:40:38 -0400 Subject: [PATCH 33/40] Add ISSM ice sheet model GridComp to Landice (#1203) * placeholder issm gridcomp, directory, cmakelists * filling out basic gridcomp structure * add call to child in landice * update issm cmakelists, add comments * more comments * comments * comment out alot to try hello-world child * edit cmakelists * trying to fix cmakelists * shuffling cmakelists commands * comments * trying to rename issm gridcomp * correct gridcomp name * add mapl metacomp pointers * debugging child run call * comment * uncomment actual issm calls * comment fix * remove redundancy * comment out just the run issm call * also comment out issm finalize just in case * try printing vm info * trying to call issm initialize again * shuffles calls around * call get vm * call issm finalize * try gridcompcreate with issm mesh * comment a comment... * try gridcompset for issm mesh... * try to call issm run * see if adding vmbarrier fixes petsc error * try buffering number of elements * revert number of elements, remove sdim * trying to run from initialize just to see... * revert to correct run/initialize structure * trying calling mapl_genericinitialize before issm * print smb inputs, never give up * smb all zeros is good, print sizes to make sure... * try running again * fix issm rootdir * fix directory argv trunction * minor comments * remove vm print info * duplicate vm comm for issm use * child call according to run alarm * add barriers and deallocates * try mpi barrier * don't forget allocations * add suffix just in case * add intrinsics and comments * point to petsc debug version * remove intrinsics, threw syntax error * remove some comments * add ISSM alarm test * declare alarm * remove some printing and alarm_off call * change mesh coordsys to lat-lon, mv runchild call * minor comments * comment about lat/long * add mesh-to-agrid regridding * add locstream transform * replace mktile * fix typo * various comments and renaming * fix type error * fix type error * fix several types * fix fieldfill * add grid-to-mesh routehandle * fix assignment * add import states * format consistency * formatting consistency * some comments * add some smb variables * fix deallocate * add regrid for smb * allocate grid field * fix meshloc * fixed allocation issue-mostly working * update locstream transforms-working * add do_issm flag * specify issm expdir/input in rc file * add average,refresh intervals to smb import * add mesh save option * set initialize method to be consistent w/o issm * v11: Build ISSM based on detection of ISSM * set issm surface resource parameters, fix comment * add element IDs to mesh save * init changes * hide locstream and grid in internal state * create mesh_grid for output * add new issm expots to gridcomp * fix variable name typo * fix fielddestroy calls * initialize issm outputs to zero * rm whitespace * edit formatting * rename mesh file * name mesh file according to issm coniguration name * get issm exports in landice tile space * initial changes * fix interface arg * icesurf export on landice tile via internal state * fix deallocate error * subroutine for transform mesh to tile * allocates outside subroutine * Revert "allocates outside subroutine" This reverts commit 08f3b0c2f6947a088a383234ff121eff731a391a. * Revert "subroutine for transform mesh to tile" This reverts commit 67112db11789ad2f35566e8dd97f73743b081279. * add flow speed and thick exports * rm grid deallocates * Revert to 67112db, rm deallocate * subroutine calls for other exports * add deallocates * mv fielddestroys * subroutine for tile to mesh transform * rm redundant fielddestroys * add allocates * commentary * remove vm barriers * Revert "remove vm barriers" This reverts commit dc53ec92a3748f6f9cc40368ad1dabf5cd89ddfd. * keep necessary barriers * comments * Revert "keep necessary barriers" This reverts commit 649cf4cd7125b1d17ec9d7d7c7f826deb457582f. * remove stray barrier * comment * rename ice-equiv smb export * comment * add elementCoords for the output * convert unit to radiant * add internal state * fix mesh seam in antarctica * add ice thickness internal * add new exports and internals * initial node updates * update regridding routines with halo info * minor fixes * add nodeowners * fix typo * fix allocate omission * fix mask type * rename iceeqsmb for simplicity * comment * fix mask index * switch from logical mask to indices * fix typos * import icesmb by private state (fix alloc issue) * add icesmb to derived type * fix deallocates * fixed deallocates; everything works now * put grid variables in subroutine * set issm restarts from geos * update gridcomp description * set issm_expdir to scratch dir * remove elementConn from run and restart interface * comment and add allocate trues * add comment * delete whitespace * more comments * conditional compilation directives * try preprocess property * Revert "try preprocess property" This reverts commit f4b6ec19da32d33022fafebe88f2792ed26f72a1. * start preproc macros on first columns * preproc initial issm additions * minor issm preproc fixes * revamp preproc file names and generalize scripts * fix variable def * hardcode model names * organize data by glacier * add script completion msg * renamed issm bcs script * update issm bcs script output * add readme and protect against long domain names * edit readme * update readme * slurm-ify issm bcs script * update issm preproc readme * update issm preproc readme w filepath * clarify readme * update issm preproc readme with stored ouput * initial make bcs edit * mesh name round to nearest meter * preproc set resolution params from cmd line * delegate issm_mesh netcdf to preproc/issm * update preproc/issm readme * initial changes * fix types and subroutine call * fix types * working solution * remove unnecessary var * comments and formatting * rename nsteps variable * set up restart bootstrap * fix error codes * redo error codes * fix alarm ring check * fix declaration * persist exports and internals from start * issm_nsteps via tile internal state * minor fixes * minor fix and formatting * add issm core timer * comments and formatting * add issm conditional * add preprocessor directive * get landice timestep carefully * put landice_dt in tile state * update issm_env in preproc * edit readme and cp mesh file to directory * make optional command line arguments * fix h_min argument * update issm bcs example name * add comment reminder * redistribute restart arrays when needed (different ntasks) * fix alarm alignment, rs was off by one step * single precision zero-diff fix * clean up formatting * only modify landice in/ex if both have+run issm * fix export check * fix export ptr checks * update datasets read from shared directories --------- Co-authored-by: agstub Co-authored-by: Matthew Thompson Co-authored-by: Weiyuan Jiang Co-authored-by: Scott Rabenhorst <53346946+sdrabenh@users.noreply.github.com> Co-authored-by: Rolf Reichle <54944691+gmao-rreichle@users.noreply.github.com> --- .../GEOSlandice_GridComp/CMakeLists.txt | 40 +- .../GEOS_LandIceGridComp.F90 | 367 ++++- .../GEOSissm_GridComp/CMakeLists.txt | 9 + .../GEOSissm_GridComp/GEOS_ISSMGridComp.F90 | 1448 +++++++++++++++++ .../Shared/GEOS_SurfaceGridComp.rc | 12 + .../Utils/Raster/makebcs/make_bcs_shared.py | 10 +- .../Raster/preproc/issm/AIS/AIS_control.py | 63 + .../Raster/preproc/issm/AIS/AIS_finalize.py | 31 + .../Raster/preproc/issm/AIS/AIS_meshgen.py | 51 + .../preproc/issm/AIS/AIS_parameterize.py | 143 ++ .../Raster/preproc/issm/GRIS/GRIS_control.py | 68 + .../Raster/preproc/issm/GRIS/GRIS_finalize.py | 31 + .../Raster/preproc/issm/GRIS/GRIS_meshgen.py | 55 + .../preproc/issm/GRIS/GRIS_parameterize.py | 126 ++ .../Utils/Raster/preproc/issm/README.txt | 59 + .../Raster/preproc/issm/generate_issm_bcs.sh | 65 + .../Utils/Raster/preproc/issm/issm_env | 11 + .../preproc/issm/utils_issm/domain_name.py | 135 ++ .../preproc/issm/utils_issm/meshgenie.sh | 53 + 19 files changed, 2755 insertions(+), 22 deletions(-) create mode 100644 GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSlandice_GridComp/GEOSissm_GridComp/CMakeLists.txt create mode 100644 GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSlandice_GridComp/GEOSissm_GridComp/GEOS_ISSMGridComp.F90 create mode 100755 GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/preproc/issm/AIS/AIS_control.py create mode 100755 GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/preproc/issm/AIS/AIS_finalize.py create mode 100644 GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/preproc/issm/AIS/AIS_meshgen.py create mode 100755 GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/preproc/issm/AIS/AIS_parameterize.py create mode 100755 GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/preproc/issm/GRIS/GRIS_control.py create mode 100755 GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/preproc/issm/GRIS/GRIS_finalize.py create mode 100644 GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/preproc/issm/GRIS/GRIS_meshgen.py create mode 100755 GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/preproc/issm/GRIS/GRIS_parameterize.py create mode 100644 GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/preproc/issm/README.txt create mode 100755 GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/preproc/issm/generate_issm_bcs.sh create mode 100755 GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/preproc/issm/issm_env create mode 100644 GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/preproc/issm/utils_issm/domain_name.py create mode 100755 GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/preproc/issm/utils_issm/meshgenie.sh diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSlandice_GridComp/CMakeLists.txt b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSlandice_GridComp/CMakeLists.txt index 09ff7482ea..21f6c7f389 100644 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSlandice_GridComp/CMakeLists.txt +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSlandice_GridComp/CMakeLists.txt @@ -1,6 +1,40 @@ esma_set_this () +# First set alldirs to empty +set(alldirs) +# ... and srcs to the LandIceGridComp +set (srcs GEOS_LandIceGridComp.F90) + +# Then try to find ISSM +find_package (ISSM QUIET COMPONENTS Core) + +if(ISSM_FOUND) + # If ISSM is found, append the directory to alldirs + message(STATUS "ISSM found, building gridded component") + list (APPEND alldirs GEOSissm_GridComp) +else() + # If ISSM is not found, append the stub component to srcs + message(STATUS "ISSM not found, using stub component") + # For esma_create_stub_component, we need the name of the *module* + # that the landice gc is expecting, minus the mod. Also we + # have to use the variable srcs but not the ${srcs} because + # esma_create_stub_component is expecting the list itself, not the + # contents of the list. + esma_create_stub_component(srcs GEOS_IssmGridComp) +endif() + +# We have to do the above way because what esma_create_stub_component +# does is to append the stub component it creates in the build tree to a +# list of sources srcs. So if ISSM is found, we go into the subdir and +# build the real component, and if ISSM is not found, we create the stub +# component and append it to srcs. + esma_add_library (${this} - SRCS GEOS_LandIceGridComp.F90 - DEPENDENCIES MAPL GEOS_Shared GEOS_SurfaceShared ESMF::ESMF NetCDF::NetCDF_Fortran - ) + SRCS ${srcs} + SUBCOMPONENTS ${alldirs} + DEPENDENCIES MAPL GEOS_Shared GEOS_SurfaceShared ESMF::ESMF NetCDF::NetCDF_Fortran) + +if(ISSM_FOUND) + # If ISSM is found, add this definition + target_compile_definitions(${this} PRIVATE HAVE_ISSM) +endif() diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSlandice_GridComp/GEOS_LandIceGridComp.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSlandice_GridComp/GEOS_LandIceGridComp.F90 index c22870a006..290564cd1e 100644 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSlandice_GridComp/GEOS_LandIceGridComp.F90 +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSlandice_GridComp/GEOS_LandIceGridComp.F90 @@ -44,6 +44,12 @@ module GEOS_LandiceGridCompMod use GEOS_UtilsMod use DragCoefficientsMod +#ifdef HAVE_ISSM + use GEOS_IssmGridCompMod, only : IssmSetServices => SetServices + use GEOS_IssmGridCompMod, only : T_ISSM_TILE_STATE + use GEOS_IssmGridCompMod, only : ISSM_TILE_WRAP +#endif + implicit none private @@ -100,6 +106,8 @@ module GEOS_LandiceGridCompMod public SetServices + integer :: ISSM + ! !DESCRIPTION: ! ! {\tt GEOS\_Landice} is a light-weight gridded component that updates @@ -149,6 +157,7 @@ subroutine SetServices ( GC, RC ) type(MAPL_MetaComp), pointer :: MAPL + integer :: DO_ISSM ! ISSM flag ! Begin... @@ -159,20 +168,32 @@ subroutine SetServices ( GC, RC ) VERIFY_(STATUS) Iam = trim(COMP_NAME) // 'SetServices' -! Set the Run entry point -! ----------------------- - - call MAPL_GridCompSetEntryPoint ( GC, ESMF_METHOD_RUN, Run1, RC=STATUS ) - VERIFY_(STATUS) - call MAPL_GridCompSetEntryPoint ( GC, ESMF_METHOD_RUN, Run2, RC=STATUS ) - VERIFY_(STATUS) - -! Get my internal MAPL_Generic state + ! Get my internal MAPL_Generic state !----------------------------------- call MAPL_GetObjectFromGC ( GC, MAPL, RC=STATUS) VERIFY_(STATUS) +! Set the Run entry point +! ----------------------- + !add initialize method for child (ISSM) + call MAPL_GetResource (MAPL, DO_ISSM, label='DO_ISSM:', DEFAULT=0, __RC__ ) + +#ifndef HAVE_ISSM + DO_ISSM=0 +#endif + + call MAPL_GridCompSetEntryPoint ( GC, ESMF_METHOD_INITIALIZE, Initialize, RC=STATUS ) + VERIFY_(STATUS) + + + call MAPL_GridCompSetEntryPoint ( GC, ESMF_METHOD_RUN, Run1, RC=STATUS ) + VERIFY_(STATUS) + call MAPL_GridCompSetEntryPoint ( GC, ESMF_METHOD_RUN, Run2, RC=STATUS ) + VERIFY_(STATUS) + + ! Get resource parameters + ! ----------------------- call MAPL_GetResource (MAPL, SURFRC, label = 'SURFRC:', default = 'GEOS_SurfaceGridComp.rc', RC=STATUS) ; VERIFY_(STATUS) SCF = ESMF_ConfigCreate(rc=status) ; VERIFY_(STATUS) call ESMF_ConfigLoadFile(SCF,SURFRC,rc=status) ; VERIFY_(STATUS) @@ -188,6 +209,46 @@ subroutine SetServices ( GC, RC ) ! !Export state: + call MAPL_AddExportSpec(GC, & + SHORT_NAME = 'ICESMB', & + LONG_NAME = 'ice_surface_mass_balance', & + UNITS = 'kg m-2 s-1', & + DIMS = MAPL_DimsTileOnly, & + VLOCATION = MAPL_VLocationNone, & + RC=STATUS ) + VERIFY_(STATUS) + +#ifdef HAVE_ISSM + if (DO_ISSM==1) then + call MAPL_AddExportSpec(GC, & + SHORT_NAME = 'ICESURF', & + LONG_NAME = 'ice_surface_elevation', & + UNITS = 'm', & + DIMS = MAPL_DimsTileOnly, & + VLOCATION = MAPL_VLocationNone, & + RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddExportSpec(GC, & + SHORT_NAME = 'ICEVEL', & + LONG_NAME = 'ice_flow_speed', & + UNITS = 'm s-1', & + DIMS = MAPL_DimsTileOnly, & + VLOCATION = MAPL_VLocationNone, & + RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddExportSpec(GC, & + SHORT_NAME = 'ICETHICK', & + LONG_NAME = 'ice_thickness', & + UNITS = 'm', & + DIMS = MAPL_DimsTileOnly, & + VLOCATION = MAPL_VLocationNone, & + RC=STATUS ) + VERIFY_(STATUS) + end if +#endif + call MAPL_AddExportSpec(GC, & SHORT_NAME = 'EMIS', & LONG_NAME = 'surface_emissivity', & @@ -947,6 +1008,19 @@ subroutine SetServices ( GC, RC ) VERIFY_(STATUS) ! !Internal state: +#ifdef HAVE_ISSM + if (DO_ISSM==1) then + call MAPL_AddInternalSpec(GC, & + SHORT_NAME = 'ICESMB_ISSM', & + LONG_NAME = 'issm_surface_mass_balance', & + UNITS = 'kg m-2 s-1', & + DIMS = MAPL_DimsTileOnly, & + VLOCATION = MAPL_VLocationNone, & + RESTART = MAPL_RestartOptional, & + DEFAULT = 0.0 , & + RC=STATUS ) + end if +#endif call MAPL_AddInternalSpec(GC, & SHORT_NAME = 'TS', & @@ -1618,6 +1692,16 @@ subroutine SetServices ( GC, RC ) VERIFY_(STATUS) !EOS +#ifdef HAVE_ISSM + if (DO_ISSM==1) then + ! Add ISSM child gridcomp + ISSM = MAPL_AddChild(GC, NAME='ISSM', SS=IssmSetServices, RC=STATUS) + VERIFY_(STATUS) + + call MAPL_TerminateImport(GC, CHILD = ISSM, RC=STATUS) + VERIFY_(STATUS) + end if +#endif ! Set the Profiling timers ! ------------------------ @@ -1641,6 +1725,137 @@ end subroutine SetServices !BOP + + subroutine Initialize ( GC, IMPORT, EXPORT, CLOCK, RC ) + ! this is for ISSM to have access to to the tile locstream + + ! !ARGUMENTS: + + type(ESMF_GridComp), intent(inout) :: GC ! Gridded component + type(ESMF_State), intent(inout) :: IMPORT ! Import state + type(ESMF_State), intent(inout) :: EXPORT ! Export state + type(ESMF_Clock), intent(inout) :: CLOCK ! The clock + integer, optional, intent( out) :: RC ! Error code + + ! !DESCRIPTION: The Initialize method of the Landice Gridded Component. + + !EOP + + ! ErrLog Variables + + character(len=ESMF_MAXSTR) :: IAm + integer :: STATUS + character(len=ESMF_MAXSTR) :: COMP_NAME + + ! Local derived type aliases + + type (MAPL_MetaComp ), pointer :: MAPL + type (MAPL_MetaComp ), pointer :: CHILD_MAPL + type (MAPL_LocStream ) :: LOCSTREAM + type (ESMF_Config ) :: CF + type (ESMF_GridComp ), pointer :: GCS(:) + character(len=ESMF_MAXSTR), pointer :: gcnames(:) + + integer :: I +#ifdef HAVE_ISSM + type(T_ISSM_TILE_STATE), pointer :: issm_tile_state + type(ISSM_TILE_WRAP) :: issm_tile_wrap + real, pointer, dimension(:) :: ICESURF + real, pointer, dimension(:) :: ICETHICK + real, pointer, dimension(:) :: ICEVEL +#endif + integer :: nt_local + integer :: DO_ISSM + real :: LANDICE_DT + + !============================================================================= + + ! Begin... + + ! Get the target components name and set-up traceback handle. + ! ----------------------------------------------------------- + + call ESMF_GridCompGet ( GC, name=COMP_NAME, RC=STATUS ) + VERIFY_(STATUS) + Iam = trim(COMP_NAME) // "Initialize" + + ! Get my internal MAPL_Generic state + !----------------------------------- + + call MAPL_GetObjectFromGC ( GC, MAPL, RC=STATUS) + VERIFY_(STATUS) + + call MAPL_TimerOn(MAPL,"INITIALIZE", RC=STATUS ); VERIFY_(STATUS) + call MAPL_TimerOn(MAPL,"TOTAL", RC=STATUS ); VERIFY_(STATUS) + + ! Get the landice tilegrid and the child components + !----------------------------------------------- + + call MAPL_Get (MAPL, LOCSTREAM=LOCSTREAM, GCS=GCS, GCNAMES=gcnames, RC=STATUS ) + VERIFY_(STATUS) + call MAPL_LocStreamGet(locstream, NT_LOCAL=nt_local, rc=STATUS) + VERIFY_(STATUS) + ! Place the land tilegrid in the generic state of each child component + !--------------------------------------------------------------------- + + ! get model timestep, overwrite with component-specific timestep if found + call MAPL_GetResource (MAPL, LANDICE_DT, label='RUN_DT:',_RC) + call MAPL_GetResource (MAPL, LANDICE_DT, label='DT:',default=LANDICE_DT,_RC) + + ! get ISSM flag + call MAPL_GetResource (MAPL, DO_ISSM, label='DO_ISSM:', DEFAULT=0, __RC__ ) + +#ifndef HAVE_ISSM + DO_ISSM=0 +#endif + +#ifdef HAVE_ISSM + ! Get Landice timestep to send to ISSM + do I = 1, SIZE(GCS) + call MAPL_GetObjectFromGC( GCS(I), CHILD_MAPL, RC=STATUS ) + VERIFY_(STATUS) + call MAPL_Set(CHILD_MAPL, LOCSTREAM=LOCSTREAM, RC=STATUS ) + VERIFY_(STATUS) + if (index(gcnames(I), 'ISSM') /=0 ) then + ! allocate landice tilespace variables for ISSM + allocate(issm_tile_state) + allocate(issm_tile_state%ICESURF_TILE(nt_local)) + allocate(issm_tile_state%ICETHICK_TILE(nt_local)) + allocate(issm_tile_state%ICEVEL_TILE(nt_local)) + allocate(issm_tile_state%ICESMB_ISSM(nt_local)) + issm_tile_state%LANDICE_DT = LANDICE_DT + issm_tile_wrap%ptr => issm_tile_state + call ESMF_UserCompSetInternalState(GCS(I), 'ISSM_TILES', issm_tile_wrap, status) + VERIFY_(STATUS) + endif + end do +#endif + call MAPL_TimerOff(MAPL,"TOTAL", RC=STATUS ); VERIFY_(STATUS) + + ! Call Initialize for every Child + !-------------------------------- + call MAPL_GenericInitialize ( GC, IMPORT, EXPORT, CLOCK, RC=STATUS) + VERIFY_(STATUS) + +#ifdef HAVE_ISSM + if (DO_ISSM==1) then + ! initialize exports to restart values set by ISSM GridComp's Initialize, + ! because ISSM typically has a multi-day timestep and exports will remain empty otherwise + call MAPL_GetPointer(EXPORT,ICESURF , 'ICESURF',alloc=.true., RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT,ICETHICK ,'ICETHICK',alloc=.true., RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT,ICEVEL ,'ICEVEL',alloc=.true., RC=STATUS); VERIFY_(STATUS) + + if(associated(ICESURF)) ICESURF = issm_tile_state%ICESURF_TILE + if(associated(ICETHICK)) ICETHICK = issm_tile_state%ICETHICK_TILE + if(associated(ICEVEL)) ICEVEL = issm_tile_state%ICEVEL_TILE + end if +#endif + call MAPL_TimerOff(MAPL,"INITIALIZE", RC=STATUS ); VERIFY_(STATUS) + + RETURN_(ESMF_SUCCESS) + end subroutine Initialize + + ! !IROUTINE: RUN1 -- First Run stage for the LandIce component !INTERFACE: @@ -2135,6 +2350,9 @@ subroutine RUN2 ( GC, IMPORT, EXPORT, CLOCK, RC ) !EOP + type(MAPL_MetaComp), pointer :: CHILD_MAPL ! MAPL state for ISSM + type(ESMF_Alarm) :: ISSM_ALARM ! run alarm for ISSM component + ! ErrLog Variables @@ -2144,7 +2362,7 @@ subroutine RUN2 ( GC, IMPORT, EXPORT, CLOCK, RC ) ! Locals - type (MAPL_MetaComp), pointer :: MAPL + type (MAPL_MetaComp), pointer :: MAPL type (ESMF_State ) :: INTERNAL type (ESMF_Alarm ) :: ALARM type (ESMF_Config ) :: CF @@ -2155,6 +2373,14 @@ subroutine RUN2 ( GC, IMPORT, EXPORT, CLOCK, RC ) type(MAPL_SunOrbit) :: ORBIT integer :: LANDICE_OFFLINE + integer :: DO_ISSM ! ISSM run flag + + type (ESMF_GridComp ), pointer :: GCS(:) + character(len=ESMF_MAXSTR), pointer :: gcnames(:) +#ifdef HAVE_ISSM + type(T_ISSM_TILE_STATE), pointer :: issm_tile_state + type(ISSM_TILE_WRAP) :: issm_tile_wrap +#endif !============================================================================= ! Begin... @@ -2172,6 +2398,12 @@ subroutine RUN2 ( GC, IMPORT, EXPORT, CLOCK, RC ) call MAPL_GetObjectFromGC ( GC, MAPL, RC=STATUS) VERIFY_(STATUS) + call MAPL_GetResource (MAPL, DO_ISSM, label='DO_ISSM:', DEFAULT=0, __RC__ ) + +#ifndef HAVE_ISSM + DO_ISSM=0 +#endif + ! Start Total timer !------------------ @@ -2227,8 +2459,17 @@ subroutine LANDICECORE(RC) character(len=ESMF_MAXSTR) :: IAm integer :: STATUS -! pointers to export +! pointer to ISSM import via private internal state +! accumulate over time steps for averaging + real, pointer, dimension(:), save :: ICESMB_ISSM=>null() + integer, save :: ISSM_NSTEPS = 0 ! time steps since last ISSM run + +! pointers to export + real, pointer, dimension(: ) :: ICESMB + real, pointer, dimension(: ) :: ICESURF + real, pointer, dimension(: ) :: ICETHICK + real, pointer, dimension(: ) :: ICEVEL real, pointer, dimension(: ) :: EMISS real, pointer, dimension(: ) :: ALBVF real, pointer, dimension(: ) :: ALBVR @@ -2291,7 +2532,7 @@ subroutine LANDICECORE(RC) real, pointer, dimension(:) :: RMELTOC002 ! pointers to internal - + real, pointer, dimension(:) :: ICESMB_IN real, pointer, dimension(:,:) :: TS real, pointer, dimension(:,:) :: QS real, pointer, dimension(:,:) :: FR @@ -2516,7 +2757,11 @@ subroutine LANDICECORE(RC) ! Pointers to internals !---------------------- - +#ifdef HAVE_ISSM +if (DO_ISSM==1) then + call MAPL_GetPointer(INTERNAL,ICESMB_IN , 'ICESMB_ISSM',alloc=.true., RC=STATUS); VERIFY_(STATUS) +end if +#endif call MAPL_GetPointer(INTERNAL,TS , 'TS' , RC=STATUS); VERIFY_(STATUS) call MAPL_GetPointer(INTERNAL,QS , 'QS' , RC=STATUS); VERIFY_(STATUS) call MAPL_GetPointer(INTERNAL,FR , 'FR' , RC=STATUS); VERIFY_(STATUS) @@ -2542,7 +2787,15 @@ subroutine LANDICECORE(RC) ! Pointers to outputs !-------------------- - +#ifdef HAVE_ISSM +if (DO_ISSM==1) then + call MAPL_GetPointer(EXPORT,ICESURF , 'ICESURF',alloc=.true., RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT,ICETHICK ,'ICETHICK',alloc=.true., RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT,ICEVEL ,'ICEVEL',alloc=.true., RC=STATUS); VERIFY_(STATUS) +end if +#endif + + call MAPL_GetPointer(EXPORT,ICESMB , 'ICESMB',alloc=.true., RC=STATUS); VERIFY_(STATUS) call MAPL_GetPointer(EXPORT,EMISS , 'EMIS' , RC=STATUS); VERIFY_(STATUS) call MAPL_GetPointer(EXPORT,ALBVF , 'ALBVF' , RC=STATUS); VERIFY_(STATUS) call MAPL_GetPointer(EXPORT,ALBVR , 'ALBVR' , RC=STATUS); VERIFY_(STATUS) @@ -2552,7 +2805,7 @@ subroutine LANDICECORE(RC) call MAPL_GetPointer(EXPORT,DELQS , 'DELQS' , RC=STATUS); VERIFY_(STATUS) call MAPL_GetPointer(EXPORT,EVPICE , 'EVPICE_GL' , RC=STATUS); VERIFY_(STATUS) call MAPL_GetPointer(EXPORT,SUBLIM , 'SUBLIM' , RC=STATUS); VERIFY_(STATUS) - call MAPL_GetPointer(EXPORT,ACCUM , 'ACCUM' , RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT,ACCUM , 'ACCUM' , alloc=.true. , RC=STATUS); VERIFY_(STATUS) call MAPL_GetPointer(EXPORT,SMELT , 'SMELT' , RC=STATUS); VERIFY_(STATUS) call MAPL_GetPointer(EXPORT,IMELT , 'IMELT' , RC=STATUS); VERIFY_(STATUS) call MAPL_GetPointer(EXPORT,RAINRFZ, 'RAINRFZ', RC=STATUS); VERIFY_(STATUS) @@ -2561,7 +2814,7 @@ subroutine LANDICECORE(RC) call MAPL_GetPointer(EXPORT,MELTWTR, 'MELTWTR', RC=STATUS); VERIFY_(STATUS) call MAPL_GetPointer(EXPORT,MELTWTRCONT, 'MELTWTRCONT', RC=STATUS); VERIFY_(STATUS) call MAPL_GetPointer(EXPORT,LWC , 'LWC' , RC=STATUS); VERIFY_(STATUS) - call MAPL_GetPointer(EXPORT,RUNOFF , 'RUNOFF' , RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT,RUNOFF , 'RUNOFF' , alloc=.true. ,RC=STATUS); VERIFY_(STATUS) call MAPL_GetPointer(EXPORT,SNOMAS , 'SNOMAS_GL' , RC=STATUS); VERIFY_(STATUS) call MAPL_GetPointer(EXPORT,SNOWMASS,'SNOWMASS',RC=STATUS); VERIFY_(STATUS) call MAPL_GetPointer(EXPORT,SNOWDP , 'SNOWDP_GL' , RC=STATUS); VERIFY_(STATUS) @@ -2630,6 +2883,35 @@ subroutine LANDICECORE(RC) NT = size(ALW) + ! initialize running mean ICESMB and number of steps since last ISSM solve +#ifdef HAVE_ISSM + if(DO_ISSM==1) then + if (.not. associated(ICESMB_ISSM)) then + allocate(ICESMB_ISSM(NT),STAT=STATUS) + VERIFY_(STATUS) + + ! initialize from restart: + if (associated(ICESMB_IN)) then + ICESMB_ISSM(:) = ICESMB_IN(:) + else + ICESMB_ISSM(:) = 0 + end if + end if + + ! get number of timesteps from issm tile internal state + call MAPL_Get (MAPL, GCS=GCS, GCNAMES=GCNAMES, RC=STATUS ) + VERIFY_(STATUS) + do N=1, size(GCS) + if (index(GCNAMES(N), 'ISSM') /=0 ) then + call ESMF_UserCompGetInternalState(GCS(N), 'ISSM_TILES', issm_tile_wrap, status) + VERIFY_(STATUS) + issm_tile_state =>issm_tile_wrap%ptr + ISSM_NSTEPS = issm_tile_state%ISSM_NSTEPS + end if + end do + end if +#endif + allocate(MLT (NT), STAT=STATUS) VERIFY_(STATUS) allocate(DTS (NT), STAT=STATUS) @@ -3241,8 +3523,21 @@ subroutine LANDICECORE(RC) if(associated(ASNOW)) ASNOW = FR(:,SNOW) if(associated(SMELT )) SMELT = PERC if(associated(RAINRFZ )) RAINRFZ = FR(:,ICE) * RAINRF + if(associated(MELTWTR )) MELTWTR = MELTWTR + MLT + + ! Calculate surface mass balance (SMB) for ISSM + if(associated(ICESMB)) ICESMB = ACCUM - RUNOFF + + ! average ICESMB over time steps between ISSM runs + if(DO_ISSM==1) then + if(associated(ICESMB_ISSM)) ICESMB_ISSM = ICESMB_ISSM + (ICESMB-ICESMB_ISSM)/(ISSM_NSTEPS+1) + ISSM_NSTEPS = ISSM_NSTEPS + 1 ! accumulated timesteps since last ISSM run + + ! update internal state + ICESMB_IN(:) = ICESMB_ISSM(:) + end if ! Update snow and landice albedos to anticipate ! next radiation calculation !----------------------------------------------- @@ -3376,6 +3671,46 @@ subroutine LANDICECORE(RC) WEBOT = WESNBOT / DT end if +! Run ISSM +#ifdef HAVE_ISSM + if (DO_ISSM==1) then + call MAPL_Get (MAPL, GCS=GCS, GCNAMES=GCNAMES, RC=STATUS ) + do N=1, size(GCS) + if (index(GCNAMES(N), 'ISSM') /=0 ) then + call MAPL_GetObjectFromGC(GCS(N), CHILD_MAPL, RC=STATUS); VERIFY_(STATUS) + call MAPL_Get(CHILD_MAPL, RUNALARM = ISSM_ALARM, RC=STATUS); VERIFY_(STATUS) + + issm_tile_state%ICESMB_ISSM = ICESMB_ISSM + issm_tile_state%ISSM_NSTEPS = ISSM_NSTEPS + + ! call ISSM run method every time landice runs so that restarts will persist + ! ISSM Run method only calls the ISSM C++ solvers at ISSM_DT intervals + call MAPL_GenericRunChildren(GC, IMPORT, EXPORT, CLOCK, RC=STATUS) + VERIFY_(STATUS) + + if (ESMF_AlarmIsRinging (ISSM_ALARM, RC=STATUS)) then + ! if ISSM solvers were called, get exports on tile space + if(associated(ICESURF)) ICESURF = issm_tile_state%ICESURF_TILE + if(associated(ICETHICK)) ICETHICK = issm_tile_state%ICETHICK_TILE + if(associated(ICEVEL)) ICEVEL = issm_tile_state%ICEVEL_TILE + + ! refresh ICESMB accumulator + ISSM_NSTEPS = 0 ! set ISSM time step accumulation back to zero + ICESMB_ISSM(:) = 0 ! zero out ICESMB running average + + ! update private internal state + issm_tile_state%ICESMB_ISSM = ICESMB_ISSM + issm_tile_state%ISSM_NSTEPS = ISSM_NSTEPS + + ! update internal state for running-mean ICESMB + ICESMB_IN(:) = ICESMB_ISSM(:) + + end if + end if + end do + end if +#endif + if(allocated (MLT)) deallocate(MLT , STAT=STATUS); VERIFY_(STATUS) if(allocated (DTS)) deallocate(DTS , STAT=STATUS); VERIFY_(STATUS) if(allocated (DQS)) deallocate(DQS , STAT=STATUS); VERIFY_(STATUS) diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSlandice_GridComp/GEOSissm_GridComp/CMakeLists.txt b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSlandice_GridComp/GEOSissm_GridComp/CMakeLists.txt new file mode 100644 index 0000000000..b240dacfa3 --- /dev/null +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSlandice_GridComp/GEOSissm_GridComp/CMakeLists.txt @@ -0,0 +1,9 @@ +find_package (ISSM REQUIRED COMPONENTS Core) + +esma_set_this () + +esma_add_library (${this} + SRCS GEOS_ISSMGridComp.F90 + DEPENDENCIES MAPL GEOS_Shared GEOS_SurfaceShared ESMF::ESMF NetCDF::NetCDF_Fortran ISSM::Core + ) + diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSlandice_GridComp/GEOSissm_GridComp/GEOS_ISSMGridComp.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSlandice_GridComp/GEOSissm_GridComp/GEOS_ISSMGridComp.F90 new file mode 100644 index 0000000000..45dd9c023e --- /dev/null +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSlandice_GridComp/GEOSissm_GridComp/GEOS_ISSMGridComp.F90 @@ -0,0 +1,1448 @@ +! $Id$ + +#include "MAPL_Generic.h" + +module GEOS_IssmGridCompMod + +!BOP +! !MODULE: GEOS_ISSM --- Runs ISSM (Ice-sheet and Sea-level System Model) +! +! +! !DESCRIPTION: +! +! {\tt GEOS\_ISSM} runs ISSM (Ice-sheet and Sea-level System Model) +! Imports: ICESMB (defined on landice tiles) [via private internal state] +! Exports: ICESURF, ICETHICK, ICESMB_ISSM, ICEVX, ICEVY (defined on mesh) [true export state] +! Exports: ICESURF, ICETHICK, ICEVEL (defined on landice tiles) [via private internal state] +! Internals: ICESURF, ICETHICK, IMLS, OMLS, ISSM_NSTEPS (defined on mesh) [true internal state] +! *** NOTES: +! (*) currently we run over all input files (*.bin) that are found in ISSM_EXPDIR (scratch directory) +! (e.g., Greenland + Antarctica + any other glaciers that have been configured) +! (*) ISSM meshes are internal to ISSM (C++ source)--we create an ESMF_MESH version for regridding +! imports/exports that is the global combination of all ISSM meshes +! (*) we transform imports from landice tiles to attached grid, then regrid to the mesh +! (*) ISSM outputs are saved with HISTORY via a 'mesh tile space' developed by Weiyuan Jiang (GMAO SI Team) +! (*) ISSM time step is generally larger than LANDICE timestep, or even a job duration. We persist ISSM +! variables across job segments through internal state checkpoints (restarts). We make sure that INTERNAL +! and EXPORT variables are 'filled in' by Initialize so that LANDICE and HISTORY have access to ISSM +! variables before it runs. +! (*) Related, we use a custom ISSM run alarm that is keyed to the last time ISSM ran, not the simulation +! start time. The number of LANDICE time steps since ISSM last ran is tracked via the internal state. + +! !USES: +use iso_fortran_env, only: dp=>real64, sp=>real32 +use iso_c_binding, only: c_ptr, c_double, c_f_pointer, c_null_char, c_char, c_loc, c_int +use ESMF +use MAPL +use GEOS_UtilsMod + +implicit none + +! declare interface to the ISSM C++ library (arguments described in Initialize & Run below) +interface +subroutine InitializeISSM(expdir, num_elements, num_nodes, comm) bind(c, name="InitializeISSM") + import :: c_char, c_int + character(c_char), dimension(*) :: expdir + integer(c_int) :: num_elements + integer(c_int) :: num_nodes + integer(c_int) :: comm +end subroutine InitializeISSM + +subroutine RunISSM(ISSM_DT, gcm_forcings, issm_outputs) bind(C,NAME="RunISSM") + import :: c_ptr, c_double + real(c_double), value :: ISSM_DT + type(c_ptr), value :: gcm_forcings + type(c_ptr), value :: issm_outputs +end subroutine RunISSM + +subroutine InputFromRestarts(gcm_restarts) bind(C,NAME="InputFromRestarts") + import :: c_ptr + type(c_ptr), value :: gcm_restarts +end subroutine InputFromRestarts + +subroutine GetNodesISSM(nodeIds, nodeCoords) bind(C,NAME="GetNodesISSM") + import :: c_ptr + type(c_ptr), value :: nodeIds + type(c_ptr), value :: nodeCoords +end subroutine GetNodesISSM + +subroutine GetElementsISSM(elementIds, elementConn, elementCoords, glacIds) bind(C,NAME="GetElementsISSM") + import :: c_ptr + type(c_ptr), value :: elementIds + type(c_ptr), value :: elementConn + type(c_ptr), value :: elementCoords + type(c_ptr), value :: glacIds +end subroutine GetElementsISSM + +subroutine FinalizeISSM() bind(C,NAME="FinalizeISSM") +end subroutine FinalizeISSM + +end interface + +private + +public SetServices + +! some shared derived types and parameters below: + +public :: T_ISSM_TILE_STATE +public :: ISSM_TILE_WRAP +! define ISSM export as internal variables, will be used by the landice gridcomp + +type T_ISSM_TILE_STATE + real, pointer :: ICESURF_TILE(:) + real, pointer :: ICETHICK_TILE(:) + real, pointer :: ICEVEL_TILE(:) + real, pointer :: ICESMB_ISSM(:) + integer :: ISSM_NSTEPS + real :: LANDICE_DT +end type T_ISSM_TILE_STATE + +type ISSM_TILE_WRAP + type(T_ISSM_TILE_STATE), pointer :: ptr=>null() +end type ISSM_TILE_WRAP + +! private internal state for regridding +type T_ISSM_STATE + private + type(ESMF_RouteHandle) :: routehandle_m2g ! routehandle for regridding mesh to grid + type(ESMF_RouteHandle) :: routehandle_g2m ! routehandle for regridding grid to mesh + type(ESMF_RouteHandle) :: halohandle ! routehandle for field halos + integer, pointer,dimension(:) :: halo_idx ! indices of halo nodes in arrays + integer, pointer,dimension(:) :: owned_idx ! indices of owned nodes in arrays + integer, pointer,dimension(:) :: halolist ! list of halo nodeIds + type(ESMF_DistGrid) :: nodalDistgrid ! distgrid (owned nodes) + type(ESMF_GRID) :: grid ! original grid (atmosphere) + type(ESMF_MESH) :: mesh ! ISSM mesh + type(MAPL_LocStream) :: locstream ! original locstream (landice tiles) +end type T_ISSM_STATE + +! Wrapper for extracting internal state +! ------------------------------------- +type ISSM_WRAP + type (T_ISSM_STATE), pointer :: ptr +end type ISSM_WRAP + +integer :: num_outputs = 6 ! number of output fields that ISSM sends to GEOS +logical :: ISSM_RST_FOUND = .false. ! restart found flag +type(T_ISSM_STATE), pointer :: internal_state=>null() ! internal state for regridding and halo operations + +contains + + +!BOP + +! !IROUTINE: SetServices -- Sets ESMF services for this component + +! !INTERFACE: + +subroutine SetServices ( GC, RC ) + + ! !ARGUMENTS: + + type(ESMF_GridComp), intent(INOUT) :: GC ! gridded component + integer, optional :: RC ! return code + + ! !DESCRIPTION: +! This version uses the MAPL\_GenericSetServices Here we set the initialize method, +! run method, and finalize method because we are interfacing with the external ISSM +! library IRF methods. + +!EOP + +!============================================================================= + +! ErrLog Variables + + character(len=ESMF_MAXSTR) :: IAm + integer :: STATUS + character(len=ESMF_MAXSTR) :: COMP_NAME + +!============================================================================= + + type(MAPL_MetaComp), pointer :: MAPL + + ! Get my internal MAPL_Generic state + + ! Begin... + +! Get my name and set-up traceback handle +! --------------------------------------- + + call ESMF_GridCompGet( GC, NAME=COMP_NAME, _RC ) + Iam = trim(COMP_NAME) // 'SetServices' + +! Set the Initialize, Run, and Finalize entry points +!----------------------------------- + + call MAPL_GridCompSetEntryPoint ( GC, ESMF_METHOD_INITIALIZE, Initialize, _RC) + call MAPL_GridCompSetEntryPoint ( GC, ESMF_METHOD_RUN, Run, _RC) + call MAPL_GridCompSetEntryPoint ( GC, ESMF_METHOD_FINALIZE, Finalize, _RC) + +!----------------------------------- + + call MAPL_GetObjectFromGC (GC, MAPL, _RC) + +! Set the state variable specs. +!----------------------------------- + +! Import states: ICESMB is imported via the ISSM_TILE private internal state + +! Export states: + call MAPL_AddExportSpec(GC, & + SHORT_NAME = 'ICESURF', & + LONG_NAME = 'ice_sheet_elevation', & + UNITS = 'm', & + DIMS = MAPL_DimsTileOnly, & + VLOCATION = MAPL_VLocationNone, & + _RC ) + + call MAPL_AddExportSpec(GC, & + SHORT_NAME = 'ICEVX', & + LONG_NAME = 'ice_velocity_x_direction', & + UNITS = 'm s-1', & + DIMS = MAPL_DimsTileOnly, & + VLOCATION = MAPL_VLocationNone, & + _RC ) + + call MAPL_AddExportSpec(GC, & + SHORT_NAME = 'ICEVY', & + LONG_NAME = 'ice_velocity_y_direction', & + UNITS = 'm s-1', & + DIMS = MAPL_DimsTileOnly, & + VLOCATION = MAPL_VLocationNone, & + _RC ) + + call MAPL_AddExportSpec(GC, & + SHORT_NAME = 'ICETHICK', & + LONG_NAME = 'ice_thickness', & + UNITS = 'm', & + DIMS = MAPL_DimsTileOnly, & + VLOCATION = MAPL_VLocationNone, & + _RC ) + + call MAPL_AddExportSpec(GC, & + SHORT_NAME = 'ICESMB_ISSM', & + LONG_NAME = 'issm_surface_mass_balance', & + UNITS = 'kg m-2 s-1', & + DIMS = MAPL_DimsTileOnly, & + VLOCATION = MAPL_VLocationNone, & + _RC ) + + ! Internal states: + call MAPL_AddInternalSpec(GC, & + SHORT_NAME = 'ICESURF', & + LONG_NAME = 'ice_sheet_elevation', & + UNITS = 'm', & + DIMS = MAPL_DimsTileOnly, & + VLOCATION = MAPL_VLocationNone, & + RESTART = MAPL_RestartOptional, & + _RC ) + + call MAPL_AddInternalSpec(GC, & + SHORT_NAME = 'ICETHICK', & + LONG_NAME = 'ice_sheet_thickness', & + UNITS = 'm', & + DIMS = MAPL_DimsTileOnly, & + VLOCATION = MAPL_VLocationNone, & + RESTART = MAPL_RestartOptional, & + _RC ) + + call MAPL_AddInternalSpec(GC, & + SHORT_NAME = 'IMLS', & + LONG_NAME = 'ice_mask_levelset', & + UNITS = 'none', & + DIMS = MAPL_DimsTileOnly, & + VLOCATION = MAPL_VLocationNone, & + RESTART = MAPL_RestartOptional, & + _RC ) + + call MAPL_AddInternalSpec(GC, & + SHORT_NAME = 'OMLS', & + LONG_NAME = 'ocean_mask_levelset', & + UNITS = 'none', & + DIMS = MAPL_DimsTileOnly, & + VLOCATION = MAPL_VLocationNone, & + RESTART = MAPL_RestartOptional, & + _RC ) + + call MAPL_AddInternalSpec(GC, & + SHORT_NAME = 'ICEVX', & + LONG_NAME = 'ice_velocity_x_direction', & + UNITS = 'm s-1', & + DIMS = MAPL_DimsTileOnly, & + VLOCATION = MAPL_VLocationNone, & + RESTART = MAPL_RestartOptional, & + _RC ) + + call MAPL_AddInternalSpec(GC, & + SHORT_NAME = 'ICEVY', & + LONG_NAME = 'ice_velocity_y_direction', & + UNITS = 'm s-1', & + DIMS = MAPL_DimsTileOnly, & + VLOCATION = MAPL_VLocationNone, & + RESTART = MAPL_RestartOptional, & + _RC ) + + call MAPL_AddInternalSpec(GC, & + SHORT_NAME = 'ISSM_NSTEPS', & + LONG_NAME = 'steps_since_last_issm', & + UNITS = 'none', & + DIMS = MAPL_DimsTileOnly, & + VLOCATION = MAPL_VLocationNone, & + RESTART = MAPL_RestartOptional, & + _RC ) + call MAPL_AddInternalSpec(GC, & + SHORT_NAME = 'RS_NODEIDS', & + LONG_NAME = 'restart_node_ids', & + UNITS = 'none', & + DIMS = MAPL_DimsTileOnly, & + VLOCATION = MAPL_VLocationNone, & + RESTART = MAPL_RestartOptional, & + _RC ) + + +! Set the Profiling timers +! ------------------------ + + call MAPL_TimerAdd(GC, name="RUN" ,_RC) + call MAPL_TimerAdd(GC, name="ISSMCore" ,_RC) + + +! ---------------------------------- + call MAPL_GenericSetServices ( GC, _RC) + + _RETURN(_SUCCESS) + + end subroutine SetServices + + ! ! INITIALIZE: + + subroutine Initialize ( GC, IMPORT, EXPORT, CLOCK, RC ) + type(ESMF_GridComp), intent(INOUT) :: GC ! Gridded component + type(ESMF_State), intent(INOUT) :: IMPORT ! Import state + type(ESMF_State), intent(INOUT) :: EXPORT ! Export state + type(ESMF_Clock), intent(INOUT) :: CLOCK ! The clock + integer, optional, intent(OUT) :: RC ! Error code + + type(MAPL_MetaComp), pointer :: MAPL + type(ESMF_State) :: INTERNAL ! internal state + + ! ISSM alarm variables + type(ESMF_Alarm) :: ISSM_ALARM ! custom ISSM RUNALARM + integer :: sec_to_ring ! seconds remaining until first ISSM run + type(ESMF_Time) :: startTime ! initial time + type(ESMF_TimeInterval) :: startInterval ! time interval to first ring + type(ESMF_Time) :: ringTime ! time of first ring + type(ESMF_TimeInterval) :: ringInterval ! ring time interval (ISSM_DT) + real :: ISSM_DT ! ISSM time step [s] (ISSM_DT set in AGCM.rc) + real :: LANDICE_DT ! landice time step [s] + integer :: NSTEPS_INIT ! landice timesteps since last ISSM run + integer :: NSTEPS_RING ! total landice timesteps between ISSM runs + real, pointer, dimension(:) :: ISSM_NSTEPS => null() ! steps since last ISSM run (from internal state) + + ! ErrLog Variables + character(len=ESMF_MAXSTR) :: IAm + integer :: STATUS + character(len=ESMF_MAXSTR) :: COMP_NAME + + ! virtual machine / mpi comm + type(ESMF_VM) :: vm + integer(c_int) :: comm ! mpi comm to pass to ISSM + integer :: localPET ! ~mpi rank + + ! mesh information + type(ESMF_Mesh) :: mesh ! ESMF_Mesh representation of ISSM mesh + integer, pointer, dimension(:) :: elementTypes => null() ! element geometry type (triangles) + integer(c_int) :: num_elements ! number of elements on PET + integer(c_int) :: num_nodes ! number of nodes on PET + integer(c_int) :: num_owned_nodes ! number of nodes owned by this PET (<=num_nodes) + integer, pointer, dimension(:) :: elementIds => null() ! list of elements local to PET + integer, pointer, dimension(:) :: elementConn => null() ! element connectivity (nodes indices) + real(dp),pointer, dimension(:) :: elementCoords => null() ! element centroids + real(dp),pointer,dimension(:) :: nodeCoords => null() ! node coordinates (longitude,latitude) + integer, pointer, dimension(:) :: nodeIds => null() ! Global IDs of nodes local to PET + integer, pointer, dimension(:) :: nodeOwners => null() ! Specify which PET owns each node + integer, pointer, dimension(:) :: glacIds => null() ! glacier ID for each element + + ! regridding varibales + type(ESMF_Grid) :: grid ! atmospheric grid + type(ESMF_RouteHandle) :: routehandle_m2g ! routehandle for regridding mesh to grid + type(ESMF_RouteHandle) :: routehandle_g2m ! routehandle for regridding grid to mesh + type(ESMF_Field) :: meshField ! field on mesh + type(ESMF_Field) :: gridField ! field on grid + type(ISSM_WRAP) :: wrap ! wrapper for internal state + + ! tile information + integer :: NT ! local number of landice tiles + type(T_ISSM_TILE_STATE), pointer :: issm_tile_state + type(ISSM_TILE_WRAP) :: issm_tile_wrap + + ! field halo variables + integer :: num_halo_nodes ! num_nodes minus num_owned_nodes + type(ESMF_RouteHandle) :: halohandle ! routehandle for field halos + integer, pointer, dimension(:) :: halolist => null() ! list of halo nodeIds + integer, pointer, dimension(:) :: ownedNodeIds => null() ! nodeIds excluding halolist + type(ESMF_DistGrid) :: nodalDistgrid ! distgrid (owned nodes) + type(ESMF_Array) :: meshArray ! array for creating mesh fields + integer, pointer,dimension(:) :: halo_idx => null() ! indices of halo nodes in arrays + integer, pointer,dimension(:) :: owned_idx => null() ! indices of owned nodes in arrays + + ! owned node coordinates (longitude,latitude) + real(dp),pointer,dimension(:) :: ownedNodeCoords => null() + real, allocatable, dimension(:) :: ownedNodeLons, ownedNodeLats + + ! command-line arguments to initialize ISSM + integer :: i,j,k ! loop indices + character(len=ESMF_MAXSTR) :: ISSM_EXPDIR ! directory containing ISSM input files + character(len=ESMF_MAXSTR) :: EXPDIR ! C++ compatible ISSM_EXPDIR string + + ! variables for creating mesh tile space + type(ESMF_Grid) :: mesh_grid + type(MAPL_LocStream) :: mesh_locstream + + ! variables for masking the mesh seam (triangles that cross +/-180 longitude) + ! (needed for elements, this is not currently needed for regridding fields defined on nodes) + real(dp) :: dlon,lon1,lon2,lon3 + integer, pointer, dimension(:) :: elementMask => null() + integer :: n1,n2,n3 + + ! pointers to internal state for restarts + real, pointer, dimension(:) :: ICESURF_IN => null() ! ice surface elevation restart + real, pointer, dimension(:) :: ICETHICK_IN => null() ! ice thickness restart + real, pointer, dimension(:) :: ICEVX_IN => null() ! ice velocity (x direction) restart + real, pointer, dimension(:) :: ICEVY_IN => null() ! ice velocity (y direction) restart + real, pointer, dimension(:) :: IMLS_IN => null() ! ice-mask levelset restart + real, pointer, dimension(:) :: OMLS_IN => null() ! ocean-mask levelset restart + + ! restarts with halo points (interleaved), to send to ISSM + real(dp), pointer, dimension(:) :: ICESURF_HALO => null() + real(dp), pointer, dimension(:) :: ICETHICK_HALO => null() + real(dp), pointer, dimension(:) :: IMLS_HALO => null() + real(dp), pointer, dimension(:) :: OMLS_HALO => null() + real(dp), pointer, dimension(:) :: ICEVX_HALO => null() + real(dp), pointer, dimension(:) :: ICEVY_HALO => null() + real(dp), pointer, dimension(:) :: ICEVEL_HALO => null() + + real(dp), pointer, dimension(:) :: GEOS_RESTARTS => null() ! concatenate restart fields + real(dp), pointer, dimension(:) :: ZEROS => null() ! zero input for bootstrapping + + ! export variables on landice tile space + real, pointer, dimension(:) :: ICESURF_TILE => null() ! ice surface elevation on landice tiles + real, pointer, dimension(:) :: ICETHICK_TILE => null() ! ice thickness on landice tiles + real, pointer, dimension(:) :: ICEVEL_TILE => null() ! ice flow speed on landice tiles + + ! export variables on mesh tile space + real, pointer, dimension(:) :: ICESURF_EX => null() ! ice surface elevation on mesh tiles + real, pointer, dimension(:) :: ICETHICK_EX => null() ! ice thickness on mesh tiles + real, pointer, dimension(:) :: ICEVX_EX => null() ! ice velocity (x direction) on mesh tiles + real, pointer, dimension(:) :: ICEVY_EX => null() ! ice velocity (y direction) on mesh tiles + + ! restart redistribution + real, pointer, dimension(:) :: restartNodeIds=> null() ! nodeIds for restart ordering + type(ESMF_DistGrid) :: restartDistgrid ! distgrid from reading restarts + logical :: distgrid_match ! check if distgrid from restarts matches nodal disgrid (locally) + logical :: needRedist ! global check for consistent distgrid across all processes + integer,allocatable,dimension(:) :: localFlag, globalFlag ! arrays for vm operations + type(ESMF_Array) :: restartArray ! array corresponding to restartDistgrid + type(ESMF_Array) :: nodalArray ! array corresponding to nodalDistgrid + type(ESMF_RouteHandle) :: redisthandle ! routehandle for redistribution + + + ! Get the target components name and set-up traceback handle. + ! ----------------------------------------------------------- + + Iam = "Initialize" + call ESMF_GridCompGet( GC, NAME=COMP_NAME, _RC ) + + Iam = trim(COMP_NAME) // trim(Iam) + + ! Get my internal MAPL_Generic state + !----------------------------------- + + call MAPL_GetObjectFromGC ( GC, MAPL, _RC) + + call ESMF_VMGetCurrent(vm, _RC) + + call ESMF_VMGet(vm,mpiCommunicator=comm,localPet=localPET,_RC) + + ! **************************************************** + ! call ISSM initialize C++ code so we can set up mesh + + ! get directory with ISSM binary input files (can modify if needed) + call GET_ENVIRONMENT_VARIABLE("SCRDIR",ISSM_EXPDIR,STATUS=STATUS); _VERIFY(STATUS) + + EXPDIR = trim(ISSM_EXPDIR)//"/"//c_null_char ! create string for C++ + + ! Call the C++ function for initializing ISSM + ! gets the number of elements and nodes of the mesh + call InitializeISSM(EXPDIR, num_elements, num_nodes, comm) + + !allocate mesh-related pointers + allocate(nodeCoords(2*num_nodes)) + allocate(nodeIds(num_nodes)) + allocate(elementTypes(num_elements)) + allocate(elementIds(num_elements)) + allocate(glacIds(num_elements)) + allocate(elementConn(3*num_elements)) + allocate(elementCoords(2*num_elements)) + allocate(elementMask(num_elements)) + allocate(nodeOwners(num_nodes)) + + ! get information about nodes and elements + ! node coords and element coords (centroids) are in (lon,lat) + call GetNodesISSM(c_loc(nodeIds), c_loc(nodeCoords)) + call GetElementsISSM(c_loc(elementIds), c_loc(elementConn), c_loc(elementCoords),c_loc(glacIds)) + + elementTypes(:) = ESMF_MESHELEMTYPE_TRI ! triangular elements + + ! mask for triangles that cross the seam (longitude +/- 180) + ! (you don't have to 'activate' this mask, it can just be 'associated' with the mesh) + ! + ! NOTE: This is only relevant in regridding when fields are defined + ! on ESMF_MESHLOC_ELEMENT (rather than ESMF_MESHLOC_NODE) + ! so is NOT CURRENTLY USED, but retained for possible future developments + elementMask(:) = 0 + do j=1,num_elements + n1 = elementConn(3*(j-1)+1) + n2 = elementConn(3*(j-1)+2) + n3 = elementConn(3*(j-1)+3) + lon1 = nodeCoords(2*n1-1) + lon2 = nodeCoords(2*n2-1) + lon3 = nodeCoords(2*n3-1) + dlon = maxval((/lon1,lon2,lon3/)) - minval((/lon1,lon2,lon3/)) + if ( dlon>180.0 ) then + elementMask(j) = 1 + end if + end do + + ! create the ESMF mesh from ISSM mesh properties + mesh = ESMF_MeshCreate(parametricDim=2, spatialDim=2, nodeIds=nodeIds, nodeCoords=nodeCoords, & + elementIds=elementIds, elementTypes=elementTypes, elementConn=elementConn,elementMask=elementMask,& + elementCoords=elementCoords,coordSys=ESMF_COORDSYS_SPH_DEG, _RC) + + ! associate ESMF_Mesh representation of ISSM mesh with GC for regridding imports/exports in Run method + call ESMF_GridCompSet(GC,mesh=mesh,_RC) + + ! set up field halos + !----------------------------------- + call ESMF_MeshGet(mesh=mesh,nodeOwners=nodeOwners,numOwnedNodes=num_owned_nodes,nodalDistgrid=nodalDistgrid) + + num_halo_nodes = num_nodes - num_owned_nodes + allocate(halolist(num_halo_nodes)) + allocate(ownedNodeCoords(2*num_owned_nodes)) + allocate(ownedNodeIds(num_owned_nodes)) + allocate(halo_idx(num_halo_nodes)) + allocate(owned_idx(num_owned_nodes)) + + call ESMF_MeshGet(mesh=mesh,ownedNodeCoords=ownedNodeCoords) + + ! get list of (global) nodeIds that are halos on this PET + ! and create a mask to remove these values from arrays + i=1; k=1 + do j=1,num_nodes + if (nodeOwners(j)/= localPET) then + halolist(i) = nodeIds(j) + halo_idx(i) = j + i = i+1 + else + ownedNodeIds(k) = nodeIds(j) + owned_idx(k) = j + k = k+1 + end if + end do + + ! create array with halo information + meshArray=ESMF_ArrayCreate(nodalDistgrid,typekind=ESMF_TYPEKIND_R8,haloSeqIndexList=halolist,_RC) + + ! create field on ISSM mesh + meshField=ESMF_FieldCreate(mesh, array=meshArray, meshLoc=ESMF_MESHLOC_NODE, _RC) + + ! store the halo operation in a routehandle + call ESMF_FieldHaloStore(meshField, routehandle=halohandle, _RC) + + ! Set up regridding next + !----------------------------------- + ! get atmospheric (attached) grid + call ESMF_GridCompGet( GC, GRID=grid, _RC ) + + ! create field on atmospheric grid + gridField = ESMF_FieldCreate(grid=grid,typekind=ESMF_TYPEKIND_R4,_RC) + + ! create routehandle for mesh-to-grid regridding (set srcMaskValues to 1 if needed... ) + call ESMF_FieldRegridStore(srcField=meshField, dstField=gridField,routehandle=routehandle_m2g,& + unmappedaction=ESMF_UNMAPPEDACTION_IGNORE,extrapmethod=ESMF_EXTRAPMETHOD_CREEP,& + extrapNumLevels=1,_RC) + + ! create routehandle for grid-to-mesh regridding (set dstMaskValues to 1 if needed... ) + call ESMF_FieldRegridStore(srcField=gridField, dstField=meshField,routehandle=routehandle_g2m,& + unmappedaction=ESMF_UNMAPPEDACTION_IGNORE,extrapmethod=ESMF_EXTRAPMETHOD_NEAREST_D,_RC) + + ! create component's private internal state + ! stores everything needed for regrid and halo operations during run method + allocate(internal_state, stat=STATUS); _VERIFY(STATUS) + + allocate(internal_state%halo_idx(num_halo_nodes)) + allocate(internal_state%owned_idx(num_owned_nodes)) + allocate(internal_state%halolist(num_halo_nodes)) + internal_state%routehandle_m2g = routehandle_m2g + internal_state%routehandle_g2m = routehandle_g2m + internal_state%halohandle = halohandle + internal_state%halo_idx = halo_idx + internal_state%owned_idx = owned_idx + internal_state%grid = grid + internal_state%mesh = mesh + internal_state%halolist = halolist + internal_state%nodalDistgrid = nodalDistgrid + call MAPL_Get(MAPL, LocStream = internal_state%locstream, _RC) + + ! wrap the private internal state + wrap%ptr => internal_state + call ESMF_UserCompSetInternalState ( GC, 'ISSM_WRAP', wrap, STATUS ); _VERIFY(STATUS) + + ! Create losctream that match mesh element id, then set it to this GC and MAPL + ! note: original attached/atmospheric grid and landice tile locstream have + ! been stored in the internal state + allocate(ownedNodeLons(num_owned_nodes)) + allocate(ownedNodeLats(num_owned_nodes)) + ownedNodeLons = ownedNodeCoords(1::2)*MAPL_DEGREES_TO_RADIANS + ownedNodeLats = ownedNodeCoords(2::2)*MAPL_DEGREES_TO_RADIANS + + mesh_grid = create_mesh_grid(_RC) + call MAPL_LocstreamCreate(mesh_locstream, mesh_grid, local_id=ownedNodeIds, & + tilelons=ownedNodeLons, tilelats=ownedNodeLats, _RC) + call MAPL%grid%set(mesh_grid, _RC) + call ESMF_GridCompSet(gc, grid=mesh_grid, _RC) + call MAPL_Set(MAPL, locstream = mesh_locstream, _RC) + + ! Generic initialize + !----------------------------------- + + call MAPL_GenericInitialize( GC, IMPORT, EXPORT, CLOCK, _RC ) + + ! Get private internal state for sending information to/from LANDICE + !----------------------------------- + + call ESMF_UserCompGetInternalState(GC, 'ISSM_TILES', issm_tile_wrap, status); _VERIFY(STATUS) + issm_tile_state => issm_tile_wrap%ptr + + ! Create Custom ISSM Run Alarm + !----------------------------------- + + ! get internal state + call MAPL_Get(MAPL,INTERNAL_ESMF_STATE = INTERNAL,_RC) + + ! get number of time steps since last ISSM run + call MAPL_GetPointer(INTERNAL, ISSM_NSTEPS, 'ISSM_NSTEPS',_RC) + NSTEPS_INIT = nint(maxval(ISSM_NSTEPS)) + + ! get timestep for landice + LANDICE_DT = issm_tile_state%LANDICE_DT + + ! get timestep for ISSM + call MAPL_GetResource(MAPL, ISSM_DT, Label=trim(COMP_NAME)//"_DT:",DEFAULT=302400.0, _RC) + + ! total landice time steps between ISSM runs + NSTEPS_RING = nint(ISSM_DT/LANDICE_DT) + + ! calculate initial ring time from initial time and remaining timesteps + call ESMF_ClockGet(CLOCK,currTime=startTime) + sec_to_ring = (NSTEPS_RING-NSTEPS_INIT-1)*nint(LANDICE_DT) + call ESMF_TimeIntervalSet(startInterval,s = sec_to_ring ) + ringTime = startTime + startInterval + + ! set ring interval to ISSM time step + call ESMF_TimeIntervalSet(ringInterval,s=nint(ISSM_DT),_RC) + + ! create new ISSM_ALARM + ISSM_ALARM = ESMF_AlarmCreate(CLOCK,ringTime=ringTime,ringInterval=ringInterval,sticky=.false.,_RC) + + ! set run alarm + call MAPL_Set(MAPL, RUNALARM = ISSM_ALARM, _RC) + + ! Next, send GEOS restarts to ISSM + !----------------------------------- + ! array holding all restarts to send to/from ISSM + allocate(GEOS_RESTARTS(num_outputs*num_nodes)) + allocate(ICESURF_HALO(num_nodes)) + allocate(ICETHICK_HALO(num_nodes)) + allocate(ICEVX_HALO(num_nodes)) + allocate(ICEVY_HALO(num_nodes)) + allocate(ICEVEL_HALO(num_nodes)) + allocate(IMLS_HALO(num_nodes)) + allocate(OMLS_HALO(num_nodes)) + allocate(ZEROS(num_nodes)) + + ! get pointers to restarts + call MAPL_GetPointer(INTERNAL, ICESURF_IN, 'ICESURF', _RC) + call MAPL_GetPointer(INTERNAL, ICETHICK_IN, 'ICETHICK',_RC) + call MAPL_GetPointer(INTERNAL, ICEVX_IN, 'ICEVX',_RC) + call MAPL_GetPointer(INTERNAL, ICEVY_IN, 'ICEVY',_RC) + call MAPL_GetPointer(INTERNAL, IMLS_IN, 'IMLS', _RC) + call MAPL_GetPointer(INTERNAL, OMLS_IN, 'OMLS',_RC) + call MAPL_GetPointer(INTERNAL, restartNodeIds, 'RS_NODEIDS',_RC) + + ! if restart has been read, apply halo operation and send pointers to ISSM + ! else, ISSM will just use default initial values in ISSM*.bin input files + if (associated(ICETHICK_IN)) then + ! simple check for positive ice thickness (initialized to zero if restart not found) + ! ISSM throws error for zero ice thickness + ISSM_RST_FOUND = minval(ICETHICK_IN) > epsilon(ICETHICK_IN) + end if + + if (ISSM_RST_FOUND) then + ! check if the nodal distgrid created above matches the distgrid read from the restart + ! it will only be different if running over a different number of processes than when + ! the restart was written. if it is, we redistribute the restart arrays correctly + allocate(localFlag(1)) + allocate(globalFlag(1)) + distgrid_match = all(ownedNodeIds==nint(restartNodeIds)) + localFlag(1) = 0 + if (distgrid_match) localFlag(1) = 1 + call ESMF_VMAllReduce(vm, sendData=localFlag, recvData=globalFlag, count=1, reduceflag=ESMF_REDUCE_MIN, _RC) + needRedist = (globalFlag(1) == 0) + + if (needRedist) then + ! create routehandle for redistribution, and redistribute all restarts from the + ! restart distgrid to the current distgrid (nodalDistgrid) + restartDistgrid = ESMF_DistGridCreate(arbSeqIndexList=nint(restartNodeIds), _RC) + restartArray=ESMF_ArrayCreate(distgrid=restartDistgrid,typekind=ESMF_TYPEKIND_R4,_RC) + nodalArray=ESMF_ArrayCreate(distgrid=nodalDistgrid,typekind=ESMF_TYPEKIND_R4,_RC) + call ESMF_ArrayRedistStore(srcArray=restartArray, dstArray=nodalArray, routehandle=redisthandle,_RC) + + call apply_redist(ICESURF_IN,_RC) + call apply_redist(ICETHICK_IN,_RC) + call apply_redist(ICEVX_IN,_RC) + call apply_redist(ICEVY_IN,_RC) + call apply_redist(IMLS_IN,_RC) + call apply_redist(OMLS_IN,_RC) + + call ESMF_VMBarrier(vm, _RC) + + call ESMF_ArrayDestroy(restartArray, _RC) + call ESMF_ArrayDestroy(nodalArray, _RC) + + end if + + ! apply halo operation to all restart variables + call apply_halo(ICESURF_IN,ICESURF_HALO,_RC) + call apply_halo(ICETHICK_IN,ICETHICK_HALO,_RC) + call apply_halo(ICEVX_IN,ICEVX_HALO,_RC) + call apply_halo(ICEVY_IN,ICEVY_HALO,_RC) + call apply_halo(IMLS_IN,IMLS_HALO,_RC) + call apply_halo(OMLS_IN,OMLS_HALO,_RC) + + ! package restarts into one pointer + GEOS_RESTARTS(:) = 0.0_dp + GEOS_RESTARTS(1:num_nodes) = ICESURF_HALO(:) + GEOS_RESTARTS(num_nodes+1:2*num_nodes) = ICETHICK_HALO(:) + GEOS_RESTARTS(2*num_nodes+1:3*num_nodes) = ICEVX_HALO(:) + GEOS_RESTARTS(3*num_nodes+1:4*num_nodes) = ICEVY_HALO(:) + GEOS_RESTARTS(4*num_nodes+1:5*num_nodes) = OMLS_HALO(:) + GEOS_RESTARTS(5*num_nodes+1:6*num_nodes) = IMLS_HALO(:) + + ! set restarts on the ISSM side + call ESMF_VMBarrier(vm, _RC) + call InputFromRestarts(c_loc(GEOS_RESTARTS)) + call ESMF_VMBarrier(vm, _RC) + + else + ! bootstrap restart values from ISSM input files (ISSM*.bin) + ! by running with 'fake' time step with zero forcing + + call ESMF_VMBarrier(vm, _RC) + call RunISSM(real(ISSM_DT,kind=dp), c_loc(ZEROS), c_loc(GEOS_RESTARTS)) + call ESMF_VMBarrier(vm, _RC) + + ! Unpack restart array + ICESURF_HALO(:) = GEOS_RESTARTS(1:num_nodes) + ICETHICK_HALO(:) = GEOS_RESTARTS(num_nodes+1:2*num_nodes) + ICEVX_HALO(:) = GEOS_RESTARTS(2*num_nodes+1:3*num_nodes) + ICEVY_HALO(:) = GEOS_RESTARTS(3*num_nodes+1:4*num_nodes) + OMLS_HALO(:) = GEOS_RESTARTS(4*num_nodes+1:5*num_nodes) + IMLS_HALO(:) = GEOS_RESTARTS(5*num_nodes+1:6*num_nodes) + + ! filter out halo points (keep the owned indices) for restarts + if(associated(ICESURF_IN)) ICESURF_IN = ICESURF_HALO(owned_idx) + if(associated(ICETHICK_IN)) ICETHICK_IN = ICETHICK_HALO(owned_idx) + if(associated(ICEVX_IN)) ICEVX_IN = ICEVX_HALO(owned_idx) + if(associated(ICEVY_IN)) ICEVY_IN = ICEVY_HALO(owned_idx) + if(associated(OMLS_IN)) OMLS_IN = OMLS_HALO(owned_idx) + if(associated(IMLS_IN)) IMLS_IN = IMLS_HALO(owned_idx) + + end if + + ! Initialize Export pointers on mesh tile space so history has something to write + !----------------------------------- + + call MAPL_GetPointer(EXPORT, ICESURF_EX, 'ICESURF',alloc=.true., _RC) + if(associated(ICESURF_EX)) ICESURF_EX = ICESURF_HALO(owned_idx) + + call MAPL_GetPointer(EXPORT, ICETHICK_EX, 'ICETHICK',alloc=.true., _RC) + if(associated(ICETHICK_EX)) ICETHICK_EX = ICETHICK_HALO(owned_idx) + + call MAPL_GetPointer(EXPORT, ICEVX_EX, 'ICEVX',alloc=.true.,_RC) + if(associated(ICEVX_EX)) ICEVX_EX = ICEVX_HALO(owned_idx) + + call MAPL_GetPointer(EXPORT, ICEVY_EX, 'ICEVY',alloc=.true.,_RC) + if(associated(ICEVY_EX)) ICEVY_EX = ICEVY_HALO(owned_idx) + + ! Finally, set the tile export state so landice can access values before ISSM runs + !----------------------------------- + + ! Regrid from mesh to tile + call MAPL_LocStreamGet(internal_state%locstream, NT_LOCAL=NT, _RC) + + ! allocate variables on landice tile space + allocate(ICESURF_TILE(NT)) + allocate(ICETHICK_TILE(NT)) + allocate(ICEVEL_TILE(NT)) + + ! calculate ice flow speed + ICEVEL_HALO = sqrt(ICEVX_HALO**2 + ICEVY_HALO**2) + + call mesh_to_tile(ICESURF_HALO,ICESURF_TILE,_RC) + issm_tile_state%ICESURF_TILE = ICESURF_TILE + + call mesh_to_tile(ICETHICK_HALO,ICETHICK_TILE,_RC) + issm_tile_state%ICETHICK_TILE = ICETHICK_TILE + + call mesh_to_tile(ICEVEL_HALO,ICEVEL_TILE,_RC) + issm_tile_state%ICEVEL_TILE = ICEVEL_TILE + + issm_tile_state%ISSM_NSTEPS = NSTEPS_INIT + + + ! set nodeIds internal associated with restart + if(associated(restartNodeIds)) restartNodeIds(:) = ownedNodeIds(:) + + call ESMF_VMBarrier(vm, _RC) + + ! deallocate pointers + if(associated(nodeCoords)) deallocate(nodeCoords) + if(associated(nodeIds)) deallocate(nodeIds) + if(associated(elementTypes)) deallocate(elementTypes) + if(associated(elementIds)) deallocate(elementIds) + if(associated(elementConn)) deallocate(elementConn) + if(associated(elementCoords)) deallocate(elementCoords) + if(associated(glacIds)) deallocate(glacIds) + if(associated(elementMask)) deallocate(elementMask) + if(associated(halo_idx)) deallocate(halo_idx) + if(associated(owned_idx)) deallocate(owned_idx) + if(associated(halolist)) deallocate(halolist) + if(associated(ownedNodeCoords)) deallocate(ownedNodeCoords) + if(associated(ownedNodeIds)) deallocate(ownedNodeIds) + if(associated(nodeOwners)) deallocate(nodeOwners) + if(associated(ICESURF_HALO)) deallocate(ICESURF_HALO) + if(associated(ICETHICK_HALO)) deallocate(ICETHICK_HALO) + if(associated(IMLS_HALO)) deallocate(IMLS_HALO) + if(associated(OMLS_HALO)) deallocate(OMLS_HALO) + if(associated(ICEVX_HALO)) deallocate(ICEVX_HALO) + if(associated(ICEVY_HALO)) deallocate(ICEVY_HALO) + if(associated(GEOS_RESTARTS)) deallocate(GEOS_RESTARTS) + if(associated(ZEROS)) deallocate(ZEROS) + if(associated(ICESURF_TILE)) deallocate(ICESURF_TILE) + if(associated(ICETHICK_TILE)) deallocate(ICETHICK_TILE) + if(associated(ICEVEL_TILE)) deallocate(ICEVEL_TILE) + + ! destroy fields and arrays + call ESMF_FieldDestroy(gridField, _RC) + call ESMF_FieldDestroy(meshField, _RC) + call ESMF_ArrayDestroy(meshArray, _RC) + + _RETURN(_SUCCESS) + + contains + subroutine apply_halo(VAR_IN,VAR_HALO,RC) + ! apply halo operation to a restart variable + ! arguments: + real, pointer, dimension(:), intent(inout) :: VAR_IN ! var on owned_nodes + real(dp), pointer, dimension(:), intent(inout) :: VAR_HALO ! var on all nodes + integer, optional, intent(out) :: RC + + ! local variables: + real(dp), pointer, dimension(:) :: VAR_DP ! double version of VAR_IN + real(dp), pointer, dimension(:) :: MESH_PTR ! pointer for ESMF_FieldGet + real(dp), pointer, dimension(:) :: ARRAY_PTR ! pointer for ESMF_ArrayGet + type(ESMF_Array) :: meshArray ! array for creating mesh fields + type(ESMF_Field) :: meshField ! field associated with meshArray + + allocate(VAR_DP(num_nodes)) + VAR_DP(:) = 0.0_dp + VAR_DP(1:num_owned_nodes) = REAL(VAR_IN,kind=dp) + + ! create array with halo information + meshArray=ESMF_ArrayCreate(nodalDistgrid,typekind=ESMF_TYPEKIND_R8,haloSeqIndexList=halolist,_RC) + + call ESMF_ArrayGet(array=meshArray,farrayPtr=ARRAY_PTR) + ARRAY_PTR(:) = VAR_DP(:) + + ! create field on ISSM mesh + meshField=ESMF_FieldCreate(mesh, array=meshArray, meshLoc=ESMF_MESHLOC_NODE, _RC) + + ! append halo values to end of "owned" array + call ESMF_FieldHalo(meshField, routehandle=halohandle, _RC) + + ! get pointer to field on mesh + call ESMF_FieldGet(meshField,farrayPtr=MESH_PTR,_RC) + + ! copy values into VAR_HALO, interleave according to owned and halo indices + VAR_HALO(owned_idx) = MESH_PTR(1:num_owned_nodes) ! owned nodes + VAR_HALO(halo_idx) = MESH_PTR(num_owned_nodes+1:num_nodes) ! halo nodes + + ! destroy field and array, deallocate pointer + call ESMF_FieldDestroy(meshField,_RC) + call ESMF_ArrayDestroy(meshArray,_RC) + deallocate(VAR_DP) + + _RETURN(_SUCCESS) + end subroutine apply_halo + + subroutine apply_redist(VAR_RS,RC) + ! arguments: + real, pointer, dimension(:), intent(inout) :: VAR_RS ! var from restsart + integer, optional, intent(out) :: RC + + type(ESMF_Array) :: restartArray ! restart array + type(ESMF_Array) :: redistArray ! redistributed array + real, pointer, dimension(:) :: redistPtr + + restartArray=ESMF_ArrayCreate(distgrid=restartDistgrid,farrayPtr=VAR_RS,_RC) + redistArray=ESMF_ArrayCreate(distgrid=nodalDistgrid,typekind=ESMF_TYPEKIND_R4,_RC) + + ! redistribute the data + call ESMF_ArrayRedist(srcArray=restartArray, dstArray=redistArray, routehandle=redisthandle,_RC) + + ! get the pointer to the data + call ESMF_ArrayGet(redistArray,farrayPtr=redistPtr) + + ! make sure all processes have finished redistribution + call ESMF_VMBarrier(vm, _RC) + + ! copy values into output + VAR_RS(:) = redistPtr(:) + + call ESMF_VMBarrier(vm, _RC) + call ESMF_ArrayDestroy(restartArray,_RC) + call ESMF_ArrayDestroy(redistArray,_RC) + + _RETURN(_SUCCESS) + end subroutine apply_redist + + function create_mesh_grid(rc) result(mesh_grid) + type (ESMF_Grid) :: mesh_grid + integer, optional, intent(out) :: RC + integer :: status, nDEs, num(1) + real(kind=8), pointer :: centers_lon(:,:) + real(kind=8), pointer :: centers_lat(:,:) + integer, allocatable :: IMs(:) + + !comm, VM, num_owned_nodes are from containing subroutine + call ESMF_VMGet(vm, petcount=nDEs, _RC) + allocate(IMS(nDEs)) + num(1) = num_owned_nodes + call MAPL_CommsAllGather(vm, num, 1, IMs, 1, _RC) + + ! create a mesh-grid in 1D + mesh_grid = ESMF_GridCreate( & + name='MESH_GRID', & + countsPerDEDim1=IMs, & + countsPerDEDim2=[1], & + indexFlag=ESMF_INDEX_DELOCAL, & + coordDep1 = (/1,2/), & + coordDep2 = (/1,2/), & + gridEdgeLWidth = (/0,0/), & + gridEdgeUWidth = (/0,0/), & + _RC) + ! coord and centers are required for a valid grid, + ! even if their values don't make sense; + ! later on, the coord will be set to element's lat lon. + call ESMF_GridAddCoord(mesh_grid, _RC) + _VERIFY(STATUS) + + call ESMF_GridGetCoord(mesh_grid, coordDim=1, localDE=0, & + staggerloc=ESMF_STAGGERLOC_CENTER, & + farrayPtr=centers_lon, _RC) + centers_lon(:,1) = ownedNodeLons + call ESMF_GridGetCoord(mesh_grid, coordDim=2, localDE=0, & + staggerloc=ESMF_STAGGERLOC_CENTER, & + farrayPtr=centers_lat, _RC) + centers_lat(:,1) = ownedNodeLats + + _RETURN(_SUCCESS) + end function create_mesh_grid + + end subroutine Initialize + + !BOP + + + subroutine RUN ( GC, IMPORT, EXPORT, CLOCK, RC ) + ! ! ****** Run ISSM ice-sheet model ****** + ! ! the core C++ solvers and associated pre/post-processing of imports/exports + ! ! are only performed at ISSM_DT intervals. However, the Run method is engaged + ! ! at every landice timestep to ensure that ISSM restarts persist + ! !ARGUMENTS: + type(ESMF_GridComp), intent(inout) :: GC ! Gridded component + type(ESMF_State), intent(inout) :: IMPORT ! Import state + type(ESMF_State), intent(inout) :: EXPORT ! Export state + type(ESMF_Clock), intent(inout) :: CLOCK ! The clock + integer, optional, intent( out) :: RC ! Error code + type(ESMF_Alarm) :: ALARM ! run alarm for ISSM component + + ! ErrLog Variables + character(len=ESMF_MAXSTR) :: IAm + integer :: STATUS + character(len=ESMF_MAXSTR) :: COMP_NAME + + type(MAPL_MetaComp), pointer :: MAPL + type(ESMF_State) :: INTERNAL + type(ESMF_VM) :: vm + + ! internal state for regridding and halo operations + type(ESMF_Mesh) :: mesh ! ESMF version of ISSM mesh + integer :: num_nodes ! number of nodes on PET + + ! tile information + integer :: NT ! number of landice tiles + type(T_ISSM_TILE_STATE), pointer :: issm_tile_state + type(ISSM_TILE_WRAP) :: issm_tile_wrap + + ! surface mass balance on mesh and landice tiles + ! note: SMB has been time-averaged between ISSM runs + real(dp), pointer, dimension(:) :: ICESMB_MESH => null() ! surface mass balce on mesh elements + real, pointer, dimension(:) :: ICESMB_TILE => null() ! surface mass balance on landice tiles + real, pointer, dimension(:) :: ICESMB_EX => null() ! pointer to export state (mesh tiles) + + ! ISSM Outputs + real(dp), pointer, dimension(:) :: ISSM_OUTPUTS => null() ! pointer containing all outputs + + ! ice-surface elevation on mesh and landice tiles + real(dp), pointer, dimension(:) :: ICESURF_MESH => null() ! ice elevation on mesh + real, pointer, dimension(:) :: ICESURF_TILE => null() ! ice elevation on landice tiles + real, pointer, dimension(:) :: ICESURF_EX => null() ! pointer to export state (mesh tiles) + real, pointer, dimension(:) :: ICESURF_IN => null() ! pointer to internal state (mesh tiles) + + ! ice thickness on mesh and landice tiles + real(dp), pointer, dimension(:) :: ICETHICK_MESH => null() ! ice thickness on mesh + real, pointer, dimension(:) :: ICETHICK_TILE => null() ! ice thickness on landice tiles + real, pointer, dimension(:) :: ICETHICK_EX => null() ! pointer to ice thickness export state (mesh tiles) + real, pointer, dimension(:) :: ICETHICK_IN => null() ! pointer to ice thicknesss internal state (mesh tiles) + + ! ice-flow velocity in x direction (in projection coordinates) + real(dp), pointer, dimension(:) :: ICEVX_MESH => null() ! ice x-velocity on mesh + real, pointer, dimension(:) :: ICEVX_EX => null() ! pointer to export state (mesh tiles) + real, pointer, dimension(:) :: ICEVX_IN => null() ! pointer to internal state (mesh tiles) + + ! ice-flow velocity in y direction (in projection coordinates) + real(dp), pointer, dimension(:) :: ICEVY_MESH => null() ! ice y-velocity on mesh + real, pointer, dimension(:) :: ICEVY_EX => null() ! pointer to export state (mesh tiles) + real, pointer, dimension(:) :: ICEVY_IN => null() ! pointer to export state (mesh tiles) + + ! ice mask level set (tracks glacier terminus) + real(dp), pointer, dimension(:) :: IMLS_MESH => null() ! ice mask level set + real, pointer, dimension(:) :: IMLS_IN => null() ! pointer to internal state (mesh tiles) + + ! ocean mask level set (tracks grounding line) + real(dp), pointer, dimension(:) :: OMLS_MESH => null() ! ocean mask level set + real, pointer, dimension(:) :: OMLS_IN => null() ! pointer to internal state (mesh tiles) + + ! ice-flow speed on mesh and landice tiles + real(dp), pointer, dimension(:) :: ICEVEL_MESH => null() ! ice flow speed on mesh tiles + real, pointer, dimension(:) :: ICEVEL_TILE => null() ! ice flow speed on landice tiles + + ! physical parameters + real(dp), parameter :: rho_ice = 917.0 ! pure ice density [kg m-3] + real(dp) :: ISSM_DT ! time step [s] (ISSM_DT set in AGCM.rc) + + ! Get the target components name, mesh and vm + ! ----------------------------------------------------------- + Iam = "Run" + call ESMF_GridCompGet(GC,name=COMP_NAME,mesh=mesh,vm=vm,_RC) + + Iam = trim(COMP_NAME) // Iam + + ! Get my internal MAPL_Generic state + !---------------------------------- + call MAPL_GetObjectFromGC(GC, MAPL, STATUS) + _VERIFY(STATUS) + + call MAPL_Get(MAPL,INTERNAL_ESMF_STATE = INTERNAL,_RC ) + + + ! Start Total timer + !------------------ + call MAPL_TimerOn(MAPL,"TOTAL") + call MAPL_TimerOn(MAPL,"RUN" ) + + call MAPL_Get(MAPL, RUNALARM = ALARM, _RC ) + + + ! run ISSM at specified time steps, + ! if bootstrapping restart and issm has run not by final time step, run anyways + ! with timestep of zero, which just gets restart values + if (ESMF_AlarmIsRinging (ALARM, RC=STATUS)) then + + ! *************************************************************************** ! + ! BASIC SETUP + ! *************************************************************************** ! + + ! get timestep for ISSM + call MAPL_GetResource(MAPL, ISSM_DT, Label=trim(COMP_NAME)//"_DT:",DEFAULT=302400.0, _RC) + + ! get number of mesh elements + call ESMF_MeshGet(mesh,nodeCount=num_nodes) + + ! allocate ice-elevation output (export from ISSM) + allocate(ISSM_OUTPUTS(num_outputs*num_nodes)) + + ! allocate output arrays defined on mesh nodes + allocate(ICESURF_MESH(num_nodes)) + allocate(ICETHICK_MESH(num_nodes)) + allocate(ICEVX_MESH(num_nodes)) + allocate(ICEVY_MESH(num_nodes)) + allocate(ICEVEL_MESH(num_nodes)) + allocate(IMLS_MESH(num_nodes)) + allocate(OMLS_MESH(num_nodes)) + + ! allocate input arrays defined on mesh nodes + allocate(ICESMB_MESH(num_nodes)) + + ! initialize ISSM outputs to zero + ICESURF_MESH(:) = 0.0_dp + ICETHICK_MESH(:) = 0.0_dp + ICEVX_MESH(:) = 0.0_dp + ICEVY_MESH(:) = 0.0_dp + ICEVEL_MESH(:) = 0.0_dp + IMLS_MESH(:) = 0.0_dp + OMLS_MESH(:) = 0.0_dp + ISSM_OUTPUTS(:) = 0.0_dp + + ! get landice tile dimensions + call MAPL_LocStreamGet(internal_state%locstream, NT_LOCAL=NT, _RC) + + call ESMF_UserCompGetInternalState(GC, 'ISSM_TILES', issm_tile_wrap, status); _VERIFY(STATUS) + issm_tile_state => issm_tile_wrap%ptr + + ! *************************************************************************** ! + ! GET ICESMB IMPORT (surface mass balance) + ! *************************************************************************** ! + ! NOTE: ICESMB (from landice) has been time-averaged between ISSM runs + ! hence the name ICESMB_ISSM + + ! allocate tiles for ICESMB + if(.not.associated(ICESMB_TILE)) then + allocate(ICESMB_TILE(NT), STAT=STATUS) + _VERIFY(STATUS) + ICESMB_TILE = MAPL_Undef + end if + + ! copy import values into tile array + ICESMB_TILE = issm_tile_state%ICESMB_ISSM + + ! transform ICESMB from landice tiles to mesh + call tile_to_mesh(ICESMB_TILE,ICESMB_MESH,_RC) + + ! save ICESMB on mesh elements + call MAPL_GetPointer(EXPORT , ICESMB_EX , 'ICESMB_ISSM' , _RC) + + if(associated(ICESMB_EX)) ICESMB_EX = ICESMB_MESH(internal_state%owned_idx) + + ! *************************************************************************** ! + ! RUN ISSM WITH SMB INPUT AND ICE-ELEVATION OUTPUT + ! *************************************************************************** ! + ! convert SMB to units of [m/s] (ice-equivalent) before passing to ISSM + ICESMB_MESH = ICESMB_MESH/rho_ice + + call ESMF_VMBarrier(vm, _RC) + call MAPL_TimerOn(MAPL,"ISSMCore" ) + + ! call run method from ISSM library + call RunISSM(ISSM_DT, c_loc(ICESMB_MESH), c_loc(ISSM_OUTPUTS)) + + call ESMF_VMBarrier(vm, _RC) + call MAPL_TimerOff(MAPL,"ISSMCore" ) + + ! *************************************************************************** ! + ! UNPACK AND EXPORT ISSM OUTPUTS ON MESH TILES + ! *************************************************************************** ! + ! unpack ISSM output pointer + ICESURF_MESH(:) = ISSM_OUTPUTS(1:num_nodes) + ICETHICK_MESH(:) = ISSM_OUTPUTS(num_nodes+1:2*num_nodes) + ICEVX_MESH(:) = ISSM_OUTPUTS(2*num_nodes+1:3*num_nodes) + ICEVY_MESH(:) = ISSM_OUTPUTS(3*num_nodes+1:4*num_nodes) + OMLS_MESH(:) = ISSM_OUTPUTS(4*num_nodes+1:5*num_nodes) + IMLS_MESH(:) = ISSM_OUTPUTS(5*num_nodes+1:6*num_nodes) + + ! calculate ice flow speed + ICEVEL_MESH = sqrt(ICEVX_MESH**2 + ICEVY_MESH**2) + + ! set pointers to tile-mesh exports + call MAPL_GetPointer(EXPORT, ICESURF_EX, 'ICESURF', _RC) + if(associated(ICESURF_EX)) ICESURF_EX = ICESURF_MESH(internal_state%owned_idx) + + call MAPL_GetPointer(EXPORT, ICEVX_EX, 'ICEVX', _RC) + if(associated(ICEVX_EX)) ICEVX_EX = ICEVX_MESH(internal_state%owned_idx) + + call MAPL_GetPointer(EXPORT, ICEVY_EX, 'ICEVY', _RC) + if(associated(ICEVY_EX)) ICEVY_EX = ICEVY_MESH(internal_state%owned_idx) + + call MAPL_GetPointer(EXPORT, ICETHICK_EX, 'ICETHICK', _RC) + if(associated(ICETHICK_EX)) ICETHICK_EX = ICETHICK_MESH(internal_state%owned_idx) + + ! set pointers to tile-mesh internals + call MAPL_GetPointer(INTERNAL, ICESURF_IN, 'ICESURF', _RC) + if(associated(ICESURF_IN)) ICESURF_IN = ICESURF_MESH(internal_state%owned_idx) + + call MAPL_GetPointer(INTERNAL, ICETHICK_IN, 'ICETHICK', _RC) + if(associated(ICETHICK_IN)) ICETHICK_IN = ICETHICK_MESH(internal_state%owned_idx) + + call MAPL_GetPointer(INTERNAL, ICEVX_IN, 'ICEVX', _RC) + if(associated(ICEVX_IN)) ICEVX_IN = ICEVX_MESH(internal_state%owned_idx) + + call MAPL_GetPointer(INTERNAL, ICEVY_IN, 'ICEVY', _RC) + if(associated(ICEVY_IN)) ICEVY_IN = ICEVY_MESH(internal_state%owned_idx) + + call MAPL_GetPointer(INTERNAL, OMLS_IN, 'OMLS', _RC) + if(associated(OMLS_IN)) OMLS_IN = OMLS_MESH(internal_state%owned_idx) + + call MAPL_GetPointer(INTERNAL, IMLS_IN, 'IMLS', _RC) + if(associated(IMLS_IN)) IMLS_IN = IMLS_MESH(internal_state%owned_idx) + + ! *************************************************************************** ! + ! REGRID MESH FIELDS ONTO LANDICE TILES AND EXPORT VIA PRIVATE INTERNAL STATE + ! *************************************************************************** ! + ! transform from mesh to tiles + call mesh_to_tile(ICESURF_MESH,ICESURF_TILE,_RC) + issm_tile_state%ICESURF_TILE = ICESURF_TILE + + call mesh_to_tile(ICETHICK_MESH,ICETHICK_TILE,_RC) + issm_tile_state%ICETHICK_TILE = ICETHICK_TILE + + call mesh_to_tile(ICEVEL_MESH,ICEVEL_TILE,_RC) + issm_tile_state%ICEVEL_TILE = ICEVEL_TILE + + ! *************************************************************************** ! + ! Round ISSM output to single precision and reset on the C++ side + ! This ensures the same result as reading in (single-precision) restarts + ! *************************************************************************** ! + ISSM_OUTPUTS = real(ISSM_OUTPUTS, kind=sp) + call ESMF_VMBarrier(vm, _RC) + call InputFromRestarts(c_loc(ISSM_OUTPUTS)) + call ESMF_VMBarrier(vm, _RC) + + end if + + ! barrier to ensure regridding completes before any deallocates + call ESMF_VMBarrier(vm,_RC) + + ! deallocates + if(associated(ICESURF_MESH)) deallocate(ICESURF_MESH) + if(associated(ICETHICK_MESH)) deallocate(ICETHICK_MESH) + if(associated(ICEVEL_MESH)) deallocate(ICEVEL_MESH) + if(associated(ICEVX_MESH)) deallocate(ICEVX_MESH) + if(associated(ICEVY_MESH)) deallocate(ICEVY_MESH) + if(associated(IMLS_MESH)) deallocate(IMLS_MESH) + if(associated(OMLS_MESH)) deallocate(OMLS_MESH) + if(associated(ICESMB_MESH)) deallocate(ICESMB_MESH) + if(associated(ISSM_OUTPUTS)) deallocate(ISSM_OUTPUTS) + if(associated(ICESMB_TILE)) deallocate(ICESMB_TILE) + if(associated(ICESURF_TILE)) deallocate(ICESURF_TILE) + if(associated(ICETHICK_TILE)) deallocate(ICETHICK_TILE) + if(associated(ICEVEL_TILE)) deallocate(ICEVEL_TILE) + + call MAPL_TimerOff(MAPL,"RUN" ) + call MAPL_TimerOff(MAPL,"TOTAL") + + _RETURN(_SUCCESS) + + end subroutine RUN + + + !BOP + +!IROUTINE: Finalize -- Finalize method for ISSM + +!INTERFACE: + + subroutine Finalize ( GC, IMPORT, EXPORT, CLOCK, RC ) + + !ARGUMENTS: + type(ESMF_GridComp), intent(INOUT) :: GC ! Gridded component + type(ESMF_State), intent(INOUT) :: IMPORT ! Import state + type(ESMF_State), intent(INOUT) :: EXPORT ! Export state + type(ESMF_Clock), intent(INOUT) :: CLOCK ! The supervisor clock + integer, optional, intent( OUT) :: RC ! Error code: + + !EOP + type(MAPL_MetaComp), pointer :: MAPL + + type(ESMF_State) :: INTERNAL + + ! ErrLog Variables + character(len=ESMF_MAXSTR) :: IAm + integer :: STATUS + character(len=ESMF_MAXSTR) :: COMP_NAME + + + type(T_ISSM_TILE_STATE), pointer :: issm_tile_state + type(ISSM_TILE_WRAP) :: issm_tile_wrap + real, pointer, dimension(:) :: ISSM_NSTEPS + + ! Get the target components name and set-up traceback handle. + ! ----------------------------------------------------------- + Iam = "Finalize" + call ESMF_GridCompGet( GC, NAME=COMP_NAME, _RC ) + + Iam = trim(comp_name) // Iam + + call MAPL_GetObjectFromGC(GC, MAPL, STATUS) + _VERIFY(STATUS) + + ! save number of steps since last ISSM run via internal state checkpoints (restarts) + call ESMF_UserCompGetInternalState(GC, 'ISSM_TILES', issm_tile_wrap, STATUS); _VERIFY(STATUS) + issm_tile_state => issm_tile_wrap%ptr + + ! get internal state + call MAPL_Get(MAPL,INTERNAL_ESMF_STATE = INTERNAL,_RC) + + ! get number of time steps since last ISSM run + call MAPL_GetPointer(INTERNAL, ISSM_NSTEPS, 'ISSM_NSTEPS',_RC) + ISSM_NSTEPS(:) = real(issm_tile_state%ISSM_NSTEPS) + + ! call ISSM's finalize method + call FinalizeISSM() + + ! Generic Finalize + ! ------------------ + call MAPL_GenericFinalize( GC, IMPORT, EXPORT, CLOCK, _RC ) + + ! All Done + ! ------------------ + + _RETURN(_SUCCESS) + end subroutine Finalize + + + subroutine mesh_to_tile(VAR_MESH,VAR_TILE,RC) + ! regrid from mesh to grid, then transform from grid to landice tiles + ! arguments: + real(dp), pointer, dimension(:), intent(inout) :: VAR_MESH ! var on mesh nodes + real, pointer, dimension(:), intent(inout) :: VAR_TILE ! var on landice tiles + integer, optional, intent(OUT) :: RC ! Error code + + ! local variables: + real, pointer, dimension(:,:) :: VAR_GRID => null() ! var on attached grid + real(dp), pointer, dimension(:) :: VAR_MESH_OWN ! var on owned mesh nodes + type(ESMF_Field) :: srcField + type(ESMF_Field) :: dstField + integer :: num_owned_nodes + integer :: NT + integer :: STATUS + + num_owned_nodes = size(internal_state%owned_idx) + + call MAPL_LocStreamGet(internal_state%locstream, NT_LOCAL=NT, _RC) + + allocate(VAR_MESH_OWN(num_owned_nodes)) + + VAR_MESH_OWN = VAR_MESH(internal_state%owned_idx) + + ! allocate tiles + if (.not.associated(VAR_TILE)) then + allocate(VAR_TILE(NT)) + VAR_TILE = MAPL_Undef + end if + + ! create source field: field on mesh nodes + srcField = ESMF_FieldCreate(mesh=internal_state%mesh,farrayPtr=VAR_MESH_OWN,meshloc=ESMF_MESHLOC_NODE, & + datacopyflag=ESMF_DATACOPY_VALUE,_RC) + + ! create destination field: field on grid + dstField = ESMF_FieldCreate(grid=internal_state%grid,typekind=ESMF_TYPEKIND_R4,_RC) + + ! regrid field from mesh to grid + call ESMF_FieldRegrid(srcField, dstField, internal_state%routehandle_m2g, _RC) + + ! get pointer to field on grid + call ESMF_FieldGet(dstField,farrayPtr=VAR_GRID,_RC) + + ! transform from grid to tiles + call MAPL_LocStreamTransform(internal_state%locstream,VAR_TILE,VAR_GRID, _RC) + + ! destroy regridding fields so they can be reused + call ESMF_FieldDestroy(srcField,_RC) + call ESMF_FieldDestroy(dstField,_RC) + + _RETURN(_SUCCESS) + + end subroutine mesh_to_tile + + subroutine tile_to_mesh(VAR_TILE,VAR_MESH,RC) + ! transform from landice tile to grid, then regrid onto mesh + ! arguments: + real, pointer, dimension(:), intent(inout) :: VAR_TILE ! var on landice tiles + real(dp), pointer, dimension(:), intent(inout) :: VAR_MESH ! var on mesh elements + integer, optional, intent(OUT) :: RC ! Error code + + ! local variables: + real, pointer, dimension(:,:) :: VAR_GRID => null() ! var on attached grid + real(dp), pointer, dimension(:) :: MESH_PTR ! pointer for ESMF_FieldGet + type(ESMF_Field) :: srcField + type(ESMF_Field) :: dstField + type(ESMF_Array) :: meshArray + integer :: num_owned_nodes + integer :: num_nodes + integer :: IM, JM, local_dims(3) + integer :: STATUS + + ! get number of nodes + call ESMF_MeshGet(internal_state%mesh,nodeCount=num_nodes,numOwnedNodes=num_owned_nodes,_RC) + + ! get grid dimensions + call MAPL_GridGet(internal_state%grid, localCellCountPerDim=local_dims, _RC) + IM = local_dims(1) + JM = local_dims(2) + + ! allocate pointer on grid for regridding + allocate(VAR_GRID(IM,JM)) + + ! transform from tile to grid + ! NOTE: we use the "transpose" option with MAPL_LocStreamTransformG2T + ! (rather than MAPL_LocStreamTransformT2G) because the "default" value is zero + ! (rather than MAPL_UNDEF, which leads to errors when regridding onto mesh) + call MAPL_LocStreamTransform(internal_state%locstream, VAR_TILE, VAR_GRID, TRANSPOSE=.true., _RC) + + ! create source field on grid + srcField = ESMF_FieldCreate(grid=internal_state%grid,farrayPtr=VAR_GRID, datacopyflag=ESMF_DATACOPY_VALUE,_RC) + + ! create destination field on mesh elements + meshArray=ESMF_ArrayCreate(internal_state%nodalDistgrid,typekind=ESMF_TYPEKIND_R8,haloSeqIndexList=internal_state%halolist,_RC) + + ! create field on ISSM mesh + dstField=ESMF_FieldCreate(internal_state%mesh, array=meshArray, meshLoc=ESMF_MESHLOC_NODE, _RC) + + ! regrid from grid to mesh + call ESMF_FieldRegrid(srcField, dstField, internal_state%routehandle_g2m, _RC) + + ! append halo values to end of "owned" array + call ESMF_FieldHalo(dstField, routehandle=internal_state%halohandle, _RC) + + ! get pointer to field on mesh + call ESMF_FieldGet(dstField,farrayPtr=MESH_PTR,_RC) + + ! copy values into VAR_MESH + VAR_MESH(internal_state%owned_idx) = MESH_PTR(1:num_owned_nodes) ! owned nodes + VAR_MESH(internal_state%halo_idx) = MESH_PTR(num_owned_nodes+1:num_nodes) ! halo nodes + + ! destroy fields and arrays so they can be reused + deallocate(VAR_GRID) + call ESMF_FieldDestroy(srcField,_RC) + call ESMF_FieldDestroy(dstField,_RC) + call ESMF_ArrayDestroy(meshArray,_RC) + + _RETURN(_SUCCESS) + + end subroutine tile_to_mesh + +end module GEOS_IssmGridCompMod diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Shared/GEOS_SurfaceGridComp.rc b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Shared/GEOS_SurfaceGridComp.rc index 6985db47e0..16ebfc0d2a 100644 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Shared/GEOS_SurfaceGridComp.rc +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Shared/GEOS_SurfaceGridComp.rc @@ -257,3 +257,15 @@ # =============== EOF ===================================================================================== +#--------------------------------------------------------# +# Ice-Sheet and Sea-Level System Model (ISSM) # +# # +# * DO_ISSM is the run flag, turned off (0) by default # +# set DO_ISSM: 1 to run ISSM # +# * ISSM_DT is ISSM's time step, semiweekly by default # +#--------------------------------------------------------# +# GEOSagcm=>DO_ISSM: 0 +# GEOSagcm=>ISSM_DT: 302400 +# +# GEOSldas=>DO_ISSM: 0 +# GEOSldas=>ISSM_DT: 302400 \ No newline at end of file diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/makebcs/make_bcs_shared.py b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/makebcs/make_bcs_shared.py index 54ff8a39cf..ccd6bed6ee 100755 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/makebcs/make_bcs_shared.py +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/makebcs/make_bcs_shared.py @@ -95,7 +95,7 @@ def get_script_head() : limit stacksize unlimited if( ! -d geometry ) then - mkdir -p geometry land/shared til rst data/MOM5 data/MOM6 clsm/plots + mkdir -p geometry land/shared landice/shared til rst data/MOM5 data/MOM6 clsm/plots endif """ return head @@ -203,7 +203,7 @@ def get_script_mv(grid_type): # move output into final directory tree (layout as of July 2023) -mkdir -p ../../geometry ../../land/shared ../../logs +mkdir -p ../../geometry ../../land/shared ../../landice/shared ../../logs echo "-----------------------------" echo "make_bcs ends date/time" @@ -230,6 +230,10 @@ def get_script_mv(grid_type): echo "Successfully copied CO2_MonthlyMean_DiurnalCycle.nc4 to bcs dir." endif +# copy ISSM files to bcs dir +/bin/cp -p /discover/nobackup/projects/gmao/bcs_shared/make_bcs_inputs/landice/issm/v1/ISSM_ME23083_N34534_AIS_GRIS/* landice/shared/ +echo "Successfully copied ISSM binary and toolkits files to bcs dir." + if ( ! -d route ) mkdir -p route if(-f route/route_parameters.nc ) then @@ -268,7 +272,7 @@ def get_script_mv(grid_type): mv_template = mv_template + """ # adjust permissions (for all grid types) -chmod +rX -R geometry land logs route +chmod +rX -R geometry land logs route landice """ return mv_template diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/preproc/issm/AIS/AIS_control.py b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/preproc/issm/AIS/AIS_control.py new file mode 100755 index 0000000000..1dfe2f5f2d --- /dev/null +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/preproc/issm/AIS/AIS_control.py @@ -0,0 +1,63 @@ +import devpath +import os +ISSM_DIR = os.getenv('ISSM_DIR') # for binaries + +import numpy as np +from model import * +from loadmodel import loadmodel +from setmask import setmask +from parameterize import parameterize +from clusters.discover_geos import export_discover +from marshall import marshall + +# Step 2: parameterize model +md = loadmodel('./netcdfs/AIS_mesh.nc') + +md = setmask(md, '', '') +md = parameterize(md, './AIS_parameterize.py') + + +# export parameterization +export_discover(md, "./netcdfs/AIS_parameterization.nc",delete_rundir=True) + +# Step 3: basal friction inversion + # Control general +md.inversion.nsteps = 100 +md.inversion.iscontrol=1 +md.inversion.maxsteps=100 +md.inversion.maxiter=100 +md.inversion.dxmin=0.01 +md.inversion.gttol=1.0e-8 + +md.inversion.step_threshold = 0.99 * np.ones((md.inversion.nsteps)) +md.inversion.maxiter_per_step = 40 * np.ones((md.inversion.nsteps)) + +md.inversion.gradient_scaling = 50 * np.ones((md.inversion.nsteps, 1)) +md.inversion.min_parameters = 1 * np.ones((md.mesh.numberofvertices, 1)) +md.inversion.max_parameters = 200 * np.ones((md.mesh.numberofvertices, 1)) + +#Cost functions +md.inversion.cost_functions = [101, 103, 501] +md.inversion.cost_functions_coefficients = np.ones((md.mesh.numberofvertices, 3)) +md.inversion.cost_functions_coefficients[:, 0] = 1 +md.inversion.cost_functions_coefficients[:, 1] = 1 +md.inversion.cost_functions_coefficients[:, 2] = 2e-10 + +# Controls +md.inversion.control_parameters = ['FrictionCoefficient'] +md.inversion.min_parameters=1*np.ones(np.shape(md.mesh.x)) +md.inversion.max_parameters=200*np.ones(np.shape(md.mesh.x)) + +# Additional parameters +md.stressbalance.restol=1.0e-12 +md.stressbalance.reltol=1.0e-12 +md.stressbalance.abstol=np.nan + +# Solve +md.private.solution = 'Stressbalance' +md.settings.waitonlock = 0 +md.toolkits.ToolkitsFile('ISSM_'+md.miscellaneous.name + '.toolkits') +marshall(md,'ISSM_'+md.miscellaneous.name+'.bin') + +# export configuration for loading solution in next step +export_discover(md,'./netcdfs/AIS_inversion.nc',delete_rundir=True) diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/preproc/issm/AIS/AIS_finalize.py b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/preproc/issm/AIS/AIS_finalize.py new file mode 100755 index 0000000000..bf7e4c81a3 --- /dev/null +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/preproc/issm/AIS/AIS_finalize.py @@ -0,0 +1,31 @@ +import devpath +import os +ISSM_DIR = os.getenv('ISSM_DIR') # for binaries + +from model import * +from loadmodel import loadmodel +from clusters.discover_geos import export_discover +from loadresultsfromdisk import loadresultsfromdisk +from marshall import marshall +from verbose import verbose + +md = loadmodel('./netcdfs/AIS_inversion.nc') +md = loadresultsfromdisk(md,'ISSM_AIS.outbin') +md.friction.coefficient = md.results.StressbalanceSolution.FrictionCoefficient + + +# Write the binary input file +# Additional options +md.inversion.iscontrol = 0 +md.stressbalance.restol=1.0e-12 +md.stressbalance.reltol=1.0e-12 +md.transient.requested_outputs = ['default'] +md.transient.isthermal=0 +md.settings.waitonlock = 0 +md.private.solution = 'Transient' +md.verbose = verbose('000000000') +md.toolkits = toolkits() +marshall(md,'ISSM_'+md.miscellaneous.name+'.bin') # create .bin file +md.toolkits.ToolkitsFile('ISSM_'+md.miscellaneous.name + '.toolkits') +export_discover(md,'./netcdfs/AIS_initialization.nc',delete_rundir=True) + diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/preproc/issm/AIS/AIS_meshgen.py b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/preproc/issm/AIS/AIS_meshgen.py new file mode 100644 index 0000000000..80c2c5b961 --- /dev/null +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/preproc/issm/AIS/AIS_meshgen.py @@ -0,0 +1,51 @@ +import devpath +import sys,os +import numpy as np +from triangle import triangle +from model import * +from netCDF4 import Dataset +from InterpFromGridToMesh import InterpFromGridToMesh +from bamg import bamg +from clusters.discover_geos import export_discover + +h_max = sys.argv[1] if len(sys.argv) > 1 else 24000 +h_min = sys.argv[2] if len(sys.argv) > 2 else 2000 +h_max = float(h_max) +h_min = float(h_min) + +print(f'h_max: {h_max}') +print(f'h_min: {h_min}') + +if not os.path.exists('./netcdfs'): + os.mkdir('./netcdfs') + +# Step 1: Mesh generation +# Generate initial uniform mesh (resolution = 60000 m) +# project mesh onto new coordinate system +md = triangle(model(), '/discover/nobackup/projects/gmao/bcs_shared/preprocessing_bcs_inputs/landice/issm/v1/AIS/AntarcticaOutline.exp', 60000) + +print(' Loading velocities data from NetCDF') +nsidc_vel = Dataset('/discover/nobackup/projects/gmao/bcs_shared/preprocessing_bcs_inputs/landice/issm/v1/AIS/Antarctica_ice_velocity.nc') +xmin = nsidc_vel.xmin +xmin = float(xmin.lstrip()[0:10]) +ymax = nsidc_vel.ymax +ymax = float(ymax.lstrip()[0:10]) +spacing = nsidc_vel.spacing +spacing = float((spacing.lstrip())[0:4]) +nx = nsidc_vel.nx +ny = nsidc_vel.ny +vx = nsidc_vel['vx'][:].data +vy = nsidc_vel['vy'][:].data +# Build coordinates +x2 = xmin + np.arange(nx + 1) * spacing +y2 = (ymax - ny * spacing) + np.arange(ny + 1) * spacing + +vx_ = InterpFromGridToMesh(x2, y2, np.flipud(vx), md.mesh.x, md.mesh.y, 0) +vy_ = InterpFromGridToMesh(x2, y2, np.flipud(vy), md.mesh.x, md.mesh.y, 0) +speed = np.sqrt(vx_**2 + vy_**2) +del vx, vy, vx_, vy_ + +md = bamg(md, 'hmax', h_max, 'hmin', h_min, 'gradation', 1.4, 'field', speed, 'err', 8) + +# export mesh +export_discover(md, './netcdfs/AIS_mesh.nc') diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/preproc/issm/AIS/AIS_parameterize.py b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/preproc/issm/AIS/AIS_parameterize.py new file mode 100755 index 0000000000..a8fbbcf973 --- /dev/null +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/preproc/issm/AIS/AIS_parameterize.py @@ -0,0 +1,143 @@ +import numpy as np +from paterson import paterson +from netCDF4 import Dataset +from xy2ll import xy2ll +from InterpFromGridToMesh import InterpFromGridToMesh +from SetMarineIceSheetBC import SetMarineIceSheetBC +from m1qn3inversion import m1qn3inversion +from setflowequation import setflowequation +from pathlib import Path + +#Name and Coordinate system +md.miscellaneous.name="AIS" +md.mesh.epsg=3031 + +nsidc_vel = Dataset('/discover/nobackup/projects/gmao/bcs_shared/preprocessing_bcs_inputs/landice/issm/v1/AIS/Antarctica_ice_velocity.nc') +xmin = nsidc_vel.xmin +xmin = float(xmin.lstrip()[0:10]) +ymax = nsidc_vel.ymax +ymax = float(ymax.lstrip()[0:10]) +spacing = nsidc_vel.spacing +spacing = float((spacing.lstrip())[0:4]) +nx = nsidc_vel.nx +ny = nsidc_vel.ny +velx = nsidc_vel['vx'][:].data +vely = nsidc_vel['vy'][:].data +# Build coordinates +x2 = xmin + np.arange(nx + 1) * spacing +y2 = (ymax - ny * spacing) + np.arange(ny + 1) * spacing + +# print(' Set observed velocities') +md.initialization.vx = InterpFromGridToMesh(x2, y2, np.flipud(velx), md.mesh.x, md.mesh.y, 0) +md.initialization.vy = InterpFromGridToMesh(x2, y2, np.flipud(vely), md.mesh.x, md.mesh.y, 0) +md.initialization.vz = np.zeros(md.mesh.numberofvertices) +md.initialization.vel = np.sqrt(md.initialization.vx**2 + md.initialization.vy**2) +del velx, vely + +# Parameters to change/Try +friction_coefficient = 10 # default [10] +Temp_change = 0 # default [0 K] + +# NetCDF Loading +print(' Loading SeaRISE data from NetCDF') +ncdata = Dataset('/discover/nobackup/projects/gmao/bcs_shared/preprocessing_bcs_inputs/landice/issm/v1/AIS/Antarctica_5km_withshelves_v0.75.nc') +x1 = ncdata['x1'][:].data +y1 = ncdata['y1'][:].data +usrf = ncdata['usrf'][:].data[0] +topg = ncdata['topg'][:].data[0] +temp = ncdata['presartm'][:].data[0] +smb = ncdata['presprcp'][:].data[0] +gflux = ncdata['bheatflx_fox'][:].data[0] + +# Geometry +print(' Interpolating surface and ice base') +md.geometry.base = InterpFromGridToMesh(x1, y1, topg, md.mesh.x, md.mesh.y, 0) +md.geometry.surface = InterpFromGridToMesh(x1, y1, usrf, md.mesh.x, md.mesh.y, 0) +del usrf, topg + +thkmask=ncdata['thkmask'][:].data[0] + +##interpolate onto our mesh vertices +groundedice= InterpFromGridToMesh(x1,y1,thkmask,md.mesh.x,md.mesh.y,0) +groundedice[groundedice<=0]=-1 +del thkmask + +#fill in the md.mask structure +md.mask.ocean_levelset = groundedice #ice is grounded for mask equal one +md.mask.ice_levelset = -1*np.ones(np.shape(md.mesh.x)) #ice is present when negatvie + +print(' Constructing thickness') +md.geometry.thickness = md.geometry.surface - md.geometry.base + +# Ensure hydrostatic equilibrium on ice shelf +di = md.materials.rho_ice / md.materials.rho_water + +# Get the node numbers of floating nodes +pos = np.where(md.mask.ocean_levelset < 0) + +# Apply flotation criterion +md.geometry.thickness[pos] = 1 / (1 - di) * md.geometry.surface[pos] +md.geometry.base[pos] = md.geometry.surface[pos] - md.geometry.thickness[pos] +md.geometry.hydrostatic_ratio = np.ones(md.mesh.numberofvertices) + +# Set min thickness to 1 meter +pos0 = np.where(md.geometry.thickness <= 1) +md.geometry.thickness[pos0] = 1 +md.geometry.surface = md.geometry.thickness + md.geometry.base +md.geometry.bed = md.geometry.base.copy() +md.geometry.bed[pos] = md.geometry.base[pos] - 1000 + + +# Initialization parameters +print(' Interpolating temperatures') +md.initialization.temperature = InterpFromGridToMesh( + x1, y1, temp, md.mesh.x, md.mesh.y, 0 +) + 273.15 + Temp_change + +[md.mesh.lat, md.mesh.long] = xy2ll(md.mesh.x, md.mesh.y, -1) + + +print(' Set Pressure') +md.initialization.pressure = md.materials.rho_ice * md.constants.g * md.geometry.thickness + +print(' Construct ice rheological properties') +md.materials.rheology_n = 3 * np.ones(md.mesh.numberofelements) +md.materials.rheology_B = paterson(md.initialization.temperature) + +# Forcings +print(' Interpolating surface mass balance') +mass_balance = InterpFromGridToMesh(x1, y1, smb, md.mesh.x, md.mesh.y, 0) +md.smb.mass_balance = mass_balance * md.materials.rho_water / md.materials.rho_ice + +print(' Set geothermal heat flux') +md.basalforcings.geothermalflux = InterpFromGridToMesh(x1, y1, gflux, md.mesh.x, md.mesh.y, 0) + +# Friction and inversion set up +print(' Construct basal friction parameters') +md.friction.coefficient = friction_coefficient * np.ones(md.mesh.numberofvertices) +md.friction.p = np.ones(md.mesh.numberofelements) +md.friction.q = np.ones(md.mesh.numberofelements) + +# No friction applied on floating ice +pos = np.where(md.mask.ocean_levelset < 0)[0] +md.friction.coefficient[pos] = 0 +md.groundingline.migration = 'SubelementMigration' + +md.inversion = m1qn3inversion() +md.inversion.vx_obs = md.initialization.vx +md.inversion.vy_obs = md.initialization.vy +md.inversion.vel_obs = md.initialization.vel + +print(' Set flow equations') +md = setflowequation(md,'SSA','all') + +print(' Set boundary conditions') +md = SetMarineIceSheetBC(md) +md.basalforcings.floatingice_melting_rate = np.zeros(md.mesh.numberofvertices) +md.basalforcings.groundedice_melting_rate = np.zeros(md.mesh.numberofvertices) +md.thermal.spctemperature = md.initialization.temperature +md.masstransport.spcthickness = np.full(md.mesh.numberofvertices, np.nan) + + + + diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/preproc/issm/GRIS/GRIS_control.py b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/preproc/issm/GRIS/GRIS_control.py new file mode 100755 index 0000000000..1646342d38 --- /dev/null +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/preproc/issm/GRIS/GRIS_control.py @@ -0,0 +1,68 @@ +import devpath +import os +ISSM_DIR = os.getenv('ISSM_DIR') # for binaries + +import numpy as np +from model import * +from loadmodel import loadmodel +from setmask import setmask +from parameterize import parameterize +from setflowequation import setflowequation +from clusters.discover_geos import export_discover +from marshall import marshall +from m1qn3inversion import m1qn3inversion + +# Step 2: parameterize model +md = loadmodel('./netcdfs/GRIS_mesh.nc') +md = setmask(md, '', '') +md = parameterize(md, './GRIS_parameterize.py') +md = setflowequation(md, 'SSA', 'all') + +# export parameterization +export_discover(md, "./netcdfs/GRIS_parameterization.nc",delete_rundir=True) + +# Control general +md.inversion = m1qn3inversion() +md.inversion.vx_obs = md.initialization.vx +md.inversion.vy_obs = md.initialization.vy +md.inversion.vel_obs = md.initialization.vel + +md.inversion.nsteps = 100 +md.inversion.iscontrol=1 +md.inversion.maxsteps=100 +md.inversion.maxiter=100 +md.inversion.dxmin=0.01 +md.inversion.gttol=1.0e-8 + +md.inversion.step_threshold = 0.99 * np.ones((md.inversion.nsteps)) +md.inversion.maxiter_per_step = 40 * np.ones((md.inversion.nsteps)) + +md.inversion.gradient_scaling = 50 * np.ones((md.inversion.nsteps, 1)) +md.inversion.min_parameters = 1 * np.ones((md.mesh.numberofvertices, 1)) +md.inversion.max_parameters = 200 * np.ones((md.mesh.numberofvertices, 1)) + +#Cost functions +md.inversion.cost_functions = [101, 103, 501] +md.inversion.cost_functions_coefficients = np.ones((md.mesh.numberofvertices, 3)) +md.inversion.cost_functions_coefficients[:, 0] = 1 +md.inversion.cost_functions_coefficients[:, 1] = 1 +md.inversion.cost_functions_coefficients[:, 2] = 2e-10 + +# Controls +md.inversion.control_parameters = ['FrictionCoefficient'] +md.inversion.min_parameters=1*np.ones(np.shape(md.mesh.x)) +md.inversion.max_parameters=200*np.ones(np.shape(md.mesh.x)) + +# Additional parameters +md.stressbalance.restol=1.0e-12 +md.stressbalance.reltol=1.0e-12 +md.stressbalance.abstol=np.nan + +# Solve +md.private.solution = 'Stressbalance' +md.settings.waitonlock = 0 +md.toolkits.ToolkitsFile('ISSM_'+md.miscellaneous.name + '.toolkits') +marshall(md,'ISSM_'+md.miscellaneous.name+'.bin') + +# export configuration for loading solution in next step +export_discover(md,'./netcdfs/GRIS_inversion.nc',delete_rundir=True) diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/preproc/issm/GRIS/GRIS_finalize.py b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/preproc/issm/GRIS/GRIS_finalize.py new file mode 100755 index 0000000000..37d1c12caa --- /dev/null +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/preproc/issm/GRIS/GRIS_finalize.py @@ -0,0 +1,31 @@ +import devpath +import os +ISSM_DIR = os.getenv('ISSM_DIR') # for binaries + +from model import * +from loadmodel import loadmodel +from clusters.discover_geos import export_discover +from loadresultsfromdisk import loadresultsfromdisk +from marshall import marshall +from verbose import verbose + +md = loadmodel('./netcdfs/GRIS_inversion.nc') +md = loadresultsfromdisk(md,'ISSM_GRIS.outbin') +md.friction.coefficient = md.results.StressbalanceSolution.FrictionCoefficient + + +# Write the binary input file +# Additional options +md.inversion.iscontrol = 0 +md.stressbalance.restol=1.0e-12 +md.stressbalance.reltol=1.0e-12 +md.transient.requested_outputs = ['default'] +md.transient.isthermal=0 +md.settings.waitonlock = 0 +md.private.solution = 'Transient' +md.verbose = verbose('000000000') +md.toolkits = toolkits() +marshall(md,'ISSM_'+md.miscellaneous.name+'.bin') # create .bin file +md.toolkits.ToolkitsFile('ISSM_'+md.miscellaneous.name + '.toolkits') +export_discover(md,'./netcdfs/GRIS_initialization.nc',delete_rundir=True) + diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/preproc/issm/GRIS/GRIS_meshgen.py b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/preproc/issm/GRIS/GRIS_meshgen.py new file mode 100644 index 0000000000..4898354df9 --- /dev/null +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/preproc/issm/GRIS/GRIS_meshgen.py @@ -0,0 +1,55 @@ +import devpath +import sys,os +import numpy as np +from triangle import triangle +from model import * +from netCDF4 import Dataset +from InterpFromGridToMesh import InterpFromGridToMesh +from bamg import bamg +from xy2ll import xy2ll +from ll2xy import ll2xy +from clusters.discover_geos import export_discover + +if not os.path.exists('./netcdfs'): + os.mkdir('./netcdfs') + +h_max = sys.argv[1] if len(sys.argv) > 1 else 24000 +h_min = sys.argv[2] if len(sys.argv) > 2 else 2000 +h_max = float(h_max) +h_min = float(h_min) + +print(f'h_max: {h_max}') +print(f'h_min: {h_min}') + +# Step 1: Mesh generation +#Generate initial uniform mesh (resolution = 20000 m) +# project mesh onto new coordinate system +md = triangle(model(), '/discover/nobackup/projects/gmao/bcs_shared/preprocessing_bcs_inputs/landice/issm/v1/GRIS/GreenlandOutline.exp', 20000) +[md.mesh.lat, md.mesh.long] = xy2ll(md.mesh.x, md.mesh.y, + 1, 39, 71) +[xi, yi] = ll2xy(md.mesh.lat, md.mesh.long, + 1, 45, 70) +md.mesh.x = xi +md.mesh.y = yi + +ncdata_vx = Dataset('/discover/nobackup/projects/gmao/bcs_shared/preprocessing_bcs_inputs/landice/issm/v1/GRIS/greenland_vel_mosaic200_2017_2018_vx_v02.1.nc', mode='r') +ncdata_vy = Dataset('/discover/nobackup/projects/gmao/bcs_shared/preprocessing_bcs_inputs/landice/issm/v1/GRIS/greenland_vel_mosaic200_2017_2018_vy_v02.1.nc', mode='r') + +# Get velocities (Note: You can use ncprint('file') to see an ncdump) +x1 = np.squeeze(ncdata_vx.variables['x'][:].data) +y1 = np.squeeze(ncdata_vx.variables['y'][:].data) +velx = np.squeeze(ncdata_vx.variables['Band1'][:].data) +vely = np.squeeze(ncdata_vy.variables['Band1'][:].data) +ncdata_vx.close() +ncdata_vy.close() + +velx[np.abs(velx)>1e9] = 0 +vely[np.abs(vely)>1e9] = 0 + +vx = InterpFromGridToMesh(x1, y1, velx, md.mesh.x, md.mesh.y, 0) +vy = InterpFromGridToMesh(x1, y1, vely, md.mesh.x, md.mesh.y, 0) +speed = np.sqrt(vx**2 + vy**2) + +# Mesh Greenland (refine according to flow speed) +md = bamg(md, 'hmax', h_max, 'hmin', h_min, 'gradation', 1.4, 'field', speed, 'err', 8) + +# export mesh +export_discover(md, './netcdfs/GRIS_mesh.nc') diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/preproc/issm/GRIS/GRIS_parameterize.py b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/preproc/issm/GRIS/GRIS_parameterize.py new file mode 100755 index 0000000000..292984656b --- /dev/null +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/preproc/issm/GRIS/GRIS_parameterize.py @@ -0,0 +1,126 @@ +import numpy as np +from paterson import paterson +from netCDF4 import Dataset +from ll2xy import ll2xy +from xy2ll import xy2ll +from InterpFromGridToMesh import InterpFromGridToMesh +from SetIceSheetBC import SetIceSheetBC +from pathlib import Path + +#Name and Coordinate system +md.miscellaneous.name = "GRIS" +md.mesh.epsg = 3413 + +# interpolate velocities +ncdata_x = Dataset('/discover/nobackup/projects/gmao/bcs_shared/preprocessing_bcs_inputs/landice/issm/v1/GRIS/greenland_vel_mosaic200_2017_2018_vx_v02.1.nc', mode='r') +ncdata_y = Dataset('/discover/nobackup/projects/gmao/bcs_shared/preprocessing_bcs_inputs/landice/issm/v1/GRIS/greenland_vel_mosaic200_2017_2018_vy_v02.1.nc', mode='r') + +x1 = np.squeeze(ncdata_x.variables['x'][:].data) +y1 = np.squeeze(ncdata_x.variables['y'][:].data) +velx = np.squeeze(ncdata_x.variables['Band1'][:].data) +vely = np.squeeze(ncdata_y.variables['Band1'][:].data) +ncdata_x.close() +ncdata_y.close() + +# set missing data points to zero??? +velx[np.abs(velx)>1e9] = 0 +vely[np.abs(vely)>1e9] = 0 + +vx = InterpFromGridToMesh(x1, y1, velx, md.mesh.x, md.mesh.y, 0) +vy = InterpFromGridToMesh(x1, y1, vely, md.mesh.x, md.mesh.y, 0) +speed = np.sqrt(vx**2 + vy**2) + +md.initialization.vx = vx +md.initialization.vy = vy +md.initialization.vz = np.zeros((md.mesh.numberofvertices)) +md.initialization.vel = speed + +md.inversion.vx_obs = vx +md.inversion.vy_obs = vy +md.inversion.vel_obs = speed + +# initialize ice thickness +ncdata_H = Dataset('/discover/nobackup/projects/gmao/bcs_shared/preprocessing_bcs_inputs/landice/issm/v1/GRIS/BedMachineGreenland-v5.nc', mode='r') +H = np.flipud(ncdata_H['thickness'][:].data.astype(np.float64)) +surf = np.flipud(ncdata_H['surface'][:].data.astype(np.float64)) +bed = np.flipud(ncdata_H['bed'][:].data.astype(np.float64)) +x1 = ncdata_H['x'][:].data.astype(np.float64) +y1 = np.flipud(ncdata_H['y'][:].data.astype(np.float64)) +ncdata_H.close() + +md.geometry.base = InterpFromGridToMesh(x1, y1, bed, md.mesh.x, md.mesh.y, 0) +md.geometry.surface = InterpFromGridToMesh(x1, y1, surf, md.mesh.x, md.mesh.y, 0) + +md.geometry.thickness = md.geometry.surface - md.geometry.base + +#Set min thickness to 1 meter +pos0 = np.nonzero(md.geometry.thickness <= 0) +md.geometry.thickness[pos0] = 1 +md.geometry.surface = md.geometry.thickness + md.geometry.base + + #-------------------------------------------------- + ## EDITS +## Project mesh onto old coordinate system temporarily +[md.mesh.lat, md.mesh.long] = xy2ll(md.mesh.x, md.mesh.y, + 1, 45, 70) +[xi, yi] = ll2xy(md.mesh.lat, md.mesh.long, + 1, 39, 71) +md.mesh.x = xi +md.mesh.y = yi + +ncdata = Dataset('/discover/nobackup/projects/gmao/bcs_shared/preprocessing_bcs_inputs/landice/issm/v1/GRIS/Greenland_5km_dev1.2.nc', mode='r') +x1 = np.squeeze(ncdata.variables['x1'][:].data) +y1 = np.squeeze(ncdata.variables['y1'][:].data) +usrf = np.squeeze(ncdata.variables['usrf'][:].data) +topg = np.squeeze(ncdata.variables['topg'][:].data) +velx = np.squeeze(ncdata.variables['surfvelx'][:].data) +vely = np.squeeze(ncdata.variables['surfvely'][:].data) +temp = np.squeeze(ncdata.variables['airtemp2m'][:].data) +smb = np.squeeze(ncdata.variables['smb'][:].data) +gflux = np.squeeze(ncdata.variables['bheatflx'][:].data) +ncdata.close() + +# initialize temperature +md.initialization.temperature = InterpFromGridToMesh(x1, y1, temp, md.mesh.x, md.mesh.y, 0) + 273.15 + +# impose observed temperature on surface +md.thermal.spctemperature = md.initialization.temperature +md.masstransport.spcthickness = np.nan * np.ones((md.mesh.numberofvertices)) + +# initialize surface mass balance (zero smb example) +md.smb.mass_balance = InterpFromGridToMesh(x1, y1, smb, md.mesh.x, md.mesh.y, 0) +md.smb.mass_balance = md.smb.mass_balance * md.materials.rho_water / md.materials.rho_ice + +# initialize basal friction +md.friction.coefficient = 30 * np.ones((md.mesh.numberofvertices)) +pos = np.nonzero(md.mask.ocean_levelset < 0) +md.friction.coefficient[pos] = 0 #no friction applied on floating ice +md.friction.p = np.ones((md.mesh.numberofelements)) +md.friction.q = np.ones((md.mesh.numberofelements)) + +# initialize ice rheology +md.materials.rheology_n = 3 * np.ones((md.mesh.numberofelements)) +md.materials.rheology_B = paterson(md.initialization.temperature) + +# set geothermal heat flux +md.basalforcings.geothermalflux = InterpFromGridToMesh(x1, y1, gflux, md.mesh.x, md.mesh.y, 0) + +# set other boundary conditions +md.mask.ice_levelset[np.nonzero(md.mesh.vertexonboundary == 1)] = 0 +md.basalforcings.floatingice_melting_rate = np.zeros((md.mesh.numberofvertices)) +md.basalforcings.groundedice_melting_rate = np.zeros((md.mesh.numberofvertices)) + +# initialize pressure +md.initialization.pressure = md.materials.rho_ice * md.constants.g * md.geometry.thickness + +# initialize single point constraints +md.stressbalance.referential = np.nan * np.ones((md.mesh.numberofvertices, 6)) +md.stressbalance.spcvx = np.nan * np.ones((md.mesh.numberofvertices)) +md.stressbalance.spcvy = np.nan * np.ones((md.mesh.numberofvertices)) +md.stressbalance.spcvz = np.nan * np.ones((md.mesh.numberofvertices)) + +## Re-project mesh onto coordinate system +[md.mesh.lat, md.mesh.long] = xy2ll(md.mesh.x, md.mesh.y, + 1, 39, 71) +[xi, yi] = ll2xy(md.mesh.lat, md.mesh.long, + 1, 45, 70) +md.mesh.x = xi +md.mesh.y = yi + +md = SetIceSheetBC(md) diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/preproc/issm/README.txt b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/preproc/issm/README.txt new file mode 100644 index 0000000000..c2ec8e5f6c --- /dev/null +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/preproc/issm/README.txt @@ -0,0 +1,59 @@ +generate_issm_bcs.sh creates ISSM input files (ISSM*.bin and ISSM*.toolkits) to be used in GEOS. +The "ISSM" prefix is used to make sure ISSM doesn't inadvertently try to read other binary files. +Run via: sbatch generate_issm_bcs.sh h_max h_min +where the (optional) arguments h_min and h_max are (approximately) the maxium and minumum element +edge length in meters, respectively. The default arguments are h_max=24000 and h_min=2000. + +Default example is produced with: + +sbatch generate_issm_bcs.sh + +Data is read from: /discover/nobackup/projects/gmao/bcs_shared/preprocessing_bcs_inputs/landice/issm/v1/ +That directory is organized into AIS (Antarctica) and GRIS (Greenland) subdirectories. + +Output is currently archived here: +/discover/nobackup/projects/gmao/bcs_shared/make_bcs_inputs/landice/issm/v1/ + +There is only one resolution for v1 ISSM BCs, ISSM_ME23083_N34534_AIS_GRIS. +The domain naming convention (ISSM_ME*_N*...) is described below. + +The script finds all subdirectories containing files of the form: +glaciername/glaciername_meshgen.py +glaciername/glaciername_parameterize.py +glaciername/glaciername_control.py +glaciername/glaciername_finalize.py + +where "glaciername" (e.g., AIS, GRIS, etc...) is the name of the subdirectory. + +The subdirectories can be nested or organized in any way (i.e., directories without the required +python files are passed over), so future development could add a structure like: + +iceland/vatnajokull/vatnajokull*.py +iceland/snaefellsjokull/snaefellsjokull*.py +... + +Upon running the required python files, two files will be produced for each glacier found: +ISSM_glaciername.bin and ISSM_glaciername.toolkits + +The bin file contains the mesh, boundary conditions, physical parameters, etc., while the toolkits +file contains configuration options for external packages (usually just PETSc solver options). + +The script then calls utils_issm/domain_name.py, which calculates the mean length of every triangle +edge across all glaciers (i.e. mean node spacing) and calculates the total number of nodes. + +A domain name is then prescribed as: + +ISSM_ME{ mean edge length }_N{ total nodes }_{ top-level glacier names separated by _ } + +*The mean edge length (in meters) is rounded to the nearest meter. + +*Top-level glacier names are those that exist at the issm directory level. In the iceland example + above, iceland would appear in domain_name while vatnajokull and snaefellsjokull would not. + +Currently, the generated domain name is: ISSM_ME23083_N34534_AIS_GRIS + +Finally, the script creates a directory with this domain name and copies all ISSM*.bin and +ISSM*toolkits files there. + + + diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/preproc/issm/generate_issm_bcs.sh b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/preproc/issm/generate_issm_bcs.sh new file mode 100755 index 0000000000..f65800da62 --- /dev/null +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/preproc/issm/generate_issm_bcs.sh @@ -0,0 +1,65 @@ +#!/bin/bash +#SBATCH --job-name=preproc_issm +#SBATCH --time=1:00:00 +#SBATCH --ntasks=126 +#SBATCH --qos=debug +#SBATCH --constraint=mil + +h_max=${1:-24000} +h_min=${2:-2000} + +find . -mindepth 1 -type d ! -name utils_issm -exec bash -c ' +h_max="$1" +h_min="$2" +shift 2 + +for dir do +( + hdir=$(pwd) + cd "$dir" || exit + name=$(basename "$dir") + + for f in "${name}_meshgen.py" "${name}_parameterize.py" "${name}_control.py" "${name}_finalize.py"; do + [[ -f "$f" ]] || exit + done + + source "$hdir/issm_env" + rm -f ISSM_${name}.bin ISSM_${name}.outbin ISSM_${name}.errlog + rm -rf netcdfs + (export LD_LIBRARY_PATH=$PYTHON_LIB:$LD_LIBRARY_PATH; python ${name}_meshgen.py "$h_max" "$h_min") + (export LD_LIBRARY_PATH=$PYTHON_LIB:$LD_LIBRARY_PATH; python ${name}_control.py) + + if [ -n "$SLURM_JOB_ID" ]; then + mpirun -np $SLURM_NTASKS ${ISSM_DIR}/bin/issm.exe StressbalanceSolution $(pwd) ISSM_${name} 2>> ISSM_${name}.errlog + else + ${ISSM_DIR}/bin/issm.exe StressbalanceSolution $(pwd) ISSM_${name} 2>> ISSM_${name}.errlog + fi + + (export LD_LIBRARY_PATH=$PYTHON_LIB:$LD_LIBRARY_PATH; python ${name}_finalize.py) +) +done +' bash "$h_max" "$h_min" {} + + +source issm_env +domain_name=$( + LD_LIBRARY_PATH="$PYTHON_LIB:$LD_LIBRARY_PATH" \ + python ./utils_issm/domain_name.py +) + +rm -rf "$domain_name" && mkdir "$domain_name" + +find . -type f -name "ISSM*.bin" -not -path "./ISSM_ME*/*" -exec cp -t "$domain_name" {} + +find . -type f -name "ISSM*.toolkits" -not -path "./ISSM_ME*/*" -exec cp -t "$domain_name" {} + + +cp ISSM_MESH.nc "$domain_name" + +echo "" +echo "================================================================================================================" +echo "Created ISSM BCs!" +echo "" +echo "Domain name: $domain_name" +echo "(ME=mean edge length [meters], N = total nodes)" +echo "" +echo "ISSM BCs copied to $(pwd)/$domain_name" +echo "================================================================================================================" +echo "" diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/preproc/issm/issm_env b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/preproc/issm/issm_env new file mode 100755 index 0000000000..3b24aabde8 --- /dev/null +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/preproc/issm/issm_env @@ -0,0 +1,11 @@ +#ISSM +module purge +source /discover/nobackup/mathomp4/SystemTests/builds/AGCM/CURRENT/GEOSgcm/@env/g5_modules.sh +export ISSM_ARCH="linux-gnu-amd64" +export ISSM_DIR=$ISSM_ROOT_DIR +export PATH="$PATH:$ISSM_DIR/scripts:/usr/include:/usr/lib64:/usr/lib" +export PYTHONPATH="$PYTHONPATH:$ISSM_DIR/src/m/dev" +export PYTHON_LIB="$(python -c "import sys; print(sys.prefix)")/lib/" +export LD_LIBRARY_PATH=$LD_LIBRARY_PATH:$ISSM_DIR/lib +source $ISSM_DIR/etc/environment.sh + diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/preproc/issm/utils_issm/domain_name.py b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/preproc/issm/utils_issm/domain_name.py new file mode 100644 index 0000000000..8e1d2802f8 --- /dev/null +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/preproc/issm/utils_issm/domain_name.py @@ -0,0 +1,135 @@ +import devpath +import numpy as np +import os,sys +from pathlib import Path +from contextlib import redirect_stdout +from netCDF4 import Dataset +ISSM_DIR = os.getenv('ISSM_DIR') # for binaries + +from model import * +from loadmodel import loadmodel + +num_nodes = np.array([ ]) +num_edges = np.array([ ]) +mean_edges = np.array([ ]) + +# node coordinates +nodeCoords_lon = np.array([]) +nodeCoords_lat = np.array([]) + +# element connectivity +elementConn_n1 = np.array([]) +elementConn_n2 = np.array([]) +elementConn_n3 = np.array([]) + + +# find all subdirectories with python code +ROOT = Path(".").resolve() +EXCLUDE = (ROOT / "utils_issm").resolve() + +models = sorted({ + str(p.parent) + for p in ROOT.rglob("*.py") + if EXCLUDE not in p.resolve().parents + and p.parent != ROOT + and not any(part.startswith(".") for part in p.relative_to(ROOT).parts) +}) + +# top-level glacier names +model_names = sorted({Path(p).relative_to(ROOT).parts[0] for p in models}) + +i=0 +for model in models: + with open(os.devnull, "w") as f: + with redirect_stdout(f): + md = loadmodel(f'{model}/netcdfs/{model_names[i]}_initialization.nc') + + v1_idx = md.mesh.edges[:,0]-1 + v2_idx = md.mesh.edges[:,1]-1 + + v1_x = md.mesh.x[v1_idx] + v1_y = md.mesh.y[v1_idx] + + v2_x = md.mesh.x[v2_idx] + v2_y = md.mesh.y[v2_idx] + + edge_lengths = np.sqrt((v1_x-v2_x)**2 + (v1_y-v2_y)**2) + mean_edge_length = np.mean(edge_lengths) + # print(f'mean edge length: {int(np.ceil(mean_edge_length))} m') + # print(f'number of edges: {v1_x.size}') + # print(f'number of nodes: {md.mesh.x.size}') + # print('\n') + + nodeCoords_lon = np.append(nodeCoords_lon,md.mesh.long) + nodeCoords_lat = np.append(nodeCoords_lat,md.mesh.lat) + + # shift nodeIds by total number of nodes from previous models + elementConn_n1 = np.append(elementConn_n1,md.mesh.elements[:,0] - 1 + np.sum(num_nodes) ) + elementConn_n2 = np.append(elementConn_n2,md.mesh.elements[:,1] - 1 + np.sum(num_nodes) ) + elementConn_n3 = np.append(elementConn_n3,md.mesh.elements[:,2] - 1 + np.sum(num_nodes) ) + + num_edges = np.append(num_edges,[v1_x.size]) + num_nodes = np.append(num_nodes,[md.mesh.x.size]) + mean_edges = np.append(mean_edges,[mean_edge_length]) + i += 1 + +nodeCoords = np.column_stack((nodeCoords_lon, nodeCoords_lat)) +elementConn = np.column_stack((elementConn_n1, elementConn_n2,elementConn_n3)) + +#print(nodeCoords.shape) + +global_mean = 0 +total_nodes = int(np.sum(num_nodes)) +total_edges = int(np.sum(num_edges)) +# print(f'total nodes: {total_nodes}') +for j in range(np.size(num_nodes)): + global_mean += num_edges[j]*mean_edges[j]/total_edges + +global_mean = int(np.round(global_mean,0)) + +#print(f'mean edge length method: {global_mean} m') + +#print('\n') +#print('============================================================') +#print(f'Domain name:) +print(f'ISSM_ME{global_mean}_N{total_nodes}_{"_".join(model_names)}') +#print('============================================================') + + +N = nodeCoords.shape[0] +M = elementConn.shape[0] + +with Dataset("ISSM_MESH.nc", "w", format="NETCDF4") as nc: + + # --- Dimensions --- + nc.createDimension("nNodes", N) + nc.createDimension("nElements", M) + nc.createDimension("nVertices", 3) # triangles + + # --- Mesh topology variable (UGRID convention) --- + mesh = nc.createVariable("mesh", "i4") + mesh.cf_role = "mesh_topology" + mesh.topology_dimension = 2 + mesh.node_coordinates = "node_lon node_lat" + mesh.face_node_connectivity = "element_conn" + + # --- Node coordinates --- + node_lon = nc.createVariable("node_lon", "f8", ("nNodes",)) + node_lon.standard_name = "longitude" + node_lon.units = "degrees_east" + node_lon[:] = nodeCoords[:, 0] + + node_lat = nc.createVariable("node_lat", "f8", ("nNodes",)) + node_lat.standard_name = "latitude" + node_lat.units = "degrees_north" + node_lat[:] = nodeCoords[:, 1] + + # --- Element connectivity --- + conn = nc.createVariable("element_conn", "i4", ("nElements", "nVertices")) + conn.cf_role = "face_node_connectivity" + conn.start_index = 0 # 0-based indexing + conn[:] = elementConn + + # --- Global attributes --- + nc.Conventions = "UGRID-1.0" + diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/preproc/issm/utils_issm/meshgenie.sh b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/preproc/issm/utils_issm/meshgenie.sh new file mode 100755 index 0000000000..d81f16d93c --- /dev/null +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/preproc/issm/utils_issm/meshgenie.sh @@ -0,0 +1,53 @@ +#!/bin/bash +# +# simple script for generating issm meshes at different resolutions +# + +SCRIPT_DIR=$( cd -- "$( dirname -- "${BASH_SOURCE[0]}" )" &> /dev/null && pwd ) +cd $SCRIPT_DIR +cd ../ + +h_max=$1 +h_min=$2 + + +find . -mindepth 1 -type d ! -name utils_issm -exec bash -c ' +h_max="$1" +h_min="$2" +shift 2 + +for dir do +( + hdir=$(pwd) + cd "$dir" || exit + name=$(basename "$dir") + + for f in "${name}_meshgen.py" "${name}_parameterize.py" "${name}_control.py" "${name}_finalize.py"; do + [[ -f "$f" ]] || exit + done + + source "$hdir/issm_env" + rm -f ISSM_${name}.bin ISSM_${name}.outbin ISSM_${name}.errlog + rm -rf netcdfs + + (export LD_LIBRARY_PATH=$PYTHON_LIB:$LD_LIBRARY_PATH; python ${name}_meshgen.py "$h_max" "$h_min") +) +done +' bash "$h_max" "$h_min" {} + + +source issm_env +domain_name=$( + LD_LIBRARY_PATH="$PYTHON_LIB:$LD_LIBRARY_PATH" \ + python ./utils_issm/domain_name.py +) + + +echo "" +echo "================================================================================================================" +echo "Candidate ISSM mesh:" +echo "" +echo "Domain name: $domain_name" +echo "(ME=mean edge length [meters], N = total nodes)" +echo "" +echo "================================================================================================================" +echo "" From 4640babce39b4df99c4733a5c06aa12ac7591cc3 Mon Sep 17 00:00:00 2001 From: Rolf Reichle <54944691+gmao-rreichle@users.noreply.github.com> Date: Fri, 10 Jul 2026 19:57:08 +0200 Subject: [PATCH 34/40] clean up programs etc related to obsolete perl re-gridding package (regrid.pl) (#1157) * removed obsolete program used by regrid.pl (mk_GEOSldasRestarts.F90) * remove more files not needed * removed additional obsolete "regrid" files * removed names of obsolete files from CMakeLists.txt * Remove mk_GEOSldasRestarts.F90 from CMakeLists.txt Removed mk_GEOSldasRestarts.F90 from the list of source files. --------- Co-authored-by: Weiyuan Jiang Co-authored-by: Matt Thompson Co-authored-by: Scott Rabenhorst <53346946+sdrabenh@users.noreply.github.com> --- .../Utils/Raster/makebcs/CMakeLists.txt | 8 - .../Utils/Raster/makebcs/findloc.F90 | 30 - .../Raster/makebcs/mod_process_hres_data.F90 | 4 - .../Utils/mk_restarts/CMakeLists.txt | 6 - .../Utils/mk_restarts/Scale_Catch.F90 | 728 --- .../Utils/mk_restarts/Scale_CatchCN.F90 | 962 ---- .../Utils/mk_restarts/mk_CatchCNRestarts.F90 | 2453 ----------- .../Utils/mk_restarts/mk_CatchRestarts.F90 | 778 ---- .../Utils/mk_restarts/mk_GEOSldasRestarts.F90 | 3917 ----------------- .../Utils/mk_restarts/mk_Restarts | 404 -- .../Utils/mk_restarts/obsolete/catchplt | 25 - .../obsolete/check_land_restarts.pro | 1167 ----- .../mk_restarts/obsolete/mk_catch_restart | 29 - .../mk_restarts/obsolete/mk_catch_restart.F90 | 859 ---- .../mk_restarts/obsolete/mk_vegdyn_restart | 23 - .../obsolete/mk_vegdyn_restart.F90 | 54 - .../Utils/mk_restarts/obsolete/new_catch.ctl | 73 - .../Utils/mk_restarts/obsolete/newcatch.F90 | 91 - .../Utils/mk_restarts/obsolete/newvegdyn.f90 | 57 - .../Utils/mk_restarts/obsolete/old_catch.ctl | 73 - .../mk_restarts/obsolete/replace_params.F90 | 296 -- .../mk_restarts/obsolete/strip_vegdyn.F90 | 78 - 22 files changed, 12115 deletions(-) delete mode 100644 GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/makebcs/findloc.F90 delete mode 100644 GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/mk_restarts/Scale_Catch.F90 delete mode 100755 GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/mk_restarts/Scale_CatchCN.F90 delete mode 100755 GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/mk_restarts/mk_CatchCNRestarts.F90 delete mode 100644 GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/mk_restarts/mk_CatchRestarts.F90 delete mode 100644 GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/mk_restarts/mk_GEOSldasRestarts.F90 delete mode 100755 GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/mk_restarts/mk_Restarts delete mode 100755 GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/mk_restarts/obsolete/catchplt delete mode 100755 GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/mk_restarts/obsolete/check_land_restarts.pro delete mode 100755 GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/mk_restarts/obsolete/mk_catch_restart delete mode 100755 GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/mk_restarts/obsolete/mk_catch_restart.F90 delete mode 100755 GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/mk_restarts/obsolete/mk_vegdyn_restart delete mode 100755 GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/mk_restarts/obsolete/mk_vegdyn_restart.F90 delete mode 100755 GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/mk_restarts/obsolete/new_catch.ctl delete mode 100644 GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/mk_restarts/obsolete/newcatch.F90 delete mode 100644 GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/mk_restarts/obsolete/newvegdyn.f90 delete mode 100755 GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/mk_restarts/obsolete/old_catch.ctl delete mode 100644 GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/mk_restarts/obsolete/replace_params.F90 delete mode 100644 GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/mk_restarts/obsolete/strip_vegdyn.F90 diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/makebcs/CMakeLists.txt b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/makebcs/CMakeLists.txt index 2352325f08..a6b165cd17 100755 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/makebcs/CMakeLists.txt +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/makebcs/CMakeLists.txt @@ -11,18 +11,10 @@ zip.c util.c ) -if(NOT FORTRAN_COMPILER_SUPPORTS_FINDLOC) - list(APPEND srcs findloc.F90) -endif () - set_source_files_properties(mkMITAquaRaster.F90 PROPERTIES COMPILE_FLAGS "${BYTERECLEN}") esma_add_library(${this} SRCS ${srcs} DEPENDENCIES MAPL GEOS_SurfaceShared GEOS_LandShared ESMF::ESMF NetCDF::NetCDF_Fortran OpenMP::OpenMP_Fortran) -if(NOT FORTRAN_COMPILER_SUPPORTS_FINDLOC) - target_compile_definitions(${this} PRIVATE USE_EXTERNAL_FINDLOC) -endif () - # MAT NOTE This should use find_package(ZLIB) but Baselibs currently # confuses find_package(). This is a hack until Baselibs is # reorganized. diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/makebcs/findloc.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/makebcs/findloc.F90 deleted file mode 100644 index ef22a99fda..0000000000 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/makebcs/findloc.F90 +++ /dev/null @@ -1,30 +0,0 @@ -module findloc_mod - - implicit none - - private - public :: findloc - - contains - - function findloc(array, value) - - integer, intent(in) :: array(:) - integer, intent(in) :: value - integer :: findloc(1) - - integer :: num_elements, i - - num_elements = size(array) - - findloc(1) = 0 - do i = 1, num_elements - if (array(i) == value) then - findloc(1) = i - exit - endif - end do - - end function findloc - -end module findloc_mod diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/makebcs/mod_process_hres_data.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/makebcs/mod_process_hres_data.F90 index 6ac2a76b88..56ba60f945 100644 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/makebcs/mod_process_hres_data.F90 +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/makebcs/mod_process_hres_data.F90 @@ -31,10 +31,6 @@ MODULE process_hres_data use lsm_routines, ONLY: sibalb use LogRectRasterizeMod, ONLY: SRTM_maxcat -#if defined USE_EXTERNAL_FINDLOC - use findloc_mod, only: findloc -#endif - implicit none include 'netcdf.inc' diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/mk_restarts/CMakeLists.txt b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/mk_restarts/CMakeLists.txt index ca7f56ea72..1a9989e3e0 100644 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/mk_restarts/CMakeLists.txt +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/mk_restarts/CMakeLists.txt @@ -7,16 +7,11 @@ set(srcs ) set (exe_srcs - Scale_Catch.F90 - Scale_CatchCN.F90 cv_SaltRestart.F90 SaltIntSplitter.F90 SaltImpConverter.F90 mk_CICERestart.F90 - mk_CatchCNRestarts.F90 - mk_CatchRestarts.F90 mk_LakeLandiceSaltRestarts.F90 - mk_GEOSldasRestarts.F90 mk_catchANDcnRestarts.F90 ) @@ -32,7 +27,6 @@ foreach (src ${exe_srcs}) LIBS MAPL GFTL_SHARED::gftl-shared GEOS_SurfaceShared GEOSroute_GridComp GEOS_LandShared GEOS_CatchCNShared ${this}) endforeach () -install(PROGRAMS mk_Restarts DESTINATION bin) foreach (src ${exe_srcs}) string (REGEX REPLACE ".F90" ".x" exe ${src}) string (REGEX REPLACE ".F90" "" lname ${src}) diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/mk_restarts/Scale_Catch.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/mk_restarts/Scale_Catch.F90 deleted file mode 100644 index f792250313..0000000000 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/mk_restarts/Scale_Catch.F90 +++ /dev/null @@ -1,728 +0,0 @@ -#define I_AM_MAIN -#include "MAPL_Generic.h" - -program Scale_Catch - - use MAPL - - use LSM_ROUTINES, ONLY: & - catch_calc_soil_moist, & - catch_calc_tp, & - catch_calc_ght - - USE CATCH_CONSTANTS, ONLY: & - N_GT => CATCH_N_GT, & - DZGT => CATCH_DZGT, & - PEATCLSM_POROS_THRESHOLD - - implicit none - - character(256) :: fname1, fname2, fname3 -#ifndef __GFORTRAN__ - integer :: ftell - external :: ftell -#endif - integer :: bpos, epos, ntiles, n, nargs - integer :: old, new, sca - integer :: iargc - real :: SURFLAY ! (Ganymed-3 and earlier) SURFLAY=20.0 for Old Soil Params - ! (Ganymed-4 and later ) SURFLAY=50.0 for New Soil Params - real :: WEMIN_IN, WEMIN_OUT - character*256 :: arg(6) - - type catch_rst - real, pointer :: bf1(:) - real, pointer :: bf2(:) - real, pointer :: bf3(:) - real, pointer :: vgwmax(:) - real, pointer :: cdcr1(:) - real, pointer :: cdcr2(:) - real, pointer :: psis(:) - real, pointer :: bee(:) - real, pointer :: poros(:) - real, pointer :: wpwet(:) - real, pointer :: cond(:) - real, pointer :: gnu(:) - real, pointer :: ars1(:) - real, pointer :: ars2(:) - real, pointer :: ars3(:) - real, pointer :: ara1(:) - real, pointer :: ara2(:) - real, pointer :: ara3(:) - real, pointer :: ara4(:) - real, pointer :: arw1(:) - real, pointer :: arw2(:) - real, pointer :: arw3(:) - real, pointer :: arw4(:) - real, pointer :: tsa1(:) - real, pointer :: tsa2(:) - real, pointer :: tsb1(:) - real, pointer :: tsb2(:) - real, pointer :: atau(:) - real, pointer :: btau(:) - real, pointer :: ity(:) - real, pointer :: tc(:,:) - real, pointer :: qc(:,:) - real, pointer :: capac(:) - real, pointer :: catdef(:) - real, pointer :: rzexc(:) - real, pointer :: srfexc(:) - real, pointer :: ghtcnt1(:) - real, pointer :: ghtcnt2(:) - real, pointer :: ghtcnt3(:) - real, pointer :: ghtcnt4(:) - real, pointer :: ghtcnt5(:) - real, pointer :: ghtcnt6(:) - real, pointer :: tsurf(:) - real, pointer :: wesnn1(:) - real, pointer :: wesnn2(:) - real, pointer :: wesnn3(:) - real, pointer :: htsnnn1(:) - real, pointer :: htsnnn2(:) - real, pointer :: htsnnn3(:) - real, pointer :: sndzn1(:) - real, pointer :: sndzn2(:) - real, pointer :: sndzn3(:) - real, pointer :: ch(:,:) - real, pointer :: cm(:,:) - real, pointer :: cq(:,:) - real, pointer :: fr(:,:) - real, pointer :: ww(:,:) - endtype catch_rst - - type(catch_rst) catch(3) - - real, allocatable, dimension(:) :: dzsf, ar1, ar2, ar4 - real, allocatable, dimension(:,:) :: TP_IN, GHT_IN, FICE, GHT_OUT, TP_OUT - real, allocatable, dimension(:) :: swe_in, depth_in, areasc_in, areasc_out, depth_out - - type(Netcdf4_fileformatter) :: formatter(3) - type(Filemetadata) :: cfg(3) - integer :: i, rc, filetype - integer :: status - character(256) :: Iam = "Scale_Catch" - -! Usage -! ----- - if (iargc() /= 6) then - write(*,*) "Usage: Scale_Catch " - call exit(2) - end if - - do n=1,6 - call getarg(n,arg(n)) - enddo - -! Open INPUT and Regridded Catch Files -! ------------------------------------ - read(arg(1),'(a)') fname1 - - read(arg(2),'(a)') fname2 - -! Open OUTPUT (Scaled) Catch File -! ------------------------------- - read(arg(3),'(a)') fname3 - - call MAPL_NCIOGetFileType(fname1, filetype, __RC__) - - if (filetype == 0) then - call formatter(1)%open(trim(fname1),pFIO_READ, __RC__) - call formatter(2)%open(trim(fname2),pFIO_READ, __RC__) - cfg(1)=formatter(1)%read(__RC__) - cfg(2)=formatter(2)%read(__RC__) - else - open(unit=10, file=trim(fname1), form='unformatted') - open(unit=20, file=trim(fname2), form='unformatted') - open(unit=30, file=trim(fname3), form='unformatted') - end if - -! Get SURFLAY Value -! ----------------- - read(arg(4),*) SURFLAY - read(arg(5),*) WEMIN_IN - read(arg(6),*) WEMIN_OUT - - if (SURFLAY.ne.20 .and. SURFLAY.ne.50) then - print *, "You must supply a valid SURFLAY value:" - print *, "(Ganymed-3 and earlier) SURFLAY=20.0 for Old Soil Params" - print *, "(Ganymed-4 and later ) SURFLAY=50.0 for New Soil Params" - call exit(2) - end if - print *, 'SURFLAY: ',SURFLAY - - if (filetype ==0) then - - ntiles = cfg(1)%get_dimension('tile', __RC__) - - else - -! Determine NTILES -! ---------------- - bpos=0 - read(10) - epos = ftell(10) ! ending position of file pointer - ntiles = (epos-bpos)/4-2 ! record size (in 4 byte words; - rewind 10 - - end if - - write(6,100) ntiles - -! Allocate Catches -! ---------------- - do n=1,3 - call allocatch ( ntiles,catch(n) ) - enddo - -! Read INPUT Catches -! ------------------ - old = 1 - new = 2 - - if (filetype ==0) then - call readcatch_nc4 ( catch(old), formatter(old), __RC__ ) - call readcatch_nc4 ( catch(new), formatter(new), __RC__ ) - else - call readcatch ( 10,catch(old) ) - call readcatch ( 20,catch(new) ) - end if - -! Create Scaled Catch -! ------------------- - sca = 3 - - catch(sca) = catch(new) - -! 1) soil moisture prognostics -! ---------------------------- -! n = count( (catch(old)%catdef .gt. catch(old)%cdcr1) .and. & -! (catch(new)%cdcr2 .gt. catch(old)%cdcr2) ) -! -! write(6,200) n,100*n/ntiles -! -! where( (catch(old)%catdef .gt. catch(old)%cdcr1) .and. & -! (catch(new)%cdcr2 .gt. catch(old)%cdcr2) ) -! -! catch(sca)%rzexc = catch(old)%rzexc * ( catch(new)%vgwmax / & -! catch(old)%vgwmax ) -! -! catch(sca)%catdef = catch(new)%cdcr1 + & -! ( catch(old)%catdef-catch(old)%cdcr1 ) / & -! ( catch(old)%cdcr2 -catch(old)%cdcr1 ) * & -! ( catch(new)%cdcr2 -catch(new)%cdcr1 ) -! end where - - n =count((catch(old)%catdef .gt. catch(old)%cdcr1)) - - write(6,200) n,100*n/ntiles - -! Scale rxexc regardless of CDCR1, CDCR2 differences -! -------------------------------------------------- - catch(sca)%rzexc = catch(old)%rzexc * ( catch(new)%vgwmax / & - catch(old)%vgwmax ) - -! Scale catdef regardless of whether CDCR2 is larger or smaller in the new situation -! ---------------------------------------------------------------------------------- - where (catch(old)%catdef .gt. catch(old)%cdcr1) - - catch(sca)%catdef = catch(new)%cdcr1 + & - ( catch(old)%catdef-catch(old)%cdcr1 ) / & - ( catch(old)%cdcr2 -catch(old)%cdcr1 ) * & - ( catch(new)%cdcr2 -catch(new)%cdcr1 ) - end where - -! Scale catdef also for the case where catdef le cdcr1. -! ----------------------------------------------------- - where( (catch(old)%catdef .le. catch(old)%cdcr1)) - catch(sca)%catdef = catch(old)%catdef * (catch(new)%cdcr1 / catch(old)%cdcr1) - end where - -! Sanity Check (catch_calc_soil_moist() forces consistency betw. srfexc, rzexc, catdef) -! ------------ - print *, 'Performing Sanity Check ...' - allocate ( dzsf(ntiles) ) - allocate ( ar1( ntiles) ) - allocate ( ar2( ntiles) ) - allocate ( ar4( ntiles) ) - - dzsf = SURFLAY - - call catch_calc_soil_moist( ntiles, dzsf, & - catch(sca)%vgwmax, catch(sca)%cdcr1, catch(sca)%cdcr2, & - catch(sca)%psis, catch(sca)%bee, catch(sca)%poros, catch(sca)%wpwet, & - catch(sca)%ars1, catch(sca)%ars2, catch(sca)%ars3, & - catch(sca)%ara1, catch(sca)%ara2, catch(sca)%ara3, catch(sca)%ara4, & - catch(sca)%arw1, catch(sca)%arw2, catch(sca)%arw3, catch(sca)%arw4, & - catch(sca)%bf1, catch(sca)%bf2, & - catch(sca)%srfexc, catch(sca)%rzexc, catch(sca)%catdef, & - ar1, ar2, ar4 ) - - n = count( catch(sca)%catdef .ne. catch(new)%catdef ) - write(6,300) n,100*n/ntiles - n = count( catch(sca)%srfexc .ne. catch(new)%srfexc ) - write(6,400) n,100*n/ntiles - n = count( catch(sca)%rzexc .ne. catch(new)%rzexc ) - write(6,400) n,100*n/ntiles - -! (2) Ground heat -! --------------- - - allocate (TP_IN (N_GT, Ntiles)) - allocate (GHT_IN (N_GT, Ntiles)) - allocate (GHT_OUT(N_GT, Ntiles)) - allocate (FICE (N_GT, NTILES)) - allocate (TP_OUT (N_GT, Ntiles)) - - GHT_IN (1,:) = catch(old)%ghtcnt1 - GHT_IN (2,:) = catch(old)%ghtcnt2 - GHT_IN (3,:) = catch(old)%ghtcnt3 - GHT_IN (4,:) = catch(old)%ghtcnt4 - GHT_IN (5,:) = catch(old)%ghtcnt5 - GHT_IN (6,:) = catch(old)%ghtcnt6 - - call catch_calc_tp ( NTILES, catch(old)%poros, GHT_IN, tp_in, FICE) - GHT_OUT = GHT_IN - -! open (99,file='ght.diff', form = 'formatted') - - do n = 1, ntiles - do i = 1, N_GT - call catch_calc_ght(dzgt(i), catch(new)%poros(n), tp_in(i,n), fice(i,n), GHT_IN(i,n)) -! if (i == N_GT) then -! if (GHT_IN(i,n) /= GHT_OUT(i,n)) write (99,*)n,catch(old)%poros(n),catch(new)%poros(n),ABS(GHT_IN(i,n)-GHT_OUT(i,n)) -! endif - end do - end do - - catch(sca)%ghtcnt1 = GHT_IN (1,:) - catch(sca)%ghtcnt2 = GHT_IN (2,:) - catch(sca)%ghtcnt3 = GHT_IN (3,:) - catch(sca)%ghtcnt4 = GHT_IN (4,:) - catch(sca)%ghtcnt5 = GHT_IN (5,:) - catch(sca)%ghtcnt6 = GHT_IN (6,:) - -! Deep soil temp sanity check -! --------------------------- - - call catch_calc_tp ( NTILES, catch(new)%poros, GHT_IN, tp_out, FICE) - - print *, 'Percent tiles TP Layer 1 differ : ', 100.* count(ABS(tp_out(1,:) - tp_in(1,:)) > 1.e-5) /float (Ntiles) - print *, 'Percent tiles TP Layer 2 differ : ', 100.* count(ABS(tp_out(2,:) - tp_in(2,:)) > 1.e-5) /float (Ntiles) - print *, 'Percent tiles TP Layer 3 differ : ', 100.* count(ABS(tp_out(3,:) - tp_in(3,:)) > 1.e-5) /float (Ntiles) - print *, 'Percent tiles TP Layer 4 differ : ', 100.* count(ABS(tp_out(4,:) - tp_in(4,:)) > 1.e-5) /float (Ntiles) - print *, 'Percent tiles TP Layer 5 differ : ', 100.* count(ABS(tp_out(5,:) - tp_in(5,:)) > 1.e-5) /float (Ntiles) - print *, 'Percent tiles TP Layer 6 differ : ', 100.* count(ABS(tp_out(6,:) - tp_in(6,:)) > 1.e-5) /float (Ntiles) - - -! SNOW scaling -! ------------ - - if(wemin_out /= wemin_in) then - - allocate (swe_in (Ntiles)) - allocate (depth_in (Ntiles)) - allocate (depth_out (Ntiles)) - allocate (areasc_in (Ntiles)) - allocate (areasc_out (Ntiles)) - - swe_in = catch(new)%wesnn1 + catch(new)%wesnn2 + catch(new)%wesnn3 - depth_in = catch(new)%sndzn1 + catch(new)%sndzn2 + catch(new)%sndzn3 - areasc_in = min(swe_in/wemin_in, 1.) - areasc_out= min(swe_in/wemin_out,1.) - - ! catch(sca)%sndzn1=catch(old)%sndzn1 - ! catch(sca)%sndzn2=catch(old)%sndzn2 - ! catch(sca)%sndzn3=catch(old)%sndzn3 - ! do i = 1, ntiles - ! if((swe_in(i) > 0.).and. ((areasc_in(i) < 1.).OR.(areasc_out(i) < 1.))) then - ! print *, i, areasc_in(i), depth_in(i) - ! density_in(i)= swe_in(i)/(areasc_in(i) * depth_in(i)) - ! depth_out(i) = swe_in(i)/(areasc_out(i)*density_in(i)) - ! depth_out(i) = areasc_in(i) * depth_in(i)/(areasc_out(i) + 1.e-20) - ! print *, catch(sca)%sndzn1(i), catch(old)%sndzn1(i),wemin_out/wemin_in - ! catch(sca)%sndzn1(i) = catch(new)%sndzn1(i)*wemin_out/wemin_in ! depth_out(i)/3. - ! catch(sca)%sndzn2(i) = catch(new)%sndzn2(i)*wemin_out/wemin_in ! depth_out(i)/3. - ! catch(sca)%sndzn3(i) = catch(new)%sndzn3(i)*wemin_out/wemin_in ! depth_out(i)/3. - ! endif - ! end do - - where (swe_in .gt. 0.) - where (areasc_in .lt. 1. .or. areasc_out .lt. 1.) - ! density_in= swe_in/(areasc_in * depth_in + 1.e-20) - ! depth_out = swe_in/(areasc_out*density_in) - depth_out = areasc_in * depth_in/(areasc_out + 1.e-20) - catch(sca)%sndzn1 = depth_out/3. - catch(sca)%sndzn2 = depth_out/3. - catch(sca)%sndzn3 = depth_out/3. - endwhere - endwhere - - print *, 'Snow scaling summary' - print *, '....................' - print *, 'Percent tiles SNDZ scaled : ', 100.* count (catch(sca)%sndzn3 .ne. catch(old)%sndzn3) /float (count (catch(sca)%sndzn3 > 0.)) - - endif - - ! PEATCLSM - ensure low CATDEF on peat tiles where "old" restart is not also peat - ! ------------------------------------------------------------------------------- - - where ( (catch(old)%poros < PEATCLSM_POROS_THRESHOLD) .and. (catch(sca)%poros >= PEATCLSM_POROS_THRESHOLD) ) - catch(sca)%catdef = 25. - catch(sca)%rzexc = 0. - catch(sca)%srfexc = 0. - end where - -! Write Scaled Catch -! ------------------ - if (filetype ==0) then - cfg(3)=cfg(2) - call formatter(3)%create(fname3, __RC__) - call formatter(3)%write(cfg(3), __RC__) - call writecatch_nc4 ( catch(sca), formatter(3) ) - else - call writecatch ( 30,catch(sca) ) - end if - -100 format(1x,'Total Tiles: ',i10) -200 format(1x,'Scaled Tiles: ',i10,2x,'(',i2.2,'%)') -300 format(1x,'CatDef Tiles: ',i10,2x,'(',i2.2,'%)') -400 format(1x,'SrfExc Tiles: ',i10,2x,'(',i2.2,'%)') -500 format(1x,' Rzexc Tiles: ',i10,2x,'(',i2.2,'%)') - - stop - - contains - - subroutine allocatch (ntiles,catch) - - integer ntiles - - type(catch_rst) catch - - allocate( catch% bf1(ntiles) ) - allocate( catch% bf2(ntiles) ) - allocate( catch% bf3(ntiles) ) - allocate( catch% vgwmax(ntiles) ) - allocate( catch% cdcr1(ntiles) ) - allocate( catch% cdcr2(ntiles) ) - allocate( catch% psis(ntiles) ) - allocate( catch% bee(ntiles) ) - allocate( catch% poros(ntiles) ) - allocate( catch% wpwet(ntiles) ) - allocate( catch% cond(ntiles) ) - allocate( catch% gnu(ntiles) ) - allocate( catch% ars1(ntiles) ) - allocate( catch% ars2(ntiles) ) - allocate( catch% ars3(ntiles) ) - allocate( catch% ara1(ntiles) ) - allocate( catch% ara2(ntiles) ) - allocate( catch% ara3(ntiles) ) - allocate( catch% ara4(ntiles) ) - allocate( catch% arw1(ntiles) ) - allocate( catch% arw2(ntiles) ) - allocate( catch% arw3(ntiles) ) - allocate( catch% arw4(ntiles) ) - allocate( catch% tsa1(ntiles) ) - allocate( catch% tsa2(ntiles) ) - allocate( catch% tsb1(ntiles) ) - allocate( catch% tsb2(ntiles) ) - allocate( catch% atau(ntiles) ) - allocate( catch% btau(ntiles) ) - allocate( catch% ity(ntiles) ) - allocate( catch% tc(ntiles,4) ) - allocate( catch% qc(ntiles,4) ) - allocate( catch% capac(ntiles) ) - allocate( catch% catdef(ntiles) ) - allocate( catch% rzexc(ntiles) ) - allocate( catch% srfexc(ntiles) ) - allocate( catch% ghtcnt1(ntiles) ) - allocate( catch% ghtcnt2(ntiles) ) - allocate( catch% ghtcnt3(ntiles) ) - allocate( catch% ghtcnt4(ntiles) ) - allocate( catch% ghtcnt5(ntiles) ) - allocate( catch% ghtcnt6(ntiles) ) - allocate( catch% tsurf(ntiles) ) - allocate( catch% wesnn1(ntiles) ) - allocate( catch% wesnn2(ntiles) ) - allocate( catch% wesnn3(ntiles) ) - allocate( catch% htsnnn1(ntiles) ) - allocate( catch% htsnnn2(ntiles) ) - allocate( catch% htsnnn3(ntiles) ) - allocate( catch% sndzn1(ntiles) ) - allocate( catch% sndzn2(ntiles) ) - allocate( catch% sndzn3(ntiles) ) - allocate( catch% ch(ntiles,4) ) - allocate( catch% cm(ntiles,4) ) - allocate( catch% cq(ntiles,4) ) - allocate( catch% fr(ntiles,4) ) - allocate( catch% ww(ntiles,4) ) - - return - end subroutine allocatch - - subroutine readcatch_nc4 (catch,formatter, rc) - type(catch_rst) catch - type(Netcdf4_fileformatter) :: formatter - integer, optional, intent(out) :: rc - integer :: status - character(256) :: Iam = "readcatch_nc4" - - call MAPL_VarRead(formatter,"BF1",catch%bf1, __RC__) - call MAPL_VarRead(formatter,"BF2",catch%bf2, __RC__) - call MAPL_VarRead(formatter,"BF3",catch%bf3, __RC__) - call MAPL_VarRead(formatter,"VGWMAX",catch%vgwmax, __RC__) - call MAPL_VarRead(formatter,"CDCR1",catch%cdcr1, __RC__) - call MAPL_VarRead(formatter,"CDCR2",catch%cdcr2, __RC__) - call MAPL_VarRead(formatter,"PSIS",catch%psis, __RC__) - call MAPL_VarRead(formatter,"BEE",catch%bee, __RC__) - call MAPL_VarRead(formatter,"POROS",catch%poros, __RC__) - call MAPL_VarRead(formatter,"WPWET",catch%wpwet, __RC__) - call MAPL_VarRead(formatter,"COND",catch%cond, __RC__) - call MAPL_VarRead(formatter,"GNU",catch%gnu, __RC__) - call MAPL_VarRead(formatter,"ARS1",catch%ars1, __RC__) - call MAPL_VarRead(formatter,"ARS2",catch%ars2, __RC__) - call MAPL_VarRead(formatter,"ARS3",catch%ars3, __RC__) - call MAPL_VarRead(formatter,"ARA1",catch%ara1, __RC__) - call MAPL_VarRead(formatter,"ARA2",catch%ara2, __RC__) - call MAPL_VarRead(formatter,"ARA3",catch%ara3, __RC__) - call MAPL_VarRead(formatter,"ARA4",catch%ara4, __RC__) - call MAPL_VarRead(formatter,"ARW1",catch%arw1, __RC__) - call MAPL_VarRead(formatter,"ARW2",catch%arw2, __RC__) - call MAPL_VarRead(formatter,"ARW3",catch%arw3, __RC__) - call MAPL_VarRead(formatter,"ARW4",catch%arw4, __RC__) - call MAPL_VarRead(formatter,"TSA1",catch%tsa1, __RC__) - call MAPL_VarRead(formatter,"TSA2",catch%tsa2, __RC__) - call MAPL_VarRead(formatter,"TSB1",catch%tsb1, __RC__) - call MAPL_VarRead(formatter,"TSB2",catch%tsb2, __RC__) - call MAPL_VarRead(formatter,"ATAU",catch%atau, __RC__) - call MAPL_VarRead(formatter,"BTAU",catch%btau, __RC__) - call MAPL_VarRead(formatter,"OLD_ITY",catch%ity, __RC__) - call MAPL_VarRead(formatter,"TC",catch%tc, __RC__) - call MAPL_VarRead(formatter,"QC",catch%qc, __RC__) - call MAPL_VarRead(formatter,"OLD_ITY",catch%ity, __RC__) - call MAPL_VarRead(formatter,"CAPAC",catch%capac, __RC__) - call MAPL_VarRead(formatter,"CATDEF",catch%catdef, __RC__) - call MAPL_VarRead(formatter,"RZEXC",catch%rzexc, __RC__) - call MAPL_VarRead(formatter,"SRFEXC",catch%srfexc, __RC__) - call MAPL_VarRead(formatter,"GHTCNT1",catch%ghtcnt1, __RC__) - call MAPL_VarRead(formatter,"GHTCNT2",catch%ghtcnt2, __RC__) - call MAPL_VarRead(formatter,"GHTCNT3",catch%ghtcnt3, __RC__) - call MAPL_VarRead(formatter,"GHTCNT4",catch%ghtcnt4, __RC__) - call MAPL_VarRead(formatter,"GHTCNT5",catch%ghtcnt5, __RC__) - call MAPL_VarRead(formatter,"GHTCNT6",catch%ghtcnt6, __RC__) - call MAPL_VarRead(formatter,"TSURF",catch%tsurf, __RC__) - call MAPL_VarRead(formatter,"WESNN1",catch%wesnn1, __RC__) - call MAPL_VarRead(formatter,"WESNN2",catch%wesnn2, __RC__) - call MAPL_VarRead(formatter,"WESNN3",catch%wesnn3, __RC__) - call MAPL_VarRead(formatter,"HTSNNN1",catch%htsnnn1, __RC__) - call MAPL_VarRead(formatter,"HTSNNN2",catch%htsnnn2, __RC__) - call MAPL_VarRead(formatter,"HTSNNN3",catch%htsnnn3, __RC__) - call MAPL_VarRead(formatter,"SNDZN1",catch%sndzn1, __RC__) - call MAPL_VarRead(formatter,"SNDZN2",catch%sndzn2, __RC__) - call MAPL_VarRead(formatter,"SNDZN3",catch%sndzn3, __RC__) - call MAPL_VarRead(formatter,"CH",catch%ch, __RC__) - call MAPL_VarRead(formatter,"CM",catch%cm, __RC__) - call MAPL_VarRead(formatter,"CQ",catch%cq, __RC__) - call MAPL_VarRead(formatter,"FR",catch%fr, __RC__) - call MAPL_VarRead(formatter,"WW",catch%ww, __RC__) - if (present(rc)) rc =0 - !_RETURN(_SUCCESS) - end subroutine readcatch_nc4 - - subroutine readcatch (unit,catch) - integer unit - type(catch_rst) catch - - read(unit) catch% bf1 - read(unit) catch% bf2 - read(unit) catch% bf3 - read(unit) catch% vgwmax - read(unit) catch% cdcr1 - read(unit) catch% cdcr2 - read(unit) catch% psis - read(unit) catch% bee - read(unit) catch% poros - read(unit) catch% wpwet - read(unit) catch% cond - read(unit) catch% gnu - read(unit) catch% ars1 - read(unit) catch% ars2 - read(unit) catch% ars3 - read(unit) catch% ara1 - read(unit) catch% ara2 - read(unit) catch% ara3 - read(unit) catch% ara4 - read(unit) catch% arw1 - read(unit) catch% arw2 - read(unit) catch% arw3 - read(unit) catch% arw4 - read(unit) catch% tsa1 - read(unit) catch% tsa2 - read(unit) catch% tsb1 - read(unit) catch% tsb2 - read(unit) catch% atau - read(unit) catch% btau - read(unit) catch% ity - read(unit) catch% tc - read(unit) catch% qc - read(unit) catch% capac - read(unit) catch% catdef - read(unit) catch% rzexc - read(unit) catch% srfexc - read(unit) catch% ghtcnt1 - read(unit) catch% ghtcnt2 - read(unit) catch% ghtcnt3 - read(unit) catch% ghtcnt4 - read(unit) catch% ghtcnt5 - read(unit) catch% ghtcnt6 - read(unit) catch% tsurf - read(unit) catch% wesnn1 - read(unit) catch% wesnn2 - read(unit) catch% wesnn3 - read(unit) catch% htsnnn1 - read(unit) catch% htsnnn2 - read(unit) catch% htsnnn3 - read(unit) catch% sndzn1 - read(unit) catch% sndzn2 - read(unit) catch% sndzn3 - read(unit) catch% ch - read(unit) catch% cm - read(unit) catch% cq - read(unit) catch% fr - read(unit) catch% ww - - return - end subroutine readcatch - - subroutine writecatch_nc4 (catch,formatter) - type(catch_rst) catch - type(Netcdf4_fileformatter) :: formatter - - call MAPL_VarWrite(formatter,"BF1",catch%bf1) - call MAPL_VarWrite(formatter,"BF2",catch%bf2) - call MAPL_VarWrite(formatter,"BF3",catch%bf3) - call MAPL_VarWrite(formatter,"VGWMAX",catch%vgwmax) - call MAPL_VarWrite(formatter,"CDCR1",catch%cdcr1) - call MAPL_VarWrite(formatter,"CDCR2",catch%cdcr2) - call MAPL_VarWrite(formatter,"PSIS",catch%psis) - call MAPL_VarWrite(formatter,"BEE",catch%bee) - call MAPL_VarWrite(formatter,"POROS",catch%poros) - call MAPL_VarWrite(formatter,"WPWET",catch%wpwet) - call MAPL_VarWrite(formatter,"COND",catch%cond) - call MAPL_VarWrite(formatter,"GNU",catch%gnu) - call MAPL_VarWrite(formatter,"ARS1",catch%ars1) - call MAPL_VarWrite(formatter,"ARS2",catch%ars2) - call MAPL_VarWrite(formatter,"ARS3",catch%ars3) - call MAPL_VarWrite(formatter,"ARA1",catch%ara1) - call MAPL_VarWrite(formatter,"ARA2",catch%ara2) - call MAPL_VarWrite(formatter,"ARA3",catch%ara3) - call MAPL_VarWrite(formatter,"ARA4",catch%ara4) - call MAPL_VarWrite(formatter,"ARW1",catch%arw1) - call MAPL_VarWrite(formatter,"ARW2",catch%arw2) - call MAPL_VarWrite(formatter,"ARW3",catch%arw3) - call MAPL_VarWrite(formatter,"ARW4",catch%arw4) - call MAPL_VarWrite(formatter,"TSA1",catch%tsa1) - call MAPL_VarWrite(formatter,"TSA2",catch%tsa2) - call MAPL_VarWrite(formatter,"TSB1",catch%tsb1) - call MAPL_VarWrite(formatter,"TSB2",catch%tsb2) - call MAPL_VarWrite(formatter,"ATAU",catch%atau) - call MAPL_VarWrite(formatter,"BTAU",catch%btau) - call MAPL_VarWrite(formatter,"OLD_ITY",catch%ity) - call MAPL_VarWrite(formatter,"TC",catch%tc) - call MAPL_VarWrite(formatter,"QC",catch%qc) - call MAPL_VarWrite(formatter,"OLD_ITY",catch%ity) - call MAPL_VarWrite(formatter,"CAPAC",catch%capac) - call MAPL_VarWrite(formatter,"CATDEF",catch%catdef) - call MAPL_VarWrite(formatter,"RZEXC",catch%rzexc) - call MAPL_VarWrite(formatter,"SRFEXC",catch%srfexc) - call MAPL_VarWrite(formatter,"GHTCNT1",catch%ghtcnt1) - call MAPL_VarWrite(formatter,"GHTCNT2",catch%ghtcnt2) - call MAPL_VarWrite(formatter,"GHTCNT3",catch%ghtcnt3) - call MAPL_VarWrite(formatter,"GHTCNT4",catch%ghtcnt4) - call MAPL_VarWrite(formatter,"GHTCNT5",catch%ghtcnt5) - call MAPL_VarWrite(formatter,"GHTCNT6",catch%ghtcnt6) - call MAPL_VarWrite(formatter,"TSURF",catch%tsurf) - call MAPL_VarWrite(formatter,"WESNN1",catch%wesnn1) - call MAPL_VarWrite(formatter,"WESNN2",catch%wesnn2) - call MAPL_VarWrite(formatter,"WESNN3",catch%wesnn3) - call MAPL_VarWrite(formatter,"HTSNNN1",catch%htsnnn1) - call MAPL_VarWrite(formatter,"HTSNNN2",catch%htsnnn2) - call MAPL_VarWrite(formatter,"HTSNNN3",catch%htsnnn3) - call MAPL_VarWrite(formatter,"SNDZN1",catch%sndzn1) - call MAPL_VarWrite(formatter,"SNDZN2",catch%sndzn2) - call MAPL_VarWrite(formatter,"SNDZN3",catch%sndzn3) - call MAPL_VarWrite(formatter,"CH",catch%ch) - call MAPL_VarWrite(formatter,"CM",catch%cm) - call MAPL_VarWrite(formatter,"CQ",catch%cq) - call MAPL_VarWrite(formatter,"FR",catch%fr) - call MAPL_VarWrite(formatter,"WW",catch%ww) - - return - end subroutine writecatch_nc4 - - subroutine writecatch (unit,catch) - integer unit - type(catch_rst) catch - - write(unit) catch% bf1 - write(unit) catch% bf2 - write(unit) catch% bf3 - write(unit) catch% vgwmax - write(unit) catch% cdcr1 - write(unit) catch% cdcr2 - write(unit) catch% psis - write(unit) catch% bee - write(unit) catch% poros - write(unit) catch% wpwet - write(unit) catch% cond - write(unit) catch% gnu - write(unit) catch% ars1 - write(unit) catch% ars2 - write(unit) catch% ars3 - write(unit) catch% ara1 - write(unit) catch% ara2 - write(unit) catch% ara3 - write(unit) catch% ara4 - write(unit) catch% arw1 - write(unit) catch% arw2 - write(unit) catch% arw3 - write(unit) catch% arw4 - write(unit) catch% tsa1 - write(unit) catch% tsa2 - write(unit) catch% tsb1 - write(unit) catch% tsb2 - write(unit) catch% atau - write(unit) catch% btau - write(unit) catch% ity - write(unit) catch% tc - write(unit) catch% qc - write(unit) catch% capac - write(unit) catch% catdef - write(unit) catch% rzexc - write(unit) catch% srfexc - write(unit) catch% ghtcnt1 - write(unit) catch% ghtcnt2 - write(unit) catch% ghtcnt3 - write(unit) catch% ghtcnt4 - write(unit) catch% ghtcnt5 - write(unit) catch% ghtcnt6 - write(unit) catch% tsurf - write(unit) catch% wesnn1 - write(unit) catch% wesnn2 - write(unit) catch% wesnn3 - write(unit) catch% htsnnn1 - write(unit) catch% htsnnn2 - write(unit) catch% htsnnn3 - write(unit) catch% sndzn1 - write(unit) catch% sndzn2 - write(unit) catch% sndzn3 - write(unit) catch% ch - write(unit) catch% cm - write(unit) catch% cq - write(unit) catch% fr - write(unit) catch% ww - - return - end subroutine writecatch - - end program diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/mk_restarts/Scale_CatchCN.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/mk_restarts/Scale_CatchCN.F90 deleted file mode 100755 index cd2bce354d..0000000000 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/mk_restarts/Scale_CatchCN.F90 +++ /dev/null @@ -1,962 +0,0 @@ -#define I_AM_MAIN -#include "MAPL_Generic.h" - -program Scale_CatchCN - - use MAPL - - use LSM_ROUTINES, ONLY: & - catch_calc_soil_moist, & - catch_calc_tp, & - catch_calc_ght - - USE CATCH_CONSTANTS, ONLY: & - N_GT => CATCH_N_GT, & - DZGT => CATCH_DZGT, & - PEATCLSM_POROS_THRESHOLD - - implicit none - - character(256) :: fname1, fname2, fname3 -#ifndef __GFORTRAN__ - integer :: ftell - external :: ftell -#endif - integer :: bpos, epos, ntiles, n, nargs - integer :: old, new, sca - integer :: iargc - real :: SURFLAY ! (Ganymed-3 and earlier) SURFLAY=20.0 for Old Soil Params - ! (Ganymed-4 and later ) SURFLAY=50.0 for New Soil Params - real :: WEMIN_IN, WEMIN_OUT - character*256 :: arg(6) - - integer, parameter :: nveg = 4 - integer, parameter :: nzone = 3 - integer :: VAR_COL, VAR_PFT - integer, parameter :: VAR_COL_CLM40 = 40 ! number of CN column restart variables - integer, parameter :: VAR_PFT_CLM40 = 74 ! number of CN PFT variables per column - integer, parameter :: npft = 19 - integer, parameter :: VAR_COL_CLM45 = 35 ! number of CN column restart variables - integer, parameter :: VAR_PFT_CLM45 = 75 ! number of CN PFT variables per column - - logical :: clm45 = .false. - integer :: un_dim3 - - type catch_rst - real, pointer :: bf1(:) - real, pointer :: bf2(:) - real, pointer :: bf3(:) - real, pointer :: vgwmax(:) - real, pointer :: cdcr1(:) - real, pointer :: cdcr2(:) - real, pointer :: psis(:) - real, pointer :: bee(:) - real, pointer :: poros(:) - real, pointer :: wpwet(:) - real, pointer :: cond(:) - real, pointer :: gnu(:) - real, pointer :: ars1(:) - real, pointer :: ars2(:) - real, pointer :: ars3(:) - real, pointer :: ara1(:) - real, pointer :: ara2(:) - real, pointer :: ara3(:) - real, pointer :: ara4(:) - real, pointer :: arw1(:) - real, pointer :: arw2(:) - real, pointer :: arw3(:) - real, pointer :: arw4(:) - real, pointer :: tsa1(:) - real, pointer :: tsa2(:) - real, pointer :: tsb1(:) - real, pointer :: tsb2(:) - real, pointer :: atau(:) - real, pointer :: btau(:) - real, pointer :: ity(:,:) - real, pointer :: fvg(:,:) - real, pointer :: tc(:,:) - real, pointer :: qc(:,:) - real, pointer :: tg(:,:) - real, pointer :: capac(:) - real, pointer :: catdef(:) - real, pointer :: rzexc(:) - real, pointer :: srfexc(:) - real, pointer :: ghtcnt1(:) - real, pointer :: ghtcnt2(:) - real, pointer :: ghtcnt3(:) - real, pointer :: ghtcnt4(:) - real, pointer :: ghtcnt5(:) - real, pointer :: ghtcnt6(:) - real, pointer :: tsurf(:) - real, pointer :: wesnn1(:) - real, pointer :: wesnn2(:) - real, pointer :: wesnn3(:) - real, pointer :: htsnnn1(:) - real, pointer :: htsnnn2(:) - real, pointer :: htsnnn3(:) - real, pointer :: sndzn1(:) - real, pointer :: sndzn2(:) - real, pointer :: sndzn3(:) - real, pointer :: ch(:,:) - real, pointer :: cm(:,:) - real, pointer :: cq(:,:) - real, pointer :: fr(:,:) - real, pointer :: ww(:,:) - real, pointer :: TILE_ID(:) - real, pointer :: ndep(:) - real, pointer :: t2(:) - real, pointer :: BGALBVR(:) - real, pointer :: BGALBVF(:) - real, pointer :: BGALBNR(:) - real, pointer :: BGALBNF(:) - real, pointer :: CNCOL(:,:) - real, pointer :: CNPFT(:,:) - real, pointer :: ABM (:) - real, pointer :: FIELDCAP(:) - real, pointer :: HDM (:) - real, pointer :: GDP (:) - real, pointer :: PEATF (:) - endtype catch_rst - - type(catch_rst) catch(3) - - real, allocatable, dimension(:) :: dzsf, ar1, ar2, ar4 - real, allocatable, dimension(:,:) :: TP_IN, GHT_IN, FICE, GHT_OUT, TP_OUT - real, allocatable, dimension(:) :: swe_in, depth_in, areasc_in, areasc_out, depth_out - - type(Netcdf4_fileformatter) :: formatter(3) - type(Filemetadata) :: cfg(3) - integer :: i, rc, filetype - integer :: status - character(256) :: Iam = "Scale_CatchCN" - -! Usage -! ----- - if (iargc() /= 6) then - write(*,*) "Usage: Scale_CatchCN " - call exit(2) - end if - - do n=1,6 - call getarg(n,arg(n)) - enddo - -! Open INPUT and Regridded Catch Files -! ------------------------------------ - read(arg(1),'(a)') fname1 - - read(arg(2),'(a)') fname2 - -! Open OUTPUT (Scaled) Catch File -! ------------------------------- - read(arg(3),'(a)') fname3 - - call MAPL_NCIOGetFileType(fname1, filetype, __RC__) - - if (filetype == 0) then - call formatter(1)%open(trim(fname1),pFIO_READ, __RC__) - call formatter(2)%open(trim(fname2),pFIO_READ, __RC__) - cfg(1)=formatter(1)%read(__RC__) - cfg(2)=formatter(2)%read(__RC__) - ! else - ! open(unit=10, file=trim(fname1), form='unformatted') - ! open(unit=20, file=trim(fname2), form='unformatted') - ! open(unit=30, file=trim(fname3), form='unformatted') - end if - -! Get SURFLAY Value -! ----------------- - read(arg(4),*) SURFLAY - read(arg(5),*) WEMIN_IN - read(arg(6),*) WEMIN_OUT - - if (SURFLAY.ne.20 .and. SURFLAY.ne.50) then - print *, "You must supply a valid SURFLAY value:" - print *, "(Ganymed-3 and earlier) SURFLAY=20.0 for Old Soil Params" - print *, "(Ganymed-4 and later ) SURFLAY=50.0 for New Soil Params" - call exit(2) - end if - print *, 'SURFLAY: ',SURFLAY - - VAR_COL = VAR_COL_CLM40 - VAR_PFT = VAR_PFT_CLM40 - - if (filetype ==0) then - - ntiles = cfg(1)%get_dimension('tile', __RC__) - un_dim3 = cfg(1)%get_dimension('unknown_dim3', __RC__) - if(un_dim3 == 105) then - clm45 = .true. - VAR_COL = VAR_COL_CLM45 - VAR_PFT = VAR_PFT_CLM45 - print *, 'Processing CLM45 restarts : ', VAR_COL, VAR_PFT, clm45 - else - print *, 'Processing CLM40 restarts : ', VAR_COL, VAR_PFT, clm45 - endif -! else -! -!! Determine NTILES -!! ---------------- -! bpos=0 -! read(10) -! epos = ftell(10) ! ending position of file pointer -! ntiles = (epos-bpos)/4-2 ! record size (in 4 byte words; -! rewind 10 - - end if - - write(6,100) ntiles - -! Allocate Catches -! ---------------- - do n=1,3 - call allocatch ( ntiles,catch(n) ) - enddo - -! Read INPUT Catches -! ------------------ - old = 1 - new = 2 - - if (filetype ==0) then - call readcatchcn_nc4 ( catch(old), formatter(old), cfg(old), __RC__ ) - call readcatchcn_nc4 ( catch(new), formatter(new), cfg(new), __RC__ ) -! else -! call readcatchcn ( 10,catch(old) ) -! call readcatchcn ( 20,catch(new) ) - end if - -! Create Scaled Catch -! ------------------- - sca = 3 - - catch(sca) = catch(new) - -! 1) soil moisture prognostics -! ---------------------------- -! n = count( (catch(old)%catdef .gt. catch(old)%cdcr1) .and. & -! (catch(new)%cdcr2 .gt. catch(old)%cdcr2) ) -! -! write(6,200) n,100*n/ntiles -! -! where( (catch(old)%catdef .gt. catch(old)%cdcr1) .and. & -! (catch(new)%cdcr2 .gt. catch(old)%cdcr2) ) -! -! catch(sca)%rzexc = catch(old)%rzexc * ( catch(new)%vgwmax / & -! catch(old)%vgwmax ) -! -! catch(sca)%catdef = catch(new)%cdcr1 + & -! ( catch(old)%catdef-catch(old)%cdcr1 ) / & -! ( catch(old)%cdcr2 -catch(old)%cdcr1 ) * & -! ( catch(new)%cdcr2 -catch(new)%cdcr1 ) -! end where - - n =count((catch(old)%catdef .gt. catch(old)%cdcr1)) - - write(6,200) n,100*n/ntiles - -! Scale rxexc regardless of CDCR1, CDCR2 differences -! -------------------------------------------------- - catch(sca)%rzexc = catch(old)%rzexc * ( catch(new)%vgwmax / & - catch(old)%vgwmax ) - -! Scale catdef regardless of whether CDCR2 is larger or smaller in the new situation -! ---------------------------------------------------------------------------------- - where (catch(old)%catdef .gt. catch(old)%cdcr1) - - catch(sca)%catdef = catch(new)%cdcr1 + & - ( catch(old)%catdef-catch(old)%cdcr1 ) / & - ( catch(old)%cdcr2 -catch(old)%cdcr1 ) * & - ( catch(new)%cdcr2 -catch(new)%cdcr1 ) - end where - -! Scale catdef also for the case where catdef le cdcr1. -! ----------------------------------------------------- - where( (catch(old)%catdef .le. catch(old)%cdcr1)) - catch(sca)%catdef = catch(old)%catdef * (catch(new)%cdcr1 / catch(old)%cdcr1) - end where - -! Sanity Check (catch_calc_soil_moist() forces consistency betw. srfexc, rzexc, catdef) -! ------------ - print *, 'Performing Sanity Check ...' - allocate ( dzsf(ntiles) ) - allocate ( ar1( ntiles) ) - allocate ( ar2( ntiles) ) - allocate ( ar4( ntiles) ) - - dzsf = SURFLAY - - call catch_calc_soil_moist( ntiles, dzsf, & - catch(sca)%vgwmax, catch(sca)%cdcr1, catch(sca)%cdcr2, & - catch(sca)%psis, catch(sca)%bee, catch(sca)%poros, catch(sca)%wpwet, & - catch(sca)%ars1, catch(sca)%ars2, catch(sca)%ars3, & - catch(sca)%ara1, catch(sca)%ara2, catch(sca)%ara3, catch(sca)%ara4, & - catch(sca)%arw1, catch(sca)%arw2, catch(sca)%arw3, catch(sca)%arw4, & - catch(sca)%bf1, catch(sca)%bf2, & - catch(sca)%srfexc, catch(sca)%rzexc, catch(sca)%catdef, & - ar1, ar2, ar4 ) - - n = count( catch(sca)%catdef .ne. catch(new)%catdef ) - write(6,300) n,100*n/ntiles - n = count( catch(sca)%srfexc .ne. catch(new)%srfexc ) - write(6,400) n,100*n/ntiles - n = count( catch(sca)%rzexc .ne. catch(new)%rzexc ) - write(6,400) n,100*n/ntiles - -! (2) Ground heat -! --------------- - - allocate (TP_IN (N_GT, Ntiles)) - allocate (GHT_IN (N_GT, Ntiles)) - allocate (GHT_OUT(N_GT, Ntiles)) - allocate (FICE (N_GT, NTILES)) - allocate (TP_OUT (N_GT, Ntiles)) - - GHT_IN (1,:) = catch(old)%ghtcnt1 - GHT_IN (2,:) = catch(old)%ghtcnt2 - GHT_IN (3,:) = catch(old)%ghtcnt3 - GHT_IN (4,:) = catch(old)%ghtcnt4 - GHT_IN (5,:) = catch(old)%ghtcnt5 - GHT_IN (6,:) = catch(old)%ghtcnt6 - - call catch_calc_tp ( NTILES, catch(old)%poros, GHT_IN, tp_in, FICE) - GHT_OUT = GHT_IN - -! open (99,file='ght.diff', form = 'formatted') - - do n = 1, ntiles - do i = 1, N_GT - call catch_calc_ght(dzgt(i), catch(new)%poros(n), tp_in(i,n), fice(i,n), GHT_IN(i,n)) -! if (i == N_GT) then -! if (GHT_IN(i,n) /= GHT_OUT(i,n)) write (99,*)n,catch(old)%poros(n),catch(new)%poros(n),ABS(GHT_IN(i,n)-GHT_OUT(i,n)) -! endif - end do - end do - - catch(sca)%ghtcnt1 = GHT_IN (1,:) - catch(sca)%ghtcnt2 = GHT_IN (2,:) - catch(sca)%ghtcnt3 = GHT_IN (3,:) - catch(sca)%ghtcnt4 = GHT_IN (4,:) - catch(sca)%ghtcnt5 = GHT_IN (5,:) - catch(sca)%ghtcnt6 = GHT_IN (6,:) - -! Deep soil temp sanity check -! --------------------------- - - call catch_calc_tp ( NTILES, catch(new)%poros, GHT_IN, tp_out, FICE) - - print *, 'Percent tiles TP Layer 1 differ : ', 100.* count(ABS(tp_out(1,:) - tp_in(1,:)) > 1.e-5) /float (Ntiles) - print *, 'Percent tiles TP Layer 2 differ : ', 100.* count(ABS(tp_out(2,:) - tp_in(2,:)) > 1.e-5) /float (Ntiles) - print *, 'Percent tiles TP Layer 3 differ : ', 100.* count(ABS(tp_out(3,:) - tp_in(3,:)) > 1.e-5) /float (Ntiles) - print *, 'Percent tiles TP Layer 4 differ : ', 100.* count(ABS(tp_out(4,:) - tp_in(4,:)) > 1.e-5) /float (Ntiles) - print *, 'Percent tiles TP Layer 5 differ : ', 100.* count(ABS(tp_out(5,:) - tp_in(5,:)) > 1.e-5) /float (Ntiles) - print *, 'Percent tiles TP Layer 6 differ : ', 100.* count(ABS(tp_out(6,:) - tp_in(6,:)) > 1.e-5) /float (Ntiles) - - -! SNOW scaling -! ------------ - - if(wemin_out /= wemin_in) then - - allocate (swe_in (Ntiles)) - allocate (depth_in (Ntiles)) - allocate (depth_out (Ntiles)) - allocate (areasc_in (Ntiles)) - allocate (areasc_out (Ntiles)) - - swe_in = catch(new)%wesnn1 + catch(new)%wesnn2 + catch(new)%wesnn3 - depth_in = catch(new)%sndzn1 + catch(new)%sndzn2 + catch(new)%sndzn3 - areasc_in = min(swe_in/wemin_in, 1.) - areasc_out= min(swe_in/wemin_out,1.) - - ! catch(sca)%sndzn1=catch(old)%sndzn1 - ! catch(sca)%sndzn2=catch(old)%sndzn2 - ! catch(sca)%sndzn3=catch(old)%sndzn3 - ! do i = 1, ntiles - ! if((swe_in(i) > 0.).and. ((areasc_in(i) < 1.).OR.(areasc_out(i) < 1.))) then - ! print *, i, areasc_in(i), depth_in(i) - ! density_in(i)= swe_in(i)/(areasc_in(i) * depth_in(i)) - ! depth_out(i) = swe_in(i)/(areasc_out(i)*density_in(i)) - ! depth_out(i) = areasc_in(i) * depth_in(i)/(areasc_out(i) + 1.e-20) - ! print *, catch(sca)%sndzn1(i), catch(old)%sndzn1(i),wemin_out/wemin_in - ! catch(sca)%sndzn1(i) = catch(new)%sndzn1(i)*wemin_out/wemin_in ! depth_out(i)/3. - ! catch(sca)%sndzn2(i) = catch(new)%sndzn2(i)*wemin_out/wemin_in ! depth_out(i)/3. - ! catch(sca)%sndzn3(i) = catch(new)%sndzn3(i)*wemin_out/wemin_in ! depth_out(i)/3. - ! endif - ! end do - - where (swe_in .gt. 0.) - where (areasc_in .lt. 1. .or. areasc_out .lt. 1.) - ! density_in= swe_in/(areasc_in * depth_in + 1.e-20) - ! depth_out = swe_in/(areasc_out*density_in) - depth_out = areasc_in * depth_in/(areasc_out + 1.e-20) - catch(sca)%sndzn1 = depth_out/3. - catch(sca)%sndzn2 = depth_out/3. - catch(sca)%sndzn3 = depth_out/3. - endwhere - endwhere - - print *, 'Snow scaling summary' - print *, '....................' - print *, 'Percent tiles SNDZ scaled : ', 100.* count (catch(sca)%sndzn3 .ne. catch(old)%sndzn3) /float (count (catch(sca)%sndzn3 > 0.)) - - endif - - ! PEATCLSM - ensure low CATDEF on peat tiles where "old" restart is not also peat - ! ------------------------------------------------------------------------------- - - where ( (catch(old)%poros < PEATCLSM_POROS_THRESHOLD) .and. (catch(sca)%poros >= PEATCLSM_POROS_THRESHOLD) ) - catch(sca)%catdef = 25. - catch(sca)%rzexc = 0. - catch(sca)%srfexc = 0. - end where - -! Write Scaled Catch -! ------------------ - if (filetype ==0) then - cfg(3)=cfg(2) - call formatter(3)%create(fname3, __RC__) - call formatter(3)%write(cfg(3), __RC__) - call writecatchcn_nc4 ( catch(sca), formatter(3) ,cfg(3) ) -! else -! call writecatchcn ( 30,catch(sca) ) - end if - -100 format(1x,'Total Tiles: ',i10) -200 format(1x,'Scaled Tiles: ',i10,2x,'(',i2.2,'%)') -300 format(1x,'CatDef Tiles: ',i10,2x,'(',i2.2,'%)') -400 format(1x,'SrfExc Tiles: ',i10,2x,'(',i2.2,'%)') -500 format(1x,' Rzexc Tiles: ',i10,2x,'(',i2.2,'%)') - - stop - - contains - - subroutine allocatch (ntiles,catch) - - integer ntiles - - type(catch_rst) catch - - allocate( catch% bf1(ntiles) ) - allocate( catch% bf2(ntiles) ) - allocate( catch% bf3(ntiles) ) - allocate( catch% vgwmax(ntiles) ) - allocate( catch% cdcr1(ntiles) ) - allocate( catch% cdcr2(ntiles) ) - allocate( catch% psis(ntiles) ) - allocate( catch% bee(ntiles) ) - allocate( catch% poros(ntiles) ) - allocate( catch% wpwet(ntiles) ) - allocate( catch% cond(ntiles) ) - allocate( catch% gnu(ntiles) ) - allocate( catch% ars1(ntiles) ) - allocate( catch% ars2(ntiles) ) - allocate( catch% ars3(ntiles) ) - allocate( catch% ara1(ntiles) ) - allocate( catch% ara2(ntiles) ) - allocate( catch% ara3(ntiles) ) - allocate( catch% ara4(ntiles) ) - allocate( catch% arw1(ntiles) ) - allocate( catch% arw2(ntiles) ) - allocate( catch% arw3(ntiles) ) - allocate( catch% arw4(ntiles) ) - allocate( catch% tsa1(ntiles) ) - allocate( catch% tsa2(ntiles) ) - allocate( catch% tsb1(ntiles) ) - allocate( catch% tsb2(ntiles) ) - allocate( catch% atau(ntiles) ) - allocate( catch% btau(ntiles) ) - allocate( catch% ity(ntiles,4) ) - allocate( catch% fvg(ntiles,4) ) - allocate( catch% tc(ntiles,4) ) - allocate( catch% qc(ntiles,4) ) - allocate( catch% tg(ntiles,4) ) - allocate( catch% capac(ntiles) ) - allocate( catch% catdef(ntiles) ) - allocate( catch% rzexc(ntiles) ) - allocate( catch% srfexc(ntiles) ) - allocate( catch% ghtcnt1(ntiles) ) - allocate( catch% ghtcnt2(ntiles) ) - allocate( catch% ghtcnt3(ntiles) ) - allocate( catch% ghtcnt4(ntiles) ) - allocate( catch% ghtcnt5(ntiles) ) - allocate( catch% ghtcnt6(ntiles) ) - allocate( catch% tsurf(ntiles) ) - allocate( catch% wesnn1(ntiles) ) - allocate( catch% wesnn2(ntiles) ) - allocate( catch% wesnn3(ntiles) ) - allocate( catch% htsnnn1(ntiles) ) - allocate( catch% htsnnn2(ntiles) ) - allocate( catch% htsnnn3(ntiles) ) - allocate( catch% sndzn1(ntiles) ) - allocate( catch% sndzn2(ntiles) ) - allocate( catch% sndzn3(ntiles) ) - allocate( catch% ch(ntiles,4) ) - allocate( catch% cm(ntiles,4) ) - allocate( catch% cq(ntiles,4) ) - allocate( catch% fr(ntiles,4) ) - allocate( catch% ww(ntiles,4) ) - allocate( catch% TILE_ID(ntiles) ) - allocate( catch% ndep(ntiles) ) - allocate( catch% t2(ntiles) ) - allocate( catch% BGALBVR(ntiles) ) - allocate( catch% BGALBVF(ntiles) ) - allocate( catch% BGALBNR(ntiles) ) - allocate( catch% BGALBNF(ntiles) ) - allocate( catch% CNCOL(ntiles,nzone*VAR_COL)) - allocate( catch% CNPFT(ntiles,nzone*nveg*VAR_PFT)) - allocate( catch% ABM(ntiles) ) - allocate( catch% FIELDCAP(ntiles) ) - allocate( catch% HDM(ntiles) ) - allocate( catch% GDP(ntiles) ) - allocate( catch% PEATF(ntiles) ) - - return - end subroutine allocatch - - subroutine readcatchcn_nc4 (catch,formatter,cfg, rc) - type(catch_rst) catch - type(Filemetadata) :: cfg - type(Netcdf4_fileformatter) :: formatter - integer, optional, intent(out) :: rc - integer :: j, dim1,dim2 - type(Variable), pointer :: myVariable - character(len=:), pointer :: dname - integer :: status - character(256) :: Iam = "readcatchcn_nc4" - - call MAPL_VarRead(formatter,"BF1",catch%bf1, __RC__) - call MAPL_VarRead(formatter,"BF2",catch%bf2, __RC__) - call MAPL_VarRead(formatter,"BF3",catch%bf3, __RC__) - call MAPL_VarRead(formatter,"VGWMAX",catch%vgwmax, __RC__) - call MAPL_VarRead(formatter,"CDCR1",catch%cdcr1, __RC__) - call MAPL_VarRead(formatter,"CDCR2",catch%cdcr2, __RC__) - call MAPL_VarRead(formatter,"PSIS",catch%psis, __RC__) - call MAPL_VarRead(formatter,"BEE",catch%bee, __RC__) - call MAPL_VarRead(formatter,"POROS",catch%poros, __RC__) - call MAPL_VarRead(formatter,"WPWET",catch%wpwet, __RC__) - call MAPL_VarRead(formatter,"COND",catch%cond, __RC__) - call MAPL_VarRead(formatter,"GNU",catch%gnu, __RC__) - call MAPL_VarRead(formatter,"ARS1",catch%ars1, __RC__) - call MAPL_VarRead(formatter,"ARS2",catch%ars2, __RC__) - call MAPL_VarRead(formatter,"ARS3",catch%ars3, __RC__) - call MAPL_VarRead(formatter,"ARA1",catch%ara1, __RC__) - call MAPL_VarRead(formatter,"ARA2",catch%ara2, __RC__) - call MAPL_VarRead(formatter,"ARA3",catch%ara3, __RC__) - call MAPL_VarRead(formatter,"ARA4",catch%ara4, __RC__) - call MAPL_VarRead(formatter,"ARW1",catch%arw1, __RC__) - call MAPL_VarRead(formatter,"ARW2",catch%arw2, __RC__) - call MAPL_VarRead(formatter,"ARW3",catch%arw3, __RC__) - call MAPL_VarRead(formatter,"ARW4",catch%arw4, __RC__) - call MAPL_VarRead(formatter,"TSA1",catch%tsa1, __RC__) - call MAPL_VarRead(formatter,"TSA2",catch%tsa2, __RC__) - call MAPL_VarRead(formatter,"TSB1",catch%tsb1, __RC__) - call MAPL_VarRead(formatter,"TSB2",catch%tsb2, __RC__) - call MAPL_VarRead(formatter,"ATAU",catch%atau, __RC__) - call MAPL_VarRead(formatter,"BTAU",catch%btau, __RC__) - - myVariable => cfg%get_variable("ITY") - dname => myVariable%get_ith_dimension(2) - dim1 = cfg%get_dimension(dname) - do j=1,dim1 - call MAPL_VarRead(formatter,"ITY",catch%ity(:,j),offset1=j, __RC__) - call MAPL_VarRead(formatter,"FVG",catch%fvg(:,j),offset1=j, __RC__) - enddo - - call MAPL_VarRead(formatter,"TC",catch%tc, __RC__) - call MAPL_VarRead(formatter,"QC",catch%qc, __RC__) - call MAPL_VarRead(formatter,"TG",catch%tg, __RC__) - call MAPL_VarRead(formatter,"CAPAC",catch%capac, __RC__) - call MAPL_VarRead(formatter,"CATDEF",catch%catdef, __RC__) - call MAPL_VarRead(formatter,"RZEXC",catch%rzexc, __RC__) - call MAPL_VarRead(formatter,"SRFEXC",catch%srfexc, __RC__) - call MAPL_VarRead(formatter,"GHTCNT1",catch%ghtcnt1, __RC__) - call MAPL_VarRead(formatter,"GHTCNT2",catch%ghtcnt2, __RC__) - call MAPL_VarRead(formatter,"GHTCNT3",catch%ghtcnt3, __RC__) - call MAPL_VarRead(formatter,"GHTCNT4",catch%ghtcnt4, __RC__) - call MAPL_VarRead(formatter,"GHTCNT5",catch%ghtcnt5, __RC__) - call MAPL_VarRead(formatter,"GHTCNT6",catch%ghtcnt6, __RC__) - call MAPL_VarRead(formatter,"TSURF",catch%tsurf, __RC__) - call MAPL_VarRead(formatter,"WESNN1",catch%wesnn1, __RC__) - call MAPL_VarRead(formatter,"WESNN2",catch%wesnn2, __RC__) - call MAPL_VarRead(formatter,"WESNN3",catch%wesnn3, __RC__) - call MAPL_VarRead(formatter,"HTSNNN1",catch%htsnnn1, __RC__) - call MAPL_VarRead(formatter,"HTSNNN2",catch%htsnnn2, __RC__) - call MAPL_VarRead(formatter,"HTSNNN3",catch%htsnnn3, __RC__) - call MAPL_VarRead(formatter,"SNDZN1",catch%sndzn1, __RC__) - call MAPL_VarRead(formatter,"SNDZN2",catch%sndzn2, __RC__) - call MAPL_VarRead(formatter,"SNDZN3",catch%sndzn3, __RC__) - call MAPL_VarRead(formatter,"CH",catch%ch, __RC__) - call MAPL_VarRead(formatter,"CM",catch%cm, __RC__) - call MAPL_VarRead(formatter,"CQ",catch%cq, __RC__) - call MAPL_VarRead(formatter,"FR",catch%fr, __RC__) - call MAPL_VarRead(formatter,"WW",catch%ww, __RC__) - call MAPL_VarRead(formatter,"TILE_ID",catch%TILE_ID, __RC__) - call MAPL_VarRead(formatter,"NDEP",catch%ndep, __RC__) - call MAPL_VarRead(formatter,"CLI_T2M",catch%t2, __RC__) - call MAPL_VarRead(formatter,"BGALBVR",catch%BGALBVR, __RC__) - call MAPL_VarRead(formatter,"BGALBVF",catch%BGALBVF, __RC__) - call MAPL_VarRead(formatter,"BGALBNR",catch%BGALBNR, __RC__) - call MAPL_VarRead(formatter,"BGALBNF",catch%BGALBNF, __RC__) - myVariable => cfg%get_variable("CNCOL") - dname => myVariable%get_ith_dimension(2) - dim1 = cfg%get_dimension(dname) - if(clm45) then - call MAPL_VarRead(formatter,"ABM", catch%ABM, __RC__) - call MAPL_VarRead(formatter,"FIELDCAP",catch%FIELDCAP, __RC__) - call MAPL_VarRead(formatter,"HDM", catch%HDM , __RC__) - call MAPL_VarRead(formatter,"GDP", catch%GDP , __RC__) - call MAPL_VarRead(formatter,"PEATF", catch%PEATF , __RC__) - endif - do j=1,dim1 - call MAPL_VarRead(formatter,"CNCOL",catch%CNCOL(:,j),offset1=j, __RC__) - enddo - ! The following three lines were added as a bug fix by smahanam on 5 Oct 2020 - ! (to be merged into the "develop" branch in late 2020): - ! The length of the 2nd dim of CNPFT differs from that of CNCOL. Prior to this fix, - ! CNPFT was not read in its entirety and some elements remained uninitialized (or zero), - ! resulting in bad values in the "regridded" (re-tiled) restart file. - ! This impacted re-tiled restarts for both CNCLM40 and CLCLM45. - ! - reichle, 23 Nov 2020 - myVariable => cfg%get_variable("CNPFT") - dname => myVariable%get_ith_dimension(2) - dim1 = cfg%get_dimension(dname) - do j=1,dim1 - call MAPL_VarRead(formatter,"CNPFT",catch%CNPFT(:,j),offset1=j, __RC__) - enddo - if (present(rc)) rc =0 - !_RETURN(_SUCCESS) - end subroutine readcatchcn_nc4 - - subroutine readcatchcn (unit,catch) - integer unit, i,j,n - type(catch_rst) catch - - read(unit) catch% bf1 - read(unit) catch% bf2 - read(unit) catch% bf3 - read(unit) catch% vgwmax - read(unit) catch% cdcr1 - read(unit) catch% cdcr2 - read(unit) catch% psis - read(unit) catch% bee - read(unit) catch% poros - read(unit) catch% wpwet - read(unit) catch% cond - read(unit) catch% gnu - read(unit) catch% ars1 - read(unit) catch% ars2 - read(unit) catch% ars3 - read(unit) catch% ara1 - read(unit) catch% ara2 - read(unit) catch% ara3 - read(unit) catch% ara4 - read(unit) catch% arw1 - read(unit) catch% arw2 - read(unit) catch% arw3 - read(unit) catch% arw4 - read(unit) catch% tsa1 - read(unit) catch% tsa2 - read(unit) catch% tsb1 - read(unit) catch% tsb2 - read(unit) catch% atau - read(unit) catch% btau - read(unit) catch% ity(:,1) - read(unit) catch% ity(:,2) - read(unit) catch% ity(:,3) - read(unit) catch% ity(:,4) - read(unit) catch% fvg(:,1) - read(unit) catch% fvg(:,2) - read(unit) catch% fvg(:,3) - read(unit) catch% fvg(:,4) - read(unit) catch% tc - read(unit) catch% qc - read(unit) catch% tg - read(unit) catch% capac - read(unit) catch% catdef - read(unit) catch% rzexc - read(unit) catch% srfexc - read(unit) catch% ghtcnt1 - read(unit) catch% ghtcnt2 - read(unit) catch% ghtcnt3 - read(unit) catch% ghtcnt4 - read(unit) catch% ghtcnt5 - read(unit) catch% ghtcnt6 - read(unit) catch% tsurf - read(unit) catch% wesnn1 - read(unit) catch% wesnn2 - read(unit) catch% wesnn3 - read(unit) catch% htsnnn1 - read(unit) catch% htsnnn2 - read(unit) catch% htsnnn3 - read(unit) catch% sndzn1 - read(unit) catch% sndzn2 - read(unit) catch% sndzn3 - read(unit) catch% ch - read(unit) catch% cm - read(unit) catch% cq - read(unit) catch% fr - read(unit) catch% ww - read(unit) catch% TILE_ID - read(unit) catch% ndep - read(unit) catch% t2 - read(unit) catch% BGALBVR - read(unit) catch% BGALBVF - read(unit) catch% BGALBNR - read(unit) catch% BGALBNF - - do j = 1,nzone * VAR_COL - read(unit) catch% CNCOL (:,j) - end do - - do i = 1,nzone * nveg * VAR_PFT - read(unit) catch% CNPFT (:,i) - end do - return - end subroutine readcatchcn - - subroutine writecatchcn_nc4 (catch,formatter,cfg) - type(catch_rst) catch - type(Netcdf4_fileformatter) :: formatter - type(filemetadata) :: cfg - integer :: i,j, dim1,dim2 - real, dimension (:), allocatable :: var - type(Variable), pointer :: myVariable - character(len=:), pointer :: dname - - call MAPL_VarWrite(formatter,"BF1",catch%bf1) - call MAPL_VarWrite(formatter,"BF2",catch%bf2) - call MAPL_VarWrite(formatter,"BF3",catch%bf3) - call MAPL_VarWrite(formatter,"VGWMAX",catch%vgwmax) - call MAPL_VarWrite(formatter,"CDCR1",catch%cdcr1) - call MAPL_VarWrite(formatter,"CDCR2",catch%cdcr2) - call MAPL_VarWrite(formatter,"PSIS",catch%psis) - call MAPL_VarWrite(formatter,"BEE",catch%bee) - call MAPL_VarWrite(formatter,"POROS",catch%poros) - call MAPL_VarWrite(formatter,"WPWET",catch%wpwet) - call MAPL_VarWrite(formatter,"COND",catch%cond) - call MAPL_VarWrite(formatter,"GNU",catch%gnu) - call MAPL_VarWrite(formatter,"ARS1",catch%ars1) - call MAPL_VarWrite(formatter,"ARS2",catch%ars2) - call MAPL_VarWrite(formatter,"ARS3",catch%ars3) - call MAPL_VarWrite(formatter,"ARA1",catch%ara1) - call MAPL_VarWrite(formatter,"ARA2",catch%ara2) - call MAPL_VarWrite(formatter,"ARA3",catch%ara3) - call MAPL_VarWrite(formatter,"ARA4",catch%ara4) - call MAPL_VarWrite(formatter,"ARW1",catch%arw1) - call MAPL_VarWrite(formatter,"ARW2",catch%arw2) - call MAPL_VarWrite(formatter,"ARW3",catch%arw3) - call MAPL_VarWrite(formatter,"ARW4",catch%arw4) - call MAPL_VarWrite(formatter,"TSA1",catch%tsa1) - call MAPL_VarWrite(formatter,"TSA2",catch%tsa2) - call MAPL_VarWrite(formatter,"TSB1",catch%tsb1) - call MAPL_VarWrite(formatter,"TSB2",catch%tsb2) - call MAPL_VarWrite(formatter,"ATAU",catch%atau) - call MAPL_VarWrite(formatter,"BTAU",catch%btau) - - myVariable => cfg%get_variable("ITY") - dname => myVariable%get_ith_dimension(2) - dim1 = cfg%get_dimension(dname) - do j=1,dim1 - call MAPL_VarWrite(formatter,"ITY",catch%ity(:,j),offset1=j) - call MAPL_VarWrite(formatter,"FVG",catch%fvg(:,j),offset1=j) - enddo - - call MAPL_VarWrite(formatter,"TC",catch%tc) - call MAPL_VarWrite(formatter,"QC",catch%qc) - call MAPL_VarWrite(formatter,"TG",catch%TG) - call MAPL_VarWrite(formatter,"CAPAC",catch%capac) - call MAPL_VarWrite(formatter,"CATDEF",catch%catdef) - call MAPL_VarWrite(formatter,"RZEXC",catch%rzexc) - call MAPL_VarWrite(formatter,"SRFEXC",catch%srfexc) - call MAPL_VarWrite(formatter,"GHTCNT1",catch%ghtcnt1) - call MAPL_VarWrite(formatter,"GHTCNT2",catch%ghtcnt2) - call MAPL_VarWrite(formatter,"GHTCNT3",catch%ghtcnt3) - call MAPL_VarWrite(formatter,"GHTCNT4",catch%ghtcnt4) - call MAPL_VarWrite(formatter,"GHTCNT5",catch%ghtcnt5) - call MAPL_VarWrite(formatter,"GHTCNT6",catch%ghtcnt6) - call MAPL_VarWrite(formatter,"TSURF",catch%tsurf) - call MAPL_VarWrite(formatter,"WESNN1",catch%wesnn1) - call MAPL_VarWrite(formatter,"WESNN2",catch%wesnn2) - call MAPL_VarWrite(formatter,"WESNN3",catch%wesnn3) - call MAPL_VarWrite(formatter,"HTSNNN1",catch%htsnnn1) - call MAPL_VarWrite(formatter,"HTSNNN2",catch%htsnnn2) - call MAPL_VarWrite(formatter,"HTSNNN3",catch%htsnnn3) - call MAPL_VarWrite(formatter,"SNDZN1",catch%sndzn1) - call MAPL_VarWrite(formatter,"SNDZN2",catch%sndzn2) - call MAPL_VarWrite(formatter,"SNDZN3",catch%sndzn3) - call MAPL_VarWrite(formatter,"CH",catch%ch) - call MAPL_VarWrite(formatter,"CM",catch%cm) - call MAPL_VarWrite(formatter,"CQ",catch%cq) - call MAPL_VarWrite(formatter,"FR",catch%fr) - call MAPL_VarWrite(formatter,"WW",catch%ww) - call MAPL_VarWrite(formatter,"TILE_ID",catch%TILE_ID) - call MAPL_VarWrite(formatter,"NDEP",catch%NDEP) - call MAPL_VarWrite(formatter,"CLI_T2M",catch%t2) - call MAPL_VarWrite(formatter,"BGALBVR",catch%BGALBVR) - call MAPL_VarWrite(formatter,"BGALBVF",catch%BGALBVF) - call MAPL_VarWrite(formatter,"BGALBNR",catch%BGALBNR) - call MAPL_VarWrite(formatter,"BGALBNF",catch%BGALBNF) - myVariable => cfg%get_variable("CNCOL") - dname => myVariable%get_ith_dimension(2) - dim1 = cfg%get_dimension(dname) - - do j=1,dim1 - call MAPL_VarWrite(formatter,"CNCOL",catch%CNCOL(:,j),offset1=j) - enddo - myVariable => cfg%get_variable("CNPFT") - dname => myVariable%get_ith_dimension(2) - dim1 = cfg%get_dimension(dname) - do j=1,dim1 - call MAPL_VarWrite(formatter,"CNPFT",catch%CNPFT(:,j),offset1=j) - enddo - - dim1 = cfg%get_dimension('tile') - allocate (var (dim1)) - var = 0. - - call MAPL_VarWrite(formatter,"BFLOWM", var) - call MAPL_VarWrite(formatter,"TOTWATM",var) - call MAPL_VarWrite(formatter,"TAIRM", var) - call MAPL_VarWrite(formatter,"TPM", var) - call MAPL_VarWrite(formatter,"CNSUM", var) - call MAPL_VarWrite(formatter,"SNDZM", var) - call MAPL_VarWrite(formatter,"ASNOWM", var) - - myVariable => cfg%get_variable("TGWM") - dname => myVariable%get_ith_dimension(2) - dim1 = cfg%get_dimension(dname) - do j=1,dim1 - call MAPL_VarWrite(formatter,"TGWM",var,offset1=j) - call MAPL_VarWrite(formatter,"RZMM",var,offset1=j) - end do - - if (clm45) then - do j=1,dim1 - call MAPL_VarWrite(formatter,"SFMM", var,offset1=j) - enddo - - call MAPL_VarWrite(formatter,"ABM", catch%ABM, rc =rc ) - call MAPL_VarWrite(formatter,"FIELDCAP",catch%FIELDCAP) - call MAPL_VarWrite(formatter,"HDM", catch%HDM ) - call MAPL_VarWrite(formatter,"GDP", catch%GDP ) - call MAPL_VarWrite(formatter,"PEATF", catch%PEATF ) - call MAPL_VarWrite(formatter,"RHM", var) - call MAPL_VarWrite(formatter,"WINDM", var) - call MAPL_VarWrite(formatter,"RAINFM", var) - call MAPL_VarWrite(formatter,"SNOWFM", var) - call MAPL_VarWrite(formatter,"RUNSRFM", var) - call MAPL_VarWrite(formatter,"AR1M", var) - call MAPL_VarWrite(formatter,"T2M10D", var) - call MAPL_VarWrite(formatter,"TPREC10D",var) - call MAPL_VarWrite(formatter,"TPREC60D",var) - else - call MAPL_VarWrite(formatter,"SFMCM", var) - endif - - myVariable => cfg%get_variable("PSNSUNM") - dname => myVariable%get_ith_dimension(2) - dim1 = cfg%get_dimension(dname) - dname => myVariable%get_ith_dimension(3) - dim2 = cfg%get_dimension(dname) - do i=1,dim2 - do j=1,dim1 - call MAPL_VarWrite(formatter,"PSNSUNM",var,offset1=j,offset2=i) - call MAPL_VarWrite(formatter,"PSNSHAM",var,offset1=j,offset2=i) - end do - end do - call formatter%close() - return - end subroutine writecatchcn_nc4 - - subroutine writecatchcn (unit,catch) - integer unit, i,j,n - type(catch_rst) catch - - write(unit) catch% bf1 - write(unit) catch% bf2 - write(unit) catch% bf3 - write(unit) catch% vgwmax - write(unit) catch% cdcr1 - write(unit) catch% cdcr2 - write(unit) catch% psis - write(unit) catch% bee - write(unit) catch% poros - write(unit) catch% wpwet - write(unit) catch% cond - write(unit) catch% gnu - write(unit) catch% ars1 - write(unit) catch% ars2 - write(unit) catch% ars3 - write(unit) catch% ara1 - write(unit) catch% ara2 - write(unit) catch% ara3 - write(unit) catch% ara4 - write(unit) catch% arw1 - write(unit) catch% arw2 - write(unit) catch% arw3 - write(unit) catch% arw4 - write(unit) catch% tsa1 - write(unit) catch% tsa2 - write(unit) catch% tsb1 - write(unit) catch% tsb2 - write(unit) catch% atau - write(unit) catch% btau - write(unit) catch% ity(:,1) - write(unit) catch% ity(:,2) - write(unit) catch% ity(:,3) - write(unit) catch% ity(:,4) - write(unit) catch% fvg(:,1) - write(unit) catch% fvg(:,2) - write(unit) catch% fvg(:,3) - write(unit) catch% fvg(:,4) - write(unit) catch% tc - write(unit) catch% qc - write(unit) catch% tg - write(unit) catch% capac - write(unit) catch% catdef - write(unit) catch% rzexc - write(unit) catch% srfexc - write(unit) catch% ghtcnt1 - write(unit) catch% ghtcnt2 - write(unit) catch% ghtcnt3 - write(unit) catch% ghtcnt4 - write(unit) catch% ghtcnt5 - write(unit) catch% ghtcnt6 - write(unit) catch% tsurf - write(unit) catch% wesnn1 - write(unit) catch% wesnn2 - write(unit) catch% wesnn3 - write(unit) catch% htsnnn1 - write(unit) catch% htsnnn2 - write(unit) catch% htsnnn3 - write(unit) catch% sndzn1 - write(unit) catch% sndzn2 - write(unit) catch% sndzn3 - write(unit) catch% ch - write(unit) catch% cm - write(unit) catch% cq - write(unit) catch% fr - write(unit) catch% ww - write(unit) catch% TILE_ID - write(unit) catch% ndep - write(unit) catch% t2 - write(unit) catch% BGALBVR - write(unit) catch% BGALBVF - write(unit) catch% BGALBNR - write(unit) catch% BGALBNF - - do j = 1,nzone * VAR_COL - write(unit) catch% CNCOL (:,j) - end do - - do i = 1,nzone * nveg * VAR_PFT - write(unit) catch% CNPFT (:,i) - end do - - return - end subroutine writecatchcn - - end program - diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/mk_restarts/mk_CatchCNRestarts.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/mk_restarts/mk_CatchCNRestarts.F90 deleted file mode 100755 index e4ab880c8a..0000000000 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/mk_restarts/mk_CatchCNRestarts.F90 +++ /dev/null @@ -1,2453 +0,0 @@ -#define I_AM_MAIN -#include "MAPL_Generic.h" - -program mk_CatchCNRestarts - -! Usage : mk_CatchCNRestarts OutTileFile InTileFile InRestart SURFLAY RestartTime -! Version 1 : Sarith Mahanama -! sarith.p.mahanama@nasa.gov (Feb 19, 2016) -! The program follows the same nearest neighbor based procedure, as in mk_CatchRestarts.F90, -! to regrid hydrological variables and BCs-based parameters. The algorithm developed -! by Greg Walker (~gkwalker/geos5/convert_offline_cn_restart.f90) to regrid carbon -! variables that looks for a neighbor with a similar vegetation type was modified -! to improve efficiency (in subroutine regrid_carbon_vars). The two main -! modifications in this implementation include: (1) instead looping over the globe, -! it starts from a 10 x 10 window and zoom out until a similar type appears, -! (2) uses MPI enabling parrellel computation. -! Version 2 : Sarith Mahanama (Oct 12, 2016) -! (1) updated to read both carbon and hydrological variables more recent SMAP M09 simulation from Fanwei. -! (2) added subroutine reorder_LDASsa_rst -! The program produces catchcn_internal_rst in nc4 format for any user specified AGCM grid resolution. - -! regrid.pl visits this program twice during the regridding process. During the first visit, the program does not use BCs data. -! It just regrids hydrological variables and BCs-based land parameters in InRestart from InTile space to OutTile -! space (InRestart could be either a catchcn_internal_rst or a catch_internal_rst). If InRestart is a -! catchcn_internal_rst, carbon variables will be regridded using the same simple nearest neighbor algorithm (getids.H) that -! was employed for regridding all other variables. If InRestart is a catch_internal_rst, carbon variables will be -! filled with zeros. - -! During the second visit, the program uses the catchcn_internal_rst produced from the first visit as InRestart (herein -! referred to as InRestart2 which is in OutTile space already). The program reads BCs data from BCSDIR, carbon variables -! from an offline simulation on the SMAP_EASEv2_M09 grid which has been initialized by another 3000-year offline simulation, and -! hydrological from -! InRestart2 in Version 1, -! the same offline simulation on the SMAP_EASEv2_M09 in Version 2. -! Then, they will be regridded to OutTile space. The regridding carbon variables utilizes a more complicated algorithm which looks -! for a M09 grid cell in the neighborhood with a similar vegetation type seperately for each fractional vegetation type within the -! catchment-tile. Note, the model can have upto 4 different types per catchment-tile: primary and secondary types -! and 2 split types for each primary and secondary type. - -! regrid.pl will then execute Scale_CatchCN.F90 which reads catchcn_internal_rst files created in the above 2 steps, -! and scale soil moisture variables to be consistent with the new BCs-based land parameters to produce the final -! catchcn_internal_rst file. - -! Output file format: Output catchcn_internal_rst is always a nc4 file. - -! Here are available options: -! (1) OPT1 (for above first step) -! Input : (1) catchcn_internal_rst from an existing AGCM run (will always be nc4) -! (2) InTile and OutTile are DIFFERENT -! (3) NO land BCs -! OutPut: Every variable (BCs-based land parameters, hydrological variables, and carbon parameters) will be regridded -! from InTile to OutTile space using the simple nearest neighbor algorithm (getids.H) - -! (2) OPT2 (for above first step) -! Input : (1) catch_internal_rst from an existing AGCM run (either nc4 or binary) -! (2) InTile and OutTile are DIFFERENT -! (3) NO land BCs -! OutPut: BCs-based land parameters, and hydrological variables will regridded from InTile to OutTile space -! using the simple nearest neighbor algorithm (getids.H). All carbon variables are filled with zeros. - -! (3) OPT3 (above second step) : -! Input : (1) catchcn_internal_rst (file format is always nc4) -! (2) InTile and OutTile are the same user defined OutTile -! (3) land BCs, -! Output: BCs-based land parameters will be replaced and carbon variables will be filled with regridded (from the -! nearest offline cell with the same vegetation type) data to produce catchcn_internal_rst - -! ---------------------------------------------------------------------------------------------------------------------------------------------- - - ! ====================== ! - ! Process ! - ! ====================== ! - -! HAVEDATA -! | -! _______________________________________________________________________ -! | | -! -! NO (OPT1/OPT2) YES (OPT3) -! -------------- ---------- -!OutTile : /= InTile == InTile -!regridding: ID (InTile to OutTile using getids.H) ID (one-to-one i.e. 1:NTILES, no regridding) -! | | -! clsmcn_file | -! _____________________________________ | -! | | | -! YES (OPT1) NO (OPT2) | -!InRestart : catchcn_internal_rst catch_internal_rst catchcn_internal_rst -! | | | -! | filetype | -! | | | -! | _________________________________ | -! | | | | -! V 0 /= 0 V -!call : read_catchcn_nc4 read_catch_nc4 read_catch_bin read_bcs_data -! | | -! ----------------------------------- -! | -! V -!1) reads InRestart nVars records (1) reads InCNRestart/regrids/writes (1:65) (1) reads BCs -!2) regrids (takes hydrological initial conditions (2) writes 1:37; 66:72 -!3) writes from offline SMAP M09) (3) reads InRestart2/writes 38, 39,40=38,41:65 -!4) close files (2) close files (4) call regrid_carbon_vars (from offline SMAP M09) -! (a) reads from InCNRestart -! (b) regrids each veg type from the nearest InRestart cell -! (c) writes (73-192,193-1080) -! (d) close files -! -! -! -! OUTPUT catchcn_internal_rst will always be nc4 -! ---------------------------------------------------------------------------------------------------------------------------------------------- - - -! The order of the INTERNAL STATE variables in GEOS_CatchCNGridComp -! ----------------------------------------------------------------- -! 1: BF1 -! 2: BF2 -! 3: BF3 -! 4: VGWMAX -! 5: CDCR1 -! 6: CDCR2 -! 7: PSIS -! 8: BEE -! 9: POROS -! 10: WPWET -! 11: COND -! 12: GNU -! 13: ARS1 -! 14: ARS2 -! 15: ARS3 -! 16: ARA1 -! 17: ARA2 -! 18: ARA3 -! 19: ARA4 -! 20: ARW1 -! 21: ARW2 -! 22: ARW3 -! 23: ARW4 -! 24: TSA1 -! 25: TSA2 -! 26: TSB1 -! 27: TSB2 -! 28: ATAU -! 29: BTAU -! 30-33: ITY * NUM_VEG -! 34-37: FVEG * NUM_VEG -! 38: ((TC (n,i),n=1,n_catd),i=1,4) -! 39: ((QC (n,i),n=1,n_catd),i=1,4) -! 40: ((TG (n,i),n=1,n_catd),i=1,4) -! 41: CAPAC -! 42: CATDEF -! 43: RZEXC -! 44: SRFEXC -! 45: GHTCNT1 -! 46: GHTCNT2 -! 47: GHTCNT3 -! 48: GHTCNT4 -! 49: GHTCNT5 -! 50: GHTCNT6 -! 51: TSURF -! 52: WESNN1 -! 53: WESNN2 -! 54: WESNN3 -! 55: HTSNNN1 -! 56: HTSNNN2 -! 57: HTSNNN3 -! 58: SNDZN1 -! 59: SNDZN2 -! 60: SNDZN3 -! 61: ((CH (n,i),n=1,n_catd),i=1,4) -! 62: ((CM (n,i),n=1,n_catd),i=1,4) -! 63: ((CQ (n,i),n=1,n_catd),i=1,4) -! 64: ((FR (n,i),n=1,n_catd),i=1,4) -! 65: ((WW (n,i),n=1,n_catd),i=1,4) -! 66: cat_id -! 67: ndep -! 68: cli_t2m -! 69: BGALBVR -! 70: BGALBVF -! 71: BGALBNR -! 72: BGALBNF -! 73-192: CNCOL (n,nz*VAR_COL) -! 193-1080: CNPFT (n,nz*nv*VAR_PFT) -! 1081-1083: TGWM (n,nz) -! 1084: SFMCM -! 1085: BFLOWM -! 1086: TOTWATM -! 1087: TAIRM -! 1088: TPM -! 1089: CNSUM -! 1090: SNDZM -! 1091: ASNOWM -! 1092-1103: PSNSUNM (n,nz*nv) -! 1104-1115: PSNSHAM (n,nz*nv) - - use MAPL - use ESMF - use gFTL_StringVector - use ieee_arithmetic, only: isnan => ieee_is_nan - use mk_restarts_getidsMod, only: GetIDs, ReadTileFile_RealLatLon - use clm_varpar_shared , only : nzone => NUM_ZON_CN, nveg => NUM_VEG_CN, & - VAR_COL => VAR_COL_40, VAR_PFT => VAR_PFT_40, & - npft => numpft_CN - - implicit none - include 'mpif.h' - INCLUDE 'netcdf.inc' - - ! initialize to non-MPI values - - integer :: myid=0, numprocs=1, mpierr, mpistatus(MPI_STATUS_SIZE) - logical :: root_proc=.true. - - real, parameter :: nan = O'17760000000' - real, parameter :: fmin= 1.e-4 ! ignore vegetation fractions at or below this value - integer, parameter :: OutUnit = 40, InUnit = 50 - - ! =============================================================================================== - ! Below hard-wired ldas restart file is from a global offline simulation on the SMAP M09 grid - ! after 1000s of years of simulations - - integer, parameter :: ntiles_cn = 1684725 - character(len=300), parameter :: & - InCNRestart = '/discover/nobackup/projects/gmao/ssd/land/l_data/LandRestarts_for_Regridding/CatchCN/M09/20151231/catchcn_internal_rst', & - InCNTilFile = '/discover/nobackup/projects/gmao/bcs_shared/legacy_bcs/Icarus-NLv3/Icarus-NLv3_EASE/SMAP_EASEv2_M09/SMAP_EASEv2_M09_3856x1624.til' - - character(len=256), parameter :: CatNames (57) = & - (/'BF1 ','BF2 ','BF3 ','VGWMAX ','CDCR1 ', & - 'CDCR2 ','PSIS ','BEE ','POROS ','WPWET ', & - 'COND ','GNU ','ARS1 ','ARS2 ','ARS3 ', & - 'ARA1 ','ARA2 ','ARA3 ','ARA4 ','ARW1 ', & - 'ARW2 ','ARW3 ','ARW4 ','TSA1 ','TSA2 ', & - 'TSB1 ','TSB2 ','ATAU ','BTAU ','OLD_ITY', & - 'TC ','QC ','CAPAC ','CATDEF ','RZEXC ', & - 'SRFEXC ','GHTCNT1','GHTCNT2','GHTCNT3','GHTCNT4', & - 'GHTCNT5','GHTCNT6','TSURF ','WESNN1 ','WESNN2 ', & - 'WESNN3 ','HTSNNN1','HTSNNN2','HTSNNN3','SNDZN1 ', & - 'SNDZN2 ','SNDZN3 ','CH ','CM ','CQ ', & - 'FR ','WW '/) - - character(len=256), parameter :: CarbNames (68) = & - (/'BF1 ','BF2 ','BF3 ','VGWMAX ','CDCR1 ', & - 'CDCR2 ','PSIS ','BEE ','POROS ','WPWET ', & - 'COND ','GNU ','ARS1 ','ARS2 ','ARS3 ', & - 'ARA1 ','ARA2 ','ARA3 ','ARA4 ','ARW1 ', & - 'ARW2 ','ARW3 ','ARW4 ','TSA1 ','TSA2 ', & - 'TSB1 ','TSB2 ','ATAU ','BTAU ','ITY ', & - 'FVG ','TC ','QC ','TG ','CAPAC ', & - 'CATDEF ','RZEXC ','SRFEXC ','GHTCNT1','GHTCNT2', & - 'GHTCNT3','GHTCNT4','GHTCNT5','GHTCNT6','TSURF ', & - 'WESNN1 ','WESNN2 ','WESNN3 ','HTSNNN1','HTSNNN2', & - 'HTSNNN3','SNDZN1 ','SNDZN2 ','SNDZN3 ','CH ', & - 'CM ','CQ ','FR ','WW ','TILE_ID', & - 'NDEP ','CLI_T2M','BGALBVR','BGALBVF','BGALBNR', & - 'BGALBNF','CNCOL ','CNPFT ' /) - - integer :: AGCM_YY, AGCM_MM, AGCM_DD, AGCM_HR - - character*256 :: DataDir="OutData/clsm/" - character*256 :: Usage="mk_CatchCNRestarts OutTileFile InTileFile InRestart SURFLAY RestartTime" - character*256 :: OutTileFile, InTileFile, InRestart, arg(6), OutFileName - character*10 :: RestartTime - - logical :: clsmcn_file = .true., RegridSMAP = .false. - logical :: havedata - integer :: i, i1, iargc, n, k, ncatch,ntiles,ntiles_in, filetype, rc, nVars, req, infos, STATUS - integer, pointer :: Id(:), id_loc(:), tid_in(:) - real, pointer :: loni(:),lono(:), lati(:), lato(:) , lonn(:), latt(:) - real :: SURFLAY - type(Netcdf4_Fileformatter) :: InFmt,OutFmt - type(FileMetadata) :: InCfg,OutCfg - integer, allocatable :: low_ind(:), upp_ind(:), nt_local (:) - character(256) :: Iam = "mk_CatchCNRestarts" - - call init_MPI() - call MPI_Info_create(infos, STATUS) ; VERIFY_(STATUS) - call MPI_Info_set(infos, "romio_cb_read", "automatic", STATUS) ; VERIFY_(STATUS) - call MPI_Barrier(MPI_COMM_WORLD, STATUS) - - !----------------------------------------------------- - ! Read command-line arguments, file names (inRestart, - ! inTile, outTile), determine file format, and BCs - ! availability. - !----------------------------------------------------- - - call ESMF_Initialize(LogKindFlag=ESMF_LOGKIND_NONE) - - I = iargc() - - if( I /=5 ) then - print *, "Wrong Number of arguments: ", i - print *, trim(Usage) - stop - end if - - do n=1,I - call getarg(n,arg(n)) - enddo - - read(arg(1),'(a)') OutTileFile - read(arg(2),'(a)') InTileFile - read(arg(3),'(a)') InRestart - read(arg(4),*) SURFLAY - read(arg(5),'(a)') RestartTime - - if (SURFLAY.ne.20 .and. SURFLAY.ne.50) then - print *, "You must supply a valid SURFLAY value:" - print *, "(Ganymed-3 and earlier) SURFLAY=20.0 for Old Soil Params" - print *, "(Ganymed-4 and later ) SURFLAY=50.0 for New Soil Params" - call exit(2) - end if - - ! Are BCs data available? - ! ----------------------- - - inquire(file=trim(DataDir)//"CLM_veg_typs_fracs",exist=havedata) - - ! Reading restart time stamp and constructing daylength array - ! ----------------------------------------------------------- - read (RestartTime (1: 4), '(i4)', IOSTAT = K) AGCM_YY ; VERIFY_(K) - read (RestartTime (5: 6), '(i2)', IOSTAT = K) AGCM_MM ; VERIFY_(K) - read (RestartTime (7: 8), '(i2)', IOSTAT = K) AGCM_DD ; VERIFY_(K) - read (RestartTime (9:10), '(i2)', IOSTAT = K) AGCM_HR ; VERIFY_(K) - - MPI_PROC0 : if (root_proc) then - - ! Read Output/Input .til files - call ReadTileFile_RealLatLon(OutTileFile, ntiles, xlon=lono, xlat=lato) - call ReadTileFile_RealLatLon(InTileFile,ntiles_in,xlon=loni, xlat=lati) - allocate(Id (ntiles)) - - ! ------------------------------------------------ - ! create output catchcn_internal_rst in nc4 format - ! ------------------------------------------------ - - call InFmt%open('/discover/nobackup/projects/gmao/ssd/land/l_data/LandRestarts_for_Regridding/CatchCN/catchcn_internal_dummy',pFIO_READ, __RC__) - InCfg=InFmt%read( __RC__) - call MAPL_IOCountNonDimVars(InCfg,nvars, __RC__) - call MAPL_IOChangeRes(InCfg,OutCfg,(/'tile'/),(/ntiles/),__RC__) - i = index(InRestart,'/',back=.true.) - OutFileName = "OutData/"//trim(InRestart(i+1:)) - call OutFmt%create(OutFileName, __RC__) - call OutFmt%write(OutCfg, __RC__) - i1= index(InRestart,'/',back=.true.) - i = index(InRestart,'catchcn',back=.true.) - - endif MPI_PROC0 - - call MPI_Barrier(MPI_COMM_WORLD, mpierr) - call MPI_BCAST(NTILES , 1, MPI_INTEGER , 0,MPI_COMM_WORLD,mpierr) ; VERIFY_(mpierr) - call MPI_BCAST(NTILES_IN, 1, MPI_INTEGER , 0,MPI_COMM_WORLD,mpierr) ; VERIFY_(mpierr) - - HAVE_DATA :if(havedata) then - - ! OPT3 - ! ---- - ! Get number of catchments - ! ------------------------ - - open(unit=22, & - file=trim(DataDir)//"catchment.def",status='old',form='formatted') - - read(22,*) ncatch - - close(22) - - if(ncatch /= ntiles) then - print *, "Number of tiles in BCs data, ",Ncatch," does not match number in OutTile file ", NTILES - print *, trim(OutTileFile) - stop - endif - - if(ntiles_in /= ntiles) then - print *, "HAVEDATA : Number of tiles in InTileFile, ",NTILES_IN," does not match number in OutTileFile ", NTILES - print *, trim ( InTileFile) - print *, trim (OutTileFile) - stop - endif - - allocate (Id(ntiles)) - - do i = 1,ntiles - id (i) = i ! Just one-to-one mapping - end do - RegridSMAP = .true. - - !OPT3 (Reading/writing BCs/hydrological variables) - - if (root_proc) call read_bcs_data (ntiles, SURFLAY, OutFmt, InRestart, __RC__) - - else - - ! What is the format of the InRestart file? - ! ----------------------------------------- - - call MAPL_NCIOGetFileType(InRestart, filetype, __RC__) - - if (filetype /= 0) then - - ! OPT2 (filetype =/ 0: a binary file must be a catch_internal_rst) - ! ---- - clsmcn_file = .false. - - open(unit=InUnit,FILE=InRestart,form='unformatted', & - status='old',convert='little_endian') - - else - - ! filetype = 0 : nc4, could be catch_internal_rst or catchcn_internal_rst - ! check nVars: if nVars > 57 OPT1 (catchcn_internal_rst) ; else OPT2 (catch_internal_rst) - ! --------------------------------------------------------------------------------------- - - call InFmt%open(InRestart,pFIO_READ, __RC__) - InCfg = InFmt%read(__RC__) - call InFmt%close() - - call MAPL_IOCountNonDimVars(InCfg,nvars) - - if(nVars == 57) clsmcn_file = .false. - - endif - - CATCHCN: if (clsmcn_file) then - - ! OPT1 - ! ---- - - ! ---------------------------------------------------- - ! INPUT/OUTPUT Mapping since InTileFile =/ OutTileFile - ! ---------------------------------------------------- - - if(myid > 0) allocate (loni (1:ntiles_in)) - if(myid > 0) allocate (lati (1:ntiles_in)) - - allocate (tid_in (1:ntiles_in)) - do n = 1, NTILES_IN - tid_in (n) = n - end do - - call MPI_BCAST(loni,ntiles_in,MPI_REAL,0,MPI_COMM_WORLD,mpierr) - call MPI_BCAST(lati,ntiles_in,MPI_REAL,0,MPI_COMM_WORLD,mpierr) - call MPI_Barrier(MPI_COMM_WORLD, mpierr) - - ! Now mapping (Id) - ! ---------------- - - allocate (Id(ntiles)) ! Id contains corresponding InTileID after mapping InTiles on to OutTile - ! call GetIds(loni,lati,lono,lato,zoom,Id) - allocate(low_ind ( numprocs)) - allocate(upp_ind ( numprocs)) - allocate(nt_local( numprocs)) - low_ind (:) = 1 - upp_ind (:) = NTILES - nt_local(:) = NTILES - - ! Domain decomposition - ! -------------------- - - if (numprocs > 1) then - do i = 1, numprocs - 1 - upp_ind(i) = low_ind(i) + (ntiles/numprocs) - 1 - low_ind(i+1) = upp_ind(i) + 1 - nt_local(i) = upp_ind(i) - low_ind(i) + 1 - end do - nt_local(numprocs) = upp_ind(numprocs) - low_ind(numprocs) + 1 - endif - - ! Get out tile lat/lots from root - - allocate (id_loc (nt_local (myid + 1))) - allocate (lonn (nt_local (myid + 1))) - allocate (latt (nt_local (myid + 1))) - - do i = 1, numprocs - if((I == 1).and.(myid == 0)) then - lonn(:) = lono(low_ind(i) : upp_ind(i)) - latt(:) = lato(low_ind(i) : upp_ind(i)) - else if (I > 1) then - if(I-1 == myid) then - ! receiving from root - - call MPI_RECV(lonn,nt_local(i) , MPI_REAL, 0,995,MPI_COMM_WORLD,MPI_STATUS_IGNORE,mpierr) - call MPI_RECV(latt,nt_local(i) , MPI_REAL, 0,994,MPI_COMM_WORLD,MPI_STATUS_IGNORE,mpierr) - else if (myid == 0) then - ! root sends - - call MPI_ISend(lono(low_ind(i) : upp_ind(i)),nt_local(i),MPI_REAL,i-1,995,MPI_COMM_WORLD,req,mpierr) - call MPI_WAIT (req,MPI_STATUS_IGNORE,mpierr) - call MPI_ISend(lato(low_ind(i) : upp_ind(i)),nt_local(i),MPI_REAL,i-1,994,MPI_COMM_WORLD,req,mpierr) - call MPI_WAIT (req,MPI_STATUS_IGNORE,mpierr) - endif - endif - end do - - call GetIds(loni,lati,lonn,latt,id_loc, tid_in) - call MPI_Barrier(MPI_COMM_WORLD, mpierr) - - do i = 1, numprocs - if((I == 1).and.(myid == 0)) then - id(low_ind(i) : upp_ind(i)) = Id_loc(:) - else if (I > 1) then - if(I-1 == myid) then - ! send to root - call MPI_ISend(id_loc,nt_local(i),MPI_INTEGER,0,993,MPI_COMM_WORLD,req,mpierr) - call MPI_WAIT (req,MPI_STATUS_IGNORE,mpierr) - else if (myid == 0) then - ! root receives - call MPI_RECV(id(low_ind(i) : upp_ind(i)),nt_local(i) , MPI_INTEGER, i-1,993,MPI_COMM_WORLD,MPI_STATUS_IGNORE,mpierr) - endif - endif - end do - - if(root_proc) deallocate (lono, lato,lonn,latt, tid_in) - - deallocate (loni,lati) - - - if (root_proc) call read_catchcn_nc4 (NTILES_IN, NTILES, OutFmt, ID, InRestart, __RC__) - - else - - call regrid_hyd_vars (NTILES, OutFmt) - - ! OPT2 - ! ---- - ! NC4ORBIN: if(filetype ==0) then - ! - ! call read_catch_nc4 (NTILES_IN, NTILES, OutFmt, ID, InRestart) - ! - ! else - ! - ! call read_catch_bin (NTILES_IN, NTILES, OutFmt, ID) - ! - ! endif NC4ORBIN - - endif CATCHCN - - endif HAVE_DATA - - if (root_proc) then - - ! ----------------- - ! BEGIN THE PROCESS - ! ----------------- - - print *, " " - print *, "**********************************************************************" - print *, " " - print *, "mk_CatchCNRestarts Configuration" - print *, "--------------------------------" - print *, " " - print '(A22, i4.4,i2.2,i2.2,i2.2)', " Restart Time :",AGCM_YY,AGCM_MM,AGCM_DD,AGCM_HR - print *, 'SURFLAY : ',SURFLAY - print *, 'Have BCs data : ',havedata - print *, "# of tiles in InTile : ",ntiles_in - print *, "# of tiles in OutTile: ",ntiles - - if(clsmcn_file) then - print *,"InRestart is from : Catchment-carbon AGCM simulation" - else - InRestart = trim(InCNRestart) - print *,"InRestart is from : offline SMAP_EASEv2_M09" - endif - - print *, "InRestart filename : ",trim(InRestart) - print *, "OutRestart filename : ",trim(OutFileName) - print *, "OutRestart file fmt : nc4" - print *, " " - print *, "**********************************************************************" - print *, " " - - endif - - call MPI_BCAST(OutFileName , 256, MPI_CHARACTER, 0,MPI_COMM_WORLD,mpierr) - call MPI_Barrier(MPI_COMM_WORLD, mpierr) - - if (RegridSMAP) then - ntiles_in = ntiles_cn - !OPT3 (carbon variables from offline SMAP M09) - call regrid_carbon_vars (NTILES,AGCM_YY,AGCM_MM,AGCM_DD,AGCM_HR, OutFileName, OutTileFile) - ! call regrid_carbon_vars_omp (NTILES,AGCM_YY,AGCM_MM,AGCM_DD,AGCM_HR, OutFileName, OutTileFile) - - endif -call MPI_BARRIER( MPI_COMM_WORLD, mpierr) -call ESMF_Finalize(endflag=ESMF_END_KEEPMPI) -call MPI_FINALIZE(mpierr) - -contains - - ! ***************************************************************************** - - SUBROUTINE read_bcs_data (ntiles, SURFLAY, OutFmt, InRestart, rc) - - ! This subroutine : - ! 1) reads BCs from BCSDIR and hydrological varables from InRestart. - ! InRestart is a catchcn_internal_rst nc4 file. - ! - ! 2) writes out BCs and hydrological variables in catchcn_internal_rst (1:72). - ! output catchcn_internal_rst is nc4. - - implicit none - real, intent (in) :: SURFLAY - integer, intent (in) :: ntiles - character (*), intent (in) :: InRestart - type(Netcdf4_Fileformatter), intent (inout) :: OutFmt - integer, optional, intent(out) :: rc - - real, allocatable :: CLMC_pf1(:), CLMC_pf2(:), CLMC_sf1(:), CLMC_sf2(:) - real, allocatable :: CLMC_pt1(:), CLMC_pt2(:), CLMC_st1(:), CLMC_st2(:) - real, allocatable :: BF1(:), BF2(:), BF3(:), VGWMAX(:) - real, allocatable :: CDCR1(:), CDCR2(:), PSIS(:), BEE(:) - real, allocatable :: POROS(:), WPWET(:), COND(:), GNU(:) - real, allocatable :: ARS1(:), ARS2(:), ARS3(:) - real, allocatable :: ARA1(:), ARA2(:), ARA3(:), ARA4(:) - real, allocatable :: ARW1(:), ARW2(:), ARW3(:), ARW4(:) - real, allocatable :: TSA1(:), TSA2(:), TSB1(:), TSB2(:) - real, allocatable :: ATAU2(:), BTAU2(:), DP2BR(:), rity(:), CanopH(:) - real, allocatable :: NDEP(:), BVISDR(:), BVISDF(:), BNIRDR(:), BNIRDF(:) - real, allocatable :: T2(:), var1(:) - integer, allocatable :: ity(:) - character*256 :: vname - character*256 :: DataDir="OutData/clsm/" - integer :: idum, i,j,n, ib, nv - real :: rdum, zdep1, zdep2, zdep3, zmet, term1, term2, bare,fvg(4) - logical :: file_exists - type(Netcdf4_Fileformatter) :: InFmt,CatchCNFmt, CatchFmt - integer :: status - - allocate ( BF1(ntiles), BF2 (ntiles), BF3(ntiles) ) - allocate (VGWMAX(ntiles), CDCR1(ntiles), CDCR2(ntiles) ) - allocate ( PSIS(ntiles), BEE(ntiles), POROS(ntiles) ) - allocate ( WPWET(ntiles), COND(ntiles), GNU(ntiles) ) - allocate ( ARS1(ntiles), ARS2(ntiles), ARS3(ntiles) ) - allocate ( ARA1(ntiles), ARA2(ntiles), ARA3(ntiles) ) - allocate ( ARA4(ntiles), ARW1(ntiles), ARW2(ntiles) ) - allocate ( ARW3(ntiles), ARW4(ntiles), TSA1(ntiles) ) - allocate ( TSA2(ntiles), TSB1(ntiles), TSB2(ntiles) ) - allocate ( ATAU2(ntiles), BTAU2(ntiles), DP2BR(ntiles) ) - allocate (BVISDR(ntiles), BVISDF(ntiles), BNIRDR(ntiles) ) - allocate (BNIRDF(ntiles), T2(ntiles), NDEP(ntiles) ) - allocate ( ity(ntiles), rity(ntiles), CanopH(ntiles)) - allocate (CLMC_pf1(ntiles), CLMC_pf2(ntiles), CLMC_sf1(ntiles)) - allocate (CLMC_sf2(ntiles), CLMC_pt1(ntiles), CLMC_pt2(ntiles)) - allocate (CLMC_st1(ntiles), CLMC_st2(ntiles)) - - inquire(file = trim(DataDir)//'/catchcn_params.nc4', exist=file_exists) - - if(file_exists) then - - print *,'FILE FORMAT FOR LAND BCS IS NC4' - call CatchFmt%open(trim(DataDir)//'/catch_params.nc4',pFIO_READ, __RC__) - call CatchCNFmt%open(trim(DataDir)//'/catchcn_params.nc4',pFIO_READ, __RC__) - call MAPL_VarRead ( CatchFmt ,'OLD_ITY', rity, __RC__) - call MAPL_VarRead ( CatchFmt ,'ARA1', ARA1, __RC__) - call MAPL_VarRead ( CatchFmt ,'ARA2', ARA2, __RC__) - call MAPL_VarRead ( CatchFmt ,'ARA3', ARA3, __RC__) - call MAPL_VarRead ( CatchFmt ,'ARA4', ARA4, __RC__) - call MAPL_VarRead ( CatchFmt ,'ARS1', ARS1, __RC__) - call MAPL_VarRead ( CatchFmt ,'ARS2', ARS2, __RC__) - call MAPL_VarRead ( CatchFmt ,'ARS3', ARS3, __RC__) - call MAPL_VarRead ( CatchFmt ,'ARW1', ARW1, __RC__) - call MAPL_VarRead ( CatchFmt ,'ARW2', ARW2, __RC__) - call MAPL_VarRead ( CatchFmt ,'ARW3', ARW3, __RC__) - call MAPL_VarRead ( CatchFmt ,'ARW4', ARW4, __RC__) - - if( SURFLAY.eq.20.0 ) then - call MAPL_VarRead ( CatchFmt ,'ATAU2', ATAU2, __RC__) - call MAPL_VarRead ( CatchFmt ,'BTAU2', BTAU2, __RC__) - endif - - if( SURFLAY.eq.50.0 ) then - call MAPL_VarRead ( CatchFmt ,'ATAU5', ATAU2, __RC__) - call MAPL_VarRead ( CatchFmt ,'BTAU5', BTAU2, __RC__) - endif - - call MAPL_VarRead ( CatchFmt ,'PSIS', PSIS, __RC__) - call MAPL_VarRead ( CatchFmt ,'BEE', BEE, __RC__) - call MAPL_VarRead ( CatchFmt ,'BF1', BF1, __RC__) - call MAPL_VarRead ( CatchFmt ,'BF2', BF2, __RC__) - call MAPL_VarRead ( CatchFmt ,'BF3', BF3, __RC__) - call MAPL_VarRead ( CatchFmt ,'TSA1', TSA1, __RC__) - call MAPL_VarRead ( CatchFmt ,'TSA2', TSA2, __RC__) - call MAPL_VarRead ( CatchFmt ,'TSB1', TSB1, __RC__) - call MAPL_VarRead ( CatchFmt ,'TSB2', TSB2, __RC__) - call MAPL_VarRead ( CatchFmt ,'COND', COND, __RC__) - call MAPL_VarRead ( CatchFmt ,'GNU', GNU, __RC__) - call MAPL_VarRead ( CatchFmt ,'WPWET', WPWET, __RC__) - call MAPL_VarRead ( CatchFmt ,'DP2BR', DP2BR, __RC__) - call MAPL_VarRead ( CatchFmt ,'POROS', POROS, __RC__) - call MAPL_VarRead ( CatchCNFmt ,'BGALBNF', BNIRDF, __RC__) - call MAPL_VarRead ( CatchCNFmt ,'BGALBNR', BNIRDR, __RC__) - call MAPL_VarRead ( CatchCNFmt ,'BGALBVF', BVISDF, __RC__) - call MAPL_VarRead ( CatchCNFmt ,'BGALBVR', BVISDR, __RC__) - call MAPL_VarRead ( CatchCNFmt ,'NDEP', NDEP, __RC__) - call MAPL_VarRead ( CatchCNFmt ,'T2_M', T2, __RC__) - call MAPL_VarRead(CatchCNFmt,'ITY',CLMC_pt1,offset1=1, __RC__) ! 30 - call MAPL_VarRead(CatchCNFmt,'ITY',CLMC_pt2,offset1=2, __RC__) ! 31 - call MAPL_VarRead(CatchCNFmt,'ITY',CLMC_st1,offset1=3, __RC__) ! 32 - call MAPL_VarRead(CatchCNFmt,'ITY',CLMC_st2,offset1=4, __RC__) ! 33 - call MAPL_VarRead(CatchCNFmt,'FVG',CLMC_pf1,offset1=1, __RC__) ! 34 - call MAPL_VarRead(CatchCNFmt,'FVG',CLMC_pf2,offset1=2, __RC__) ! 35 - call MAPL_VarRead(CatchCNFmt,'FVG',CLMC_sf1,offset1=3, __RC__) ! 36 - call MAPL_VarRead(CatchCNFmt,'FVG',CLMC_sf2,offset1=4, __RC__) ! 37 - call CatchFmt%close() - call CatchCNFmt%close() - - else - - open(unit=22, & - file=trim(DataDir)//"mosaic_veg_typs_fracs",status='old',form='formatted') - - do N=1,ntiles - read(22,*) I, j, ITY(N),idum, rdum, rdum, CanopH(N) - enddo - - rity(:) = float(ity) - - close(22) - - open(unit=22, file=trim(DataDir)//'bf.dat' ,form='formatted') - open(unit=23, file=trim(DataDir)//'soil_param.dat' ,form='formatted') - open(unit=24, file=trim(DataDir)//'ar.new' ,form='formatted') - open(unit=25, file=trim(DataDir)//'ts.dat' ,form='formatted') - open(unit=26, file=trim(DataDir)//'tau_param.dat' ,form='formatted') - open(unit=27, file=trim(DataDir)//'CLM_veg_typs_fracs' ,form='formatted') - open(unit=28, file=trim(DataDir)//'CLM_NDep_SoilAlb_T2m' ,form='formatted') - - do n=1,ntiles - read (22, *) i,j, GNU(n), BF1(n), BF2(n), BF3(n) - - read (23, *) i,j, idum, idum, BEE(n), PSIS(n),& - POROS(n), COND(n), WPWET(n), DP2BR(n) - - read (24, *) i,j, rdum, ARS1(n), ARS2(n), ARS3(n), & - ARA1(n), ARA2(n), ARA3(n), ARA4(n), & - ARW1(n), ARW2(n), ARW3(n), ARW4(n) - - read (25, *) i,j, rdum, TSA1(n), TSA2(n), TSB1(n), TSB2(n) - - if( SURFLAY.eq.20.0 ) read (26, *) i,j, ATAU2(n), BTAU2(n), rdum, rdum ! for old soil params - if( SURFLAY.eq.50.0 ) read (26, *) i,j, rdum , rdum, ATAU2(n), BTAU2(n) ! for new soil params - - read (27, *) i,j, CLMC_pt1(n), CLMC_pt2(n), CLMC_st1(n), CLMC_st2(n), & - CLMC_pf1(n), CLMC_pf2(n), CLMC_sf1(n), CLMC_sf2(n) - - read (28, *) NDEP(n), BVISDR(n), BVISDF(n), BNIRDR(n), BNIRDF(n), T2(n) ! MERRA-2 Annual Mean Temp is default. - - end do - - CLOSE (22, STATUS = 'KEEP') - CLOSE (23, STATUS = 'KEEP') - CLOSE (24, STATUS = 'KEEP') - CLOSE (25, STATUS = 'KEEP') - CLOSE (26, STATUS = 'KEEP') - CLOSE (27, STATUS = 'KEEP') - CLOSE (28, STATUS = 'KEEP') - - endif - - do n=1,ntiles - - BVISDR(n) = amax1(1.e-6, BVISDR(n)) - BVISDF(n) = amax1(1.e-6, BVISDF(n)) - BNIRDR(n) = amax1(1.e-6, BNIRDR(n)) - BNIRDF(n) = amax1(1.e-6, BNIRDF(n)) - - zdep2=1000. - zdep3=amax1(1000.,DP2BR(n)) - - if (zdep2 .gt.0.75*zdep3) then - zdep2 = 0.75*zdep3 - end if - - zdep1=20. - zmet=zdep3/1000. - - term1=-1.+((PSIS(n)-zmet)/PSIS(n))**((BEE(n)-1.)/BEE(n)) - term2=PSIS(n)*BEE(n)/(BEE(n)-1) - - VGWMAX(n) = POROS(n)*zdep2 - CDCR1(n) = 1000.*POROS(n)*(zmet-(-term2*term1)) - CDCR2(n) = (1.-WPWET(n))*POROS(n)*zdep3 - - ! convert % to fractions - - CLMC_pf1(n) = CLMC_pf1(n) / 100. - CLMC_pf2(n) = CLMC_pf2(n) / 100. - CLMC_sf1(n) = CLMC_sf1(n) / 100. - CLMC_sf2(n) = CLMC_sf2(n) / 100. - - fvg(1) = CLMC_pf1(n) - fvg(2) = CLMC_pf2(n) - fvg(3) = CLMC_sf1(n) - fvg(4) = CLMC_sf2(n) - - BARE = 1. - - DO NV = 1, NVEG - BARE = BARE - FVG(NV)! subtract vegetated fractions - END DO - - if (BARE /= 0.) THEN - IB = MAXLOC(FVG(:),1) - FVG (IB) = FVG(IB) + BARE ! This also corrects all cases sum ne 0. - ENDIF - - CLMC_pf1(n) = fvg(1) - CLMC_pf2(n) = fvg(2) - CLMC_sf1(n) = fvg(3) - CLMC_sf2(n) = fvg(4) - - enddo - - NDEP = NDEP * 1.e-9 - -! prevent trivial fractions -! ------------------------- - do n = 1,ntiles - if(CLMC_pf1(n) <= 1.e-4) then - CLMC_pf2(n) = CLMC_pf2(n) + CLMC_pf1(n) - CLMC_pf1(n) = 0. - endif - - if(CLMC_pf2(n) <= 1.e-4) then - CLMC_pf1(n) = CLMC_pf1(n) + CLMC_pf2(n) - CLMC_pf2(n) = 0. - endif - - if(CLMC_sf1(n) <= 1.e-4) then - if(CLMC_sf2(n) > 1.e-4) then - CLMC_sf2(n) = CLMC_sf2(n) + CLMC_sf1(n) - else if(CLMC_pf2(n) > 1.e-4) then - CLMC_pf2(n) = CLMC_pf2(n) + CLMC_sf1(n) - else if(CLMC_pf1(n) > 1.e-4) then - CLMC_pf1(n) = CLMC_pf1(n) + CLMC_sf1(n) - else - stop 'fveg3' - endif - CLMC_sf1(n) = 0. - endif - - if(CLMC_sf2(n) <= 1.e-4) then - if(CLMC_sf1(n) > 1.e-4) then - CLMC_sf1(n) = CLMC_sf1(n) + CLMC_sf2(n) - else if(CLMC_pf2(n) > 1.e-4) then - CLMC_pf2(n) = CLMC_pf2(n) + CLMC_sf2(n) - else if(CLMC_pf1(n) > 1.e-4) then - CLMC_pf1(n) = CLMC_pf1(n) + CLMC_sf2(n) - else - stop 'fveg4' - endif - CLMC_sf2(n) = 0. - endif - end do - - - - ! Now writing BCs (from BCSDIR) and regridded hydrological variables 1-72 - ! ----------------------------------------------------------------------- - - call InFmt%open(InRestart,pFIO_READ, __RC__) - - call MAPL_VarWrite(OutFmt,trim(CarbNames(1)),BF1) ! 1 - call MAPL_VarWrite(OutFmt,trim(CarbNames(2)),BF2) ! 2 - call MAPL_VarWrite(OutFmt,trim(CarbNames(3)),BF3) ! 3 - call MAPL_VarWrite(OutFmt,trim(CarbNames(4)),VGWMAX) ! 4 - call MAPL_VarWrite(OutFmt,trim(CarbNames(5)),CDCR1) ! 5 - call MAPL_VarWrite(OutFmt,trim(CarbNames(6)),CDCR2) ! 6 - call MAPL_VarWrite(OutFmt,trim(CarbNames(7)),PSIS) ! 7 - call MAPL_VarWrite(OutFmt,trim(CarbNames(8)),BEE) ! 8 - call MAPL_VarWrite(OutFmt,trim(CarbNames(9)),POROS) ! 9 - call MAPL_VarWrite(OutFmt,trim(CarbNames(10)),WPWET) ! 10 - call MAPL_VarWrite(OutFmt,trim(CarbNames(11)),COND) ! 11 - call MAPL_VarWrite(OutFmt,trim(CarbNames(12)),GNU) ! 12 - call MAPL_VarWrite(OutFmt,trim(CarbNames(13)),ARS1) ! 13 - call MAPL_VarWrite(OutFmt,trim(CarbNames(14)),ARS2) ! 14 - call MAPL_VarWrite(OutFmt,trim(CarbNames(15)),ARS3) ! 15 - call MAPL_VarWrite(OutFmt,trim(CarbNames(16)),ARA1) ! 16 - call MAPL_VarWrite(OutFmt,trim(CarbNames(17)),ARA2) ! 17 - call MAPL_VarWrite(OutFmt,trim(CarbNames(18)),ARA3) ! 18 - call MAPL_VarWrite(OutFmt,trim(CarbNames(19)),ARA4) ! 19 - call MAPL_VarWrite(OutFmt,trim(CarbNames(20)),ARW1) ! 20 - call MAPL_VarWrite(OutFmt,trim(CarbNames(21)),ARW2) ! 21 - call MAPL_VarWrite(OutFmt,trim(CarbNames(22)),ARW3) ! 22 - call MAPL_VarWrite(OutFmt,trim(CarbNames(23)),ARW4) ! 23 - call MAPL_VarWrite(OutFmt,trim(CarbNames(24)),TSA1) ! 24 - call MAPL_VarWrite(OutFmt,trim(CarbNames(25)),TSA2) ! 25 - call MAPL_VarWrite(OutFmt,trim(CarbNames(26)),TSB1) ! 26 - call MAPL_VarWrite(OutFmt,trim(CarbNames(27)),TSB2) ! 27 - call MAPL_VarWrite(OutFmt,trim(CarbNames(28)),ATAU2) ! 28 - call MAPL_VarWrite(OutFmt,trim(CarbNames(29)),BTAU2) ! 29 - call MAPL_VarWrite(OutFmt,'ITY',CLMC_pt1,offset1=1) ! 30 - call MAPL_VarWrite(OutFmt,'ITY',CLMC_pt2,offset1=2) ! 31 - call MAPL_VarWrite(OutFmt,'ITY',CLMC_st1,offset1=3) ! 32 - call MAPL_VarWrite(OutFmt,'ITY',CLMC_st2,offset1=4) ! 33 - call MAPL_VarWrite(OutFmt,'FVG',CLMC_pf1,offset1=1) ! 34 - call MAPL_VarWrite(OutFmt,'FVG',CLMC_pf2,offset1=2) ! 35 - call MAPL_VarWrite(OutFmt,'FVG',CLMC_sf1,offset1=3) ! 36 - call MAPL_VarWrite(OutFmt,'FVG',CLMC_sf2,offset1=4) ! 37 - - allocate(var1(ntiles)) - - ! TC QC TG - - do n = 38,40 - if(n == 38) vname = 'TC' - if(n == 39) vname = 'QC' - if(n == 40) vname = 'TG' - do j = 1,4 - call MAPL_VarRead ( InFmt,vname,var1 ,offset1=j, __RC__) - call MAPL_VarWrite(OutFmt,vname,var1 ,offset1=j) ! 38-40 - end do - end do - - ! CAPAC CATDEF RZEXC SRFEXC ... SNDZN3 - - do n=41,60 - call MAPL_VarRead ( InFmt,trim(CarbNames(n-6)),var1, __RC__) - call MAPL_VarWrite(OutFmt,trim(CarbNames(n-6)),var1) ! 41-60 - enddo - - ! CH CM CQ FR WW - var1 = 0. - - do n=61,65 - if((n >= 61).AND.(n <= 63)) var1 = 1.e-3 - if(n == 64) var1 = 0.25 - if(n == 65) var1 = 0.1 - do j = 1,4 - - call MAPL_VarRead ( InFmt,trim(CarbNames(n-6)),var1 ,offset1=j, __RC__) - call MAPL_VarWrite(OutFmt,trim(CarbNames(n-6)),var1 ,offset1=j) ! 61-65 - end do - end do - - do i=1,ntiles - var1(i) = real(i) - end do - - call MAPL_VarWrite(OutFmt,'TILE_ID',var1 ) ! 66 : cat_id - call MAPL_VarWrite(OutFmt,'NDEP' ,NDEP ) ! 67 : ndep - call MAPL_VarWrite(OutFmt,'CLI_T2M',T2 ) ! 68 : cli_t2m - call MAPL_VarWrite(OutFmt,'BGALBVR',BVISDR) ! 69 : BGALBVR - call MAPL_VarWrite(OutFmt,'BGALBVF',BVISDF) ! 70 : BGALBVF - call MAPL_VarWrite(OutFmt,'BGALBNR',BNIRDR) ! 71 : BGALBNR - call MAPL_VarWrite(OutFmt,'BGALBNF',BNIRDF) ! 72 : BGALBNF - - deallocate (var1) - call InFmt%close() - call OutFmt%close() - -! Vegdyn Boundary Condition -! ------------------------- -! -! open(20,file=trim("OutData/vegdyn_internal_rst"), & -! status="unknown", & -! form="unformatted",convert="little_endian") -! write(20) rity -! write(20) CanopH -! close(20) -! print *, "Wrote vegdyn_internal_restart" - - deallocate ( BF1, BF2, BF3 ) - deallocate (VGWMAX, CDCR1, CDCR2 ) - deallocate ( PSIS, BEE, POROS ) - deallocate ( WPWET, COND, GNU ) - deallocate ( ARS1, ARS2, ARS3 ) - deallocate ( ARA1, ARA2, ARA3 ) - deallocate ( ARA4, ARW1, ARW2 ) - deallocate ( ARW3, ARW4, TSA1 ) - deallocate ( TSA2, TSB1, TSB2 ) - deallocate ( ATAU2, BTAU2, DP2BR ) - deallocate (BVISDR, BVISDF, BNIRDR ) - deallocate (BNIRDF, T2, NDEP ) - deallocate ( ity, rity, CanopH) - deallocate (CLMC_pf1, CLMC_pf2, CLMC_sf1) - deallocate (CLMC_sf2, CLMC_pt1, CLMC_pt2) - deallocate (CLMC_st1,CLMC_st2) - if (present(rc)) rc = 0 - !_RETURN(_SUCCESS) - END SUBROUTINE read_bcs_data - - ! ***************************************************************************** - - SUBROUTINE read_catchcn_nc4 (NTILES_IN, NTILES, OutFmt, IDX, InRestart, rc) - - implicit none - - ! Reads catchcn_internal_rst nc4 file, regrids every single variable and writes - ! out catchcn_internal_rst in nc4 format. - ! This subroutine is called when BCs data are not available. - - integer, intent (in) :: NTILES_IN, NTILES - character(*), intent (in) :: InRestart - type(Netcdf4_Fileformatter), intent (inout) :: OutFmt - integer, dimension (NTILES), intent (in) :: IDX - integer, optional, intent(out) :: rc - type(Netcdf4_Fileformatter) :: InFmt - type(FileMetadata) :: InCfg - integer :: n,i,j, ndims, nVars,dim1,dim2 - character(len=:), pointer :: vname - real, allocatable :: var1 (:), var2 (:) - integer, allocatable :: TILE_ID (:) - type(StringVariableMap), pointer :: variables - type(Variable), pointer :: var - type(StringVariableMapIterator) :: var_iter - type(StringVector), pointer :: var_dimensions - character(len=:), pointer :: dname - integer :: status - - call InFmt%open(InRestart,pFIO_READ, __RC__) - InCfg = InFmt%read(__RC__) - - allocate (var1 (1:NTILES_IN)) - allocate (var2 (1:NTILES_IN)) - allocate (TILE_ID (1:NTILES_IN)) - - call MAPL_VarRead ( InFmt,'TILE_ID',var1, __RC__) - do n = 1, NTILES_IN - tile_id (NINT (var1(n))) = n - end do - - variables => InCfg%get_variables() - var_iter = variables%begin() - do while (var_iter /= variables%end()) - - vname => var_iter%key() - var => var_iter%value() - var_dimensions => var%get_dimensions() - - ndims = var_dimensions%size() - - if (ndims == 1) then - call MAPL_VarRead ( InFmt,vname,var1, __RC__) - var2 = var1 (tile_id) - call MAPL_VarWrite(OutFmt,vname,var2(idx)) - - else if (ndims == 2) then - - dname => var%get_ith_dimension(2) - dim1=InCfg%get_dimension(dname) - do j=1,dim1 - call MAPL_VarRead ( InFmt,vname,var1 ,offset1=j, __RC__) - var2 = var1 (tile_id) - call MAPL_VarWrite(OutFmt,vname,var2(idx),offset1=j) - enddo - - else if (ndims == 3) then - - dname => var%get_ith_dimension(2) - dim1=InCfg%get_dimension(dname) - dname => var%get_ith_dimension(3) - dim2=InCfg%get_dimension(dname) - do i=1,dim2 - do j=1,dim1 - call MAPL_VarRead ( InFmt,vname,var1 ,offset1=j,offset2=i, __RC__) - var2 = var1 (tile_id) - call MAPL_VarWrite(OutFmt,vname,var2(idx),offset1=j,offset2=i) - enddo - enddo - - end if - - call var_iter%next() - enddo - - deallocate (var1, var2, tile_id) - call InFmt%close() - call OutFmt%close() - if (present(rc)) rc = 0 - !_RETURN(_SUCCESS) - END SUBROUTINE read_catchcn_nc4 - - ! ***************************************************************************** - - SUBROUTINE regrid_carbon_vars ( & - NTILES,AGCM_YY,AGCM_MM,AGCM_DD,AGCM_HR, OutFileName, OutTileFile) - - implicit none - character (*), intent (in) :: OutTileFile, OutFileName - integer, intent (in) :: NTILES,AGCM_YY,AGCM_MM,AGCM_DD,AGCM_HR - real, allocatable, dimension (:) :: CLMC_pf1, CLMC_pf2, CLMC_sf1, CLMC_sf2, & - CLMC_pt1, CLMC_pt2,CLMC_st1,CLMC_st2 - - ! =============================================================================================== - - integer :: iclass(npft) = (/1,1,2,3,3,4,5,5,6,7,8,9,10,11,12,11,12,11,12/) - integer, allocatable, dimension(:,:) :: Id_glb, Id_loc - integer, allocatable, dimension(:) :: tid_offl, id_vec - real, allocatable, dimension(:,:) :: fveg_offl, ityp_offl - real :: fveg_new, sub_dist - integer :: n,i,j, k, nv, nx, nz, iv, offl_cell, ityp_new, STATUS,NCFID, req - integer :: outid, local_id - integer, allocatable, dimension (:) :: sub_tid, sub_ityp1, sub_ityp2,icl_ityp1 - real , pointer, dimension (:) :: sub_lon, sub_lat, rev_dist, sub_fevg1, sub_fevg2,& - lonc, latc, LATT, LONN, DAYX, long, latg, var_dum, TILE_ID, var_dum2 - real, allocatable :: var_off_col (:,:,:), var_off_pft (:,:,:,:) - real, allocatable :: var_col_out (:,:,:), var_pft_out (:,:,:,:) - integer, allocatable :: low_ind(:), upp_ind(:), nt_local (:) - integer :: AGCM_YYY, AGCM_MMM, AGCM_DDD, AGCM_HRR, AGCM_MI, AGCM_S, dofyr - type(MAPL_SunOrbit) :: ORBIT - type(ESMF_Time) :: CURRENT_TIME - type(ESMF_TimeInterval) :: timeStep - type(ESMF_Clock) :: CLOCK - type(ESMF_Config) :: CF - - - allocate (tid_offl (ntiles_cn)) - allocate (ityp_offl (ntiles_cn,nveg)) - allocate (fveg_offl (ntiles_cn,nveg)) - - allocate(low_ind ( numprocs)) - allocate(upp_ind ( numprocs)) - allocate(nt_local( numprocs)) - - low_ind (:) = 1 - upp_ind (:) = NTILES - nt_local(:) = NTILES - - ! Domain decomposition - ! -------------------- - - if (numprocs > 1) then - do i = 1, numprocs - 1 - upp_ind(i) = low_ind(i) + (ntiles/numprocs) - 1 - low_ind(i+1) = upp_ind(i) + 1 - nt_local(i) = upp_ind(i) - low_ind(i) + 1 - end do - nt_local(numprocs) = upp_ind(numprocs) - low_ind(numprocs) + 1 - endif - - allocate (id_loc (nt_local (myid + 1),4)) - allocate (lonn (nt_local (myid + 1))) - allocate (latt (nt_local (myid + 1))) - allocate (CLMC_pf1(nt_local (myid + 1))) - allocate (CLMC_pf2(nt_local (myid + 1))) - allocate (CLMC_sf1(nt_local (myid + 1))) - allocate (CLMC_sf2(nt_local (myid + 1))) - allocate (CLMC_pt1(nt_local (myid + 1))) - allocate (CLMC_pt2(nt_local (myid + 1))) - allocate (CLMC_st1(nt_local (myid + 1))) - allocate (CLMC_st2(nt_local (myid + 1))) - allocate (lonc (1:ntiles_cn)) - allocate (latc (1:ntiles_cn)) - - if (root_proc) then - - ! -------------------------------------------- - ! Read exact lonn, latt from output .til file - ! -------------------------------------------- - - allocate (long (ntiles)) - allocate (latg (ntiles)) - allocate (DAYX (NTILES)) - - call ReadTileFile_RealLatLon (OutTileFile, i, xlon=long, xlat=latg) - - !----------------------- - ! COMPUTE DAYX - !----------------------- - - AGCM_YYY = AGCM_YY - AGCM_MMM = AGCM_MM - AGCM_DDD = AGCM_DD - AGCM_HRR = AGCM_HR - AGCM_MI = 0 - AGCM_S = 0 - - - call ESMF_CalendarSetDefault ( ESMF_CALKIND_GREGORIAN, rc=status ) - - ! get current date & time - ! ----------------------- - call ESMF_TimeSet ( CURRENT_TIME, YY = AGCM_YYY, & - MM = AGCM_MMM, & - DD = AGCM_DDD, & - H = AGCM_HRR, & - M = AGCM_MI, & - S = AGCM_S , & - rc=status ) - VERIFY_(STATUS) - - call ESMF_TimeIntervalSet(TimeStep, S=450, RC=status) - clock = ESMF_ClockCreate(TimeStep, startTime = CURRENT_TIME, RC=status) - VERIFY_(STATUS) - call ESMF_ClockSet ( clock, CurrTime=CURRENT_TIME, rc=status ) - - CF = ESMF_ConfigCreate(RC=STATUS) - VERIFY_(status) - - ORBIT = MAPL_SunOrbitCreateFromConfig(CF, CLOCK, .false., RC=status) - VERIFY_(status) - - ! compute current daylight duration - !---------------------------------- - call MAPL_SunGetDaylightDuration(ORBIT,latg,dayx,currTime=CURRENT_TIME,RC=STATUS) - VERIFY_(STATUS) - - ! --------------------------------------------- - ! Read exact lonc, latc from offline .til File - ! --------------------------------------------- - - call ReadTileFile_RealLatLon(InCNTilFile,i,xlon=lonc,xlat=latc) - - endif - -! call MPI_SCATTERV ( & -! long,nt_local,low_ind-1,MPI_real, & -! lonn,size(lonn),MPI_real , & -! 0,MPI_COMM_WORLD, mpierr ) -! -! call MPI_SCATTERV ( & -! latg,nt_local,low_ind-1,MPI_real, & -! latt,nt_local(myid+1),MPI_real , & -! 0,MPI_COMM_WORLD, mpierr ) - - do i = 1, numprocs - if((I == 1).and.(myid == 0)) then - lonn(:) = long(low_ind(i) : upp_ind(i)) - latt(:) = latg(low_ind(i) : upp_ind(i)) - else if (I > 1) then - if(I-1 == myid) then - ! receiving from root - call MPI_RECV(lonn,nt_local(i) , MPI_REAL, 0,995,MPI_COMM_WORLD,MPI_STATUS_IGNORE,mpierr) - call MPI_RECV(latt,nt_local(i) , MPI_REAL, 0,994,MPI_COMM_WORLD,MPI_STATUS_IGNORE,mpierr) - else if (myid == 0) then - ! root sends - call MPI_ISend(long(low_ind(i) : upp_ind(i)),nt_local(i),MPI_REAL,i-1,995,MPI_COMM_WORLD,req,mpierr) - call MPI_WAIT (req,MPI_STATUS_IGNORE,mpierr) - call MPI_ISend(latg(low_ind(i) : upp_ind(i)),nt_local(i),MPI_REAL,i-1,994,MPI_COMM_WORLD,req,mpierr) - call MPI_WAIT (req,MPI_STATUS_IGNORE,mpierr) - endif - endif - end do - - if(root_proc) deallocate (long, latg) - - call MPI_BCAST(lonc,ntiles_cn,MPI_REAL,0,MPI_COMM_WORLD,mpierr) - call MPI_BCAST(latc,ntiles_cn,MPI_REAL,0,MPI_COMM_WORLD,mpierr) - - ! Open GKW/Fzeng SMAP M09 catchcn_internal_rst and output catchcn_internal_rst - ! ---------------------------------------------------------------------------- - ! call MPI_Info_create(info, STATUS) - ! call MPI_Info_set(info, "romio_cb_read", "automatic", STATUS) - ! STATUS = NF_OPEN_PAR (trim(InCNRestart),IOR(NF_NOWRITE,NF_MPIIO),MPI_COMM_WORLD, info,NCFID) - ! STATUS = NF_OPEN_PAR (trim(OutFileName),IOR(NF_WRITE ,NF_MPIIO),MPI_COMM_WORLD, info,OUTID) - - STATUS = NF_OPEN_PAR (trim(OutFileName),IOR(NF_NOWRITE,NF_MPIIO),MPI_COMM_WORLD, infos,OUTID) ; VERIFY_(STATUS) - ! if(root_proc) then - ! STATUS = NF_OPEN (trim(OutFileName),NF_WRITE,OUTID) - ! - ! else - ! STATUS = NF_OPEN (trim(OutFileName),NF_NOWRITE,OUTID) - ! endif - ! - IF (STATUS .NE. NF_NOERR) CALL HANDLE_ERR(STATUS, 'OUTPUT RESTART FAILED') - - STATUS = NF_GET_VARA_REAL(OUTID,VarID(OUTID,'ITY'), (/low_ind(myid+1),1/), (/nt_local(myid+1),1/),CLMC_pt1) - STATUS = NF_GET_VARA_REAL(OUTID,VarID(OUTID,'ITY'), (/low_ind(myid+1),2/), (/nt_local(myid+1),1/),CLMC_pt2) - STATUS = NF_GET_VARA_REAL(OUTID,VarID(OUTID,'ITY'), (/low_ind(myid+1),3/), (/nt_local(myid+1),1/),CLMC_st1) - STATUS = NF_GET_VARA_REAL(OUTID,VarID(OUTID,'ITY'), (/low_ind(myid+1),4/), (/nt_local(myid+1),1/),CLMC_st2) - STATUS = NF_GET_VARA_REAL(OUTID,VarID(OUTID,'FVG'), (/low_ind(myid+1),1/), (/nt_local(myid+1),1/),CLMC_pf1) - STATUS = NF_GET_VARA_REAL(OUTID,VarID(OUTID,'FVG'), (/low_ind(myid+1),2/), (/nt_local(myid+1),1/),CLMC_pf2) - STATUS = NF_GET_VARA_REAL(OUTID,VarID(OUTID,'FVG'), (/low_ind(myid+1),3/), (/nt_local(myid+1),1/),CLMC_sf1) - STATUS = NF_GET_VARA_REAL(OUTID,VarID(OUTID,'FVG'), (/low_ind(myid+1),4/), (/nt_local(myid+1),1/),CLMC_sf2) - - if (root_proc) then - - STATUS = NF_OPEN (trim(InCNRestart),NF_NOWRITE,NCFID) - IF (STATUS .NE. NF_NOERR) CALL HANDLE_ERR(STATUS, 'OFFLINE RESTART FAILED') - allocate (TILE_ID (1:ntiles_cn)) - - STATUS = NF_GET_VARA_REAL(NCFID,VarID(NCFID,'TILE_ID' ), (/1/), (/NTILES_cn/),TILE_ID) - - do n = 1,ntiles_cn - - K = NINT (TILE_ID (n)) - - STATUS = NF_GET_VARA_REAL(NCFID,VarID(NCFID,'ITY'), (/n,1/), (/1,4/),ityp_offl(k,:)) - STATUS = NF_GET_VARA_REAL(NCFID,VarID(NCFID,'FVG'), (/n,1/), (/1,4/),fveg_offl(k,:)) - - tid_offl (n) = n - - do nv = 1,nveg - if(ityp_offl(k,nv)<0 .or. ityp_offl(k,nv)>npft) stop 'ityp' - if(fveg_offl(k,nv)<0..or. fveg_offl(k,nv)>1.00001) stop 'fveg' - end do - - if((ityp_offl(k,3) == 0).and.(ityp_offl(k,4) == 0)) then - if(ityp_offl(k,1) /= 0) then - ityp_offl(k,3) = ityp_offl(k,1) - else - ityp_offl(k,3) = ityp_offl(k,2) - endif - endif - - if((ityp_offl(k,1) == 0).and.(ityp_offl(k,2) /= 0)) ityp_offl(k,1) = ityp_offl(k,2) - if((ityp_offl(k,2) == 0).and.(ityp_offl(k,1) /= 0)) ityp_offl(k,2) = ityp_offl(k,1) - if((ityp_offl(k,3) == 0).and.(ityp_offl(k,4) /= 0)) ityp_offl(k,3) = ityp_offl(k,4) - if((ityp_offl(k,4) == 0).and.(ityp_offl(k,3) /= 0)) ityp_offl(k,4) = ityp_offl(k,3) - - end do - - endif - - call MPI_BCAST(tid_offl ,size(tid_offl ),MPI_INTEGER,0,MPI_COMM_WORLD,mpierr) - call MPI_BCAST(ityp_offl,size(ityp_offl),MPI_REAL ,0,MPI_COMM_WORLD,mpierr) - call MPI_BCAST(fveg_offl,size(fveg_offl),MPI_REAL ,0,MPI_COMM_WORLD,mpierr) - - ! -------------------------------------------------------------------------------- - ! Here we create transfer index array to map offline restarts to output tile space - ! -------------------------------------------------------------------------------- - - call GetIds(lonc,latc,lonn,latt,id_loc, tid_offl, & - CLMC_pf1, CLMC_pf2, CLMC_sf1, CLMC_sf2, CLMC_pt1, CLMC_pt2,CLMC_st1,CLMC_st2, & - fveg_offl, ityp_offl) - deallocate (CLMC_pf1, CLMC_pf2, CLMC_sf1, CLMC_sf2, CLMC_pt1, CLMC_pt2,CLMC_st1,CLMC_st2,lonc,latc,lonn,latt) - - ! update id_glb in root - - if(root_proc) then - allocate (id_glb (ntiles,4)) - allocate (id_vec (ntiles)) - endif - - do nv = 1, nveg - call MPI_Barrier(MPI_COMM_WORLD, STATUS) -! call MPI_GATHERV( & -! id_loc (:,nv), nt_local(myid+1) , MPI_real, & -! id_vec, nt_local,low_ind-1, MPI_real, & -! 0, MPI_COMM_WORLD, mpierr ) - - do i = 1, numprocs - if((I == 1).and.(myid == 0)) then - id_vec(low_ind(i) : upp_ind(i)) = Id_loc(:,nv) - else if (I > 1) then - if(I-1 == myid) then - ! send to root - call MPI_ISend(id_loc(:,nv),nt_local(i),MPI_INTEGER,0,993,MPI_COMM_WORLD,req,mpierr) - call MPI_WAIT (req,MPI_STATUS_IGNORE,mpierr) - else if (myid == 0) then - ! root receives - call MPI_RECV(id_vec(low_ind(i) : upp_ind(i)),nt_local(i) , MPI_INTEGER, i-1,993,MPI_COMM_WORLD,MPI_STATUS_IGNORE,mpierr) - endif - endif - end do - - if(root_proc) id_glb (:,nv) = id_vec - - end do - - call MPI_Barrier(MPI_COMM_WORLD, STATUS) - STATUS = NF_CLOSE (OutID) -! write out regridded carbon variables - - if(root_proc) then - - STATUS = NF_OPEN (trim(OutFileName),NF_WRITE,OUTID) ; VERIFY_(STATUS) - allocate (CLMC_pf1(NTILES)) - allocate (CLMC_pf2(NTILES)) - allocate (CLMC_sf1(NTILES)) - allocate (CLMC_sf2(NTILES)) - allocate (CLMC_pt1(NTILES)) - allocate (CLMC_pt2(NTILES)) - allocate (CLMC_st1(NTILES)) - allocate (CLMC_st2(NTILES)) - allocate (VAR_DUM (NTILES)) - allocate (var_dum2 (1:ntiles_cn)) - - STATUS = NF_GET_VARA_REAL(OUTID,VarID(OUTID,'ITY'), (/1,1/), (/NTILES,1/),CLMC_pt1) - STATUS = NF_GET_VARA_REAL(OUTID,VarID(OUTID,'ITY'), (/1,2/), (/NTILES,1/),CLMC_pt2) - STATUS = NF_GET_VARA_REAL(OUTID,VarID(OUTID,'ITY'), (/1,3/), (/NTILES,1/),CLMC_st1) - STATUS = NF_GET_VARA_REAL(OUTID,VarID(OUTID,'ITY'), (/1,4/), (/NTILES,1/),CLMC_st2) - STATUS = NF_GET_VARA_REAL(OUTID,VarID(OUTID,'FVG'), (/1,1/), (/NTILES,1/),CLMC_pf1) - STATUS = NF_GET_VARA_REAL(OUTID,VarID(OUTID,'FVG'), (/1,2/), (/NTILES,1/),CLMC_pf2) - STATUS = NF_GET_VARA_REAL(OUTID,VarID(OUTID,'FVG'), (/1,3/), (/NTILES,1/),CLMC_sf1) - STATUS = NF_GET_VARA_REAL(OUTID,VarID(OUTID,'FVG'), (/1,4/), (/NTILES,1/),CLMC_sf2) - - allocate (var_off_col (1: NTILES_CN, 1 : nzone,1 : var_col)) - allocate (var_off_pft (1: NTILES_CN, 1 : nzone,1 : nveg, 1 : var_pft)) - - allocate (var_col_out (1: NTILES, 1 : nzone,1 : var_col)) - allocate (var_pft_out (1: NTILES, 1 : nzone,1 : nveg, 1 : var_pft)) - - i = 1 - do nv = 1,VAR_COL - do nz = 1,nzone - STATUS = NF_GET_VARA_REAL(NCFID,VarID(NCFID,'CNCOL'), (/1,i/), (/NTILES_CN,1 /),VAR_DUM2) - do k = 1, NTILES_CN - var_off_col(TILE_ID(K), nz,nv) = VAR_DUM2(K) - end do - i = i + 1 - end do - end do - - i = 1 - do iv = 1,VAR_PFT - do nv = 1,nveg - do nz = 1,nzone - STATUS = NF_GET_VARA_REAL(NCFID,VarID(NCFID,'CNPFT'), (/1,i/), (/NTILES_CN,1 /),VAR_DUM2) - do k = 1, NTILES_CN - var_off_pft(TILE_ID(K), nz,nv,iv) = VAR_DUM2(K) - end do - i = i + 1 - end do - end do - end do - - var_col_out = 0. - var_pft_out = NaN - - where(isnan(var_off_pft)) var_off_pft = 0. - where(var_off_pft /= var_off_pft) var_off_pft = 0. - - OUT_TILE : DO N = 1, NTILES - - !if(mod (n,1000) == 0) print *, myid +1, n, Id_glb(n,:) - - NVLOOP2 : do nv = 1, nveg - - if(nv <= 2) then ! index for secondary PFT index if primary or primary if secondary - nx = nv + 2 - else - nx = nv - 2 - endif - - if (nv == 1) ityp_new = CLMC_pt1(n) - if (nv == 1) fveg_new = CLMC_pf1(n) - if (nv == 2) ityp_new = CLMC_pt2(n) - if (nv == 2) fveg_new = CLMC_pf2(n) - if (nv == 3) ityp_new = CLMC_st1(n) - if (nv == 3) fveg_new = CLMC_sf1(n) - if (nv == 4) ityp_new = CLMC_st2(n) - if (nv == 4) fveg_new = CLMC_sf2(n) - - if (fveg_new > fmin) then - - offl_cell = Id_glb(n,nv) - - if(ityp_new == ityp_offl (offl_cell,nv) .and. fveg_offl (offl_cell,nv)> fmin) then - iv = nv ! same type fraction (primary of secondary) - else if(ityp_new == ityp_offl (offl_cell,nx) .and. fveg_offl (offl_cell,nx)> fmin) then - iv = nx ! not same fraction - else if(iclass(ityp_new)==iclass(ityp_offl(offl_cell,nv)) .and. fveg_offl (offl_cell,nv)> fmin) then - iv = nv ! primary, other type (same class) - else if(fveg_offl (offl_cell,nx)> fmin) then - iv = nx ! secondary, other type (same class) - endif - - ! Get col and pft variables for the Id_glb(nv) grid cell from offline catchcn_internal_rst - ! ---------------------------------------------------------------------------------------- - - ! call NCDF_reshape_getOput (NCFID,Id_glb(n,nv),var_off_col,var_off_pft,.true.) - - var_pft_out (n,:,nv,:) = var_off_pft(Id_glb(n,nv), :,iv,:) - var_col_out (n,:,:) = var_col_out(n,:,:) + fveg_new * var_off_col(Id_glb(n,nv), :,:) ! gkw: column state simple weighted mean; ! could use "woody" fraction? - - ! Check whether var_pft_out is realistic - do nz = 1, nzone - do j = 1, VAR_PFT - if (isnan(var_pft_out (n, nz,nv,j))) print *,j,nv,nz,n,var_pft_out (n, nz,nv,j),fveg_new - !if(isnan(var_pft_out (n, nz,nv,69))) var_pft_out (n, nz,nv,69) = 1.e-6 - !if(isnan(var_pft_out (n, nz,nv,70))) var_pft_out (n, nz,nv,70) = 1.e-6 - !if(isnan(var_pft_out (n, nz,nv,73))) var_pft_out (n, nz,nv,73) = 1.e-6 - !if(isnan(var_pft_out (n, nz,nv,74))) var_pft_out (n, nz,nv,74) = 1.e-6 - end do - end do - endif - - end do NVLOOP2 - - ! reset carbon if negative < 10g - ! ------------------------ - - NZLOOP : do nz = 1, nzone - - if(var_col_out (n, nz,14) < 10.) then - - var_col_out(n, nz, 1) = max(var_col_out(n, nz, 1), 0.) - var_col_out(n, nz, 2) = max(var_col_out(n, nz, 2), 0.) - var_col_out(n, nz, 3) = max(var_col_out(n, nz, 3), 0.) - var_col_out(n, nz, 4) = max(var_col_out(n, nz, 4), 0.) - var_col_out(n, nz, 5) = max(var_col_out(n, nz, 5), 0.) - var_col_out(n, nz,10) = max(var_col_out(n, nz,10), 0.) - var_col_out(n, nz,11) = max(var_col_out(n, nz,11), 0.) - var_col_out(n, nz,12) = max(var_col_out(n, nz,12), 0.) - var_col_out(n, nz,13) = max(var_col_out(n, nz,13),10.) ! soil4c - var_col_out(n, nz,14) = max(var_col_out(n, nz,14), 0.) - var_col_out(n, nz,15) = max(var_col_out(n, nz,15), 0.) - var_col_out(n, nz,16) = max(var_col_out(n, nz,16), 0.) - var_col_out(n, nz,17) = max(var_col_out(n, nz,17), 0.) - var_col_out(n, nz,18) = max(var_col_out(n, nz,18), 0.) - var_col_out(n, nz,19) = max(var_col_out(n, nz,19), 0.) - var_col_out(n, nz,20) = max(var_col_out(n, nz,20), 0.) - var_col_out(n, nz,24) = max(var_col_out(n, nz,24), 0.) - var_col_out(n, nz,25) = max(var_col_out(n, nz,25), 0.) - var_col_out(n, nz,26) = max(var_col_out(n, nz,26), 0.) - var_col_out(n, nz,27) = max(var_col_out(n, nz,27), 0.) - var_col_out(n, nz,28) = max(var_col_out(n, nz,28), 1.) - var_col_out(n, nz,29) = max(var_col_out(n, nz,29), 0.) - - NVLOOP3 : do nv = 1,nveg - - if (nv == 1) ityp_new = CLMC_pt1(n) - if (nv == 1) fveg_new = CLMC_pf1(n) - if (nv == 2) ityp_new = CLMC_pt2(n) - if (nv == 2) fveg_new = CLMC_pf2(n) - if (nv == 3) ityp_new = CLMC_st1(n) - if (nv == 3) fveg_new = CLMC_sf1(n) - if (nv == 4) ityp_new = CLMC_st2(n) - if (nv == 4) fveg_new = CLMC_sf2(n) - - if(fveg_new > fmin) then - var_pft_out(n, nz,nv, 1) = max(var_pft_out(n, nz,nv, 1),0.) - var_pft_out(n, nz,nv, 2) = max(var_pft_out(n, nz,nv, 2),0.) - var_pft_out(n, nz,nv, 3) = max(var_pft_out(n, nz,nv, 3),0.) - var_pft_out(n, nz,nv, 4) = max(var_pft_out(n, nz,nv, 4),0.) - - if(ityp_new <= 12) then ! tree or shrub deadstemc - var_pft_out(n, nz,nv, 5) = max(var_pft_out(n, nz,nv, 5),0.1) - else - var_pft_out(n, nz,nv, 5) = max(var_pft_out(n, nz,nv, 5),0.0) - endif - - var_pft_out(n, nz,nv, 6) = max(var_pft_out(n, nz,nv, 6),0.) - var_pft_out(n, nz,nv, 7) = max(var_pft_out(n, nz,nv, 7),0.) - var_pft_out(n, nz,nv, 8) = max(var_pft_out(n, nz,nv, 8),0.) - var_pft_out(n, nz,nv, 9) = max(var_pft_out(n, nz,nv, 9),0.) - var_pft_out(n, nz,nv,10) = max(var_pft_out(n, nz,nv,10),0.) - var_pft_out(n, nz,nv,11) = max(var_pft_out(n, nz,nv,11),0.) - var_pft_out(n, nz,nv,12) = max(var_pft_out(n, nz,nv,12),0.) - - if(ityp_new <=2 .or. ityp_new ==4 .or. ityp_new ==5 .or. ityp_new == 9) then - var_pft_out(n, nz,nv,13) = max(var_pft_out(n, nz,nv,13),1.) ! leaf carbon display for evergreen - var_pft_out(n, nz,nv,14) = max(var_pft_out(n, nz,nv,14),0.) - else - var_pft_out(n, nz,nv,13) = max(var_pft_out(n, nz,nv,13),0.) - var_pft_out(n, nz,nv,14) = max(var_pft_out(n, nz,nv,14),1.) ! leaf carbon storage for deciduous - endif - - var_pft_out(n, nz,nv,15) = max(var_pft_out(n, nz,nv,15),0.) - var_pft_out(n, nz,nv,16) = max(var_pft_out(n, nz,nv,16),0.) - var_pft_out(n, nz,nv,17) = max(var_pft_out(n, nz,nv,17),0.) - var_pft_out(n, nz,nv,18) = max(var_pft_out(n, nz,nv,18),0.) - var_pft_out(n, nz,nv,19) = max(var_pft_out(n, nz,nv,19),0.) - var_pft_out(n, nz,nv,20) = max(var_pft_out(n, nz,nv,20),0.) - var_pft_out(n, nz,nv,21) = max(var_pft_out(n, nz,nv,21),0.) - var_pft_out(n, nz,nv,22) = max(var_pft_out(n, nz,nv,22),0.) - var_pft_out(n, nz,nv,23) = max(var_pft_out(n, nz,nv,23),0.) - var_pft_out(n, nz,nv,25) = max(var_pft_out(n, nz,nv,25),0.) - var_pft_out(n, nz,nv,26) = max(var_pft_out(n, nz,nv,26),0.) - var_pft_out(n, nz,nv,27) = max(var_pft_out(n, nz,nv,27),0.) - var_pft_out(n, nz,nv,41) = max(var_pft_out(n, nz,nv,41),0.) - var_pft_out(n, nz,nv,42) = max(var_pft_out(n, nz,nv,42),0.) - var_pft_out(n, nz,nv,44) = max(var_pft_out(n, nz,nv,44),0.) - var_pft_out(n, nz,nv,45) = max(var_pft_out(n, nz,nv,45),0.) - var_pft_out(n, nz,nv,46) = max(var_pft_out(n, nz,nv,46),0.) - var_pft_out(n, nz,nv,47) = max(var_pft_out(n, nz,nv,47),0.) - var_pft_out(n, nz,nv,48) = max(var_pft_out(n, nz,nv,48),0.) - var_pft_out(n, nz,nv,49) = max(var_pft_out(n, nz,nv,49),0.) - var_pft_out(n, nz,nv,50) = max(var_pft_out(n, nz,nv,50),0.) - var_pft_out(n, nz,nv,51) = max(var_pft_out(n, nz,nv, 5)/500.,0.) - var_pft_out(n, nz,nv,52) = max(var_pft_out(n, nz,nv,52),0.) - var_pft_out(n, nz,nv,53) = max(var_pft_out(n, nz,nv,53),0.) - var_pft_out(n, nz,nv,54) = max(var_pft_out(n, nz,nv,54),0.) - var_pft_out(n, nz,nv,55) = max(var_pft_out(n, nz,nv,55),0.) - var_pft_out(n, nz,nv,56) = max(var_pft_out(n, nz,nv,56),0.) - var_pft_out(n, nz,nv,57) = max(var_pft_out(n, nz,nv,13)/25.,0.) - var_pft_out(n, nz,nv,58) = max(var_pft_out(n, nz,nv,14)/25.,0.) - var_pft_out(n, nz,nv,59) = max(var_pft_out(n, nz,nv,59),0.) - var_pft_out(n, nz,nv,60) = max(var_pft_out(n, nz,nv,60),0.) - var_pft_out(n, nz,nv,61) = max(var_pft_out(n, nz,nv,61),0.) - var_pft_out(n, nz,nv,62) = max(var_pft_out(n, nz,nv,62),0.) - var_pft_out(n, nz,nv,63) = max(var_pft_out(n, nz,nv,63),0.) - var_pft_out(n, nz,nv,64) = max(var_pft_out(n, nz,nv,64),0.) - var_pft_out(n, nz,nv,65) = max(var_pft_out(n, nz,nv,65),0.) - var_pft_out(n, nz,nv,66) = max(var_pft_out(n, nz,nv,66),0.) - var_pft_out(n, nz,nv,67) = max(var_pft_out(n, nz,nv,67),0.) - var_pft_out(n, nz,nv,68) = max(var_pft_out(n, nz,nv,68),0.) - var_pft_out(n, nz,nv,69) = max(var_pft_out(n, nz,nv,69),0.) - var_pft_out(n, nz,nv,70) = max(var_pft_out(n, nz,nv,70),0.) - var_pft_out(n, nz,nv,73) = max(var_pft_out(n, nz,nv,73),0.) - var_pft_out(n, nz,nv,74) = max(var_pft_out(n, nz,nv,74),0.) - endif - end do NVLOOP3 ! end veg loop - endif ! end carbon check - end do NZLOOP ! end zone loop - - ! Update dayx variable var_pft_out (:,:,28) - - do j = 28, 28 ! 1,VAR_PFT var_pft_out (:,:,:,28) - do nv = 1,nveg - do nz = 1,nzone - var_pft_out (n, nz,nv,j) = dayx(n) - end do - end do - end do - - ! call NCDF_reshape_getOput (OutID,N,var_col_out,var_pft_out,.false.) - - ! column vars - ! ----------- - ! 1 clm3%g%l%c%ccs%col_ctrunc - ! 2 clm3%g%l%c%ccs%cwdc - ! 3 clm3%g%l%c%ccs%litr1c - ! 4 clm3%g%l%c%ccs%litr2c - ! 5 clm3%g%l%c%ccs%litr3c - ! 6 clm3%g%l%c%ccs%pcs_a%totvegc - ! 7 clm3%g%l%c%ccs%prod100c - ! 8 clm3%g%l%c%ccs%prod10c - ! 9 clm3%g%l%c%ccs%seedc - ! 10 clm3%g%l%c%ccs%soil1c - ! 11 clm3%g%l%c%ccs%soil2c - ! 12 clm3%g%l%c%ccs%soil3c - ! 13 clm3%g%l%c%ccs%soil4c - ! 14 clm3%g%l%c%ccs%totcolc - ! 15 clm3%g%l%c%ccs%totlitc - ! 16 clm3%g%l%c%cns%col_ntrunc - ! 17 clm3%g%l%c%cns%cwdn - ! 18 clm3%g%l%c%cns%litr1n - ! 19 clm3%g%l%c%cns%litr2n - ! 20 clm3%g%l%c%cns%litr3n - ! 21 clm3%g%l%c%cns%prod100n - ! 22 clm3%g%l%c%cns%prod10n - ! 23 clm3%g%l%c%cns%seedn - ! 24 clm3%g%l%c%cns%sminn - ! 25 clm3%g%l%c%cns%soil1n - ! 26 clm3%g%l%c%cns%soil2n - ! 27 clm3%g%l%c%cns%soil3n - ! 28 clm3%g%l%c%cns%soil4n - ! 29 clm3%g%l%c%cns%totcoln - ! 30 clm3%g%l%c%cps%ann_farea_burned - ! 31 clm3%g%l%c%cps%annsum_counter - ! 32 clm3%g%l%c%cps%cannavg_t2m - ! 33 clm3%g%l%c%cps%cannsum_npp - ! 34 clm3%g%l%c%cps%farea_burned - ! 35 clm3%g%l%c%cps%fire_prob - ! 36 clm3%g%l%c%cps%fireseasonl - ! 37 clm3%g%l%c%cps%fpg - ! 38 clm3%g%l%c%cps%fpi - ! 39 clm3%g%l%c%cps%me - ! 40 clm3%g%l%c%cps%mean_fire_prob - - ! PFT vars - ! -------- - ! 1 clm3%g%l%c%p%pcs%cpool - ! 2 clm3%g%l%c%p%pcs%deadcrootc - ! 3 clm3%g%l%c%p%pcs%deadcrootc_storage - ! 4 clm3%g%l%c%p%pcs%deadcrootc_xfer - ! 5 clm3%g%l%c%p%pcs%deadstemc - ! 6 clm3%g%l%c%p%pcs%deadstemc_storage - ! 7 clm3%g%l%c%p%pcs%deadstemc_xfer - ! 8 clm3%g%l%c%p%pcs%frootc - ! 9 clm3%g%l%c%p%pcs%frootc_storage - ! 10 clm3%g%l%c%p%pcs%frootc_xfer - ! 11 clm3%g%l%c%p%pcs%gresp_storage - ! 12 clm3%g%l%c%p%pcs%gresp_xfer - ! 13 clm3%g%l%c%p%pcs%leafc - ! 14 clm3%g%l%c%p%pcs%leafc_storage - ! 15 clm3%g%l%c%p%pcs%leafc_xfer - ! 16 clm3%g%l%c%p%pcs%livecrootc - ! 17 clm3%g%l%c%p%pcs%livecrootc_storage - ! 18 clm3%g%l%c%p%pcs%livecrootc_xfer - ! 19 clm3%g%l%c%p%pcs%livestemc - ! 20 clm3%g%l%c%p%pcs%livestemc_storage - ! 21 clm3%g%l%c%p%pcs%livestemc_xfer - ! 22 clm3%g%l%c%p%pcs%pft_ctrunc - ! 23 clm3%g%l%c%p%pcs%xsmrpool - ! 24 clm3%g%l%c%p%pepv%annavg_t2m - ! 25 clm3%g%l%c%p%pepv%annmax_retransn - ! 26 clm3%g%l%c%p%pepv%annsum_npp - ! 27 clm3%g%l%c%p%pepv%annsum_potential_gpp - ! 28 clm3%g%l%c%p%pepv%dayl - ! 29 clm3%g%l%c%p%pepv%days_active - ! 30 clm3%g%l%c%p%pepv%dormant_flag - ! 31 clm3%g%l%c%p%pepv%offset_counter - ! 32 clm3%g%l%c%p%pepv%offset_fdd - ! 33 clm3%g%l%c%p%pepv%offset_flag - ! 34 clm3%g%l%c%p%pepv%offset_swi - ! 35 clm3%g%l%c%p%pepv%onset_counter - ! 36 clm3%g%l%c%p%pepv%onset_fdd - ! 37 clm3%g%l%c%p%pepv%onset_flag - ! 38 clm3%g%l%c%p%pepv%onset_gdd - ! 39 clm3%g%l%c%p%pepv%onset_gddflag - ! 40 clm3%g%l%c%p%pepv%onset_swi - ! 41 clm3%g%l%c%p%pepv%prev_frootc_to_litter - ! 42 clm3%g%l%c%p%pepv%prev_leafc_to_litter - ! 43 clm3%g%l%c%p%pepv%tempavg_t2m - ! 44 clm3%g%l%c%p%pepv%tempmax_retransn - ! 45 clm3%g%l%c%p%pepv%tempsum_npp - ! 46 clm3%g%l%c%p%pepv%tempsum_potential_gpp - ! 47 clm3%g%l%c%p%pepv%xsmrpool_recover - ! 48 clm3%g%l%c%p%pns%deadcrootn - ! 49 clm3%g%l%c%p%pns%deadcrootn_storage - ! 50 clm3%g%l%c%p%pns%deadcrootn_xfer - ! 51 clm3%g%l%c%p%pns%deadstemn - ! 52 clm3%g%l%c%p%pns%deadstemn_storage - ! 53 clm3%g%l%c%p%pns%deadstemn_xfer - ! 54 clm3%g%l%c%p%pns%frootn - ! 55 clm3%g%l%c%p%pns%frootn_storage - ! 56 clm3%g%l%c%p%pns%frootn_xfer - ! 57 clm3%g%l%c%p%pns%leafn - ! 58 clm3%g%l%c%p%pns%leafn_storage - ! 59 clm3%g%l%c%p%pns%leafn_xfer - ! 60 clm3%g%l%c%p%pns%livecrootn - ! 61 clm3%g%l%c%p%pns%livecrootn_storage - ! 62 clm3%g%l%c%p%pns%livecrootn_xfer - ! 63 clm3%g%l%c%p%pns%livestemn - ! 64 clm3%g%l%c%p%pns%livestemn_storage - ! 65 clm3%g%l%c%p%pns%livestemn_xfer - ! 66 clm3%g%l%c%p%pns%npool - ! 67 clm3%g%l%c%p%pns%pft_ntrunc - ! 68 clm3%g%l%c%p%pns%retransn - ! 69 clm3%g%l%c%p%pps%elai - ! 70 clm3%g%l%c%p%pps%esai - ! 71 clm3%g%l%c%p%pps%hbot - ! 72 clm3%g%l%c%p%pps%htop - ! 73 clm3%g%l%c%p%pps%tlai - ! 74 clm3%g%l%c%p%pps%tsai - - end do OUT_TILE - - i = 1 - do nv = 1,VAR_COL - do nz = 1,nzone - STATUS = NF_PUT_VARA_REAL(OutID,VarID(OUTID,'CNCOL'), (/1,i/), (/NTILES,1 /),var_col_out(:, nz,nv)) - i = i + 1 - end do - end do - - i = 1 - do iv = 1,VAR_PFT - do nv = 1,nveg - do nz = 1,nzone - STATUS = NF_PUT_VARA_REAL(OutID,VarID(OUTID,'CNPFT'), (/1,i/), (/NTILES,1 /),var_pft_out(:, nz,nv,iv)) - i = i + 1 - end do - end do - end do - - VAR_DUM = 0. - - do nz = 1,nzone - STATUS = NF_PUT_VARA_REAL(OutID,VarID(OUTID,'TGWM'), (/1,nz/), (/NTILES,1 /),VAR_DUM(:)) - STATUS = NF_PUT_VARA_REAL(OutID,VarID(OUTID,'RZMM'), (/1,nz/), (/NTILES,1 /),VAR_DUM(:)) - end do - - STATUS = NF_PUT_VARA_REAL(OutID,VarID(OUTID,'SFMCM'), (/1/), (/NTILES/),VAR_DUM(:)) - STATUS = NF_PUT_VARA_REAL(OutID,VarID(OUTID,'BFLOWM'), (/1/), (/NTILES/),VAR_DUM(:)) - STATUS = NF_PUT_VARA_REAL(OutID,VarID(OUTID,'TOTWATM'), (/1/), (/NTILES/),VAR_DUM(:)) - STATUS = NF_PUT_VARA_REAL(OutID,VarID(OUTID,'TAIRM'), (/1/), (/NTILES/),VAR_DUM(:)) - STATUS = NF_PUT_VARA_REAL(OutID,VarID(OUTID,'TPM'), (/1/), (/NTILES/),VAR_DUM(:)) - STATUS = NF_PUT_VARA_REAL(OutID,VarID(OUTID,'CNSUM'), (/1/), (/NTILES/),VAR_DUM(:)) - STATUS = NF_PUT_VARA_REAL(OutID,VarID(OUTID,'SNDZM'), (/1/), (/NTILES/),VAR_DUM(:)) - STATUS = NF_PUT_VARA_REAL(OutID,VarID(OUTID,'ASNOWM'), (/1/), (/NTILES/),VAR_DUM(:)) - - do nv = 1,nzone - do nz = 1,nveg - STATUS = NF_PUT_VARA_REAL(OutID,VarID(OUTID,'PSNSUNM'), (/1,nz,nv/), (/NTILES,1,1/),VAR_DUM(:)) - STATUS = NF_PUT_VARA_REAL(OutID,VarID(OUTID,'PSNSHAM'), (/1,nz,nv/), (/NTILES,1,1/),VAR_DUM(:)) - end do - end do - - STATUS = NF_CLOSE (NCFID) - STATUS = NF_CLOSE (OutID) - - deallocate (var_off_col,var_off_pft,var_col_out,var_pft_out) - deallocate (CLMC_pf1, CLMC_pf2, CLMC_sf1, CLMC_sf2) - deallocate (CLMC_pt1, CLMC_pt2, CLMC_st1, CLMC_st2) - - endif - - call MPI_Barrier(MPI_COMM_WORLD, STATUS) - - - END SUBROUTINE regrid_carbon_vars - - ! ***************************************************************************** - - SUBROUTINE NCDF_reshape_getOput (NCFID,CID,col,pft, get_var) - - implicit none - - integer, intent (in) :: NCFID,CID - logical, intent (in) :: get_var - real, intent (inout) :: col (nzone * VAR_COL) - real, intent (inout) :: pft (nzone * nveg * var_PFT) - integer :: STATUS - - if (get_var) then - STATUS = NF_GET_VARA_REAL(NCFID,VarID(NCFID,'CNCOL'), (/CID,1/), (/1,nzone * VAR_COL /),col) - STATUS = NF_GET_VARA_REAL(NCFID,VarID(NCFID,'CNPFT'), (/CID,1/), (/1,nzone * nveg * var_PFT/),pft) - else - STATUS = NF_PUT_VARA_REAL(NCFID,VarID(NCFID,'CNCOL'), (/CID,1/), (/1,nzone * VAR_COL /),col) - STATUS = NF_PUT_VARA_REAL(NCFID,VarID(NCFID,'CNPFT'), (/CID,1/), (/1,nzone * nveg * var_PFT/),pft) - endif - - IF ((STATUS .NE. NF_NOERR).and.(get_var)) then - print *,CID - CALL HANDLE_ERR(STATUS, 'Out : NCDF_reshape_getOput') - ENDIF - - IF ((STATUS .NE. NF_NOERR).and.(.not.get_var)) then - print *,CID - CALL HANDLE_ERR(STATUS, 'In : NCDF_reshape_getOput') - ENDIF - END SUBROUTINE NCDF_reshape_getOput - - ! ***************************************************************************** - - SUBROUTINE NCDF_whole_getOput (NCFID,NTILES,col,pft, get_var) - - implicit none - - integer, intent (in) :: NCFID,NTILES - logical, intent (in) :: get_var - real, intent (inout) :: col (NTILES, nzone * VAR_COL) - real, intent (inout) :: pft (NTILES, nzone * nveg * var_PFT) - integer :: STATUS, J - - if (get_var) then - DO J = 1,nzone * VAR_COL - STATUS = NF_GET_VARA_REAL(NCFID,VarID(NCFID,'CNCOL'), (/1,J/), (/NTILES,1 /),col(:,j)) - END DO - DO J = 1, nzone * nveg * var_PFT - STATUS = NF_GET_VARA_REAL(NCFID,VarID(NCFID,'CNPFT'), (/1,J/), (/NTILES,1/),pft(:,J)) - END DO - else - DO J = 1,nzone * VAR_COL - STATUS = NF_PUT_VARA_REAL(NCFID,VarID(NCFID,'CNCOL'), (/1,J/), (/NTILES,1 /),col(:,J)) - END DO - DO J = 1, nzone * nveg * var_PFT - STATUS = NF_PUT_VARA_REAL(NCFID,VarID(NCFID,'CNPFT'), (/1,J/), (/NTILES,1/) ,pft(:,J)) - END DO - endif - - IF ((STATUS .NE. NF_NOERR).and.(get_var)) CALL HANDLE_ERR(STATUS, 'Out : NCDF_whole_getOput') - IF ((STATUS .NE. NF_NOERR).and.(.not.get_var)) CALL HANDLE_ERR(STATUS, 'In : NCDF_whole_getOput') - - END SUBROUTINE NCDF_whole_getOput - - ! ----------------------------------------------------------------------- - - SUBROUTINE HANDLE_ERR(STATUS, Line) - - INTEGER, INTENT (IN) :: STATUS - CHARACTER(*), INTENT (IN) :: Line - - IF (STATUS .NE. NF_NOERR) THEN - PRINT *, trim(Line),': ',NF_STRERROR(STATUS) - STOP 'Stopped' - ENDIF - - END SUBROUTINE HANDLE_ERR - - ! ***************************************************************************** - - integer function VarID (NCFID, VNAME) - - integer, intent (in) :: NCFID - character(*), intent (in) :: VNAME - integer :: status - - STATUS = NF_INQ_VARID (NCFID, trim(VNAME) ,VarID) - IF (STATUS .NE. NF_NOERR) & - CALL HANDLE_ERR(STATUS, trim(VNAME)) - - end function VarID - - ! ***************************************************************************** - - SUBROUTINE regrid_hyd_vars (NTILES, OutFMT) - - implicit none - integer, intent (in) :: NTILES - - ! =============================================================================================== - - integer, allocatable, dimension(:) :: Id_glb, Id_loc - integer, allocatable, dimension(:) :: ld_reorder, tid_offl - real , allocatable, dimension(:) :: tmp_var - integer :: n,i,j, nv, nx, offl_cell, STATUS,NCFID, req - integer :: outid, local_id - real , pointer, dimension (:) :: lonc, latc, LATT, LONN, long, latg - integer, allocatable :: low_ind(:), upp_ind(:), nt_local (:) - type(Netcdf4_Fileformatter) :: InFmt, OutFmt - - allocate (tid_offl (ntiles_cn)) - allocate (tmp_var (ntiles_cn)) - - allocate(low_ind ( numprocs)) - allocate(upp_ind ( numprocs)) - allocate(nt_local( numprocs)) - - low_ind (:) = 1 - upp_ind (:) = NTILES - nt_local(:) = NTILES - - ! Domain decomposition - ! -------------------- - - if (numprocs > 1) then - do i = 1, numprocs - 1 - upp_ind(i) = low_ind(i) + (ntiles/numprocs) - 1 - low_ind(i+1) = upp_ind(i) + 1 - nt_local(i) = upp_ind(i) - low_ind(i) + 1 - end do - nt_local(numprocs) = upp_ind(numprocs) - low_ind(numprocs) + 1 - endif - - allocate (id_loc (nt_local (myid + 1))) - allocate (lonn (nt_local (myid + 1))) - allocate (latt (nt_local (myid + 1))) - allocate (lonc (1:ntiles_cn)) - allocate (latc (1:ntiles_cn)) - - if (root_proc) then - - allocate (long (ntiles)) - allocate (latg (ntiles)) - allocate (ld_reorder(ntiles_cn)) - - call ReadTileFile_RealLatLon (OutTileFile, i, xlon=long, xlat=latg) - - ! --------------------------------------------- - ! Read exact lonc, latc from offline .til File - ! --------------------------------------------- - - call ReadTileFile_RealLatLon(trim(InCNTilFile), i,xlon=lonc,xlat=latc) - - STATUS = NF_OPEN (trim(InCNRestart),NF_NOWRITE,NCFID) - STATUS = NF_GET_VARA_REAL(NCFID,VarID(NCFID,'TILE_ID' ), (/1/), (/NTILES_CN/),tmp_var) - STATUS = NF_CLOSE (NCFID) - - do n = 1, ntiles_cn - ld_reorder ( NINT(tmp_var(n))) = n - tid_offl(n) = n - end do - - deallocate (tmp_var) - - endif - - call MPI_Barrier(MPI_COMM_WORLD, STATUS) - - do i = 1, numprocs - if((I == 1).and.(myid == 0)) then - lonn(:) = long(low_ind(i) : upp_ind(i)) - latt(:) = latg(low_ind(i) : upp_ind(i)) - else if (I > 1) then - if(I-1 == myid) then - ! receiving from root - call MPI_RECV(lonn,nt_local(i) , MPI_REAL, 0,995,MPI_COMM_WORLD,MPI_STATUS_IGNORE,mpierr) - call MPI_RECV(latt,nt_local(i) , MPI_REAL, 0,994,MPI_COMM_WORLD,MPI_STATUS_IGNORE,mpierr) - else if (myid == 0) then - ! root sends - call MPI_ISend(long(low_ind(i) : upp_ind(i)),nt_local(i),MPI_REAL,i-1,995,MPI_COMM_WORLD,req,mpierr) - call MPI_WAIT (req,MPI_STATUS_IGNORE,mpierr) - call MPI_ISend(latg(low_ind(i) : upp_ind(i)),nt_local(i),MPI_REAL,i-1,994,MPI_COMM_WORLD,req,mpierr) - call MPI_WAIT (req,MPI_STATUS_IGNORE,mpierr) - endif - endif - end do - -! call MPI_SCATTERV ( & -! long,nt_local,low_ind-1,MPI_real, & -! lonn,size(lonn),MPI_real , & -! 0,MPI_COMM_WORLD, mpierr ) -! -! call MPI_SCATTERV ( & -! latg,nt_local,low_ind-1,MPI_real, & -! latt,nt_local(myid+1),MPI_real , & -! 0,MPI_COMM_WORLD, mpierr ) - - if(root_proc) deallocate (long, latg) - - call MPI_BCAST(lonc,ntiles_cn,MPI_REAL,0,MPI_COMM_WORLD,mpierr) - call MPI_BCAST(latc,ntiles_cn,MPI_REAL,0,MPI_COMM_WORLD,mpierr) - call MPI_BCAST(tid_offl,size(tid_offl ),MPI_INTEGER,0,MPI_COMM_WORLD,mpierr) - - ! -------------------------------------------------------------------------------- - ! Here we create transfer index array to map offline restarts to output tile space - ! -------------------------------------------------------------------------------- - - call GetIds(lonc,latc,lonn,latt,id_loc, tid_offl) - - ! Loop through NTILES (# of tiles in output array) find the nearest neighbor from Qing. - - if(root_proc) allocate (id_glb (ntiles)) - - call MPI_Barrier(MPI_COMM_WORLD, STATUS) - - do i = 1, numprocs - if((I == 1).and.(myid == 0)) then - id_glb(low_ind(i) : upp_ind(i)) = Id_loc(:) - else if (I > 1) then - if(I-1 == myid) then - ! send to root - call MPI_ISend(id_loc,nt_local(i),MPI_INTEGER,0,993,MPI_COMM_WORLD,req,mpierr) - call MPI_WAIT (req,MPI_STATUS_IGNORE,mpierr) - else if (myid == 0) then - ! root receives - call MPI_RECV(id_glb(low_ind(i) : upp_ind(i)),nt_local(i) , MPI_INTEGER, i-1,993,MPI_COMM_WORLD,MPI_STATUS_IGNORE,mpierr) - endif - endif - end do - -! call MPI_GATHERV( & -! id_loc, nt_local(myid+1) , MPI_real, & -! id_glb, nt_local,low_ind-1, MPI_real, & -! 0, MPI_COMM_WORLD, mpierr ) - - if (root_proc) call put_land_vars (NTILES, id_glb, ld_reorder, OutFmt) - - call MPI_Barrier(MPI_COMM_WORLD, STATUS) - - END SUBROUTINE regrid_hyd_vars - - ! ***************************************************************************** - SUBROUTINE put_land_vars (NTILES, id_glb, ld_reorder, OutFmt) - - implicit none - - integer, intent (in) :: NTILES - integer, intent (in) :: id_glb(NTILES), ld_reorder (NTILES_CN) - integer :: i,k,n - real , dimension (:), allocatable :: var_get, var_put - type(Netcdf4_Fileformatter) :: OutFmt - integer :: nVars, STATUS, NCFID - - allocate (var_get (NTILES_CN)) - allocate (var_put (NTILES)) - - ! Read catparam - ! ------------- - - STATUS = NF_OPEN (trim(InCNRestart),NF_NOWRITE,NCFID) - - STATUS = NF_GET_VARA_REAL(NCFID,VarID(NCFID,'POROS' ), (/1/), (/NTILES_CN/),var_get) - do k = 1, NTILES - VAR_PUT(k) = var_get(ld_reorder(id_glb(k))) - end do - call MAPL_VarWrite(OutFmt,'POROS',var_put) - - STATUS = NF_GET_VARA_REAL(NCFID,VarID(NCFID,'COND' ), (/1/), (/NTILES_CN/),var_get) - do k = 1, NTILES - VAR_PUT(k) = var_get(ld_reorder(id_glb(k))) - end do - call MAPL_VarWrite(OutFmt,'COND',var_put) - - STATUS = NF_GET_VARA_REAL(NCFID,VarID(NCFID,'PSIS' ), (/1/), (/NTILES_CN/),var_get) - do k = 1, NTILES - VAR_PUT(k) = var_get(ld_reorder(id_glb(k))) - end do - call MAPL_VarWrite(OutFmt,'PSIS',var_put) - - STATUS = NF_GET_VARA_REAL(NCFID,VarID(NCFID,'BEE' ), (/1/), (/NTILES_CN/),var_get) - do k = 1, NTILES - VAR_PUT(k) = var_get(ld_reorder(id_glb(k))) - end do - call MAPL_VarWrite(OutFmt,'BEE',var_put) - - STATUS = NF_GET_VARA_REAL(NCFID,VarID(NCFID,'WPWET' ), (/1/), (/NTILES_CN/),var_get) - do k = 1, NTILES - VAR_PUT(k) = var_get(ld_reorder(id_glb(k))) - end do - call MAPL_VarWrite(OutFmt,'WPWET',var_put) - - STATUS = NF_GET_VARA_REAL(NCFID,VarID(NCFID,'GNU' ), (/1/), (/NTILES_CN/),var_get) - do k = 1, NTILES - VAR_PUT(k) = var_get(ld_reorder(id_glb(k))) - end do - call MAPL_VarWrite(OutFmt,'GNU',var_put) - - STATUS = NF_GET_VARA_REAL(NCFID,VarID(NCFID,'VGWMAX' ), (/1/), (/NTILES_CN/),var_get) - do k = 1, NTILES - VAR_PUT(k) = var_get(ld_reorder(id_glb(k))) - end do - call MAPL_VarWrite(OutFmt,'VGWMAX',var_put) - - STATUS = NF_GET_VARA_REAL(NCFID,VarID(NCFID,'BF1' ), (/1/), (/NTILES_CN/),var_get) - do k = 1, NTILES - VAR_PUT(k) = var_get(ld_reorder(id_glb(k))) - end do - call MAPL_VarWrite(OutFmt,'BF1',var_put) - - STATUS = NF_GET_VARA_REAL(NCFID,VarID(NCFID,'BF2' ), (/1/), (/NTILES_CN/),var_get) - do k = 1, NTILES - VAR_PUT(k) = var_get(ld_reorder(id_glb(k))) - end do - call MAPL_VarWrite(OutFmt,'BF2',var_put) - - STATUS = NF_GET_VARA_REAL(NCFID,VarID(NCFID,'BF3' ), (/1/), (/NTILES_CN/),var_get) - do k = 1, NTILES - VAR_PUT(k) = var_get(ld_reorder(id_glb(k))) - end do - call MAPL_VarWrite(OutFmt,'BF3',var_put) - - STATUS = NF_GET_VARA_REAL(NCFID,VarID(NCFID,'CDCR1' ), (/1/), (/NTILES_CN/),var_get) - do k = 1, NTILES - VAR_PUT(k) = var_get(ld_reorder(id_glb(k))) - end do - call MAPL_VarWrite(OutFmt,'CDCR1',var_put) - - STATUS = NF_GET_VARA_REAL(NCFID,VarID(NCFID,'CDCR2' ), (/1/), (/NTILES_CN/),var_get) - do k = 1, NTILES - VAR_PUT(k) = var_get(ld_reorder(id_glb(k))) - end do - call MAPL_VarWrite(OutFmt,'CDCR2',var_put) - - STATUS = NF_GET_VARA_REAL(NCFID,VarID(NCFID,'ARS1' ), (/1/), (/NTILES_CN/),var_get) - do k = 1, NTILES - VAR_PUT(k) = var_get(ld_reorder(id_glb(k))) - end do - call MAPL_VarWrite(OutFmt,'ARS1',var_put) - - STATUS = NF_GET_VARA_REAL(NCFID,VarID(NCFID,'ARS2' ), (/1/), (/NTILES_CN/),var_get) - do k = 1, NTILES - VAR_PUT(k) = var_get(ld_reorder(id_glb(k))) - end do - call MAPL_VarWrite(OutFmt,'ARS2',var_put) - - STATUS = NF_GET_VARA_REAL(NCFID,VarID(NCFID,'ARS3' ), (/1/), (/NTILES_CN/),var_get) - do k = 1, NTILES - VAR_PUT(k) = var_get(ld_reorder(id_glb(k))) - end do - call MAPL_VarWrite(OutFmt,'ARS3',var_put) - - STATUS = NF_GET_VARA_REAL(NCFID,VarID(NCFID,'ARA1' ), (/1/), (/NTILES_CN/),var_get) - do k = 1, NTILES - VAR_PUT(k) = var_get(ld_reorder(id_glb(k))) - end do - call MAPL_VarWrite(OutFmt,'ARA1',var_put) - - STATUS = NF_GET_VARA_REAL(NCFID,VarID(NCFID,'ARA2' ), (/1/), (/NTILES_CN/),var_get) - do k = 1, NTILES - VAR_PUT(k) = var_get(ld_reorder(id_glb(k))) - end do - call MAPL_VarWrite(OutFmt,'ARA2',var_put) - - STATUS = NF_GET_VARA_REAL(NCFID,VarID(NCFID,'ARA3' ), (/1/), (/NTILES_CN/),var_get) - do k = 1, NTILES - VAR_PUT(k) = var_get(ld_reorder(id_glb(k))) - end do - call MAPL_VarWrite(OutFmt,'ARA3',var_put) - - STATUS = NF_GET_VARA_REAL(NCFID,VarID(NCFID,'ARA4' ), (/1/), (/NTILES_CN/),var_get) - do k = 1, NTILES - VAR_PUT(k) = var_get(ld_reorder(id_glb(k))) - end do - call MAPL_VarWrite(OutFmt,'ARA4',var_put) - - STATUS = NF_GET_VARA_REAL(NCFID,VarID(NCFID,'ARW1' ), (/1/), (/NTILES_CN/),var_get) - do k = 1, NTILES - VAR_PUT(k) = var_get(ld_reorder(id_glb(k))) - end do - call MAPL_VarWrite(OutFmt,'ARW1',var_put) - - STATUS = NF_GET_VARA_REAL(NCFID,VarID(NCFID,'ARW2' ), (/1/), (/NTILES_CN/),var_get) - do k = 1, NTILES - VAR_PUT(k) = var_get(ld_reorder(id_glb(k))) - end do - call MAPL_VarWrite(OutFmt,'ARW2',var_put) - - STATUS = NF_GET_VARA_REAL(NCFID,VarID(NCFID,'ARW3' ), (/1/), (/NTILES_CN/),var_get) - do k = 1, NTILES - VAR_PUT(k) = var_get(ld_reorder(id_glb(k))) - end do - call MAPL_VarWrite(OutFmt,'ARW3',var_put) - - STATUS = NF_GET_VARA_REAL(NCFID,VarID(NCFID,'ARW4' ), (/1/), (/NTILES_CN/),var_get) - do k = 1, NTILES - VAR_PUT(k) = var_get(ld_reorder(id_glb(k))) - end do - call MAPL_VarWrite(OutFmt,'ARW4',var_put) - - STATUS = NF_GET_VARA_REAL(NCFID,VarID(NCFID,'TSA1' ), (/1/), (/NTILES_CN/),var_get) - do k = 1, NTILES - VAR_PUT(k) = var_get(ld_reorder(id_glb(k))) - end do - call MAPL_VarWrite(OutFmt,'TSA1',var_put) - - STATUS = NF_GET_VARA_REAL(NCFID,VarID(NCFID,'TSA2' ), (/1/), (/NTILES_CN/),var_get) - do k = 1, NTILES - VAR_PUT(k) = var_get(ld_reorder(id_glb(k))) - end do - call MAPL_VarWrite(OutFmt,'TSA2',var_put) - - STATUS = NF_GET_VARA_REAL(NCFID,VarID(NCFID,'TSB1' ), (/1/), (/NTILES_CN/),var_get) - do k = 1, NTILES - VAR_PUT(k) = var_get(ld_reorder(id_glb(k))) - end do - call MAPL_VarWrite(OutFmt,'TSB1',var_put) - - STATUS = NF_GET_VARA_REAL(NCFID,VarID(NCFID,'TSB2' ), (/1/), (/NTILES_CN/),var_get) - do k = 1, NTILES - VAR_PUT(k) = var_get(ld_reorder(id_glb(k))) - end do - call MAPL_VarWrite(OutFmt,'TSB2',var_put) - - STATUS = NF_GET_VARA_REAL(NCFID,VarID(NCFID,'ATAU' ), (/1/), (/NTILES_CN/),var_get) - do k = 1, NTILES - VAR_PUT(k) = var_get(ld_reorder(id_glb(k))) - end do - call MAPL_VarWrite(OutFmt,'ATAU',var_put) - - STATUS = NF_GET_VARA_REAL(NCFID,VarID(NCFID,'BTAU' ), (/1/), (/NTILES_CN/),var_get) - do k = 1, NTILES - VAR_PUT(k) = var_get(ld_reorder(id_glb(k))) - end do - call MAPL_VarWrite(OutFmt,'BTAU',var_put) - - STATUS = NF_GET_VARA_REAL(NCFID,VarID(NCFID,'ITY' ), (/1,1/), (/NTILES_CN,1/),var_get) - do k = 1, NTILES - VAR_PUT(k) = var_get(ld_reorder(id_glb(k))) - end do - call MAPL_VarWrite(OutFmt,'ITY',var_put, offset1=1) - STATUS = NF_GET_VARA_REAL(NCFID,VarID(NCFID,'ITY' ), (/1,2/), (/NTILES_CN,1/),var_get) - do k = 1, NTILES - VAR_PUT(k) = var_get(ld_reorder(id_glb(k))) - end do - call MAPL_VarWrite(OutFmt,'ITY',var_put, offset1=2) - STATUS = NF_GET_VARA_REAL(NCFID,VarID(NCFID,'ITY' ), (/1,3/), (/NTILES_CN,1/),var_get) - do k = 1, NTILES - VAR_PUT(k) = var_get(ld_reorder(id_glb(k))) - end do - call MAPL_VarWrite(OutFmt,'ITY',var_put, offset1=3) - STATUS = NF_GET_VARA_REAL(NCFID,VarID(NCFID,'ITY' ), (/1,4/), (/NTILES_CN,1/),var_get) - do k = 1, NTILES - VAR_PUT(k) = var_get(ld_reorder(id_glb(k))) - end do - call MAPL_VarWrite(OutFmt,'ITY',var_put, offset1=4) - - STATUS = NF_GET_VARA_REAL(NCFID,VarID(NCFID,'FVG' ), (/1,1/), (/NTILES_CN,1/),var_get) - do k = 1, NTILES - VAR_PUT(k) = var_get(ld_reorder(id_glb(k))) - end do - call MAPL_VarWrite(OutFmt,'FVG',var_put, offset1=1) - STATUS = NF_GET_VARA_REAL(NCFID,VarID(NCFID,'FVG' ), (/1,2/), (/NTILES_CN,1/),var_get) - do k = 1, NTILES - VAR_PUT(k) = var_get(ld_reorder(id_glb(k))) - end do - call MAPL_VarWrite(OutFmt,'FVG',var_put, offset1=2) - STATUS = NF_GET_VARA_REAL(NCFID,VarID(NCFID,'FVG' ), (/1,3/), (/NTILES_CN,1/),var_get) - do k = 1, NTILES - VAR_PUT(k) = var_get(ld_reorder(id_glb(k))) - end do - call MAPL_VarWrite(OutFmt,'FVG',var_put, offset1=3) - STATUS = NF_GET_VARA_REAL(NCFID,VarID(NCFID,'FVG' ), (/1,4/), (/NTILES_CN,1/),var_get) - do k = 1, NTILES - VAR_PUT(k) = var_get(ld_reorder(id_glb(k))) - end do - call MAPL_VarWrite(OutFmt,'FVG',var_put, offset1=4) - - ! read restart and regrid - ! ----------------------- - - STATUS = NF_GET_VARA_REAL(NCFID,VarID(NCFID,'TG' ), (/1,1/), (/NTILES_CN,1/),var_get) - do k = 1, NTILES - VAR_PUT(k) = var_get(ld_reorder(id_glb(k))) - end do - call MAPL_VarWrite(OutFmt,'TG',var_put, offset1=1) ! if you see offset1=1 it is a 2-D var - - STATUS = NF_GET_VARA_REAL(NCFID,VarID(NCFID,'TG' ), (/1,2/), (/NTILES_CN,1/),var_get) - do k = 1, NTILES - VAR_PUT(k) = var_get(ld_reorder(id_glb(k))) - end do - call MAPL_VarWrite(OutFmt,'TG',var_put, offset1=2) - - STATUS = NF_GET_VARA_REAL(NCFID,VarID(NCFID,'TG' ), (/1,3/), (/NTILES_CN,1/),var_get) - do k = 1, NTILES - VAR_PUT(k) = var_get(ld_reorder(id_glb(k))) - end do - call MAPL_VarWrite(OutFmt,'TG',var_put, offset1=3) - - STATUS = NF_GET_VARA_REAL(NCFID,VarID(NCFID,'TC' ), (/1,1/), (/NTILES_CN,1/),var_get) - do k = 1, NTILES - VAR_PUT(k) = var_get(ld_reorder(id_glb(k))) - end do - call MAPL_VarWrite(OutFmt,'TC',var_put, offset1=1) - - STATUS = NF_GET_VARA_REAL(NCFID,VarID(NCFID,'TC' ), (/1,2/), (/NTILES_CN,1/),var_get) - do k = 1, NTILES - VAR_PUT(k) = var_get(ld_reorder(id_glb(k))) - end do - call MAPL_VarWrite(OutFmt,'TC',var_put, offset1=2) - - STATUS = NF_GET_VARA_REAL(NCFID,VarID(NCFID,'TC' ), (/1,3/), (/NTILES_CN,1/),var_get) - do k = 1, NTILES - VAR_PUT(k) = var_get(ld_reorder(id_glb(k))) - end do - call MAPL_VarWrite(OutFmt,'TC',var_put, offset1=3) - - STATUS = NF_GET_VARA_REAL(NCFID,VarID(NCFID,'QC' ), (/1,1/), (/NTILES_CN,1/),var_get) - do k = 1, NTILES - VAR_PUT(k) = var_get(ld_reorder(id_glb(k))) - end do - call MAPL_VarWrite(OutFmt,'QC',var_put, offset1=1) - - STATUS = NF_GET_VARA_REAL(NCFID,VarID(NCFID,'QC' ), (/1,2/), (/NTILES_CN,1/),var_get) - do k = 1, NTILES - VAR_PUT(k) = var_get(ld_reorder(id_glb(k))) - end do - call MAPL_VarWrite(OutFmt,'QC',var_put, offset1=2) - - STATUS = NF_GET_VARA_REAL(NCFID,VarID(NCFID,'QC' ), (/1,3/), (/NTILES_CN,1/),var_get) - do k = 1, NTILES - VAR_PUT(k) = var_get(ld_reorder(id_glb(k))) - end do - call MAPL_VarWrite(OutFmt,'QC',var_put, offset1=3) - - STATUS = NF_GET_VARA_REAL(NCFID,VarID(NCFID,'CAPAC' ), (/1/), (/NTILES_CN/),var_get) - do k = 1, NTILES - VAR_PUT(k) = var_get(ld_reorder(id_glb(k))) - end do - call MAPL_VarWrite(OutFmt,'CAPAC',var_put) - - STATUS = NF_GET_VARA_REAL(NCFID,VarID(NCFID,'CATDEF' ), (/1/), (/NTILES_CN/),var_get) - do k = 1, NTILES - VAR_PUT(k) = var_get(ld_reorder(id_glb(k))) - end do - call MAPL_VarWrite(OutFmt,'CATDEF',var_put) - - STATUS = NF_GET_VARA_REAL(NCFID,VarID(NCFID,'RZEXC' ), (/1/), (/NTILES_CN/),var_get) - do k = 1, NTILES - VAR_PUT(k) = var_get(ld_reorder(id_glb(k))) - end do - call MAPL_VarWrite(OutFmt,'RZEXC',var_put) - - STATUS = NF_GET_VARA_REAL(NCFID,VarID(NCFID,'SRFEXC' ), (/1/), (/NTILES_CN/),var_get) - do k = 1, NTILES - VAR_PUT(k) = var_get(ld_reorder(id_glb(k))) - end do - call MAPL_VarWrite(OutFmt,'SRFEXC',var_put) - - STATUS = NF_GET_VARA_REAL(NCFID,VarID(NCFID,'GHTCNT1' ), (/1/), (/NTILES_CN/),var_get) - do k = 1, NTILES - VAR_PUT(k) = var_get(ld_reorder(id_glb(k))) - end do - call MAPL_VarWrite(OutFmt,'GHTCNT1',var_put) - - STATUS = NF_GET_VARA_REAL(NCFID,VarID(NCFID,'GHTCNT2' ), (/1/), (/NTILES_CN/),var_get) - do k = 1, NTILES - VAR_PUT(k) = var_get(ld_reorder(id_glb(k))) - end do - call MAPL_VarWrite(OutFmt,'GHTCNT2',var_put) - - STATUS = NF_GET_VARA_REAL(NCFID,VarID(NCFID,'GHTCNT3' ), (/1/), (/NTILES_CN/),var_get) - do k = 1, NTILES - VAR_PUT(k) = var_get(ld_reorder(id_glb(k))) - end do - call MAPL_VarWrite(OutFmt,'GHTCNT3',var_put) - - STATUS = NF_GET_VARA_REAL(NCFID,VarID(NCFID,'GHTCNT4' ), (/1/), (/NTILES_CN/),var_get) - do k = 1, NTILES - VAR_PUT(k) = var_get(ld_reorder(id_glb(k))) - end do - call MAPL_VarWrite(OutFmt,'GHTCNT4',var_put) - - STATUS = NF_GET_VARA_REAL(NCFID,VarID(NCFID,'GHTCNT5' ), (/1/), (/NTILES_CN/),var_get) - do k = 1, NTILES - VAR_PUT(k) = var_get(ld_reorder(id_glb(k))) - end do - call MAPL_VarWrite(OutFmt,'GHTCNT5',var_put) - - STATUS = NF_GET_VARA_REAL(NCFID,VarID(NCFID,'GHTCNT6' ), (/1/), (/NTILES_CN/),var_get) - do k = 1, NTILES - VAR_PUT(k) = var_get(ld_reorder(id_glb(k))) - end do - call MAPL_VarWrite(OutFmt,'GHTCNT6',var_put) - - STATUS = NF_GET_VARA_REAL(NCFID,VarID(NCFID,'WESNN1' ), (/1/), (/NTILES_CN/),var_get) - do k = 1, NTILES - VAR_PUT(k) = var_get(ld_reorder(id_glb(k))) - end do - call MAPL_VarWrite(OutFmt,'WESNN1',var_put) - - STATUS = NF_GET_VARA_REAL(NCFID,VarID(NCFID,'WESNN2' ), (/1/), (/NTILES_CN/),var_get) - do k = 1, NTILES - VAR_PUT(k) = var_get(ld_reorder(id_glb(k))) - end do - call MAPL_VarWrite(OutFmt,'WESNN2',var_put) - - STATUS = NF_GET_VARA_REAL(NCFID,VarID(NCFID,'WESNN3' ), (/1/), (/NTILES_CN/),var_get) - do k = 1, NTILES - VAR_PUT(k) = var_get(ld_reorder(id_glb(k))) - end do - call MAPL_VarWrite(OutFmt,'WESNN3',var_put) - - STATUS = NF_GET_VARA_REAL(NCFID,VarID(NCFID,'HTSNNN1' ), (/1/), (/NTILES_CN/),var_get) - do k = 1, NTILES - VAR_PUT(k) = var_get(ld_reorder(id_glb(k))) - end do - call MAPL_VarWrite(OutFmt,'HTSNNN1',var_put) - - STATUS = NF_GET_VARA_REAL(NCFID,VarID(NCFID,'HTSNNN2' ), (/1/), (/NTILES_CN/),var_get) - do k = 1, NTILES - VAR_PUT(k) = var_get(ld_reorder(id_glb(k))) - end do - call MAPL_VarWrite(OutFmt,'HTSNNN2',var_put) - - STATUS = NF_GET_VARA_REAL(NCFID,VarID(NCFID,'HTSNNN3' ), (/1/), (/NTILES_CN/),var_get) - do k = 1, NTILES - VAR_PUT(k) = var_get(ld_reorder(id_glb(k))) - end do - call MAPL_VarWrite(OutFmt,'HTSNNN3',var_put) - - STATUS = NF_GET_VARA_REAL(NCFID,VarID(NCFID,'SNDZN1' ), (/1/), (/NTILES_CN/),var_get) - do k = 1, NTILES - VAR_PUT(k) = var_get(ld_reorder(id_glb(k))) - end do - call MAPL_VarWrite(OutFmt,'SNDZN1',var_put) - - STATUS = NF_GET_VARA_REAL(NCFID,VarID(NCFID,'SNDZN2' ), (/1/), (/NTILES_CN/),var_get) - do k = 1, NTILES - VAR_PUT(k) = var_get(ld_reorder(id_glb(k))) - end do - call MAPL_VarWrite(OutFmt,'SNDZN2',var_put) - - STATUS = NF_GET_VARA_REAL(NCFID,VarID(NCFID,'SNDZN3' ), (/1/), (/NTILES_CN/),var_get) - do k = 1, NTILES - VAR_PUT(k) = var_get(ld_reorder(id_glb(k))) - end do - call MAPL_VarWrite(OutFmt,'SNDZN3',var_put) - - STATUS = NF_CLOSE ( NCFID) - - deallocate (var_get, var_put) - - END SUBROUTINE put_land_vars - - ! ***************************************************************************** - subroutine init_MPI() - - ! initialize MPI - - call MPI_INIT(mpierr) - - call MPI_COMM_RANK( MPI_COMM_WORLD, myid, mpierr ) - call MPI_COMM_SIZE( MPI_COMM_WORLD, numprocs, mpierr ) - - if (myid .ne. 0) root_proc = .false. - -! write (*,*) "MPI process ", myid, " of ", numprocs, " is alive" -! write (*,*) "MPI process ", myid, ": root_proc=", root_proc - - end subroutine init_MPI - - ! ***************************************************************************** - -end program mk_CatchCNRestarts - diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/mk_restarts/mk_CatchRestarts.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/mk_restarts/mk_CatchRestarts.F90 deleted file mode 100644 index 26884ad035..0000000000 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/mk_restarts/mk_CatchRestarts.F90 +++ /dev/null @@ -1,778 +0,0 @@ -#define I_AM_MAIN -#include "MAPL_Generic.h" -program mk_CatchRestarts - -! $Id: - - use MAPL - use mk_restarts_getidsMod, only: GetIDs,ReadTileFile_RealLatLon - use gFTL_StringVector - - implicit none - include 'mpif.h' - ! initialize to non-MPI values - - integer :: myid=0, numprocs=1, mpierr, mpistatus(MPI_STATUS_SIZE) - logical :: root_proc=.true. - - character*256 :: Usage="mk_CatchRestarts OutTileFile InTileFile InRestart SURFLAY " - character*256 :: OutTileFile - character*256 :: InTileFile - character*256 :: InRestart - character*256 :: OutType - character*256 :: arg(6) - - integer :: i, k, iargc, n, ntiles,ntiles_in, nplus, req - integer, pointer :: Id(:), tid_in (:) - real, pointer :: loni(:),lono(:), lati(:), lato(:) - real :: SURFLAY - integer, allocatable :: low_ind(:), upp_ind(:), nt_local (:), Id_loc (:) - real , pointer, dimension (:) :: LATT, LONN - logical :: OutIsOld, havedata - character*256, parameter :: DataDir="OutData/clsm/" - real :: min_lon, max_lon, min_lat, max_lat - logical, allocatable, dimension(:) :: mask - integer, allocatable, dimension (:) :: sub_tid - real , allocatable, dimension (:) :: sub_lon, sub_lat - integer :: status - - call init_MPI() - -!--------------------------------------------------------------------------- - - I = iargc() - - if( I<4 .or. I>5 ) then - print *, "Wrong Number of arguments: ", i - print *, trim(Usage) - call exit(1) - end if - - do n=1,I - call getarg(n,arg(n)) - enddo - read(arg(1),'(a)') OutTileFile - read(arg(2),'(a)') InTileFile - read(arg(3),'(a)') InRestart - read(arg(4),*) SURFLAY - - if(I==5) then - call getarg(6,OutType) - OutIsOld = trim(OutType)=="OutIsOld" - else - OutIsOld = .false. - endif - - if (SURFLAY.ne.20 .and. SURFLAY.ne.50) then - print *, "You must supply a valid SURFLAY value:" - print *, "(Ganymed-3 and earlier) SURFLAY=20.0 for Old Soil Params" - print *, "(Ganymed-4 and later ) SURFLAY=50.0 for New Soil Params" - call exit(2) - end if - - inquire(file=trim(DataDir)//"mosaic_veg_typs_fracs",exist=havedata) - - if (root_proc) then - - ! Read Output/Input .til files - call ReadTileFile_RealLatLon(OutTileFile, ntiles, xlon=lono, xlat=lato) - call ReadTileFile_RealLatLon(InTileFile,ntiles_in,xlon=loni, xlat=lati) - allocate(Id (ntiles)) - ! allocate(mask (ntiles_in)) - ! allocate(tid_in (ntiles_in)) - ! do n = 1, NTILES_IN - ! tid_in (n) = n - ! end do - - endif - - if (havedata) then - if (root_proc) call read_and_write_rst (NTILES, SURFLAY, OutIsOld, NTILES, __RC__) - else - - call MPI_BCAST (ntiles , 1, MPI_INTEGER, 0,MPI_COMM_WORLD, mpierr) - call MPI_BCAST (ntiles_in, 1, MPI_INTEGER, 0,MPI_COMM_WORLD, mpierr) - - allocate(low_ind ( numprocs)) - allocate(upp_ind ( numprocs)) - allocate(nt_local( numprocs)) - - low_ind (:) = 1 - upp_ind (:) = NTILES - nt_local(:) = NTILES - - if (numprocs > 1) then - do i = 1, numprocs - 1 - upp_ind(i) = low_ind(i) + (ntiles/numprocs) - 1 - low_ind(i+1) = upp_ind(i) + 1 - nt_local(i) = upp_ind(i) - low_ind(i) + 1 - end do - nt_local(numprocs) = upp_ind(numprocs) - low_ind(numprocs) + 1 - endif - - ! Get intile lat/lon - -! do i = 2, numprocs -! if (i -1 == myid) then -! ! receive ntiles_in in the block -! call MPI_RECV(ntiles_in, 1, MPI_INTEGER,0,999,MPI_COMM_WORLD,MPI_STATUS_IGNORE,mpierr) -! ! ALLOCATE -! allocate (loni (1:NTILES_IN)) -! allocate (lati (1:NTILES_IN)) -! allocate (tid_in (1:NTILES_IN)) -! -! ! RECEIVE LAT/LON IN -! call MPI_RECV(tid_in, ntiles_in, MPI_INTEGER,0,998,MPI_COMM_WORLD,MPI_STATUS_IGNORE,mpierr) -! call MPI_RECV(loni , ntiles_in, MPI_REAL ,0,997,MPI_COMM_WORLD,MPI_STATUS_IGNORE,mpierr) -! call MPI_RECV(lati , ntiles_in, MPI_REAL ,0,996,MPI_COMM_WORLD,MPI_STATUS_IGNORE,mpierr) -! -! else if (myid == 0) then -! -! ! Send local ntiles_in -! -! min_lon = MAX(MINVAL(lono (low_ind(i) : upp_ind(i))) - 5, -180.) -! max_lon = MIN(MAXVAL(lono (low_ind(i) : upp_ind(i))) + 5, 180.) -! min_lat = MAX(MINVAL(lato (low_ind(i) : upp_ind(i))) - 5, -90.) -! max_lat = MIN(MAXVAL(lato (low_ind(i) : upp_ind(i))) + 5, 90.) -! mask = .false. -! mask = ((lati >= min_lat .and. lati <= max_lat).and.(loni >= min_lon .and. loni <= max_lon)) -! nplus = count(mask = mask) -! -! call MPI_ISend(NPLUS ,1,MPI_INTEGER,i-1,999,MPI_COMM_WORLD,req,mpierr) -! call MPI_WAIT (req,MPI_STATUS_IGNORE,mpierr) -! -! -! ! SEND LAT/LON IN -! allocate (sub_tid (1:nplus)) -! allocate (sub_lon (1:nplus)) -! allocate (sub_lat (1:nplus)) -! -! sub_tid = PACK (tid_in , mask= mask) -! sub_lon = PACK (loni , mask= mask) -! sub_lat = PACK (lati , mask= mask) -! -! call MPI_ISend(sub_tid, nplus,MPI_INTEGER,i-1,998,MPI_COMM_WORLD,req,mpierr) -! call MPI_WAIT (req,MPI_STATUS_IGNORE,mpierr) -! call MPI_ISend(sub_lon, nplus,MPI_REAL ,i-1,997,MPI_COMM_WORLD,req,mpierr) -! call MPI_WAIT (req,MPI_STATUS_IGNORE,mpierr) -! call MPI_ISend(sub_lat, nplus,MPI_REAL ,i-1,996,MPI_COMM_WORLD,req,mpierr) -! call MPI_WAIT (req,MPI_STATUS_IGNORE,mpierr) -! deallocate (sub_tid,sub_lon,sub_lat) -! endif -! end do - - ! Get out tile lat/lots from root - - allocate (id_loc (nt_local (myid + 1))) - allocate (lonn (nt_local (myid + 1))) - allocate (latt (nt_local (myid + 1))) - - do i = 1, numprocs - if((I == 1).and.(myid == 0)) then - lonn(:) = lono(low_ind(i) : upp_ind(i)) - latt(:) = lato(low_ind(i) : upp_ind(i)) - else if (I > 1) then - if(I-1 == myid) then - ! receiving from root - call MPI_RECV(lonn,nt_local(i) , MPI_REAL, 0,995,MPI_COMM_WORLD,MPI_STATUS_IGNORE,mpierr) - call MPI_RECV(latt,nt_local(i) , MPI_REAL, 0,994,MPI_COMM_WORLD,MPI_STATUS_IGNORE,mpierr) - else if (myid == 0) then - ! root sends - call MPI_ISend(lono(low_ind(i) : upp_ind(i)),nt_local(i),MPI_REAL,i-1,995,MPI_COMM_WORLD,req,mpierr) - call MPI_WAIT (req,MPI_STATUS_IGNORE,mpierr) - call MPI_ISend(lato(low_ind(i) : upp_ind(i)),nt_local(i),MPI_REAL,i-1,994,MPI_COMM_WORLD,req,mpierr) - call MPI_WAIT (req,MPI_STATUS_IGNORE,mpierr) - endif - endif - end do - -! call MPI_SCATTERV ( & -! lono,nt_local,low_ind-1,MPI_real, & -! lonn,size(lonn),MPI_real , & -! 0,MPI_COMM_WORLD, mpierr ) -! -! call MPI_SCATTERV ( & -! lato,nt_local,low_ind-1,MPI_real, & -! latt,size(latt),MPI_real , & -! 0,MPI_COMM_WORLD, mpierr ) - - if(myid > 0) allocate (loni (1:NTILES_IN)) - if(myid > 0) allocate (lati (1:NTILES_IN)) - - call MPI_BCAST(loni,ntiles_in,MPI_REAL,0,MPI_COMM_WORLD,mpierr) - call MPI_BCAST(lati,ntiles_in,MPI_REAL,0,MPI_COMM_WORLD,mpierr) - - allocate(tid_in (ntiles_in)) - do n = 1, NTILES_IN - tid_in (n) = n - end do - - call GetIds(loni,lati,lonn,latt,Id_loc, tid_in) - call MPI_Barrier(MPI_COMM_WORLD, mpierr) -! call MPI_GATHERV( & -! id_loc (:), nt_local(myid+1), MPI_real, & -! id, nt_local,low_ind-1, MPI_real, & -! 0, MPI_COMM_WORLD, mpierr ) - - do i = 1, numprocs - if((I == 1).and.(myid == 0)) then - id(low_ind(i) : upp_ind(i)) = Id_loc(:) - else if (I > 1) then - if(I-1 == myid) then - ! send to root - call MPI_ISend(id_loc,nt_local(i),MPI_INTEGER,0,993,MPI_COMM_WORLD,req,mpierr) - call MPI_WAIT (req,MPI_STATUS_IGNORE,mpierr) - else if (myid == 0) then - ! root receives - call MPI_RECV(id(low_ind(i) : upp_ind(i)),nt_local(i) , MPI_INTEGER, i-1,993,MPI_COMM_WORLD,MPI_STATUS_IGNORE,mpierr) - endif - endif - end do - - deallocate (loni,lati,lonn,latt, tid_in) - call MPI_Barrier(MPI_COMM_WORLD, mpierr) - - if (root_proc) call read_and_write_rst (NTILES, SURFLAY, OutIsOld, NTILES_IN, id, __RC__) - - endif - - call MPI_BARRIER( MPI_COMM_WORLD, mpierr) - call MPI_FINALIZE(mpierr) - -contains - - SUBROUTINE read_and_write_rst (NTILES, SURFLAY, OutIsOld, NTILES_IN, idi, rc) - - implicit none - real, intent (in) :: SURFLAY - logical, intent (in) :: OutIsOld - integer, intent (in) :: NTILES, NTILES_IN - integer, pointer, dimension(:), optional, intent (in) :: idi - integer, optional, intent(out) :: rc - logical :: havedata, NewLand - character(len=256), parameter :: Names(29) = & - (/'BF1 ','BF2 ','BF3 ','VGWMAX','CDCR1 ', & - 'CDCR2 ','PSIS ','BEE ','POROS ','WPWET ', & - 'COND ','GNU ','ARS1 ','ARS2 ','ARS3 ', & - 'ARA1 ','ARA2 ','ARA3 ','ARA4 ','ARW1 ', & - 'ARW2 ','ARW3 ','ARW4 ','TSA1 ','TSA2 ', & - 'TSB1 ','TSB2 ','ATAU ','BTAU '/) - - integer, pointer :: ity(:) - real, allocatable :: BF1(:), BF2(:), BF3(:), VGWMAX(:) - real, allocatable :: CDCR1(:), CDCR2(:), PSIS(:), BEE(:) - real, allocatable :: POROS(:), WPWET(:), COND(:), GNU(:) - real, allocatable :: ARS1(:), ARS2(:), ARS3(:) - real, allocatable :: ARA1(:), ARA2(:), ARA3(:), ARA4(:) - real, allocatable :: ARW1(:), ARW2(:), ARW3(:), ARW4(:) - real, allocatable :: TSA1(:), TSA2(:), TSB1(:), TSB2(:) - real, allocatable :: ATAU2(:), BTAU2(:), DP2BR(:), rity(:) - - real :: zdep1, zdep2, zdep3, zmet, term1, term2, rdum - real, allocatable :: var1(:),var2(:,:) - character*256 :: vname - character*256 :: OutFileName - integer :: i, n, j,k,ncatch,idum - logical,allocatable :: written(:) - integer :: ndims,filetype - integer :: dimSizes(3),nVars - logical :: file_exists - integer, pointer :: Ido(:), idx(:), id(:) - logical :: InIsOld - type(NetCDF4_Fileformatter) :: InFmt,OutFmt,CatchFmt - type(FileMetadata) :: InCfg,OutCfg - type(StringVariableMap), pointer :: variables - type(Variable), pointer :: myVariable - type(StringVariableMapIterator) :: var_iter - character(len=:), pointer :: var_name,dname - type(StringVector), pointer :: var_dimensions - integer :: dim1, dim2 - character(256) :: Iam = "read_and_write_rst" - integer :: status - - print *, 'SURFLAY: ',SURFLAY - - inquire(file=trim(DataDir)//"mosaic_veg_typs_fracs",exist=havedata) - inquire(file=trim(DataDir)//"CLM_veg_typs_fracs" ,exist=NewLand ) - - print *, 'havedata = ',havedata - - call MAPL_NCIOGetFileType(InRestart, filetype,__RC__) - - if (filetype == 0) then - - call InFmt%open(InRestart,pFIO_READ,__RC__) - InCfg=InFmt%read(__RC__) - call MAPL_IOChangeRes(InCfg,OutCfg,(/'tile'/),(/ntiles/),__RC__) - i = index(InRestart,'/',back=.true.) - OutFileName = "OutData/"//trim(InRestart(i+1:)) - call OutFmt%create(OutFileName,__RC__) - call OutFmt%write(OutCfg,__RC__) - call MAPL_IOCountNonDimVars(OutCfg,nvars,__RC__) - - allocate(written(nvars)) - written=.false. - - else - - open(unit=50,FILE=InRestart,form='unformatted',& - status='old',convert='little_endian') - - do i=1,58 - read(50,end=2001) - end do -2001 continue - InIsOld = I==59 - - rewind(50) - - i = index(InRestart,'/',back=.true.) - - open(unit=40,FILE="OutData/"//trim(InRestart(i+1:)),form='unformatted',& - status='unknown',convert='little_endian') - - end if - - HAVE: if(havedata) then - - print *,'Working from Sariths data pretiled for this resolution' - - ! Get number of catchments - - open(unit=22, & - file=trim(DataDir)//"catchment.def",status='old',form='formatted') - - read (22, *) ncatch - - close(22) - - if(ncatch==ntiles) then - print *, "Read ",Ncatch," land tiles." - allocate (ido (ntiles)) - do i=1,ncatch - ido(i) = i - enddo - else - print *, "Number of tiles in data, ",Ncatch," does not match number in til file ", size(Ido) - call exit(1) - endif - - allocate(ity(ncatch),rity(ncatch)) - allocate ( BF1(ncatch), BF2 (ncatch), BF3(ncatch) ) - allocate (VGWMAX(ncatch), CDCR1(ncatch), CDCR2(ncatch) ) - allocate ( PSIS(ncatch), BEE(ncatch), POROS(ncatch) ) - allocate ( WPWET(ncatch), COND(ncatch), GNU(ncatch) ) - allocate ( ARS1(ncatch), ARS2(ncatch), ARS3(ncatch) ) - allocate ( ARA1(ncatch), ARA2(ncatch), ARA3(ncatch) ) - allocate ( ARA4(ncatch), ARW1(ncatch), ARW2(ncatch) ) - allocate ( ARW3(ncatch), ARW4(ncatch), TSA1(ncatch) ) - allocate ( TSA2(ncatch), TSB1(ncatch), TSB2(ncatch) ) - allocate ( ATAU2(ncatch), BTAU2(ncatch), DP2BR(ncatch) ) - - inquire(file = trim(DataDir)//'/catch_params.nc4', exist=file_exists) - - if(file_exists) then - print *,'FILE FORMAT FOR LAND BCS IS NC4' - call CatchFmt%open(trim(DataDir)//'/catch_params.nc4',pFIO_Read, __RC__) - call MAPL_VarRead ( catchFmt ,'OLD_ITY', rity, __RC__) - call MAPL_VarRead ( catchFmt ,'ARA1', ARA1, __RC__) - call MAPL_VarRead ( catchFmt ,'ARA2', ARA2, __RC__) - call MAPL_VarRead ( catchFmt ,'ARA3', ARA3, __RC__) - call MAPL_VarRead ( catchFmt ,'ARA4', ARA4, __RC__) - call MAPL_VarRead ( catchFmt ,'ARS1', ARS1, __RC__) - call MAPL_VarRead ( catchFmt ,'ARS2', ARS2, __RC__) - call MAPL_VarRead ( catchFmt ,'ARS3', ARS3, __RC__) - call MAPL_VarRead ( catchFmt ,'ARW1', ARW1, __RC__) - call MAPL_VarRead ( catchFmt ,'ARW2', ARW2, __RC__) - call MAPL_VarRead ( catchFmt ,'ARW3', ARW3, __RC__) - call MAPL_VarRead ( catchFmt ,'ARW4', ARW4, __RC__) - - if( SURFLAY.eq.20.0 ) then - call MAPL_VarRead ( catchFmt ,'ATAU2', ATAU2, __RC__) - call MAPL_VarRead ( catchFmt ,'BTAU2', BTAU2, __RC__) - endif - - if( SURFLAY.eq.50.0 ) then - call MAPL_VarRead ( catchFmt ,'ATAU5', ATAU2, __RC__) - call MAPL_VarRead ( catchFmt ,'BTAU5', BTAU2, __RC__) - endif - - call MAPL_VarRead ( catchFmt ,'PSIS', PSIS, __RC__) - call MAPL_VarRead ( catchFmt ,'BEE', BEE, __RC__) - call MAPL_VarRead ( catchFmt ,'BF1', BF1, __RC__) - call MAPL_VarRead ( catchFmt ,'BF2', BF2, __RC__) - call MAPL_VarRead ( catchFmt ,'BF3', BF3, __RC__) - call MAPL_VarRead ( catchFmt ,'TSA1', TSA1, __RC__) - call MAPL_VarRead ( catchFmt ,'TSA2', TSA2, __RC__) - call MAPL_VarRead ( catchFmt ,'TSB1', TSB1, __RC__) - call MAPL_VarRead ( catchFmt ,'TSB2', TSB2, __RC__) - call MAPL_VarRead ( catchFmt ,'COND', COND, __RC__) - call MAPL_VarRead ( catchFmt ,'GNU', GNU, __RC__) - call MAPL_VarRead ( catchFmt ,'WPWET', WPWET, __RC__) - call MAPL_VarRead ( catchFmt ,'DP2BR', DP2BR, __RC__) - call MAPL_VarRead ( catchFmt ,'POROS', POROS, __RC__) - call catchFmt%close(__RC__) - - else - open(unit=21, file=trim(DataDir)//"mosaic_veg_typs_fracs",status='old',form='formatted') - open(unit=22, file=trim(DataDir)//'bf.dat' ,form='formatted') - open(unit=23, file=trim(DataDir)//'soil_param.dat' ,form='formatted') - open(unit=24, file=trim(DataDir)//'ar.new' ,form='formatted') - open(unit=25, file=trim(DataDir)//'ts.dat' ,form='formatted') - open(unit=26, file=trim(DataDir)//'tau_param.dat' ,form='formatted') - - do n=1,ncatch - read (21,*) I, j, ITY(N) - read (22, *) i,j, GNU(n), BF1(n), BF2(n), BF3(n) - - read (23, *) i,j, idum, idum, BEE(n), PSIS(n),& - POROS(n), COND(n), WPWET(n), DP2BR(n) - - read (24, *) i,j, rdum, ARS1(n), ARS2(n), ARS3(n), & - ARA1(n), ARA2(n), ARA3(n), ARA4(n), & - ARW1(n), ARW2(n), ARW3(n), ARW4(n) - - read (25, *) i,j, rdum, TSA1(n), TSA2(n), TSB1(n), TSB2(n) - - if( SURFLAY.eq.20.0 ) read (26, *) i,j, ATAU2(n), BTAU2(n), rdum, rdum ! for old soil params - if( SURFLAY.eq.50.0 ) read (26, *) i,j, rdum , rdum, ATAU2(n), BTAU2(n) ! for new soil params - end do - - rity = float(ity) - CLOSE (21, STATUS = 'KEEP') - CLOSE (22, STATUS = 'KEEP') - CLOSE (23, STATUS = 'KEEP') - CLOSE (24, STATUS = 'KEEP') - CLOSE (25, STATUS = 'KEEP') - - endif - - do n=1,ncatch - - zdep2=1000. - zdep3=amax1(1000.,DP2BR(n)) - - if (zdep2 > 0.75*zdep3) then - zdep2 = 0.75*zdep3 - end if - - zdep1=20. - zmet=zdep3/1000. - - term1=-1.+((PSIS(n)-zmet)/PSIS(n))**((BEE(n)-1.)/BEE(n)) - term2=PSIS(n)*BEE(n)/(BEE(n)-1) - - VGWMAX(n) = POROS(n)*zdep2 - CDCR1(n) = 1000.*POROS(n)*(zmet-(-term2*term1)) - CDCR2(n) = (1.-WPWET(n))*POROS(n)*zdep3 - enddo - - - if (filetype /=0) then - do i=1,30 - read(50) - enddo - end if - - idx => ido - - else - - print *,'Working from restarts alone' - - ncatch = NTILES_IN - - allocate ( rity(ncatch)) - allocate ( BF1(ncatch), BF2 (ncatch), BF3(ncatch) ) - allocate (VGWMAX(ncatch), CDCR1(ncatch), CDCR2(ncatch) ) - allocate ( PSIS(ncatch), BEE(ncatch), POROS(ncatch) ) - allocate ( WPWET(ncatch), COND(ncatch), GNU(ncatch) ) - allocate ( ARS1(ncatch), ARS2(ncatch), ARS3(ncatch) ) - allocate ( ARA1(ncatch), ARA2(ncatch), ARA3(ncatch) ) - allocate ( ARA4(ncatch), ARW1(ncatch), ARW2(ncatch) ) - allocate ( ARW3(ncatch), ARW4(ncatch), TSA1(ncatch) ) - allocate ( TSA2(ncatch), TSB1(ncatch), TSB2(ncatch) ) - allocate ( ATAU2(ncatch), BTAU2(ncatch), DP2BR(ncatch) ) - - if (filetype == 0) then - - call MAPL_VarRead(InFmt,names(1),BF1, __RC__) - call MAPL_VarRead(InFmt,names(2),BF2, __RC__) - call MAPL_VarRead(InFmt,names(3),BF3, __RC__) - call MAPL_VarRead(InFmt,names(4),VGWMAX, __RC__) - call MAPL_VarRead(InFmt,names(5),CDCR1, __RC__) - call MAPL_VarRead(InFmt,names(6),CDCR2, __RC__) - call MAPL_VarRead(InFmt,names(7),PSIS, __RC__) - call MAPL_VarRead(InFmt,names(8),BEE, __RC__) - call MAPL_VarRead(InFmt,names(9),POROS, __RC__) - call MAPL_VarRead(InFmt,names(10),WPWET, __RC__) - - call MAPL_VarRead(InFmt,names(11),COND, __RC__) - call MAPL_VarRead(InFmt,names(12),GNU, __RC__) - call MAPL_VarRead(InFmt,names(13),ARS1, __RC__) - call MAPL_VarRead(InFmt,names(14),ARS2, __RC__) - call MAPL_VarRead(InFmt,names(15),ARS3, __RC__) - call MAPL_VarRead(InFmt,names(16),ARA1, __RC__) - call MAPL_VarRead(InFmt,names(17),ARA2, __RC__) - call MAPL_VarRead(InFmt,names(18),ARA3, __RC__) - call MAPL_VarRead(InFmt,names(19),ARA4, __RC__) - call MAPL_VarRead(InFmt,names(20),ARW1, __RC__) - - call MAPL_VarRead(InFmt,names(21),ARW2, __RC__) - call MAPL_VarRead(InFmt,names(22),ARW3, __RC__) - call MAPL_VarRead(InFmt,names(23),ARW4, __RC__) - call MAPL_VarRead(InFmt,names(24),TSA1, __RC__) - call MAPL_VarRead(InFmt,names(25),TSA2, __RC__) - call MAPL_VarRead(InFmt,names(26),TSB1, __RC__) - call MAPL_VarRead(InFmt,names(27),TSB2, __RC__) - call MAPL_VarRead(InFmt,names(28),ATAU2, __RC__) - call MAPL_VarRead(InFmt,names(29),BTAU2, __RC__) - call MAPL_VarRead(InFmt,'OLD_ITY',rITY, __RC__) - - else - - read(50) BF1 - read(50) BF2 - read(50) BF3 - read(50) VGWMAX - read(50) CDCR1 - read(50) CDCR2 - read(50) PSIS - read(50) BEE - read(50) POROS - read(50) WPWET - - read(50) COND - read(50) GNU - read(50) ARS1 - read(50) ARS2 - read(50) ARS3 - read(50) ARA1 - read(50) ARA2 - read(50) ARA3 - read(50) ARA4 - read(50) ARW1 - - read(50) ARW2 - read(50) ARW3 - read(50) ARW4 - read(50) TSA1 - read(50) TSA2 - read(50) TSB1 - read(50) TSB2 - read(50) ATAU2 - read(50) BTAU2 - read(50) rITY - - end if - - idx => idi - - endif HAVE - - if (filetype == 0) then - call MAPL_VarWrite(OutFmt,names(1),BF1(Idx)) - call MAPL_VarWrite(OutFmt,names(2),BF2(Idx)) - call MAPL_VarWrite(OutFmt,names(3),BF3(Idx)) - call MAPL_VarWrite(OutFmt,names(4),VGWMAX(Idx)) - call MAPL_VarWrite(OutFmt,names(5),CDCR1(Idx)) - call MAPL_VarWrite(OutFmt,names(6),CDCR2(Idx)) - call MAPL_VarWrite(OutFmt,names(7),PSIS(Idx)) - call MAPL_VarWrite(OutFmt,names(8),BEE(Idx)) - call MAPL_VarWrite(OutFmt,names(9),POROS(Idx)) - call MAPL_VarWrite(OutFmt,names(10),WPWET(Idx)) - call MAPL_VarWrite(OutFmt,names(11),COND(Idx)) - call MAPL_VarWrite(OutFmt,names(12),GNU(Idx)) - call MAPL_VarWrite(OutFmt,names(13),ARS1(Idx)) - call MAPL_VarWrite(OutFmt,names(14),ARS2(Idx)) - call MAPL_VarWrite(OutFmt,names(15),ARS3(Idx)) - call MAPL_VarWrite(OutFmt,names(16),ARA1(Idx)) - call MAPL_VarWrite(OutFmt,names(17),ARA2(Idx)) - call MAPL_VarWrite(OutFmt,names(18),ARA3(Idx)) - call MAPL_VarWrite(OutFmt,names(19),ARA4(Idx)) - call MAPL_VarWrite(OutFmt,names(20),ARW1(Idx)) - call MAPL_VarWrite(OutFmt,names(21),ARW2(Idx)) - call MAPL_VarWrite(OutFmt,names(22),ARW3(Idx)) - call MAPL_VarWrite(OutFmt,names(23),ARW4(Idx)) - call MAPL_VarWrite(OutFmt,names(24),TSA1(Idx)) - call MAPL_VarWrite(OutFmt,names(25),TSA2(Idx)) - call MAPL_VarWrite(OutFmt,names(26),TSB1(Idx)) - call MAPL_VarWrite(OutFmt,names(27),TSB2(Idx)) - call MAPL_VarWrite(OutFmt,names(28),ATAU2(Idx)) - call MAPL_VarWrite(OutFmt,names(29),BTAU2(Idx)) - call MAPL_VarWrite(OutFmt,'OLD_ITY',rity(Idx)) - - - call MAPL_IOCountNonDimVars(InCfg,nvars) - - variables => InCfg%get_variables() - var_iter = variables%begin() - i = 0 - do while (var_iter /= variables%end()) - - var_name => var_iter%key() - i=i+1 - do j=1,29 - if ( trim(var_name) == trim(names(j)) ) written(i) = .true. - enddo - if (trim(var_name) == "OLD_ITY" ) written(i) = .true. - - call var_iter%next() - - enddo - - variables => InCfg%get_variables() - var_iter = variables%begin() - n=0 - allocate(var1(NTILES_IN)) - do while (var_iter /= variables%end()) - - var_name => var_iter%key() - myVariable => var_iter%value() - - if (.not.InCfg%is_coordinate_variable(var_name)) then - - n=n+1 - if (.not.written(n) ) then - - var_dimensions => myVariable%get_dimensions() - - ndims = var_dimensions%size() - - if (ndims == 1) then - call MAPL_VarRead(InFmt,var_name,var1, __RC__) - call MAPL_VarWrite(OutFmt,var_name,var1(idx)) - else if (ndims == 2) then - - dname => myVariable%get_ith_dimension(2) - dim1=InCfg%get_dimension(dname) - do j=1,dim1 - call MAPL_VarRead(InFmt,var_name,var1,offset1=j, __RC__) - call MAPL_VarWrite(OutFmt,var_name,var1(idx),offset1=j) - enddo - else if (ndims == 3) then - - dname => myVariable%get_ith_dimension(2) - dim1=InCfg%get_dimension(dname) - dname => myVariable%get_ith_dimension(3) - dim2=InCfg%get_dimension(dname) - do k=1,dim2 - do j=1,dim1 - call MAPL_VarRead(InFmt,var_name,var1,offset1=j,offset2=k, __RC__) - call MAPL_VarWrite(OutFmt,var_name,var1(idx),offset1=j,offset2=k) - enddo - enddo - - end if - - end if - end if - call var_iter%next() - - enddo - - else - - write(40) BF1(Idx) - write(40) BF2(Idx) - write(40) BF3(Idx) - write(40) VGWMAX(Idx) - write(40) CDCR1(Idx) - write(40) CDCR2(Idx) - write(40) PSIS(Idx) - write(40) BEE(Idx) - write(40) POROS (Idx) - write(40) WPWET(Idx) - write(40) COND(Idx) - write(40) GNU(Idx) - write(40) ARS1(Idx) - write(40) ARS2(Idx) - write(40) ARS3(Idx) - write(40) ARA1(Idx) - write(40) ARA2(Idx) - write(40) ARA3(Idx) - write(40) ARA4(Idx) - write(40) ARW1(Idx) - write(40) ARW2(Idx) - write(40) ARW3(Idx) - write(40) ARW4(Idx) - write(40) TSA1(Idx) - write(40) TSA2(Idx) - write(40) TSB1(Idx) - write(40) TSB2(Idx) - write(40) ATAU2(Idx) - write(40) BTAU2(Idx) - write(40) rITY(Idx) - - - allocate(var1(NTILES_IN)) - allocate(var2(NTILES_IN,4)) - - ! TC QC - - do n=1,2 - read (50) var2 - write(40) ((var2(idx(i),j),i=1,ntiles),j=1,4) - end do - - !CAPAC CATDEF RZEXC SRFEXC ... SNDZN3 - - do n=1,20 - read (50) var1 - write(40) var1(Idx) - enddo - - ! CH CM CQ FR - - do n=1,4 - read (50) var2 - write(40) ((var2(idx(i),j),i=1,ntiles),j=1,4) - end do - - ! These are the 2 prev/next pairs that dont are not - ! in the internal in fortuna-2_0 and later. Earlier the - ! record are there, but their values are not needed, since - ! they are initialized on start-up. - - if(InIsOld) then - do n=1,4 - read (50) - enddo - endif - - if(OutIsOld) then - var1 = 0.0 - do n=1,4 - write(40) (var1(idx(i)),i = 1, ntiles) - end do - endif - - ! WW - - read (50) var2 - write(40) ((var2(idx(i),j),i=1,ntiles),j=1,4) - end if - if (present(rc)) rc =0 - !_RETURN(_SUCCESS) - END SUBROUTINE read_and_write_rst - - ! ***************************************************************************** - - subroutine init_MPI() - - ! initialize MPI - - call MPI_INIT(mpierr) - - call MPI_COMM_RANK( MPI_COMM_WORLD, myid, mpierr ) - call MPI_COMM_SIZE( MPI_COMM_WORLD, numprocs, mpierr ) - - if (myid .ne. 0) root_proc = .false. - -! write (*,*) "MPI process ", myid, " of ", numprocs, " is alive" -! write (*,*) "MPI process ", myid, ": root_proc=", root_proc - - end subroutine init_MPI - -end program mk_CatchRestarts - diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/mk_restarts/mk_GEOSldasRestarts.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/mk_restarts/mk_GEOSldasRestarts.F90 deleted file mode 100644 index 5e3da8d3ad..0000000000 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/mk_restarts/mk_GEOSldasRestarts.F90 +++ /dev/null @@ -1,3917 +0,0 @@ -#define I_AM_MAIN -#include "MAPL_Generic.h" - -PROGRAM mk_GEOSldasRestarts - -! USAGE/HELP (NOTICE mpirun -np 1) -! mpirun -np 1 bin/mk_GEOSldasRestarts.x -h -! -! (1) to create an initial catch(cn)_internal_rst file ready for an offline experiment : -! -------------------------------------------------------------------------------------- -! (1.1) mpirun -np 1 bin/mk_GEOSldasRestarts.x -a SPONSORCODE -b BCSDIR -m MODEL -s SURFLAY(20/50) -t TILFILE -! where MODEL : catch or catchcn -! (1.2) sbatch mkLDAS.j -! -! (2) to reorder an LDASsa restart file to the order of the BCs for use in an GCM experiment : -! -------------------------------------------------------------------------------------------- -! mpirun -np 1 bin/mk_GEOSldasRestarts.x -b BCSDIR -d YYYYMMDD -e EXPNAME -l EXPDIR -m MODEL -s SURFLAY(20/50) -r Y -t TILFILE -p PARAMFILE - use netcdf - use MAPL - use mk_restarts_getidsMod, only: GetIDs, ReadTileFile_RealLatLon - use gFTL_StringVector - use ieee_arithmetic, only: isnan => ieee_is_nan - USE STIEGLITZSNOW, ONLY : & - StieglitzSnow_calc_tpsnow - implicit none - include 'mpif.h' - INCLUDE 'netcdf.inc' - - ! initialize to non-MPI values - - integer :: myid=0, numprocs=1, mpierr - logical :: root_proc=.true. - - ! Carbon model specifics - ! ---------------------- - - character*256 :: Usage="mk_GEOSldasRestarts.x -a SPONSORCODE -b BCSDIR -d YYYYMMDDHH -e EXPNAME -j JOBFILE -k ENS -l EXPDIR -m MODEL -r REORDER -s SURFLAY -t TILFILE -p PARAMFILE -f RSTFILE" - character*256 :: BCSDIR, SPONSORCODE, EXPNAME, EXPDIR, TILFILE, SFL, PFILE - character*400 :: CMD - character*10 :: YYYYMMDDHH - character(len=:), allocatable :: model, catch_scaler, rstfile - - real, parameter :: ECCENTRICITY = 0.0167 - real, parameter :: PERIHELION = 102.0 - real, parameter :: OBLIQUITY = 23.45 - integer, parameter :: EQUINOX = 80 - - integer, parameter :: nveg = 4 - integer, parameter :: nzone = 3 - integer, parameter :: VAR_COL_CLM40 = 40 ! number of CN column restart variables - integer, parameter :: VAR_PFT_CLM40 = 74 ! number of CN PFT variables per column - integer, parameter :: npft = 19 - integer, parameter :: npft_clm45 = 19 - integer, parameter :: VAR_COL_CLM45 = 35 ! number of CN column restart variables - integer, parameter :: VAR_PFT_CLM45 = 75 ! number of CN PFT variables per column - - real, parameter :: nan = O'17760000000' - real, parameter :: fmin= 1.e-4 ! ignore vegetation fractions at or below this value - integer, parameter :: OutUnit = 40, InUnit = 50 - character*256 :: arg, tmpstring, ESMADIR - character*1 :: opt, REORDER='N', JOBFILE ='N' - character*4 :: ENS='0000' - integer :: ntiles, rc, nxt - character(len=300) :: OutFileName - integer :: VAR_COL, VAR_PFT - integer :: iclass(npft) = (/1,1,2,3,3,4,5,5,6,7,8,9,10,11,12,11,12,11,12/) - - ! =============================================================================================== - ! Below hard-wired ldas restart file is from a global offline simulation on the SMAP M09 grid - ! after 1000s of years of simulations - - integer, parameter :: ntiles_cn = 1684725, ntiles_cat = 1653157 - character(len=300), parameter :: & - InCNRestart = '/discover/nobackup/projects/gmao/ssd/land/l_data/LandRestarts_for_Regridding/CatchCN/M09/20151231/catchcn_internal_rst', & - InCNTilFile = '/discover/nobackup/projects/gmao/bcs_shared/legacy_bcs/Heracles-NL/SMAP_EASEv2_M09/SMAP_EASEv2_M09_3856x1624.til', & - InCatRestart= '/discover/nobackup/projects/gmao/ssd/land/l_data/LandRestarts_for_Regridding/Catch/M09/20170101/catch_internal_rst', & - InCatTilFile= '/discover/nobackup/projects/gmao/ssd/land/l_data/geos5/bcs/CLSM_params/mkCatchParam_SMAP_L4SM_v002/' & - //'SMAP_EASEv2_M09/SMAP_EASEv2_M09_3856x1624.til', & - InCatRest45 = '/discover/nobackup/projects/gmao/ssd/land/l_data/LandRestarts_for_Regridding/Catch/M09/20170101/catch_internal_rst', & - InCatTil45 = '/discover/nobackup/projects/gmao/ssd/land/l_data/geos5/bcs/CLSM_params/mkCatchParam_SMAP_L4SM_v002/' & - //'SMAP_EASEv2_M09/SMAP_EASEv2_M09_3856x1624.til' - REAL :: SURFLAY = 50. - integer :: STATUS - - character(len=256), parameter :: CatNames (57) = & - (/'BF1 ', 'BF2 ', 'BF3 ', 'VGWMAX ', 'CDCR1 ', & - 'CDCR2 ', 'PSIS ', 'BEE ', 'POROS ', 'WPWET ', & - 'COND ', 'GNU ', 'ARS1 ', 'ARS2 ', 'ARS3 ', & - 'ARA1 ', 'ARA2 ', 'ARA3 ', 'ARA4 ', 'ARW1 ', & - 'ARW2 ', 'ARW3 ', 'ARW4 ', 'TSA1 ', 'TSA2 ', & - 'TSB1 ', 'TSB2 ', 'ATAU ', 'BTAU ', 'OLD_ITY', & - 'TC ', 'QC ', 'CAPAC ', 'CATDEF ', 'RZEXC ', & - 'SRFEXC ', 'GHTCNT1', 'GHTCNT2', 'GHTCNT3', 'GHTCNT4', & - 'GHTCNT5', 'GHTCNT6', 'TSURF ', 'WESNN1 ', 'WESNN2 ', & - 'WESNN3 ', 'HTSNNN1', 'HTSNNN2', 'HTSNNN3', 'SNDZN1 ', & - 'SNDZN2 ', 'SNDZN3 ', 'CH ', 'CM ', 'CQ ', & - 'FR ', 'WW '/) - - character(len=256), parameter :: CarbNames (68) = & - (/'BF1 ', 'BF2 ', 'BF3 ', 'VGWMAX ', 'CDCR1 ', & - 'CDCR2 ', 'PSIS ', 'BEE ', 'POROS ', 'WPWET ', & - 'COND ', 'GNU ', 'ARS1 ', 'ARS2 ', 'ARS3 ', & - 'ARA1 ', 'ARA2 ', 'ARA3 ', 'ARA4 ', 'ARW1 ', & - 'ARW2 ', 'ARW3 ', 'ARW4 ', 'TSA1 ', 'TSA2 ', & - 'TSB1 ', 'TSB2 ', 'ATAU ', 'BTAU ', 'ITY ', & - 'FVG ', 'TC ', 'QC ', 'TG ', 'CAPAC ', & - 'CATDEF ', 'RZEXC ', 'SRFEXC ', 'GHTCNT1', 'GHTCNT2', & - 'GHTCNT3', 'GHTCNT4', 'GHTCNT5', 'GHTCNT6', 'TSURF ', & - 'WESNN1 ', 'WESNN2 ', 'WESNN3 ', 'HTSNNN1', 'HTSNNN2', & - 'HTSNNN3', 'SNDZN1 ', 'SNDZN2 ', 'SNDZN3 ', 'CH ', & - 'CM ', 'CQ ', 'FR ', 'WW ', 'TILE_ID', & - 'NDEP ', 'CLI_T2M', 'BGALBVR', 'BGALBVF', 'BGALBNR', & - 'BGALBNF', 'CNCOL ', 'CNPFT ' /) - - CHARACTER( * ), PARAMETER :: LOWER_CASE = 'abcdefghijklmnopqrstuvwxyz' - CHARACTER( * ), PARAMETER :: UPPER_CASE = 'ABCDEFGHIJKLMNOPQRSTUVWXYZ' - logical :: clm45 = .false. - logical :: second_visit - integer :: zoom, k, n, infos - character*100 :: InRestart - character(100) :: Iam = "mk_GEOSldasRestarts" - - VAR_COL = VAR_COL_CLM40 - VAR_PFT = VAR_PFT_CLM40 - - call init_MPI() - call MPI_Info_create(infos, STATUS) ; VERIFY_(STATUS) - call MPI_Info_set(infos, "romio_cb_read", "automatic", STATUS) ; VERIFY_(STATUS) - call MPI_Barrier(MPI_COMM_WORLD, STATUS) - ! process commands - ! ---------------- - - CALL get_command (cmd) - call getenv ("ESMADIR" ,ESMADIR ) - nxt = 1 - - call getarg(nxt,arg) - rstfile = 'NONE' - do while(arg(1:1)=='-') - - opt=arg(2:2) - if(len(trim(arg))==2) then - nxt = nxt + 1 - call getarg(nxt,arg) - else - arg = arg(3:) - end if - - select case (opt) - case ('a') - SPONSORCODE = trim(arg) - case ('b') - BCSDIR = trim(arg) - case ('d') - YYYYMMDDHH = trim(arg) - case ('e') - EXPNAME = trim(arg) - case ('h') - print *,' ' - print *,'(1) to create an initial catch(cn)_internal_rst file ready for an offline experiment :' - print *,'--------------------------------------------------------------------------------------' - print *,'(1.1) mpirun -np 1 bin/mk_GEOSldasRestarts.x -a SPONSORCODE -b BCSDIR -m MODEL -s SURFLAY(20/50)' - print *,'where MODEL : catch, catchcnclm40, catchcnclm45' - print *,'(1.2) sbatch mkLDAS.j' - print *,' ' - print *,'(2) to reorder an LDASsa restart file to the order of the BCs for use in an GCM experiment :' - print *,'--------------------------------------------------------------------------------------------' - print *,'mpirun -np 1 bin/mk_GEOSldasRestarts.x -b BCSDIR -d YYYYMMDDHH -e EXPNAME -l EXPDIR -m MODEL -s SURFLAY(20/50) -r Y -t TILFILE -p PARAMFILE' - stop - case ('j') - JOBFILE = trim(arg) - case ('k') - ENS = trim(arg) - case ('l') - EXPDIR = trim(arg) - case ('m') - MODEL = StrLowCase(trim(arg)) - case ('r') - REORDER = trim(arg) - case ('s') - SFL = trim(arg) - read(arg,*) SURFLAY - case ('t') - TILFILE = trim(arg) - case ('p') - PFILE = trim(arg) - case ('f') - RSTFILE = trim(arg) - case default - print *, trim(Usage) - call exit(1) - end select - nxt = nxt + 1 - call getarg(nxt,arg) - end do - - if (index(model, 'catchcn') /=0 ) then - if((INDEX(BCSDIR, 'NL') == 0).AND.(INDEX(BCSDIR, 'OutData') == 0)) then - print *,'Land BCs in : ',trim(BCSDIR) - print *,'do not support ',trim (model) - stop - endif - - if (index(model,'45') /=0) then - clm45 = .true. - VAR_COL = VAR_COL_CLM45 - VAR_PFT = VAR_PFT_CLM45 - endif - catch_scaler = 'Scale_CatchCN' - else - catch_scaler = 'Scale_Catch' - endif - - - if(trim(REORDER) == 'Y') then - - ! This call is to reorder a LDASsa restart file (RESTART: 1) - - call reorder_LDASsa_restarts (SURFLAY, BCSDIR, YYYYMMDDHH, EXPNAME, EXPDIR, MODEL, ENS, rstfile, __RC__) - - call MPI_Barrier(MPI_COMM_WORLD, STATUS) - call MPI_FINALIZE(mpierr) - call exit(0) - - elseif (trim(REORDER) == 'R') then - - ! This call is to regrid LDASsa/GEOSldas restarts from a different grid (RESTART: 2) - - call regrid_from_xgrid (SURFLAY, BCSDIR, YYYYMMDDHH, EXPNAME, EXPDIR, MODEL, PFILE, rstfile) - - call MPI_Barrier(MPI_COMM_WORLD, STATUS) - call MPI_FINALIZE(mpierr) - call exit(0) - - else - - ! The user does not have restarts, thus cold start (RESTART: 0) - - if(JOBFILE == 'N') then - - call system('mkdir -p InData/ OutData/') - tmpstring = 'cp '//trim(BCSDIR)//'/'//trim(TILFILE)//' InData/OutTileFile' - call system(tmpstring) - tmpstring = 'cp '//trim(BCSDIR)//'/'//trim(TILFILE)//' OutData/OutTileFile' - call system(tmpstring) - tmpstring = 'ln -s '//trim(BCSDIR)//'/clsm OutData/clsm' - call system(tmpstring) - - open (10, file ='mkLDASsa.j', form = 'formatted', status ='unknown', action = 'write') - write(10,'(a)')'#!/bin/csh -fx' - write(10,'(a)')' ' - write(10,'(a)')'#SBATCH --account='//trim(SPONSORCODE) - write(10,'(a)')'#SBATCH --time=1:00:00' - write(10,'(a)')'#SBATCH --ntasks=56' - write(10,'(a)')'#SBATCH --job-name=mkLDAS' - write(10,'(a)')'###SBATCH --constraint=hasw' - write(10,'(a)')'#SBATCH --output=mkLDAS.o' - write(10,'(a)')'#SBATCH --error=mkLDAS.e' - write(10,'(a)')' ' - write(10,'(a)')'limit stacksize unlimited' - write(10,'(a)')'source bin/g5_modules' - !tmpstring = "set BINDIR=`ls -l bin | cut -d'>' -f2`" - !write(10,'(a)')trim(tmpstring) - !tmpstring = "setenv ESMADIR `echo $BINDIR | sed 's/Linux\/bin//g'`" - write(10,'(a)')'setenv ESMADIR '//trim(ESMADIR) - write(10,'(a)')'setenv MKL_CBWR SSE4_2 # ensure zero-diff across archs' - write(10,'(a)')'setenv MV2_ON_DEMAND_THRESHOLD 8192 # MVAPICH2' - write(10,'(a)')' ' - write(10,'(a)')'mpirun -np 56 '//trim(cmd)//' -j Y' - - write(10,'(a)')'bin/'//trim(catch_scaler)//' InData/'//model//'_internal_rst OutData/'//model//'_internal_rst '//model//'_internal_rst '//trim(SFL) - - close (10, status ='keep') - call system('chmod 755 mkLDASsa.j') - stop - endif - endif - - if (root_proc) then - - ! read in ntiles - ! ---------------------------- - - open (10,file = trim(BCSDIR)//'/clsm/catchment.def', form = 'formatted', status ='old', action = 'read') - read (10,*) ntiles - close (10, status ='keep') - - endif - - call MPI_BCAST(NTILES , 1, MPI_INTEGER , 0,MPI_COMM_WORLD,mpierr) - - ! Regridding - inquire(file='InData/'//trim(MODEL)//'_internal_rst',exist=second_visit ) - - if(.not. second_visit) then - call regrid_hyd_vars (NTILES, trim(MODEL)) - call MPI_Barrier(MPI_COMM_WORLD, STATUS) - stop - endif - if (root_proc) then - call read_bcs_data (NTILES, SURFLAY, trim(MODEL),'OutData/clsm/','OutData/'//trim(MODEL)//'_internal_rst', __RC__) - endif - - call MPI_Barrier(MPI_COMM_WORLD, STATUS) - - if(index(MODEL,'catchcn') /=0) then - - call regrid_carbon_vars (NTILES, model) - - endif - - call MPI_FINALIZE(mpierr) - -contains - - ! ***************************************************************************** - - SUBROUTINE regrid_from_xgrid (SURFLAY, BCSDIR, YYYYMMDDHH, EXPNAME, EXPDIR, MODEL, PFILE, rstfile) - - implicit none - - real, intent (in) :: SURFLAY - character(*), intent (in) :: BCSDIR, YYYYMMDDHH, EXPNAME, EXPDIR, MODEL, PFILE, rstfile - character(256) :: tile_coord, vname - character(300) :: rst_file - integer :: NTILES, nv, iv, i,j,k,n, nx, nz, ndims,dimSizes(3), NTILES_RST,nplus, STATUS,NCFID, req, filetype, OUTID - integer, allocatable :: LDAS2BCS (:), tile_id(:) - real, allocatable :: var1(:), var2(:),wesn1(:), htsn1(:), lon_rst(:), lat_rst(:) - logical :: fexist, bin_out = .false., lendian = .true. - real , allocatable, dimension (:) :: LATT, LONN, DAYX - real , pointer , dimension (:) :: long, latg, lonc, latc - integer, allocatable, dimension (:) :: low_ind, upp_ind, nt_local - integer, allocatable, dimension (:) :: Id_glb, id_loc - integer, allocatable, dimension (:,:) :: Id_glb_cn, id_loc_cn - integer, allocatable, dimension (:) :: ld_reorder, tid_offl - real, allocatable, dimension (:) :: CLMC_pf1, CLMC_pf2, CLMC_sf1, CLMC_sf2, & - CLMC_pt1, CLMC_pt2,CLMC_st1,CLMC_st2, var_dum2 - integer :: AGCM_YY,AGCM_MM,AGCM_DD,AGCM_HR=0,AGCM_DATE - real, allocatable, dimension(:,:) :: fveg_offl, ityp_offl, fveg_tmp, ityp_tmp - real, allocatable :: var_off_col (:,:,:), var_off_pft (:,:,:,:) - type(Netcdf4_FileFormatter) :: ldFmt - type(FileMetadata) :: meta_data - character(256) :: Iam = "regrid_from_xgrid" - ! read NTILES from output BCs and tile_coord from GEOSldas/LDASsa input restarts - - open (10,file =trim(BCSDIR)//"clsm/catchment.def",status='old',form='formatted') - read (10,*) ntiles - close (10, status = 'keep') - - ! Determine whether LDASsa or GEOSldas - if (trim(rstfile) == "NONE") then - if (trim(MODEL) == 'catch') then - rst_file = trim(EXPDIR)//'rs/ens'//ENS//'/Y'//YYYYMMDDHH(1:4)//'/M'//YYYYMMDDHH(5:6)//'/'//trim(ExpName)//& - '.catch_internal_rst.'//YYYYMMDDHH(1:8)//'_'//YYYYMMDDHH(9:10)//'00' - inquire(file = trim(rst_file), exist=fexist) - if (.not.fexist) then - rst_file = trim(EXPDIR)//'rs/ens'//ENS//'/Y'//YYYYMMDDHH(1:4)//'/M'//YYYYMMDDHH(5:6)//'/' & - //trim(ExpName)//'.ens'//ENS//'.catch_ldas_rst.'// & - YYYYMMDDHH(1:8)//'_'//YYYYMMDDHH(9:10)//'00z.bin' - lendian = .false. - endif - else !catchcn - rst_file = trim(EXPDIR)//'rs/ens'//ENS//'/Y'//YYYYMMDDHH(1:4)//'/M'//YYYYMMDDHH(5:6)//'/'//trim(ExpName)//& - '.'//trim(MODEL)//'_internal_rst.'//YYYYMMDDHH(1:8)//'_'//YYYYMMDDHH(9:10)//'00' - inquire(file = trim(rst_file), exist=fexist) - if (.not. fexist) then - rst_file = trim(EXPDIR)//'rs/ens'//ENS//'/Y'//YYYYMMDDHH(1:4)//'/M'//YYYYMMDDHH(5:6)//'/'//trim(ExpName)//& - '.ens'//ENS//'.'//trim(MODEL)//'_ldas_rst.'//YYYYMMDDHH(1:8)//'_'//YYYYMMDDHH(9:10)//'00z' - lendian = .false. - endif - endif ! catch - else ! rstfile is provided - rst_file = rstfile - if (index(rst_file, "_ldas_rst") /=0) lendian = .false. - endif - - if (index(MODEL, 'catchcn') /=0) then - call ldFmt%open(trim(rst_file) , pFIO_READ,__RC__) - meta_data = ldFmt%read(__RC__) - call ldFmt%close(__RC__) - if(meta_data%get_dimension('unknown_dim3',rc=status) == 105) then - clm45 = .true. - VAR_COL = VAR_COL_CLM45 - VAR_PFT = VAR_PFT_CLM45 - if (root_proc) print *, 'Processing CLM45 restarts : ', VAR_COL, VAR_PFT, clm45 - else - if (root_proc) print *, 'Processing CLM40 restarts : ', VAR_COL, VAR_PFT, clm45 - endif - endif - - ! Open input tile_coord - tile_coord = trim(EXPDIR)//'rc_out/'//trim(expname)//'.ldas_tilecoord.bin' - inquire(file = trim(tile_coord), exist=fexist) - if ( .not. fexist ) then - print*, tile_coord // " file not exists" - stop " no tile_coord file" - endif - - if(lendian) then - open (10,file =trim(tile_coord),status='old',form='unformatted', action = 'read') - else - open (10,file =trim(tile_coord),status='old',form='unformatted', action = 'read', convert ='big_endian') - endif - - read (10) NTILES_RST - - if(root_proc) then - print *,'NTILES in BCs : ',NTILES - print *,'NTILES in restarts : ',NTILES_RST - endif - - ! Domain decomposition - ! -------------------- - - allocate(low_ind ( numprocs)) - allocate(upp_ind ( numprocs)) - allocate(nt_local( numprocs)) - - low_ind (:) = 1 - upp_ind (:) = NTILES - nt_local(:) = NTILES - - if (numprocs > 1) then - do i = 1, numprocs - 1 - upp_ind(i) = low_ind(i) + (ntiles/numprocs) - 1 - low_ind(i+1) = upp_ind(i) + 1 - nt_local(i) = upp_ind(i) - low_ind(i) + 1 - end do - nt_local(numprocs) = upp_ind(numprocs) - low_ind(numprocs) + 1 - endif - - allocate (id_loc (nt_local (myid + 1))) - allocate (lonn (nt_local (myid + 1))) - allocate (latt (nt_local (myid + 1))) - allocate (lonc (1:ntiles_rst)) - allocate (latc (1:ntiles_rst)) - allocate (tid_offl (ntiles_rst)) - - if (root_proc) then - allocate (long (ntiles)) - allocate (latg (ntiles)) - allocate (ld_reorder(ntiles_rst)) - allocate (tile_id (1:ntiles_rst)) - allocate (LDAS2BCS (1:ntiles_rst)) - allocate (lon_rst (1:ntiles_rst)) - allocate (lat_rst (1:ntiles_rst)) - - call ReadTileFile_RealLatLon ('InData/OutTileFile', i, xlon=long, xlat=latg); VERIFY_(i-ntiles) - - read (10) LDAS2BCS - read (10) tile_id - read (10) tile_id - read (10) lon_rst - read (10) lat_rst - - tile_id = LDAS2BCS - - do n = 1, NTILES_RST - ld_reorder (tile_id(n)) = n - tid_offl(n) = n - end do - do n = 1, NTILES_RST - lonc(n) = lon_rst(ld_reorder(n)) - latc(n) = lat_rst(ld_reorder(n)) - END DO - deallocate (lon_rst, lat_rst) - endif - - close (10, status = 'keep') - call MPI_Barrier(MPI_COMM_WORLD, STATUS) - - do i = 1, numprocs - if((I == 1).and.(myid == 0)) then - lonn(:) = long(low_ind(i) : upp_ind(i)) - latt(:) = latg(low_ind(i) : upp_ind(i)) - else if (I > 1) then - if(I-1 == myid) then - ! receiving from root - call MPI_RECV(lonn,nt_local(i) , MPI_REAL, 0,995,MPI_COMM_WORLD,MPI_STATUS_IGNORE,mpierr) - call MPI_RECV(latt,nt_local(i) , MPI_REAL, 0,994,MPI_COMM_WORLD,MPI_STATUS_IGNORE,mpierr) - else if (myid == 0) then - ! root sends - call MPI_ISend(long(low_ind(i) : upp_ind(i)),nt_local(i),MPI_REAL,i-1,995,MPI_COMM_WORLD,req,mpierr) - call MPI_WAIT (req,MPI_STATUS_IGNORE,mpierr) - call MPI_ISend(latg(low_ind(i) : upp_ind(i)),nt_local(i),MPI_REAL,i-1,994,MPI_COMM_WORLD,req,mpierr) - call MPI_WAIT (req,MPI_STATUS_IGNORE,mpierr) - endif - endif - end do - - if(root_proc) deallocate (long) - - call MPI_BCAST(lonc,ntiles_rst,MPI_REAL,0,MPI_COMM_WORLD,mpierr) - call MPI_BCAST(latc,ntiles_rst,MPI_REAL,0,MPI_COMM_WORLD,mpierr) - call MPI_BCAST(tid_offl,size(tid_offl ),MPI_INTEGER,0,MPI_COMM_WORLD,mpierr) - - ! -------------------------------------------------------------------------------- - ! Here we create transfer index array to map offline restarts to output tile space - ! -------------------------------------------------------------------------------- - - ! id_glb for hydrologic variable - - call GetIds(lonc,latc,lonn,latt,id_loc, tid_offl) - if(root_proc) allocate (id_glb (ntiles)) - - call MPI_Barrier(MPI_COMM_WORLD, STATUS) -! call MPI_GATHERV( & -! id_loc, nt_local(myid+1) , MPI_real, & -! id_glb, nt_local,low_ind-1, MPI_real, & -! 0, MPI_COMM_WORLD, mpierr ) - do i = 1, numprocs - if((I == 1).and.(myid == 0)) then - id_glb(low_ind(i) : upp_ind(i)) = Id_loc(:) - else if (I > 1) then - if(I-1 == myid) then - ! send to root - call MPI_ISend(id_loc,nt_local(i),MPI_INTEGER,0,993,MPI_COMM_WORLD,req,mpierr) - call MPI_WAIT (req,MPI_STATUS_IGNORE,mpierr) - else if (myid == 0) then - ! root receives - call MPI_RECV(id_glb(low_ind(i) : upp_ind(i)),nt_local(i) , MPI_INTEGER, i-1,993,MPI_COMM_WORLD,MPI_STATUS_IGNORE,mpierr) - endif - endif - end do - - deallocate (id_loc) - - if(root_proc) then - - inquire(file = trim(rst_file), exist=fexist) - if (.not. fexist) then - print*, "WARNING!!" - print*, trim(rst_file) // " does not exist .. !" - stop - endif - - ! =========================================================== - ! Map restart nearest restart to output grid (hydrologic var) - ! =========================================================== - - filetype = 0 - call MAPL_NCIOGetFileType(rst_file, filetype,__RC__) - if(filetype == 0) then - ! GEOSldas CATCH/CATCHCN or CATCHCN LDASsa - call put_land_vars (NTILES, ntiles_rst, id_glb, ld_reorder, model, rst_file) - else - call read_ldas_restarts (NTILES, ntiles_rst, id_glb, ld_reorder, rst_file, pfile) - endif - - ! ==================== - ! READ AND PUT OUT BCS - ! ==================== - - do i = 1,10000 - ! just delaying few seconds to allow the system to copy the file - end do - - call read_bcs_data (NTILES, SURFLAY, trim(MODEL),'OutData/clsm/','OutData/'//trim(model)//'_internal_rst', __RC__) - - endif - - call MPI_Barrier(MPI_COMM_WORLD, STATUS) - - ! ============= - ! REGRID Carbon - ! ============= - - if (index(MODEL, 'catchcn') /=0) then - - allocate (CLMC_pf1(nt_local (myid + 1))) - allocate (CLMC_pf2(nt_local (myid + 1))) - allocate (CLMC_sf1(nt_local (myid + 1))) - allocate (CLMC_sf2(nt_local (myid + 1))) - allocate (CLMC_pt1(nt_local (myid + 1))) - allocate (CLMC_pt2(nt_local (myid + 1))) - allocate (CLMC_st1(nt_local (myid + 1))) - allocate (CLMC_st2(nt_local (myid + 1))) - allocate (ityp_offl (ntiles_rst,nveg)) - allocate (fveg_offl (ntiles_rst,nveg)) - allocate (id_loc_cn (nt_local (myid + 1),nveg)) - -! STATUS = NF90_OPEN ('OutData/catchcn_internal_rst',NF_WRITE,OUTID) ; VERIFY_(STATUS) - STATUS = NF_OPEN_PAR ('OutData/'//trim(model)//'_internal_rst',IOR(NF_WRITE,NF_MPIIO),MPI_COMM_WORLD, infos,OUTID) ; VERIFY_(STATUS) - STATUS = NF_GET_VARA_REAL(OUTID,VarID(OUTID,'ITY'), (/low_ind(myid+1),1/), (/nt_local(myid+1),1/),CLMC_pt1) - STATUS = NF_GET_VARA_REAL(OUTID,VarID(OUTID,'ITY'), (/low_ind(myid+1),2/), (/nt_local(myid+1),1/),CLMC_pt2) - STATUS = NF_GET_VARA_REAL(OUTID,VarID(OUTID,'ITY'), (/low_ind(myid+1),3/), (/nt_local(myid+1),1/),CLMC_st1) - STATUS = NF_GET_VARA_REAL(OUTID,VarID(OUTID,'ITY'), (/low_ind(myid+1),4/), (/nt_local(myid+1),1/),CLMC_st2) - STATUS = NF_GET_VARA_REAL(OUTID,VarID(OUTID,'FVG'), (/low_ind(myid+1),1/), (/nt_local(myid+1),1/),CLMC_pf1) - STATUS = NF_GET_VARA_REAL(OUTID,VarID(OUTID,'FVG'), (/low_ind(myid+1),2/), (/nt_local(myid+1),1/),CLMC_pf2) - STATUS = NF_GET_VARA_REAL(OUTID,VarID(OUTID,'FVG'), (/low_ind(myid+1),3/), (/nt_local(myid+1),1/),CLMC_sf1) - STATUS = NF_GET_VARA_REAL(OUTID,VarID(OUTID,'FVG'), (/low_ind(myid+1),4/), (/nt_local(myid+1),1/),CLMC_sf2) - - if (root_proc) then - - allocate (ityp_tmp (ntiles_rst,nveg)) - allocate (fveg_tmp (ntiles_rst,nveg)) - allocate (DAYX (NTILES)) - - READ(YYYYMMDDHH(1:8),'(I8)') AGCM_DATE - AGCM_YY = AGCM_DATE / 10000 - AGCM_MM = (AGCM_DATE - AGCM_YY*10000) / 100 - AGCM_DD = (AGCM_DATE - AGCM_YY*10000 - AGCM_MM*100) - - call compute_dayx ( & - NTILES, AGCM_YY, AGCM_MM, AGCM_DD, AGCM_HR, & - LATG, DAYX) - - STATUS = NF_OPEN (trim(rst_file),NF_NOWRITE,NCFID) ; VERIFY_(STATUS) - STATUS = NF_GET_VARA_REAL(NCFID,VarID(NCFID,'ITY'), (/1,1/), (/ntiles_rst,4/),ityp_tmp) - STATUS = NF_GET_VARA_REAL(NCFID,VarID(NCFID,'FVG'), (/1,1/), (/ntiles_rst,4/),fveg_tmp) - - do n = 1, NTILES_RST - ityp_offl (n,:) = ityp_tmp (ld_reorder(n),:) - fveg_offl (n,:) = fveg_tmp (ld_reorder(n),:) - - if((ityp_offl(N,3) == 0).and.(ityp_offl(N,4) == 0)) then - if(ityp_offl(N,1) /= 0) then - ityp_offl(N,3) = ityp_offl(N,1) - else - ityp_offl(N,3) = ityp_offl(N,2) - endif - endif - - if((ityp_offl(N,1) == 0).and.(ityp_offl(N,2) /= 0)) ityp_offl(N,1) = ityp_offl(N,2) - if((ityp_offl(N,2) == 0).and.(ityp_offl(N,1) /= 0)) ityp_offl(N,2) = ityp_offl(N,1) - if((ityp_offl(N,3) == 0).and.(ityp_offl(N,4) /= 0)) ityp_offl(N,3) = ityp_offl(N,4) - if((ityp_offl(N,4) == 0).and.(ityp_offl(N,3) /= 0)) ityp_offl(N,4) = ityp_offl(N,3) - end do - deallocate (ityp_tmp, fveg_tmp) - endif - - call MPI_BCAST(ityp_offl,size(ityp_offl),MPI_REAL ,0,MPI_COMM_WORLD,mpierr) - call MPI_BCAST(fveg_offl,size(fveg_offl),MPI_REAL ,0,MPI_COMM_WORLD,mpierr) - - call GetIds(lonc,latc,lonn,latt,id_loc_cn, tid_offl, & - CLMC_pf1, CLMC_pf2, CLMC_sf1, CLMC_sf2, CLMC_pt1, CLMC_pt2,CLMC_st1,CLMC_st2, & - fveg_offl, ityp_offl) - - if(root_proc) allocate (id_glb_cn (ntiles,nveg)) - - allocate (id_loc (ntiles)) - call MPI_Barrier(MPI_COMM_WORLD, STATUS) - deallocate (CLMC_pf1, CLMC_pf2, CLMC_sf1, CLMC_sf2) - deallocate (CLMC_pt1, CLMC_pt2, CLMC_st1, CLMC_st2) - - do nv = 1, nveg - call MPI_Barrier(MPI_COMM_WORLD, STATUS) - ! call MPI_GATHERV( & - ! id_loc (:,nv), nt_local(myid+1) , MPI_real, & - ! id_vec, nt_local,low_ind-1, MPI_real, & - ! 0, MPI_COMM_WORLD, mpierr ) - - do i = 1, numprocs - if((I == 1).and.(myid == 0)) then - id_loc(low_ind(i) : upp_ind(i)) = Id_loc_cn(:,nv) - else if (I > 1) then - if(I-1 == myid) then - ! send to root - call MPI_ISend(id_loc_cn(:,nv),nt_local(i),MPI_INTEGER,0,994,MPI_COMM_WORLD,req,mpierr) - call MPI_WAIT (req,MPI_STATUS_IGNORE,mpierr) - else if (myid == 0) then - ! root receives - call MPI_RECV(id_loc(low_ind(i) : upp_ind(i)),nt_local(i) , MPI_INTEGER, i-1,994,MPI_COMM_WORLD,MPI_STATUS_IGNORE,mpierr) - endif - endif - end do - - if(root_proc) id_glb_cn (:,nv) = id_loc - - end do - - if(root_proc) then - - allocate (var_off_col (1: NTILES_RST, 1 : nzone,1 : var_col)) - allocate (var_off_pft (1: NTILES_RST, 1 : nzone,1 : nveg, 1 : var_pft)) - allocate (var_dum2 (1:ntiles_rst)) - - i = 1 - do nv = 1,VAR_COL - do nz = 1,nzone - STATUS = NF_GET_VARA_REAL(NCFID,VarID(NCFID,'CNCOL'), (/1,i/), (/NTILES_RST,1 /),VAR_DUM2) - do k = 1, NTILES_RST - var_off_col(k, nz,nv) = VAR_DUM2(ld_reorder(k)) - end do - i = i + 1 - end do - end do - - i = 1 - do iv = 1,VAR_PFT - do nv = 1,nveg - do nz = 1,nzone - STATUS = NF_GET_VARA_REAL(NCFID,VarID(NCFID,'CNPFT'), (/1,i/), (/NTILES_RST,1 /),VAR_DUM2) - do k = 1, NTILES_RST - var_off_pft(K, nz,nv,iv) = VAR_DUM2(ld_reorder(k)) - end do - i = i + 1 - end do - end do - end do - - where(isnan(var_off_pft)) var_off_pft = 0. - where(var_off_pft /= var_off_pft) var_off_pft = 0. - print *, 'Writing regridded carbn' - call write_regridded_carbon (NTILES, ntiles_rst, NCFID, OUTID, id_glb_cn, & - DAYX, var_off_col,var_off_pft, ityp_offl, fveg_offl) - deallocate (var_off_col,var_off_pft) - endif - call MPI_Barrier(MPI_COMM_WORLD, STATUS) - STATUS = NF_CLOSE (OutID) - endif - - END SUBROUTINE regrid_from_xgrid - - ! ***************************************************************************** - - SUBROUTINE reorder_LDASsa_restarts (SURFLAY, BCSDIR, YYYYMMDDHH, EXPNAME, EXPDIR, MODEL, ENS, rstfile, rc) - - implicit none - - real, intent (in) :: SURFLAY - character(*), intent (in) :: BCSDIR, YYYYMMDDHH, EXPNAME, EXPDIR, MODEL, ENS, rstfile - integer, optional, intent(out) :: rc - character(256) :: tile_coord - character(300) :: rst_file, out_rst_file - type(Netcdf4_FileFormatter) :: InFmt,OutFmt, ldFmt - type(FileMetadata) :: meta_data - integer :: NTILES, i,j,k,n, ndims,dimSizes(3) - integer, allocatable :: LDAS2BCS (:), g2d(:), tile_id(:) - real, allocatable :: var1(:), var2(:),wesn1(:), htsn1(:) - integer :: dim1,dim2 - type(StringVariableMap), pointer :: variables - type(Variable), pointer :: var - type(StringVariableMapIterator) :: var_iter - type(StringVector), pointer :: var_dimensions - character(len=:), pointer :: vname,dname - logical :: fexist, bin_out = .false. - character(len=:), allocatable :: ftype - character*256 :: Iam = "reorder_LDASsa_restarts" - integer :: status - - if (trim(rstfile) == "NONE") then - ftype = '' - if(trim(MODEL) == 'catch') ftype='.bin' - rst_file = trim(EXPDIR)//'rs/ens'//ENS//'/Y'//YYYYMMDDHH(1:4)//'/M'//YYYYMMDDHH(5:6)//'/'//trim(ExpName)//& - '.ens'//ENS//'.'//trim(model)//'_ldas_rst.'//YYYYMMDDHH(1:8)//'_'//YYYYMMDDHH(9:10)//'00z'//trim(ftype) - else - rst_file = rstfile - endif - - inquire(file = trim(rst_file), exist=fexist) - if (.not. fexist) then - print*, "WARNING!!" - print*, rst_file // "does not exsit" - print*, "MAY USE ENS0000 only!!" - return - endif - - out_rst_file = trim(model)//ENS//'_internal_rst.'//YYYYMMDDHH(1:8) - - if (index(model,'catchcn') /=0) then - call ldFmt%open(trim(rst_file) , pFIO_READ,__RC__) - meta_data = ldFmt%read(__RC__) - call ldFmt%close(__RC__) - if(meta_data%get_dimension('unknown_dim3',rc=status) == 105) then - VAR_COL = VAR_COL_CLM45 - VAR_PFT = VAR_PFT_CLM45 - if ( .not. clm45) stop ' ERROR: Given clm45 restart, but the model is not clm45' - if (root_proc) print *, 'Processing CLM45 restarts : ', VAR_COL, VAR_PFT, clm45 - else - if (root_proc) print *, 'Processing CLM40 restarts : ', VAR_COL, VAR_PFT, clm45 - endif - endif - - open (10,file =trim(BCSDIR)//"clsm/catchment.def",status='old',form='formatted') - read (10,*) ntiles - close (10, status = 'keep') - - ! read NTILES from BCs and tile_coord from LDASsa experiment - - tile_coord = trim(EXPDIR)//'rc_out/'//trim(expname)//'.ldas_tilecoord.bin' - inquire(file = tile_coord, exist=fexist) - if (.not. fexist) then - print*, trim(tile_coord) // " file should be provided" - stop "no tile_coord file" - endif - - open (10,file =trim(tile_coord),status='old',form='unformatted',convert='big_endian') - read (10) i - if (i /= ntiles) then - print *,'NTILES BCs/LDASsa mismatch:', i,ntiles - stop - endif - - if(trim(MODEL) == 'catch') then - call InFmt%open('/discover/nobackup/projects/gmao/ssd/land/l_data/LandRestarts_for_Regridding/Catch/catch_internal_rst' , pFIO_READ,__RC__) - end if - if(index(MODEL, 'catchcn') /=0) then - if (clm45) then - call InFmt%open('/discover/nobackup/projects/gmao/ssd/land/l_data/LandRestarts_for_Regridding/CatchCN/catchcn_internal_clm45',PFIO_READ, __RC__) - else - call InFmt%open('/discover/nobackup/projects/gmao/ssd/land/l_data/LandRestarts_for_Regridding/CatchCN/catchcn_internal_dummy' , pFIO_READ, __RC__) - endif - end if - meta_data = InFmt%read(__RC__) - call inFmt%close(__RC__) - - call meta_data%modify_dimension('tile',ntiles,__RC__) - - call OutFmt%create(trim(out_rst_file),__RC__) - call OutFmt%write(meta_data, __RC__) - - - allocate (tile_id (1:ntiles)) - allocate (LDAS2BCS (1:ntiles)) - allocate (g2d (1:ntiles)) - - read (10) LDAS2BCS - close (10, status = 'keep') - - ! ========================== - ! READ/WRITE LDASsa RESTARTS - ! ========================== - - allocate(var1(ntiles)) - allocate(var2(ntiles)) - allocate(wesn1 (ntiles)) - allocate(htsn1 (ntiles)) - ! CH CM CQ FR WW - ! WW - var1 = 0.1 - do j = 1,4 - call MAPL_VarWrite(OutFmt,'WW',var1 ,offset1=j) - end do - ! FR - var1 = 0.25 - do j = 1,4 - call MAPL_VarWrite(OutFmt,'FR',var1 ,offset1=j) - end do - ! CH CM CQ - var1 = 0.001 - do j = 1,4 - call MAPL_VarWrite(OutFmt,'CH',var1 ,offset1=j) - call MAPL_VarWrite(OutFmt,'CM',var1 ,offset1=j) - call MAPL_VarWrite(OutFmt,'CQ',var1 ,offset1=j) - end do - - tile_id = LDAS2BCS - do n = 1, NTILES - G2D(tile_id(n)) = n - end do - - if(trim(MODEL) == 'catch') then - - open(10, file=trim(rst_file), form='unformatted', status='old', & - convert='big_endian', action='read') - - var1 = real(tile_id) - var2 = var1 (tile_id) - do n = 1, NTILES - var2(n) = var1(g2d(n)) - end do - call MAPL_VarWrite(OutFmt,'TILE_ID' ,var2) - - read(10) var1 - var2 = var1 (tile_id) - do n = 1, NTILES - var2(n) = var1(g2d(n)) - end do - call MAPL_VarWrite(OutFmt,'TC' ,var2, offset1=1) - read(10) var1 - var2 = var1 (tile_id) - do n = 1, NTILES - var2(n) = var1(g2d(n)) - end do - call MAPL_VarWrite(OutFmt,'TC' ,var2, offset1=2) - read(10) var1 - var2 = var1 (tile_id) - do n = 1, NTILES - var2(n) = var1(g2d(n)) - end do - call MAPL_VarWrite(OutFmt,'TC' ,var2, offset1=3) - - read(10) var1 - var2 = var1 (tile_id) - do n = 1, NTILES - var2(n) = var1(g2d(n)) - end do - call MAPL_VarWrite(OutFmt,'QC' ,var2, offset1=1) - read(10) var1 - var2 = var1 (tile_id) - do n = 1, NTILES - var2(n) = var1(g2d(n)) - end do - call MAPL_VarWrite(OutFmt,'QC' ,var2, offset1=2) - read(10) var1 - var2 = var1 (tile_id) - do n = 1, NTILES - var2(n) = var1(g2d(n)) - end do - call MAPL_VarWrite(OutFmt,'QC' ,var2, offset1=3) - call MAPL_VarWrite(OutFmt,'QC' ,var2, offset1=4) - - read(10) var1 - var2 = var1 (tile_id) - do n = 1, NTILES - var2(n) = var1(g2d(n)) - end do - call MAPL_VarWrite(OutFmt,'CAPAC' ,var2) - read(10) var1 - var2 = var1 (tile_id) - do n = 1, NTILES - var2(n) = var1(g2d(n)) - end do - call MAPL_VarWrite(OutFmt,'CATDEF' ,var2) - read(10) var1 - var2 = var1 (tile_id) - do n = 1, NTILES - var2(n) = var1(g2d(n)) - end do - call MAPL_VarWrite(OutFmt,'RZEXC' ,var2) - read(10) var1 - var2 = var1 (tile_id) - do n = 1, NTILES - var2(n) = var1(g2d(n)) - end do - call MAPL_VarWrite(OutFmt,'SRFEXC' ,var2) - read(10) var1 - var2 = var1 (tile_id) - do n = 1, NTILES - var2(n) = var1(g2d(n)) - end do - call MAPL_VarWrite(OutFmt,'GHTCNT1' ,var2) - read(10) var1 - var2 = var1 (tile_id) - do n = 1, NTILES - var2(n) = var1(g2d(n)) - end do - call MAPL_VarWrite(OutFmt,'GHTCNT2' ,var2) - read(10) var1 - var2 = var1 (tile_id) - do n = 1, NTILES - var2(n) = var1(g2d(n)) - end do - call MAPL_VarWrite(OutFmt,'GHTCNT3' ,var2) - read(10) var1 - var2 = var1 (tile_id) - do n = 1, NTILES - var2(n) = var1(g2d(n)) - end do - call MAPL_VarWrite(OutFmt,'GHTCNT4' ,var2) - read(10) var1 - var2 = var1 (tile_id) - do n = 1, NTILES - var2(n) = var1(g2d(n)) - end do - call MAPL_VarWrite(OutFmt,'GHTCNT5' ,var2) - read(10) var1 - var2 = var1 (tile_id) - do n = 1, NTILES - var2(n) = var1(g2d(n)) - end do - call MAPL_VarWrite(OutFmt,'GHTCNT6' ,var2) - read(10) var1 - var2 = var1 (tile_id) - - do n = 1, NTILES - var2(n) = var1(g2d(n)) - end do - wesn1 = var2 - call MAPL_VarWrite(OutFmt,'WESNN1' ,var2) - read(10) var1 - var2 = var1 (tile_id) - do n = 1, NTILES - var2(n) = var1(g2d(n)) - end do - call MAPL_VarWrite(OutFmt,'WESNN2' ,var2) - read(10) var1 - var2 = var1 (tile_id) - do n = 1, NTILES - var2(n) = var1(g2d(n)) - end do - call MAPL_VarWrite(OutFmt,'WESNN3' ,var2) - read(10) var1 - var2 = var1 (tile_id) - do n = 1, NTILES - var2(n) = var1(g2d(n)) - end do - htsn1 = var2 - call MAPL_VarWrite(OutFmt,'HTSNNN1' ,var2) - read(10) var1 - var2 = var1 (tile_id) - do n = 1, NTILES - var2(n) = var1(g2d(n)) - end do - call MAPL_VarWrite(OutFmt,'HTSNNN2' ,var2) - read(10) var1 - var2 = var1 (tile_id) - do n = 1, NTILES - var2(n) = var1(g2d(n)) - end do - call MAPL_VarWrite(OutFmt,'HTSNNN3' ,var2) - read(10) var1 - var2 = var1 (tile_id) - do n = 1, NTILES - var2(n) = var1(g2d(n)) - end do - call MAPL_VarWrite(OutFmt,'SNDZN1' ,var2) - read(10) var1 - var2 = var1 (tile_id) - do n = 1, NTILES - var2(n) = var1(g2d(n)) - end do - call MAPL_VarWrite(OutFmt,'SNDZN2' ,var2) - read(10) var1 - var2 = var1 (tile_id) - do n = 1, NTILES - var2(n) = var1(g2d(n)) - end do - call MAPL_VarWrite(OutFmt,'SNDZN3' ,var2) - call STIEGLITZSNOW_CALC_TPSNOW(NTILES, HTSN1(:), WESN1(:), var2, var1) - var2 = var2 + 273.16 - call MAPL_VarWrite(OutFmt,'TC' ,var2, offset1=4) - deallocate (var1, var2) - call OutFmt%close() - close(10) - - else ! CATCHCN - - call InFmt%open(trim(rst_file),pFIO_READ,__RC__) - meta_data = InFmt%read(__RC__) - - call MAPL_VarRead ( InFmt,'TILE_ID',var1, __RC__) - if(sum (nint(var1) - LDAS2BCS) /= 0) then - print *, 'Tile order mismatch ', sum(var1)/ntiles, sum(LDAS2BCS)/ntiles - stop - endif - - variables => meta_data%get_variables() - var_iter = variables%begin() - do while (var_iter /= variables%end()) - - vname => var_iter%key() - var => var_iter%value() - var_dimensions => var%get_dimensions() - - ndims = var_dimensions%size() - - if (ndims == 1) then - call MAPL_VarRead ( InFmt,vname,var1, __RC__) - var2 = var1 (tile_id) - do n = 1, NTILES - var2(n) = var1(g2d(n)) - end do - if(trim(vname) == 'SFMCM' ) var2 = 0. - if(trim(vname) == 'BFLOWM' ) var2 = 0. - if(trim(vname) == 'TOTWATM') var2 = 0. - if(trim(vname) == 'TAIRM' ) var2 = 0. - if(trim(vname) == 'TPM' ) var2 = 0. - if(trim(vname) == 'CNSUM' ) var2 = 0. - if(trim(vname) == 'SNDZM' ) var2 = 0. - if(trim(vname) == 'ASNOWM' ) var2 = 0. - if(trim(vname) == 'TSURF' ) var2 = 0. - - call MAPL_VarWrite(OutFmt,vname,var2) - - else if (ndims == 2) then - - dname => var%get_ith_dimension(2) - dim1=meta_data%get_dimension(dname) - do j=1,dim1 - call MAPL_VarRead ( InFmt,vname,var1 ,offset1=j, __RC__) - var2 = var1 (tile_id) - do n = 1, NTILES - var2(n) = var1(g2d(n)) - end do - if(trim(vname) == 'TGWM' ) var2 = 0. - if(trim(vname) == 'RZMM' ) var2 = 0. - if(trim(vname) == 'WW' ) var2 = 0.1 - if(trim(vname) == 'FR' ) var2 = 0.25 - if(trim(vname) == 'CQ' ) var2 = 0.001 - if(trim(vname) == 'CN' ) var2 = 0.001 - if(trim(vname) == 'CM' ) var2 = 0.001 - if(trim(vname) == 'CH' ) var2 = 0.001 - call MAPL_VarWrite(OutFmt,vname,var2 ,offset1=j) - enddo - - else if (ndims == 3) then - - dname => var%get_ith_dimension(2) - dim1=meta_data%get_dimension(dname) - dname => var%get_ith_dimension(3) - dim2=meta_data%get_dimension(dname) - do i=1,dim2 - do j=1,dim1 - call MAPL_VarRead ( InFmt,vname,var1 ,offset1=j,offset2=i, __RC__) - var2 = var1 (tile_id) - do n = 1, NTILES - var2(n) = var1(g2d(n)) - end do - if(trim(vname) == 'PSNSUNM' ) var2 = 0. - if(trim(vname) == 'PSNSHAM' ) var2 = 0. - call MAPL_VarWrite(OutFmt,vname,var2 ,offset1=j,offset2=i) - enddo - enddo - - end if - call var_iter%next() - enddo - - call InFmt%close() - call OutFmt%close() - deallocate (var1, var2, tile_id) - endif - - call read_bcs_data (ntiles, SURFLAY, trim(MODEL), trim(BCSDIR)//'/clsm/',trim(out_rst_file), __RC__) - - if(bin_out) then - call InFmt%open(trim(out_rst_file),pFIO_READ,__RC__) - open(unit=30, file=trim(out_rst_file)//'.bin', form='unformatted') - call write_bin (30, InFmt, NTILES) - close(30) - call InFmt%close() - endif - if (present(rc)) rc =0 - !_RETURN(_SUCCESS) - - END SUBROUTINE reorder_LDASsa_restarts - - ! ***************************************************************************** - - SUBROUTINE regrid_hyd_vars (NTILES, model) - - implicit none - integer, intent (in) :: NTILES - character(*), intent (in) :: model - - ! =============================================================================================== - - integer, allocatable, dimension(:) :: Id_glb, Id_loc - integer, allocatable, dimension(:) :: ld_reorder, tid_offl - real , allocatable, dimension(:) :: tmp_var - integer :: n,i,nplus, STATUS,NCFID, req - integer :: local_id, ntiles_smap - real , allocatable, dimension (:) :: LATT, LONN - real , pointer , dimension (:) :: long, latg, lonc, latc - integer, allocatable :: low_ind(:), upp_ind(:), nt_local (:) - - logical :: all_found - character(256) :: Iam="regrid_hyd_vars" - - if(index(MODEL, 'catchcn') /=0) ntiles_smap = ntiles_cn - if(trim(MODEL) == 'catch' ) ntiles_smap = ntiles_cat - - allocate (tid_offl (ntiles_smap)) - allocate (tmp_var (ntiles_smap)) - - allocate(low_ind ( numprocs)) - allocate(upp_ind ( numprocs)) - allocate(nt_local( numprocs)) - - low_ind (:) = 1 - upp_ind (:) = NTILES - nt_local(:) = NTILES - - ! Domain decomposition - ! -------------------- - - if (numprocs > 1) then - do i = 1, numprocs - 1 - upp_ind(i) = low_ind(i) + (ntiles/numprocs) - 1 - low_ind(i+1) = upp_ind(i) + 1 - nt_local(i) = upp_ind(i) - low_ind(i) + 1 - end do - nt_local(numprocs) = upp_ind(numprocs) - low_ind(numprocs) + 1 - endif - - allocate (id_loc (nt_local (myid + 1))) - allocate (lonn (nt_local (myid + 1))) - allocate (latt (nt_local (myid + 1))) - allocate (lonc (1:ntiles_smap)) - allocate (latc (1:ntiles_smap)) - - if (root_proc) then - - allocate (long (ntiles)) - allocate (latg (ntiles)) - allocate (ld_reorder(ntiles_smap)) - - call ReadTileFile_RealLatLon ('InData/OutTileFile', i, xlon=long, xlat=latg); VERIFY_(i-ntiles) - ! --------------------------------------------- - ! Read exact lonc, latc from offline .til File - ! --------------------------------------------- - - if(index(MODEL,'catchcn') /=0) then - call ReadTileFile_RealLatLon(trim(InCNTilFile ),i,xlon=lonc,xlat=latc) - VERIFY_(i-ntiles_smap) - endif - if(trim(MODEL) == 'catch' ) then - call ReadTileFile_RealLatLon(trim(InCatTilFile),i,xlon=lonc,xlat=latc) - VERIFY_(i-ntiles_smap) - endif - if(index(MODEL,'catchcn') /=0) then - STATUS = NF_OPEN (trim(InCNRestart ),NF_NOWRITE,NCFID) ; VERIFY_(STATUS) - endif - if(trim(MODEL) == 'catch' ) then - STATUS = NF_OPEN (trim(InCatRestart),NF_NOWRITE,NCFID) ; VERIFY_(STATUS) - endif - STATUS = NF_GET_VARA_REAL(NCFID,VarID(NCFID,'TILE_ID' ), (/1/), (/NTILES_SMAP/),tmp_var) - STATUS = NF_CLOSE (NCFID) - - do n = 1, ntiles_smap - ld_reorder ( NINT(tmp_var(n))) = n - tid_offl(n) = n - end do - - deallocate (tmp_var) - - endif - - call MPI_Barrier(MPI_COMM_WORLD, STATUS) - - do i = 1, numprocs - if((I == 1).and.(myid == 0)) then - lonn(:) = long(low_ind(i) : upp_ind(i)) - latt(:) = latg(low_ind(i) : upp_ind(i)) - else if (I > 1) then - if(I-1 == myid) then - ! receiving from root - call MPI_RECV(lonn,nt_local(i) , MPI_REAL, 0,995,MPI_COMM_WORLD,MPI_STATUS_IGNORE,mpierr) - call MPI_RECV(latt,nt_local(i) , MPI_REAL, 0,994,MPI_COMM_WORLD,MPI_STATUS_IGNORE,mpierr) - else if (myid == 0) then - ! root sends - call MPI_ISend(long(low_ind(i) : upp_ind(i)),nt_local(i),MPI_REAL,i-1,995,MPI_COMM_WORLD,req,mpierr) - call MPI_WAIT (req,MPI_STATUS_IGNORE,mpierr) - call MPI_ISend(latg(low_ind(i) : upp_ind(i)),nt_local(i),MPI_REAL,i-1,994,MPI_COMM_WORLD,req,mpierr) - call MPI_WAIT (req,MPI_STATUS_IGNORE,mpierr) - endif - endif - end do - -! call MPI_SCATTERV ( & -! long,nt_local,low_ind-1,MPI_real, & -! lonn,size(lonn),MPI_real , & -! 0,MPI_COMM_WORLD, mpierr ) -! -! call MPI_SCATTERV ( & -! latg,nt_local,low_ind-1,MPI_real, & -! latt,nt_local(myid+1),MPI_real , & -! 0,MPI_COMM_WORLD, mpierr ) - - if(root_proc) deallocate (long, latg) - - call MPI_BCAST(lonc,ntiles_smap,MPI_REAL,0,MPI_COMM_WORLD,mpierr) - call MPI_BCAST(latc,ntiles_smap,MPI_REAL,0,MPI_COMM_WORLD,mpierr) - call MPI_BCAST(tid_offl,size(tid_offl ),MPI_INTEGER,0,MPI_COMM_WORLD,mpierr) - - ! -------------------------------------------------------------------------------- - ! Here we create transfer index array to map offline restarts to output tile space - ! -------------------------------------------------------------------------------- - - call GetIds(lonc,latc,lonn,latt,id_loc, tid_offl) - - ! Loop through NTILES (# of tiles in output array) find the nearest neighbor from Qing. - - if(root_proc) allocate (id_glb (ntiles)) - - call MPI_Barrier(MPI_COMM_WORLD, STATUS) -! call MPI_GATHERV( & -! id_loc, nt_local(myid+1) , MPI_real, & -! id_glb, nt_local,low_ind-1, MPI_real, & -! 0, MPI_COMM_WORLD, mpierr ) - do i = 1, numprocs - if((I == 1).and.(myid == 0)) then - id_glb(low_ind(i) : upp_ind(i)) = Id_loc(:) - else if (I > 1) then - if(I-1 == myid) then - ! send to root - call MPI_ISend(id_loc,nt_local(i),MPI_INTEGER,0,993,MPI_COMM_WORLD,req,mpierr) - call MPI_WAIT (req,MPI_STATUS_IGNORE,mpierr) - else if (myid == 0) then - ! root receives - call MPI_RECV(id_glb(low_ind(i) : upp_ind(i)),nt_local(i) , MPI_INTEGER, i-1,993,MPI_COMM_WORLD,MPI_STATUS_IGNORE,mpierr) - endif - endif - end do - - if (root_proc) call put_land_vars (NTILES, ntiles_smap, id_glb, ld_reorder, model) - - call MPI_Barrier(MPI_COMM_WORLD, STATUS) - - END SUBROUTINE regrid_hyd_vars - - - ! ***************************************************************************** - - SUBROUTINE read_bcs_data (ntiles, SURFLAY,MODEL, DataDir, InRestart, rc) - - ! This subroutine : - ! 1) reads BCs from BCSDIR and hydrological varables from InRestart. - ! InRestart is a catchcn_internal_rst nc4 file. - ! - ! 2) writes out BCs and hydrological variables in catchcn_internal_rst (1:72). - ! output catchcn_internal_rst is nc4. - - implicit none - real, intent (in) :: SURFLAY - integer, intent (in) :: ntiles - character(*), intent (in) :: MODEL, DataDir, InRestart - integer, optional, intent(out) :: rc - real, allocatable :: CLMC_pf1(:), CLMC_pf2(:), CLMC_sf1(:), CLMC_sf2(:) - real, allocatable :: CLMC_pt1(:), CLMC_pt2(:), CLMC_st1(:), CLMC_st2(:) - real, allocatable :: CLMC45_pf1(:), CLMC45_pf2(:), CLMC45_sf1(:), CLMC45_sf2(:) - real, allocatable :: CLMC45_pt1(:), CLMC45_pt2(:), CLMC45_st1(:), CLMC45_st2(:) - real, allocatable :: BF1(:), BF2(:), BF3(:), VGWMAX(:) - real, allocatable :: CDCR1(:), CDCR2(:), PSIS(:), BEE(:) - real, allocatable :: POROS(:), WPWET(:), COND(:), GNU(:) - real, allocatable :: ARS1(:), ARS2(:), ARS3(:) - real, allocatable :: ARA1(:), ARA2(:), ARA3(:), ARA4(:) - real, allocatable :: ARW1(:), ARW2(:), ARW3(:), ARW4(:) - real, allocatable :: TSA1(:), TSA2(:), TSB1(:), TSB2(:) - real, allocatable :: ATAU2(:), BTAU2(:), DP2BR(:), CanopH(:) - real, allocatable :: NDEP(:), BVISDR(:), BVISDF(:), BNIRDR(:), BNIRDF(:) - real, allocatable :: T2(:), var1(:), hdm(:), fc(:), gdp(:), peatf(:), RITY(:) - integer, allocatable :: ity(:), abm (:) - integer :: NCFID, STATUS - integer :: idum, i,j,n, ib, nv - real :: rdum, zdep1, zdep2, zdep3, zmet, term1, term2, bare,fvg(4) - logical :: NEWLAND, isCatchCN - logical :: file_exists - type(NetCDF4_Fileformatter) :: CatchFmt,CatchCNFmt - character*256 :: Iam = "read_bcs_data" - - allocate ( BF1(ntiles), BF2 (ntiles), BF3(ntiles) ) - allocate (VGWMAX(ntiles), CDCR1(ntiles), CDCR2(ntiles) ) - allocate ( PSIS(ntiles), BEE(ntiles), POROS(ntiles) ) - allocate ( WPWET(ntiles), COND(ntiles), GNU(ntiles) ) - allocate ( ARS1(ntiles), ARS2(ntiles), ARS3(ntiles) ) - allocate ( ARA1(ntiles), ARA2(ntiles), ARA3(ntiles) ) - allocate ( ARA4(ntiles), ARW1(ntiles), ARW2(ntiles) ) - allocate ( ARW3(ntiles), ARW4(ntiles), TSA1(ntiles) ) - allocate ( TSA2(ntiles), TSB1(ntiles), TSB2(ntiles) ) - allocate ( ATAU2(ntiles), BTAU2(ntiles), DP2BR(ntiles) ) - allocate (BVISDR(ntiles), BVISDF(ntiles), BNIRDR(ntiles) ) - allocate (BNIRDF(ntiles), T2(ntiles), NDEP(ntiles) ) - allocate ( ity(ntiles), CanopH(ntiles) ) - allocate (CLMC_pf1(ntiles), CLMC_pf2(ntiles), CLMC_sf1(ntiles)) - allocate (CLMC_sf2(ntiles), CLMC_pt1(ntiles), CLMC_pt2(ntiles)) - allocate (CLMC45_pf1(ntiles), CLMC45_pf2(ntiles), CLMC45_sf1(ntiles)) - allocate (CLMC45_sf2(ntiles), CLMC45_pt1(ntiles), CLMC45_pt2(ntiles)) - allocate (CLMC_st1(ntiles), CLMC_st2(ntiles)) - allocate (CLMC45_st1(ntiles), CLMC45_st2(ntiles)) - allocate (hdm(ntiles), fc(ntiles), gdp(ntiles)) - allocate (peatf(ntiles), abm(ntiles), var1(ntiles), RITY(ntiles)) - - inquire(file = trim(DataDir)//'/catchcn_params.nc4', exist=file_exists) - inquire(file = trim(DataDir)//"CLM_veg_typs_fracs" ,exist=NewLand ) - - isCatchCN = (index(model,'catchcn') /=0) - - if(file_exists) then - - print *,'FILE FORMAT FOR LAND BCS IS NC4' - call CatchFmt%Open(trim(DataDir)//'/catch_params.nc4', pFIO_READ, __RC__) - call MAPL_VarRead ( CatchFmt ,'OLD_ITY', RITY, __RC__) - ITY = NINT (RITY) - call MAPL_VarRead ( CatchFmt ,'ARA1', ARA1, __RC__) - call MAPL_VarRead ( CatchFmt ,'ARA2', ARA2, __RC__) - call MAPL_VarRead ( CatchFmt ,'ARA3', ARA3, __RC__) - call MAPL_VarRead ( CatchFmt ,'ARA4', ARA4, __RC__) - call MAPL_VarRead ( CatchFmt ,'ARS1', ARS1, __RC__) - call MAPL_VarRead ( CatchFmt ,'ARS2', ARS2, __RC__) - call MAPL_VarRead ( CatchFmt ,'ARS3', ARS3, __RC__) - call MAPL_VarRead ( CatchFmt ,'ARW1', ARW1, __RC__) - call MAPL_VarRead ( CatchFmt ,'ARW2', ARW2, __RC__) - call MAPL_VarRead ( CatchFmt ,'ARW3', ARW3, __RC__) - call MAPL_VarRead ( CatchFmt ,'ARW4', ARW4, __RC__) - - if( SURFLAY.eq.20.0 ) then - call MAPL_VarRead ( CatchFmt ,'ATAU2', ATAU2, __RC__) - call MAPL_VarRead ( CatchFmt ,'BTAU2', BTAU2, __RC__) - endif - - if( SURFLAY.eq.50.0 ) then - call MAPL_VarRead ( CatchFmt ,'ATAU5', ATAU2, __RC__) - call MAPL_VarRead ( CatchFmt ,'BTAU5', BTAU2, __RC__) - endif - - call MAPL_VarRead ( CatchFmt ,'PSIS', PSIS, __RC__) - call MAPL_VarRead ( CatchFmt ,'BEE', BEE, __RC__) - call MAPL_VarRead ( CatchFmt ,'BF1', BF1, __RC__) - call MAPL_VarRead ( CatchFmt ,'BF2', BF2, __RC__) - call MAPL_VarRead ( CatchFmt ,'BF3', BF3, __RC__) - call MAPL_VarRead ( CatchFmt ,'TSA1', TSA1, __RC__) - call MAPL_VarRead ( CatchFmt ,'TSA2', TSA2, __RC__) - call MAPL_VarRead ( CatchFmt ,'TSB1', TSB1, __RC__) - call MAPL_VarRead ( CatchFmt ,'TSB2', TSB2, __RC__) - call MAPL_VarRead ( CatchFmt ,'COND', COND, __RC__) - call MAPL_VarRead ( CatchFmt ,'GNU', GNU, __RC__) - call MAPL_VarRead ( CatchFmt ,'WPWET', WPWET, __RC__) - call MAPL_VarRead ( CatchFmt ,'DP2BR', DP2BR, __RC__) - call MAPL_VarRead ( CatchFmt ,'POROS', POROS, __RC__) - call CatchFmt%close() - if(isCatchCN) then - call CatchCNFmt%Open(trim(DataDir)//'/catchcn_params.nc4', pFIO_READ, __RC__) - call MAPL_VarRead ( CatchCNFmt ,'BGALBNF', BNIRDF, __RC__) - call MAPL_VarRead ( CatchCNFmt ,'BGALBNR', BNIRDR, __RC__) - call MAPL_VarRead ( CatchCNFmt ,'BGALBVF', BVISDF, __RC__) - call MAPL_VarRead ( CatchCNFmt ,'BGALBVR', BVISDR, __RC__) - call MAPL_VarRead ( CatchCNFmt ,'NDEP', NDEP, __RC__) - call MAPL_VarRead ( CatchCNFmt ,'T2_M', T2, __RC__) - call MAPL_VarRead(CatchCNFmt,'ITY',CLMC_pt1,offset1=1, __RC__) ! 30 - call MAPL_VarRead(CatchCNFmt,'ITY',CLMC_pt2,offset1=2, __RC__) ! 31 - call MAPL_VarRead(CatchCNFmt,'ITY',CLMC_st1,offset1=3, __RC__) ! 32 - call MAPL_VarRead(CatchCNFmt,'ITY',CLMC_st2,offset1=4, __RC__) ! 33 - call MAPL_VarRead(CatchCNFmt,'FVG',CLMC_pf1,offset1=1, __RC__) ! 34 - call MAPL_VarRead(CatchCNFmt,'FVG',CLMC_pf2,offset1=2, __RC__) ! 35 - call MAPL_VarRead(CatchCNFmt,'FVG',CLMC_sf1,offset1=3, __RC__) ! 36 - call MAPL_VarRead(CatchCNFmt,'FVG',CLMC_sf2,offset1=4, __RC__) ! 37 - call CatchCNFmt%close() - if(clm45) then - open(unit=30, file=trim(DataDir)//'CLM4.5_abm_peatf_gdp_hdm_fc' ,form='formatted') - do n=1,ntiles - read (30, *) i, j, abm(n), peatf(n), & - gdp(n), hdm(n), fc(n) - end do - CLOSE (30, STATUS = 'KEEP') - endif - endif - - - else - open(unit=21, file=trim(DataDir)//'mosaic_veg_typs_fracs',form='formatted') - open(unit=22, file=trim(DataDir)//'bf.dat' ,form='formatted') - open(unit=23, file=trim(DataDir)//'soil_param.dat' ,form='formatted') - open(unit=24, file=trim(DataDir)//'ar.new' ,form='formatted') - open(unit=25, file=trim(DataDir)//'ts.dat' ,form='formatted') - open(unit=26, file=trim(DataDir)//'tau_param.dat' ,form='formatted') - - if(NewLand .and. isCatchCN) then - open(unit=27, file=trim(DataDir)//'CLM_veg_typs_fracs' ,form='formatted') - open(unit=28, file=trim(DataDir)//'CLM_NDep_SoilAlb_T2m' ,form='formatted') - if(clm45) then - open(unit=29, file=trim(DataDir)//'CLM4.5_veg_typs_fracs',form='formatted') - open(unit=30, file=trim(DataDir)//'CLM4.5_abm_peatf_gdp_hdm_fc' ,form='formatted') - endif - endif - - do n=1,ntiles - var1 (n) = real (n) - ! W.J notes: CanopH is not used. If CLM_veg_typs_fracs exists, the read some dummy ???? Ask Sarith - if (NewLand) then - read(21,*) I, j, ITY(N),idum, rdum, rdum, CanopH(N) - else - read(21,*) I, j, ITY(N),idum, rdum, rdum - endif - - read (22, *) i,j, GNU(n), BF1(n), BF2(n), BF3(n) - - read (23, *) i,j, idum, idum, BEE(n), PSIS(n),& - POROS(n), COND(n), WPWET(n), DP2BR(n) - - read (24, *) i,j, rdum, ARS1(n), ARS2(n), ARS3(n), & - ARA1(n), ARA2(n), ARA3(n), ARA4(n), & - ARW1(n), ARW2(n), ARW3(n), ARW4(n) - - read (25, *) i,j, rdum, TSA1(n), TSA2(n), TSB1(n), TSB2(n) - - if( SURFLAY.eq.20.0 ) read (26, *) i,j, ATAU2(n), BTAU2(n), rdum, rdum ! for old soil params - if( SURFLAY.eq.50.0 ) read (26, *) i,j, rdum , rdum, ATAU2(n), BTAU2(n) ! for new soil params - - if (NewLand .and. isCatchCN) then - read (27, *) i,j, CLMC_pt1(n), CLMC_pt2(n), CLMC_st1(n), CLMC_st2(n), & - CLMC_pf1(n), CLMC_pf2(n), CLMC_sf1(n), CLMC_sf2(n) - - read (28, *) NDEP(n), BVISDR(n), BVISDF(n), BNIRDR(n), BNIRDF(n), T2(n) ! MERRA-2 Annual Mean Temp is default. - if(clm45) then - read (29, *) i,j, CLMC45_pt1(n), CLMC45_pt2(n), CLMC45_st1(n), CLMC45_st2(n), & - CLMC45_pf1(n), CLMC45_pf2(n), CLMC45_sf1(n), CLMC45_sf2(n) - - read (30, *) i, j, abm(n), peatf(n), & - gdp(n), hdm(n), fc(n) - endif - endif - end do - - CLOSE (21, STATUS = 'KEEP') - CLOSE (22, STATUS = 'KEEP') - CLOSE (23, STATUS = 'KEEP') - CLOSE (24, STATUS = 'KEEP') - CLOSE (25, STATUS = 'KEEP') - CLOSE (26, STATUS = 'KEEP') - - if(NewLand .and. isCatchCN) then - CLOSE (27, STATUS = 'KEEP') - CLOSE (28, STATUS = 'KEEP') - if(clm45) then - CLOSE (29, STATUS = 'KEEP') - CLOSE (30, STATUS = 'KEEP') - endif - endif - endif - - - do n=1,ntiles - var1 (n) = real (n) - - zdep2=1000. - zdep3=amax1(1000.,DP2BR(n)) - - if (zdep2 .gt.0.75*zdep3) then - zdep2 = 0.75*zdep3 - end if - - zdep1=20. - zmet=zdep3/1000. - - term1=-1.+((PSIS(n)-zmet)/PSIS(n))**((BEE(n)-1.)/BEE(n)) - term2=PSIS(n)*BEE(n)/(BEE(n)-1) - - VGWMAX(n) = POROS(n)*zdep2 - CDCR1(n) = 1000.*POROS(n)*(zmet-(-term2*term1)) - CDCR2(n) = (1.-WPWET(n))*POROS(n)*zdep3 - - if( isCatchCN) then - - BVISDR(n) = amax1(1.e-6, BVISDR(n)) - BVISDF(n) = amax1(1.e-6, BVISDF(n)) - BNIRDR(n) = amax1(1.e-6, BNIRDR(n)) - BNIRDF(n) = amax1(1.e-6, BNIRDF(n)) - - ! convert % to fractions - - CLMC_pf1(n) = CLMC_pf1(n) / 100. - CLMC_pf2(n) = CLMC_pf2(n) / 100. - CLMC_sf1(n) = CLMC_sf1(n) / 100. - CLMC_sf2(n) = CLMC_sf2(n) / 100. - - fvg(1) = CLMC_pf1(n) - fvg(2) = CLMC_pf2(n) - fvg(3) = CLMC_sf1(n) - fvg(4) = CLMC_sf2(n) - - BARE = 1. - - DO NV = 1, NVEG - BARE = BARE - FVG(NV)! subtract vegetated fractions - END DO - - if (BARE /= 0.) THEN - IB = MAXLOC(FVG(:),1) - FVG (IB) = FVG(IB) + BARE ! This also corrects all cases sum ne 0. - ENDIF - - CLMC_pf1(n) = fvg(1) - CLMC_pf2(n) = fvg(2) - CLMC_sf1(n) = fvg(3) - CLMC_sf2(n) = fvg(4) - - if(CLM45) then - ! CLM 45 - - CLMC45_pf1(n) = CLMC45_pf1(n) / 100. - CLMC45_pf2(n) = CLMC45_pf2(n) / 100. - CLMC45_sf1(n) = CLMC45_sf1(n) / 100. - CLMC45_sf2(n) = CLMC45_sf2(n) / 100. - - fvg(1) = CLMC45_pf1(n) - fvg(2) = CLMC45_pf2(n) - fvg(3) = CLMC45_sf1(n) - fvg(4) = CLMC45_sf2(n) - - BARE = 1. - - DO NV = 1, NVEG - BARE = BARE - FVG(NV)! subtract vegetated fractions - END DO - - if (BARE /= 0.) THEN - IB = MAXLOC(FVG(:),1) - FVG (IB) = FVG(IB) + BARE ! This also corrects all cases sum ne 0. - ENDIF - - CLMC45_pf1(n) = fvg(1) - CLMC45_pf2(n) = fvg(2) - CLMC45_sf1(n) = fvg(3) - CLMC45_sf2(n) = fvg(4) - endif - endif - enddo - - if( isCatchCN) then - - NDEP = NDEP * 1.e-9 - - ! prevent trivial fractions - ! ------------------------- - do n = 1,ntiles - if(CLMC_pf1(n) <= 1.e-4) then - CLMC_pf2(n) = CLMC_pf2(n) + CLMC_pf1(n) - CLMC_pf1(n) = 0. - endif - - if(CLMC_pf2(n) <= 1.e-4) then - CLMC_pf1(n) = CLMC_pf1(n) + CLMC_pf2(n) - CLMC_pf2(n) = 0. - endif - - if(CLMC_sf1(n) <= 1.e-4) then - if(CLMC_sf2(n) > 1.e-4) then - CLMC_sf2(n) = CLMC_sf2(n) + CLMC_sf1(n) - else if(CLMC_pf2(n) > 1.e-4) then - CLMC_pf2(n) = CLMC_pf2(n) + CLMC_sf1(n) - else if(CLMC_pf1(n) > 1.e-4) then - CLMC_pf1(n) = CLMC_pf1(n) + CLMC_sf1(n) - else - stop 'fveg3' - endif - CLMC_sf1(n) = 0. - endif - - if(CLMC_sf2(n) <= 1.e-4) then - if(CLMC_sf1(n) > 1.e-4) then - CLMC_sf1(n) = CLMC_sf1(n) + CLMC_sf2(n) - else if(CLMC_pf2(n) > 1.e-4) then - CLMC_pf2(n) = CLMC_pf2(n) + CLMC_sf2(n) - else if(CLMC_pf1(n) > 1.e-4) then - CLMC_pf1(n) = CLMC_pf1(n) + CLMC_sf2(n) - else - stop 'fveg4' - endif - CLMC_sf2(n) = 0. - endif - - if (clm45) then - ! CLM45 - if(CLMC45_pf1(n) <= 1.e-4) then - CLMC45_pf2(n) = CLMC45_pf2(n) + CLMC45_pf1(n) - CLMC45_pf1(n) = 0. - endif - - if(CLMC45_pf2(n) <= 1.e-4) then - CLMC45_pf1(n) = CLMC45_pf1(n) + CLMC45_pf2(n) - CLMC45_pf2(n) = 0. - endif - - if(CLMC45_sf1(n) <= 1.e-4) then - if(CLMC45_sf2(n) > 1.e-4) then - CLMC45_sf2(n) = CLMC45_sf2(n) + CLMC45_sf1(n) - else if(CLMC45_pf2(n) > 1.e-4) then - CLMC45_pf2(n) = CLMC45_pf2(n) + CLMC45_sf1(n) - else if(CLMC45_pf1(n) > 1.e-4) then - CLMC45_pf1(n) = CLMC45_pf1(n) + CLMC45_sf1(n) - else - stop 'fveg3' - endif - CLMC45_sf1(n) = 0. - endif - - if(CLMC45_sf2(n) <= 1.e-4) then - if(CLMC45_sf1(n) > 1.e-4) then - CLMC45_sf1(n) = CLMC45_sf1(n) + CLMC45_sf2(n) - else if(CLMC45_pf2(n) > 1.e-4) then - CLMC45_pf2(n) = CLMC45_pf2(n) + CLMC45_sf2(n) - else if(CLMC45_pf1(n) > 1.e-4) then - CLMC45_pf1(n) = CLMC45_pf1(n) + CLMC45_sf2(n) - else - stop 'fveg4' - endif - CLMC45_sf2(n) = 0. - endif - endif - end do - endif - - - ! Vegdyn Boundary Condition - ! ------------------------- - - ! open(20,file=trim("vegdyn_internal_rst"), & - ! status="unknown", & - ! form="unformatted",convert="little_endian") - ! write(20) real(ity) - ! if(NewLand) write(20) CanopH - ! close(20) - ! print *, "Wrote vegdyn_internal_restart" - - ! Now writing BCs (from BCSDIR) and regridded hydrological variables 1-72 - ! ----------------------------------------------------------------------- - - STATUS = NF_OPEN (trim(InRestart),NF_WRITE,NCFID) ; VERIFY_(STATUS) - STATUS = NF_PUT_VARA_REAL(NCFID,VarID(NCFID,'BF1'), (/1/), (/NTILES/),BF1) - STATUS = NF_PUT_VARA_REAL(NCFID,VarID(NCFID,'BF2'), (/1/), (/NTILES/),BF2) - STATUS = NF_PUT_VARA_REAL(NCFID,VarID(NCFID,'BF3'), (/1/), (/NTILES/),BF3) - STATUS = NF_PUT_VARA_REAL(NCFID,VarID(NCFID,'VGWMAX'), (/1/), (/NTILES/),VGWMAX) - STATUS = NF_PUT_VARA_REAL(NCFID,VarID(NCFID,'CDCR1'), (/1/), (/NTILES/),CDCR1) - STATUS = NF_PUT_VARA_REAL(NCFID,VarID(NCFID,'CDCR2'), (/1/), (/NTILES/),CDCR2) - STATUS = NF_PUT_VARA_REAL(NCFID,VarID(NCFID,'PSIS'), (/1/), (/NTILES/),PSIS) - STATUS = NF_PUT_VARA_REAL(NCFID,VarID(NCFID,'BEE'), (/1/), (/NTILES/),BEE) - STATUS = NF_PUT_VARA_REAL(NCFID,VarID(NCFID,'POROS'), (/1/), (/NTILES/),POROS) - STATUS = NF_PUT_VARA_REAL(NCFID,VarID(NCFID,'WPWET'), (/1/), (/NTILES/),WPWET) - STATUS = NF_PUT_VARA_REAL(NCFID,VarID(NCFID,'COND'), (/1/), (/NTILES/),COND) - STATUS = NF_PUT_VARA_REAL(NCFID,VarID(NCFID,'GNU'), (/1/), (/NTILES/),GNU) - STATUS = NF_PUT_VARA_REAL(NCFID,VarID(NCFID,'ARS1'), (/1/), (/NTILES/),ARS1) - STATUS = NF_PUT_VARA_REAL(NCFID,VarID(NCFID,'ARS2'), (/1/), (/NTILES/),ARS2) - STATUS = NF_PUT_VARA_REAL(NCFID,VarID(NCFID,'ARS3'), (/1/), (/NTILES/),ARS3) - STATUS = NF_PUT_VARA_REAL(NCFID,VarID(NCFID,'ARA1'), (/1/), (/NTILES/),ARA1) - STATUS = NF_PUT_VARA_REAL(NCFID,VarID(NCFID,'ARA2'), (/1/), (/NTILES/),ARA2) - STATUS = NF_PUT_VARA_REAL(NCFID,VarID(NCFID,'ARA3'), (/1/), (/NTILES/),ARA3) - STATUS = NF_PUT_VARA_REAL(NCFID,VarID(NCFID,'ARA4'), (/1/), (/NTILES/),ARA4) - STATUS = NF_PUT_VARA_REAL(NCFID,VarID(NCFID,'ARW1'), (/1/), (/NTILES/),ARW1) - STATUS = NF_PUT_VARA_REAL(NCFID,VarID(NCFID,'ARW2'), (/1/), (/NTILES/),ARW2) - STATUS = NF_PUT_VARA_REAL(NCFID,VarID(NCFID,'ARW3'), (/1/), (/NTILES/),ARW3) - STATUS = NF_PUT_VARA_REAL(NCFID,VarID(NCFID,'ARW4'), (/1/), (/NTILES/),ARW4) - STATUS = NF_PUT_VARA_REAL(NCFID,VarID(NCFID,'TSA1'), (/1/), (/NTILES/),TSA1) - STATUS = NF_PUT_VARA_REAL(NCFID,VarID(NCFID,'TSA2'), (/1/), (/NTILES/),TSA2) - STATUS = NF_PUT_VARA_REAL(NCFID,VarID(NCFID,'TSB1'), (/1/), (/NTILES/),TSB1) - STATUS = NF_PUT_VARA_REAL(NCFID,VarID(NCFID,'TSB2'), (/1/), (/NTILES/),TSB2) - STATUS = NF_PUT_VARA_REAL(NCFID,VarID(NCFID,'ATAU'), (/1/), (/NTILES/),ATAU2) - STATUS = NF_PUT_VARA_REAL(NCFID,VarID(NCFID,'BTAU'), (/1/), (/NTILES/),BTAU2) - STATUS = NF_PUT_VARA_REAL(NCFID,VarID(NCFID,'TILE_ID'), (/1/), (/NTILES/),VAR1) - - if( isCatchCN ) then - - STATUS = NF_PUT_VARA_REAL(NCFID,VarID(NCFID,'ITY'), (/1,1/), (/NTILES,1/),CLMC_pt1) - STATUS = NF_PUT_VARA_REAL(NCFID,VarID(NCFID,'ITY'), (/1,2/), (/NTILES,1/),CLMC_pt2) - STATUS = NF_PUT_VARA_REAL(NCFID,VarID(NCFID,'ITY'), (/1,3/), (/NTILES,1/),CLMC_st1) - STATUS = NF_PUT_VARA_REAL(NCFID,VarID(NCFID,'ITY'), (/1,4/), (/NTILES,1/),CLMC_st2) - - STATUS = NF_PUT_VARA_REAL(NCFID,VarID(NCFID,'FVG'), (/1,1/), (/NTILES,1/),CLMC_pf1) - STATUS = NF_PUT_VARA_REAL(NCFID,VarID(NCFID,'FVG'), (/1,2/), (/NTILES,1/),CLMC_pf2) - STATUS = NF_PUT_VARA_REAL(NCFID,VarID(NCFID,'FVG'), (/1,3/), (/NTILES,1/),CLMC_sf1) - STATUS = NF_PUT_VARA_REAL(NCFID,VarID(NCFID,'FVG'), (/1,4/), (/NTILES,1/),CLMC_sf2) - - - STATUS = NF_PUT_VARA_REAL(NCFID,VarID(NCFID,'NDEP' ), (/1/), (/NTILES/),NDEP) - STATUS = NF_PUT_VARA_REAL(NCFID,VarID(NCFID,'CLI_T2M'), (/1/), (/NTILES/),T2) - STATUS = NF_PUT_VARA_REAL(NCFID,VarID(NCFID,'BGALBVR'), (/1/), (/NTILES/),BVISDR) - STATUS = NF_PUT_VARA_REAL(NCFID,VarID(NCFID,'BGALBVF'), (/1/), (/NTILES/),BVISDF) - STATUS = NF_PUT_VARA_REAL(NCFID,VarID(NCFID,'BGALBNR'), (/1/), (/NTILES/),BNIRDR) - STATUS = NF_PUT_VARA_REAL(NCFID,VarID(NCFID,'BGALBNF'), (/1/), (/NTILES/),BNIRDF) - - if(CLM45) then - - STATUS = NF_PUT_VARA_REAL(NCFID,VarID(NCFID,'ABM' ), (/1/), (/NTILES/),real(ABM)) - STATUS = NF_PUT_VARA_REAL(NCFID,VarID(NCFID,'FIELDCAP'), (/1/), (/NTILES/),FC) - STATUS = NF_PUT_VARA_REAL(NCFID,VarID(NCFID,'HDM' ), (/1/), (/NTILES/),HDM) - STATUS = NF_PUT_VARA_REAL(NCFID,VarID(NCFID,'GDP' ), (/1/), (/NTILES/),GDP) - STATUS = NF_PUT_VARA_REAL(NCFID,VarID(NCFID,'PEATF' ), (/1/), (/NTILES/),PEATF) - endif - - else - STATUS = NF_PUT_VARA_REAL(NCFID,VarID(NCFID,'OLD_ITY'), (/1/), (/NTILES/),real(ITY)) - endif - - STATUS = NF_CLOSE ( NCFID) - - deallocate ( BF1, BF2, BF3 ) - deallocate (VGWMAX, CDCR1, CDCR2 ) - deallocate ( PSIS, BEE, POROS ) - deallocate ( WPWET, COND, GNU ) - deallocate ( ARS1, ARS2, ARS3 ) - deallocate ( ARA1, ARA2, ARA3 ) - deallocate ( ARA4, ARW1, ARW2 ) - deallocate ( ARW3, ARW4, TSA1 ) - deallocate ( TSA2, TSB1, TSB2 ) - deallocate ( ATAU2, BTAU2, DP2BR ) - deallocate (BVISDR, BVISDF, BNIRDR ) - deallocate (BNIRDF, T2, NDEP ) - deallocate ( ity, CanopH) - deallocate (CLMC_pf1, CLMC_pf2, CLMC_sf1) - deallocate (CLMC_sf2, CLMC_pt1, CLMC_pt2) - deallocate (CLMC_st1,CLMC_st2) - if (present(rc)) rc =0 - !_RETURN(_SUCCESS) - END SUBROUTINE read_bcs_data - - ! ***************************************************************************** - - SUBROUTINE regrid_carbon_vars (NTILES, model) - - implicit none - - integer, intent (in) :: NTILES - character(*), intent (in) :: model - character*300 :: OutTileFile = 'InData/OutTileFile' - character*300 :: OutFileName - integer :: AGCM_YY=2015,AGCM_MM=1,AGCM_DD=1,AGCM_HR=0 - real, allocatable, dimension (:) :: CLMC_pf1, CLMC_pf2, CLMC_sf1, CLMC_sf2, & - CLMC_pt1, CLMC_pt2,CLMC_st1,CLMC_st2 - - ! =============================================================================================== - - integer, allocatable, dimension(:,:) :: Id_glb, Id_loc - integer, allocatable, dimension(:) :: tid_offl, id_vec - real, allocatable, dimension(:,:) :: fveg_offl, ityp_offl - integer :: n,i,j, k, offl_cell, STATUS,NCFID, req - integer :: outid, local_id, nv, nz, iv - real , allocatable, dimension (:) :: LATT, LONN, DAYX, TILE_ID, var_dum2 - real, allocatable :: var_off_col (:,:,:), var_off_pft (:,:,:,:) - integer, allocatable :: low_ind(:), upp_ind(:), nt_local (:) - real , pointer , dimension (:) :: long, latg, lonc, latc - character*256 :: Iam = "regrid_carbon_vars" - - OutFileName='OutData/'//trim(model)//'_internal_rst' - - allocate (tid_offl (ntiles_cn)) - allocate (ityp_offl (ntiles_cn,nveg)) - allocate (fveg_offl (ntiles_cn,nveg)) - - allocate(low_ind ( numprocs)) - allocate(upp_ind ( numprocs)) - allocate(nt_local( numprocs)) - - low_ind (:) = 1 - upp_ind (:) = NTILES - nt_local(:) = NTILES - - ! Domain decomposition - ! -------------------- - - if (numprocs > 1) then - do i = 1, numprocs - 1 - upp_ind(i) = low_ind(i) + (ntiles/numprocs) - 1 - low_ind(i+1) = upp_ind(i) + 1 - nt_local(i) = upp_ind(i) - low_ind(i) + 1 - end do - nt_local(numprocs) = upp_ind(numprocs) - low_ind(numprocs) + 1 - endif - - allocate (id_loc (nt_local (myid + 1),4)) - allocate (lonn (nt_local (myid + 1))) - allocate (latt (nt_local (myid + 1))) - allocate (CLMC_pf1(nt_local (myid + 1))) - allocate (CLMC_pf2(nt_local (myid + 1))) - allocate (CLMC_sf1(nt_local (myid + 1))) - allocate (CLMC_sf2(nt_local (myid + 1))) - allocate (CLMC_pt1(nt_local (myid + 1))) - allocate (CLMC_pt2(nt_local (myid + 1))) - allocate (CLMC_st1(nt_local (myid + 1))) - allocate (CLMC_st2(nt_local (myid + 1))) - allocate (lonc (1:ntiles_cn)) - allocate (latc (1:ntiles_cn)) - - if (root_proc) then - - ! -------------------------------------------- - ! Read exact lonn, latt from output .til file - ! -------------------------------------------- - - allocate (long (ntiles)) - allocate (latg (ntiles)) - allocate (DAYX (NTILES)) - - call ReadTileFile_RealLatLon (OutTileFile, i, xlon=long, xlat=latg); VERIFY_(i-ntiles) - - ! Compute DAYX - ! ------------ - - call compute_dayx ( & - NTILES, AGCM_YY, AGCM_MM, AGCM_DD, AGCM_HR, & - LATG, DAYX) - - ! --------------------------------------------- - ! Read exact lonc, latc from offline .til File - ! --------------------------------------------- - - call ReadTileFile_RealLatLon(trim(InCNTilFile),i,xlon=lonc,xlat=latc); VERIFY_(i-ntiles_cn) - - endif - -! call MPI_SCATTERV ( & -! long,nt_local,low_ind-1,MPI_real, & -! lonn,size(lonn),MPI_real , & -! 0,MPI_COMM_WORLD, mpierr ) - -! call MPI_SCATTERV ( & -! latg,nt_local,low_ind-1,MPI_real, & -! latt,nt_local(myid+1),MPI_real , & -! 0,MPI_COMM_WORLD, mpierr ) - - do i = 1, numprocs - if((I == 1).and.(myid == 0)) then - lonn(:) = long(low_ind(i) : upp_ind(i)) - latt(:) = latg(low_ind(i) : upp_ind(i)) - else if (I > 1) then - if(I-1 == myid) then - ! receiving from root - call MPI_RECV(lonn,nt_local(i) , MPI_REAL, 0,995,MPI_COMM_WORLD,MPI_STATUS_IGNORE,mpierr) - call MPI_RECV(latt,nt_local(i) , MPI_REAL, 0,994,MPI_COMM_WORLD,MPI_STATUS_IGNORE,mpierr) - else if (myid == 0) then - ! root sends - call MPI_ISend(long(low_ind(i) : upp_ind(i)),nt_local(i),MPI_REAL,i-1,995,MPI_COMM_WORLD,req,mpierr) - call MPI_WAIT (req,MPI_STATUS_IGNORE,mpierr) - call MPI_ISend(latg(low_ind(i) : upp_ind(i)),nt_local(i),MPI_REAL,i-1,994,MPI_COMM_WORLD,req,mpierr) - call MPI_WAIT (req,MPI_STATUS_IGNORE,mpierr) - endif - endif - end do - - - if(root_proc) deallocate (long, latg) - - call MPI_BCAST(lonc,ntiles_cn,MPI_REAL,0,MPI_COMM_WORLD,mpierr) - call MPI_BCAST(latc,ntiles_cn,MPI_REAL,0,MPI_COMM_WORLD,mpierr) - - ! Open GKW/Fzeng SMAP M09 catchcn_internal_rst and output catchcn_internal_rst - ! ---------------------------------------------------------------------------- - - STATUS = NF_OPEN_PAR (trim(OutFileName),IOR(NF_WRITE ,NF_MPIIO),MPI_COMM_WORLD, infos,OUTID) - IF (STATUS .NE. NF_NOERR) CALL HANDLE_ERR(STATUS, 'OUTPUT RESTART FAILED') - - STATUS = NF_GET_VARA_REAL(OUTID,VarID(OUTID,'ITY'), (/low_ind(myid+1),1/), (/nt_local(myid+1),1/),CLMC_pt1) - STATUS = NF_GET_VARA_REAL(OUTID,VarID(OUTID,'ITY'), (/low_ind(myid+1),2/), (/nt_local(myid+1),1/),CLMC_pt2) - STATUS = NF_GET_VARA_REAL(OUTID,VarID(OUTID,'ITY'), (/low_ind(myid+1),3/), (/nt_local(myid+1),1/),CLMC_st1) - STATUS = NF_GET_VARA_REAL(OUTID,VarID(OUTID,'ITY'), (/low_ind(myid+1),4/), (/nt_local(myid+1),1/),CLMC_st2) - STATUS = NF_GET_VARA_REAL(OUTID,VarID(OUTID,'FVG'), (/low_ind(myid+1),1/), (/nt_local(myid+1),1/),CLMC_pf1) - STATUS = NF_GET_VARA_REAL(OUTID,VarID(OUTID,'FVG'), (/low_ind(myid+1),2/), (/nt_local(myid+1),1/),CLMC_pf2) - STATUS = NF_GET_VARA_REAL(OUTID,VarID(OUTID,'FVG'), (/low_ind(myid+1),3/), (/nt_local(myid+1),1/),CLMC_sf1) - STATUS = NF_GET_VARA_REAL(OUTID,VarID(OUTID,'FVG'), (/low_ind(myid+1),4/), (/nt_local(myid+1),1/),CLMC_sf2) - - if (root_proc) then - STATUS = NF_OPEN (trim(InCNRestart),NF_NOWRITE,NCFID) - allocate (TILE_ID (1:ntiles_cn)) - - STATUS = NF_GET_VARA_REAL(NCFID,VarID(NCFID,'TILE_ID' ), (/1/), (/NTILES_CN/),TILE_ID) - - do n = 1,ntiles_cn - - K = NINT (TILE_ID (n)) - - STATUS = NF_GET_VARA_REAL(NCFID,VarID(NCFID,'ITY'), (/n,1/), (/1,4/),ityp_offl(K,:)) - STATUS = NF_GET_VARA_REAL(NCFID,VarID(NCFID,'FVG'), (/n,1/), (/1,4/),fveg_offl(K,:)) - - tid_offl (n) = n - - do nv = 1,nveg - if(ityp_offl(K,nv)<0 .or. ityp_offl(K,nv)>npft) stop 'ityp' - if(fveg_offl(K,nv)<0..or. fveg_offl(K,nv)>1.00001) stop 'fveg' - end do - - if((ityp_offl(K,3) == 0).and.(ityp_offl(K,4) == 0)) then - if(ityp_offl(K,1) /= 0) then - ityp_offl(K,3) = ityp_offl(K,1) - else - ityp_offl(K,3) = ityp_offl(K,2) - endif - endif - - if((ityp_offl(K,1) == 0).and.(ityp_offl(K,2) /= 0)) ityp_offl(K,1) = ityp_offl(K,2) - if((ityp_offl(K,2) == 0).and.(ityp_offl(K,1) /= 0)) ityp_offl(K,2) = ityp_offl(K,1) - if((ityp_offl(K,3) == 0).and.(ityp_offl(K,4) /= 0)) ityp_offl(K,3) = ityp_offl(K,4) - if((ityp_offl(K,4) == 0).and.(ityp_offl(K,3) /= 0)) ityp_offl(K,4) = ityp_offl(K,3) - - end do - - endif - - call MPI_BCAST(tid_offl ,size(tid_offl ),MPI_INTEGER,0,MPI_COMM_WORLD,mpierr) - call MPI_BCAST(ityp_offl,size(ityp_offl),MPI_REAL ,0,MPI_COMM_WORLD,mpierr) - call MPI_BCAST(fveg_offl,size(fveg_offl),MPI_REAL ,0,MPI_COMM_WORLD,mpierr) - - ! -------------------------------------------------------------------------------- - ! Here we create transfer index array to map offline restarts to output tile space - ! -------------------------------------------------------------------------------- - - call GetIds(lonc,latc,lonn,latt,id_loc, tid_offl, & - CLMC_pf1, CLMC_pf2, CLMC_sf1, CLMC_sf2, CLMC_pt1, CLMC_pt2,CLMC_st1,CLMC_st2, & - fveg_offl, ityp_offl) - - ! update id_glb in root - - if(root_proc) then - allocate (id_glb (ntiles, nveg)) - allocate (id_vec (ntiles)) - endif - - do nv = 1, nveg - call MPI_Barrier(MPI_COMM_WORLD, STATUS) - ! call MPI_GATHERV( & - ! id_loc (:,nv), nt_local(myid+1) , MPI_real, & - ! id_vec, nt_local,low_ind-1, MPI_real, & - ! 0, MPI_COMM_WORLD, mpierr ) - - do i = 1, numprocs - if((I == 1).and.(myid == 0)) then - id_vec(low_ind(i) : upp_ind(i)) = Id_loc(:,nv) - else if (I > 1) then - if(I-1 == myid) then - ! send to root - call MPI_ISend(id_loc(:,nv),nt_local(i),MPI_INTEGER,0,993,MPI_COMM_WORLD,req,mpierr) - call MPI_WAIT (req,MPI_STATUS_IGNORE,mpierr) - else if (myid == 0) then - ! root receives - call MPI_RECV(id_vec(low_ind(i) : upp_ind(i)),nt_local(i) , MPI_INTEGER, i-1,993,MPI_COMM_WORLD,MPI_STATUS_IGNORE,mpierr) - endif - endif - end do - - if(root_proc) id_glb (:,nv) = id_vec - - end do - - if(root_proc) then - - allocate (var_off_col (1: NTILES_CN, 1 : nzone,1 : var_col)) - allocate (var_off_pft (1: NTILES_CN, 1 : nzone,1 : nveg, 1 : var_pft)) - allocate (var_dum2 (1:ntiles_cn)) - i = 1 - do nv = 1,VAR_COL - do nz = 1,nzone - STATUS = NF_GET_VARA_REAL(NCFID,VarID(NCFID,'CNCOL'), (/1,i/), (/NTILES_CN,1 /),VAR_DUM2) - do k = 1, NTILES_CN - var_off_col(TILE_ID(K), nz,nv) = VAR_DUM2(K) - end do - i = i + 1 - end do - end do - - i = 1 - do iv = 1,VAR_PFT - do nv = 1,nveg - do nz = 1,nzone - STATUS = NF_GET_VARA_REAL(NCFID,VarID(NCFID,'CNPFT'), (/1,i/), (/NTILES_CN,1 /),VAR_DUM2) - do k = 1, NTILES_CN - var_off_pft(TILE_ID(K), nz,nv,iv) = VAR_DUM2(K) - end do - i = i + 1 - end do - end do - end do - - where(isnan(var_off_pft)) var_off_pft = 0. - where(var_off_pft /= var_off_pft) var_off_pft = 0. - - call write_regridded_carbon (NTILES, ntiles_cn, NCFID, OUTID, id_glb, & - DAYX, var_off_col, var_off_pft, ityp_offl, fveg_offl) - deallocate (var_off_col,var_off_pft) - endif - - call MPI_Barrier(MPI_COMM_WORLD, STATUS) - - END SUBROUTINE regrid_carbon_vars - -! --------------------------------------------------------------------------------------------------------- - - SUBROUTINE write_regridded_carbon (NTILES, ntiles_rst, NCFID, OUTID, id_glb, & - DAYX, var_off_col, var_off_pft, ityp_offl, fveg_offl) - - ! write out regridded carbon variables - implicit none - integer, intent (in) :: NTILES, ntiles_rst,NCFID, OUTID, id_glb (ntiles,nveg) - real, intent (in) :: DAYX (NTILES), var_off_col(NTILES_RST,NZONE,var_col), var_off_pft(NTILES_RST,NZONE, NVEG, var_pft) - real, intent (in), dimension(ntiles_rst,nveg) :: fveg_offl, ityp_offl - real, allocatable, dimension (:) :: CLMC_pf1, CLMC_pf2, CLMC_sf1, CLMC_sf2, & - CLMC_pt1, CLMC_pt2,CLMC_st1,CLMC_st2, var_dum - real, allocatable :: var_col_out (:,:,:), var_pft_out (:,:,:,:) - integer :: N, STATUS, nv, nx, offl_cell, ityp_new, i, j, nz, iv - real :: fveg_new - character(256) :: Iam = "write_regridded_carbon" - - - allocate (CLMC_pf1(NTILES)) - allocate (CLMC_pf2(NTILES)) - allocate (CLMC_sf1(NTILES)) - allocate (CLMC_sf2(NTILES)) - allocate (CLMC_pt1(NTILES)) - allocate (CLMC_pt2(NTILES)) - allocate (CLMC_st1(NTILES)) - allocate (CLMC_st2(NTILES)) - allocate (VAR_DUM (NTILES)) - - STATUS = NF_GET_VARA_REAL(OUTID,VarID(OUTID,'ITY'), (/1,1/), (/NTILES,1/),CLMC_pt1) ; VERIFY_(STATUS) - STATUS = NF_GET_VARA_REAL(OUTID,VarID(OUTID,'ITY'), (/1,2/), (/NTILES,1/),CLMC_pt2) ; VERIFY_(STATUS) - STATUS = NF_GET_VARA_REAL(OUTID,VarID(OUTID,'ITY'), (/1,3/), (/NTILES,1/),CLMC_st1) ; VERIFY_(STATUS) - STATUS = NF_GET_VARA_REAL(OUTID,VarID(OUTID,'ITY'), (/1,4/), (/NTILES,1/),CLMC_st2) ; VERIFY_(STATUS) - STATUS = NF_GET_VARA_REAL(OUTID,VarID(OUTID,'FVG'), (/1,1/), (/NTILES,1/),CLMC_pf1) ; VERIFY_(STATUS) - STATUS = NF_GET_VARA_REAL(OUTID,VarID(OUTID,'FVG'), (/1,2/), (/NTILES,1/),CLMC_pf2) ; VERIFY_(STATUS) - STATUS = NF_GET_VARA_REAL(OUTID,VarID(OUTID,'FVG'), (/1,3/), (/NTILES,1/),CLMC_sf1) ; VERIFY_(STATUS) - STATUS = NF_GET_VARA_REAL(OUTID,VarID(OUTID,'FVG'), (/1,4/), (/NTILES,1/),CLMC_sf2) ; VERIFY_(STATUS) - - allocate (var_col_out (1: NTILES, 1 : nzone,1 : var_col)) - allocate (var_pft_out (1: NTILES, 1 : nzone,1 : nveg, 1 : var_pft)) - - var_col_out = 0. - var_pft_out = NaN - - OUT_TILE : DO N = 1, NTILES - - ! if(mod (n,1000) == 0) print *, myid +1, n, Id_glb(n,:) - - NVLOOP2 : do nv = 1, nveg - - if(nv <= 2) then ! index for secondary PFT index if primary or primary if secondary - nx = nv + 2 - else - nx = nv - 2 - endif - - if (nv == 1) ityp_new = CLMC_pt1(n) - if (nv == 1) fveg_new = CLMC_pf1(n) - if (nv == 2) ityp_new = CLMC_pt2(n) - if (nv == 2) fveg_new = CLMC_pf2(n) - if (nv == 3) ityp_new = CLMC_st1(n) - if (nv == 3) fveg_new = CLMC_sf1(n) - if (nv == 4) ityp_new = CLMC_st2(n) - if (nv == 4) fveg_new = CLMC_sf2(n) - - if (fveg_new > fmin) then - - offl_cell = Id_glb(n,nv) - - if(ityp_new == ityp_offl (offl_cell,nv) .and. fveg_offl (offl_cell,nv)> fmin) then - iv = nv ! same type fraction (primary of secondary) - else if(ityp_new == ityp_offl (offl_cell,nx) .and. fveg_offl (offl_cell,nx)> fmin) then - iv = nx ! not same fraction - else if(iclass(ityp_new)==iclass(ityp_offl(offl_cell,nv)) .and. fveg_offl (offl_cell,nv)> fmin) then - iv = nv ! primary, other type (same class) - else if(fveg_offl (offl_cell,nx)> fmin) then - iv = nx ! secondary, other type (same class) - endif - - ! Get col and pft variables for the Id_glb(nv) grid cell from offline catchcn_internal_rst - ! ---------------------------------------------------------------------------------------- - - ! call NCDF_reshape_getOput (NCFID,Id_glb(n,nv),var_off_col,var_off_pft,.true.) - - var_pft_out (n,:,nv,:) = var_off_pft(Id_glb(n,nv), :,iv,:) - var_col_out (n,:,:) = var_col_out(n,:,:) + fveg_new * var_off_col(Id_glb(n,nv), :,:) ! gkw: column state simple weighted mean; ! could use "woody" fraction? - - ! Check whether var_pft_out is realistic - do nz = 1, nzone - do j = 1, VAR_PFT - if (isnan(var_pft_out (n, nz,nv,j))) print *,j,nv,nz,n,var_pft_out (n, nz,nv,j),fveg_new - !if(isnan(var_pft_out (n, nz,nv,69))) var_pft_out (n, nz,nv,69) = 1.e-6 - !if(isnan(var_pft_out (n, nz,nv,70))) var_pft_out (n, nz,nv,70) = 1.e-6 - !if(isnan(var_pft_out (n, nz,nv,73))) var_pft_out (n, nz,nv,73) = 1.e-6 - !if(isnan(var_pft_out (n, nz,nv,74))) var_pft_out (n, nz,nv,74) = 1.e-6 - end do - end do - endif - - end do NVLOOP2 - - ! reset carbon if negative < 10g - ! ------------------------ - - NZLOOP : do nz = 1, nzone - - if(var_col_out (n, nz,14) < 10.) then - - var_col_out(n, nz, 1) = max(var_col_out(n, nz, 1), 0.) - var_col_out(n, nz, 2) = max(var_col_out(n, nz, 2), 0.) - var_col_out(n, nz, 3) = max(var_col_out(n, nz, 3), 0.) - var_col_out(n, nz, 4) = max(var_col_out(n, nz, 4), 0.) - var_col_out(n, nz, 5) = max(var_col_out(n, nz, 5), 0.) - var_col_out(n, nz,10) = max(var_col_out(n, nz,10), 0.) - var_col_out(n, nz,11) = max(var_col_out(n, nz,11), 0.) - var_col_out(n, nz,12) = max(var_col_out(n, nz,12), 0.) - var_col_out(n, nz,13) = max(var_col_out(n, nz,13),10.) ! soil4c - var_col_out(n, nz,14) = max(var_col_out(n, nz,14), 0.) - var_col_out(n, nz,15) = max(var_col_out(n, nz,15), 0.) - var_col_out(n, nz,16) = max(var_col_out(n, nz,16), 0.) - var_col_out(n, nz,17) = max(var_col_out(n, nz,17), 0.) - var_col_out(n, nz,18) = max(var_col_out(n, nz,18), 0.) - var_col_out(n, nz,19) = max(var_col_out(n, nz,19), 0.) - var_col_out(n, nz,20) = max(var_col_out(n, nz,20), 0.) - var_col_out(n, nz,24) = max(var_col_out(n, nz,24), 0.) - var_col_out(n, nz,25) = max(var_col_out(n, nz,25), 0.) - var_col_out(n, nz,26) = max(var_col_out(n, nz,26), 0.) - var_col_out(n, nz,27) = max(var_col_out(n, nz,27), 0.) - var_col_out(n, nz,28) = max(var_col_out(n, nz,28), 1.) - var_col_out(n, nz,29) = max(var_col_out(n, nz,29), 0.) - - NVLOOP3 : do nv = 1,nveg - - if (nv == 1) ityp_new = CLMC_pt1(n) - if (nv == 1) fveg_new = CLMC_pf1(n) - if (nv == 2) ityp_new = CLMC_pt2(n) - if (nv == 2) fveg_new = CLMC_pf2(n) - if (nv == 3) ityp_new = CLMC_st1(n) - if (nv == 3) fveg_new = CLMC_sf1(n) - if (nv == 4) ityp_new = CLMC_st2(n) - if (nv == 4) fveg_new = CLMC_sf2(n) - - if(fveg_new > fmin) then - var_pft_out(n, nz,nv, 1) = max(var_pft_out(n, nz,nv, 1),0.) - var_pft_out(n, nz,nv, 2) = max(var_pft_out(n, nz,nv, 2),0.) - var_pft_out(n, nz,nv, 3) = max(var_pft_out(n, nz,nv, 3),0.) - var_pft_out(n, nz,nv, 4) = max(var_pft_out(n, nz,nv, 4),0.) - - if(ityp_new <= 12) then ! tree or shrub deadstemc - var_pft_out(n, nz,nv, 5) = max(var_pft_out(n, nz,nv, 5),0.1) - else - var_pft_out(n, nz,nv, 5) = max(var_pft_out(n, nz,nv, 5),0.0) - endif - - var_pft_out(n, nz,nv, 6) = max(var_pft_out(n, nz,nv, 6),0.) - var_pft_out(n, nz,nv, 7) = max(var_pft_out(n, nz,nv, 7),0.) - var_pft_out(n, nz,nv, 8) = max(var_pft_out(n, nz,nv, 8),0.) - var_pft_out(n, nz,nv, 9) = max(var_pft_out(n, nz,nv, 9),0.) - var_pft_out(n, nz,nv,10) = max(var_pft_out(n, nz,nv,10),0.) - var_pft_out(n, nz,nv,11) = max(var_pft_out(n, nz,nv,11),0.) - var_pft_out(n, nz,nv,12) = max(var_pft_out(n, nz,nv,12),0.) - - if(ityp_new <=2 .or. ityp_new ==4 .or. ityp_new ==5 .or. ityp_new == 9) then - var_pft_out(n, nz,nv,13) = max(var_pft_out(n, nz,nv,13),1.) ! leaf carbon display for evergreen - var_pft_out(n, nz,nv,14) = max(var_pft_out(n, nz,nv,14),0.) - else - var_pft_out(n, nz,nv,13) = max(var_pft_out(n, nz,nv,13),0.) - var_pft_out(n, nz,nv,14) = max(var_pft_out(n, nz,nv,14),1.) ! leaf carbon storage for deciduous - endif - - var_pft_out(n, nz,nv,15) = max(var_pft_out(n, nz,nv,15),0.) - var_pft_out(n, nz,nv,16) = max(var_pft_out(n, nz,nv,16),0.) - var_pft_out(n, nz,nv,17) = max(var_pft_out(n, nz,nv,17),0.) - var_pft_out(n, nz,nv,18) = max(var_pft_out(n, nz,nv,18),0.) - var_pft_out(n, nz,nv,19) = max(var_pft_out(n, nz,nv,19),0.) - var_pft_out(n, nz,nv,20) = max(var_pft_out(n, nz,nv,20),0.) - var_pft_out(n, nz,nv,21) = max(var_pft_out(n, nz,nv,21),0.) - var_pft_out(n, nz,nv,22) = max(var_pft_out(n, nz,nv,22),0.) - var_pft_out(n, nz,nv,23) = max(var_pft_out(n, nz,nv,23),0.) - var_pft_out(n, nz,nv,25) = max(var_pft_out(n, nz,nv,25),0.) - var_pft_out(n, nz,nv,26) = max(var_pft_out(n, nz,nv,26),0.) - var_pft_out(n, nz,nv,27) = max(var_pft_out(n, nz,nv,27),0.) - var_pft_out(n, nz,nv,41) = max(var_pft_out(n, nz,nv,41),0.) - var_pft_out(n, nz,nv,42) = max(var_pft_out(n, nz,nv,42),0.) - var_pft_out(n, nz,nv,44) = max(var_pft_out(n, nz,nv,44),0.) - var_pft_out(n, nz,nv,45) = max(var_pft_out(n, nz,nv,45),0.) - var_pft_out(n, nz,nv,46) = max(var_pft_out(n, nz,nv,46),0.) - var_pft_out(n, nz,nv,47) = max(var_pft_out(n, nz,nv,47),0.) - var_pft_out(n, nz,nv,48) = max(var_pft_out(n, nz,nv,48),0.) - var_pft_out(n, nz,nv,49) = max(var_pft_out(n, nz,nv,49),0.) - var_pft_out(n, nz,nv,50) = max(var_pft_out(n, nz,nv,50),0.) - var_pft_out(n, nz,nv,51) = max(var_pft_out(n, nz,nv, 5)/500.,0.) - var_pft_out(n, nz,nv,52) = max(var_pft_out(n, nz,nv,52),0.) - var_pft_out(n, nz,nv,53) = max(var_pft_out(n, nz,nv,53),0.) - var_pft_out(n, nz,nv,54) = max(var_pft_out(n, nz,nv,54),0.) - var_pft_out(n, nz,nv,55) = max(var_pft_out(n, nz,nv,55),0.) - var_pft_out(n, nz,nv,56) = max(var_pft_out(n, nz,nv,56),0.) - var_pft_out(n, nz,nv,57) = max(var_pft_out(n, nz,nv,13)/25.,0.) - var_pft_out(n, nz,nv,58) = max(var_pft_out(n, nz,nv,14)/25.,0.) - var_pft_out(n, nz,nv,59) = max(var_pft_out(n, nz,nv,59),0.) - var_pft_out(n, nz,nv,60) = max(var_pft_out(n, nz,nv,60),0.) - var_pft_out(n, nz,nv,61) = max(var_pft_out(n, nz,nv,61),0.) - var_pft_out(n, nz,nv,62) = max(var_pft_out(n, nz,nv,62),0.) - var_pft_out(n, nz,nv,63) = max(var_pft_out(n, nz,nv,63),0.) - var_pft_out(n, nz,nv,64) = max(var_pft_out(n, nz,nv,64),0.) - var_pft_out(n, nz,nv,65) = max(var_pft_out(n, nz,nv,65),0.) - var_pft_out(n, nz,nv,66) = max(var_pft_out(n, nz,nv,66),0.) - var_pft_out(n, nz,nv,67) = max(var_pft_out(n, nz,nv,67),0.) - var_pft_out(n, nz,nv,68) = max(var_pft_out(n, nz,nv,68),0.) - var_pft_out(n, nz,nv,69) = max(var_pft_out(n, nz,nv,69),0.) - var_pft_out(n, nz,nv,70) = max(var_pft_out(n, nz,nv,70),0.) - var_pft_out(n, nz,nv,73) = max(var_pft_out(n, nz,nv,73),0.) - var_pft_out(n, nz,nv,74) = max(var_pft_out(n, nz,nv,74),0.) - if(clm45) var_pft_out(n, nz,nv,75) = max(var_pft_out(n, nz,nv,75),0.) - endif - end do NVLOOP3 ! end veg loop - endif ! end carbon check - end do NZLOOP ! end zone loop - - ! Update dayx variable var_pft_out (:,:,28) - - do j = 28, 28 ! 1,VAR_PFT var_pft_out (:,:,:,28) - do nv = 1,nveg - do nz = 1,nzone - var_pft_out (n, nz,nv,j) = dayx(n) - end do - end do - end do - - ! call NCDF_reshape_getOput (OutID,N,var_col_out,var_pft_out,.false.) - - ! column vars clm40 clm45 - ! ----------------- --------------------- - ! 1 clm3%g%l%c%ccs%col_ctrunc ! 1 ccs%col_ctrunc_vr (:,1) - ! 2 clm3%g%l%c%ccs%cwdc ! 2 ccs%decomp_cpools_vr(:,1,4) ! cwdc - ! 3 clm3%g%l%c%ccs%litr1c ! 3 ccs%decomp_cpools_vr(:,1,1) ! litr1c - ! 4 clm3%g%l%c%ccs%litr2c ! 4 ccs%decomp_cpools_vr(:,1,2) ! litr2c - ! 5 clm3%g%l%c%ccs%litr3c ! 5 ccs%decomp_cpools_vr(:,1,3) ! litr3c - ! 6 clm3%g%l%c%ccs%pcs_a%totvegc ! 6 ccs%totvegc_col - ! 7 clm3%g%l%c%ccs%prod100c ! 7 ccs%prod100c - ! 8 clm3%g%l%c%ccs%prod10c ! 8 ccs%prod10c - ! 9 clm3%g%l%c%ccs%seedc ! 9 ccs%seedc - ! 10 clm3%g%l%c%ccs%soil1c ! 10 ccs%decomp_cpools_vr(:,1,5) ! soil1c - ! 11 clm3%g%l%c%ccs%soil2c ! 11 ccs%decomp_cpools_vr(:,1,6) ! soil2c - ! 12 clm3%g%l%c%ccs%soil3c ! 12 ccs%decomp_cpools_vr(:,1,7) ! soil3c - ! 13 clm3%g%l%c%ccs%soil4c ! 13 ccs%decomp_cpools_vr(:,1,8) ! soil4c - ! 14 clm3%g%l%c%ccs%totcolc ! 14 ccs%totcolc - ! 15 clm3%g%l%c%ccs%totlitc ! 15 ccs%totlitc - ! 16 clm3%g%l%c%cns%col_ntrunc ! 16 cns%col_ntrunc_vr (:,1) - ! 17 clm3%g%l%c%cns%cwdn ! 17 cns%decomp_npools_vr(:,1,4) ! cwdn - ! 18 clm3%g%l%c%cns%litr1n ! 18 cns%decomp_npools_vr(:,1,1) ! litr1n - ! 19 clm3%g%l%c%cns%litr2n ! 19 cns%decomp_npools_vr(:,1,2) ! litr2n - ! 20 clm3%g%l%c%cns%litr3n ! 20 cns%decomp_npools_vr(:,1,3) ! litr3n - ! 21 clm3%g%l%c%cns%prod100n ! 21 cns%prod100n - ! 22 clm3%g%l%c%cns%prod10n ! 22 cns%prod10n - ! 23 clm3%g%l%c%cns%seedn ! 23 cns%seedn - ! 24 clm3%g%l%c%cns%sminn ! 24 cns%sminn_vr (:,1) - ! 25 clm3%g%l%c%cns%soil1n ! 25 cns%decomp_npools_vr(:,1,5) ! soil1n - ! 26 clm3%g%l%c%cns%soil2n ! 26 cns%decomp_npools_vr(:,1,6) ! soil2n - ! 27 clm3%g%l%c%cns%soil3n ! 27 cns%decomp_npools_vr(:,1,7) ! soil3n - ! 28 clm3%g%l%c%cns%soil4n ! 28 cns%decomp_npools_vr(:,1,8) ! soil4n - ! 29 clm3%g%l%c%cns%totcoln ! 29 cns%totcoln - ! 30 clm3%g%l%c%cps%ann_farea_burned ! 30 cps%fpg - ! 31 clm3%g%l%c%cps%annsum_counter ! 31 cps%annsum_counter - ! 32 clm3%g%l%c%cps%cannavg_t2m ! 32 cps%cannavg_t2m - ! 33 clm3%g%l%c%cps%cannsum_npp ! 33 cps%cannsum_npp - ! 34 clm3%g%l%c%cps%farea_burned ! 34 cps%farea_burned - ! 35 clm3%g%l%c%cps%fire_prob ! 35 cps%fpi_vr (:,1) - ! 36 clm3%g%l%c%cps%fireseasonl ! OLD ! 30 cps%altmax - ! 37 clm3%g%l%c%cps%fpg ! OLD ! 31 cps%annsum_counter - ! 38 clm3%g%l%c%cps%fpi ! OLD ! 32 cps%cannavg_t2m - ! 39 clm3%g%l%c%cps%me ! OLD ! 33 cps%cannsum_npp - ! 40 clm3%g%l%c%cps%mean_fire_prob ! OLD ! 34 cps%farea_burned - ! OLD ! 35 cps%altmax_lastyear - ! OLD ! 36 cps%altmax_indx - ! OLD ! 37 cps%fpg - ! OLD ! 38 cps%fpi_vr (:,1) - ! OLD ! 39 cps%altmax_lastyear_indx - - ! PFT vars CLM40 CLM45 - ! -------------- ----- - ! 1 clm3%g%l%c%p%pcs%cpool ! 1 pcs%cpool - ! 2 clm3%g%l%c%p%pcs%deadcrootc ! 2 pcs%deadcrootc - ! 3 clm3%g%l%c%p%pcs%deadcrootc_storage ! 3 pcs%deadcrootc_storage - ! 4 clm3%g%l%c%p%pcs%deadcrootc_xfer ! 4 pcs%deadcrootc_xfer - ! 5 clm3%g%l%c%p%pcs%deadstemc ! 5 pcs%deadstemc - ! 6 clm3%g%l%c%p%pcs%deadstemc_storage ! 6 pcs%deadstemc_storage - ! 7 clm3%g%l%c%p%pcs%deadstemc_xfer ! 7 pcs%deadstemc_xfer - ! 8 clm3%g%l%c%p%pcs%frootc ! 8 pcs%frootc - ! 9 clm3%g%l%c%p%pcs%frootc_storage ! 9 pcs%frootc_storage - ! 10 clm3%g%l%c%p%pcs%frootc_xfer ! 10 pcs%frootc_xfer - ! 11 clm3%g%l%c%p%pcs%gresp_storage ! 11 pcs%gresp_storage - ! 12 clm3%g%l%c%p%pcs%gresp_xfer ! 12 pcs%gresp_xfer - ! 13 clm3%g%l%c%p%pcs%leafc ! 13 pcs%leafc - ! 14 clm3%g%l%c%p%pcs%leafc_storage ! 14 pcs%leafc_storage - ! 15 clm3%g%l%c%p%pcs%leafc_xfer ! 15 pcs%leafc_xfer - ! 16 clm3%g%l%c%p%pcs%livecrootc ! 16 pcs%livecrootc - ! 17 clm3%g%l%c%p%pcs%livecrootc_storage ! 17 pcs%livecrootc_storage - ! 18 clm3%g%l%c%p%pcs%livecrootc_xfer ! 18 pcs%livecrootc_xfer - ! 19 clm3%g%l%c%p%pcs%livestemc ! 19 pcs%livestemc - ! 20 clm3%g%l%c%p%pcs%livestemc_storage ! 20 pcs%livestemc_storage - ! 21 clm3%g%l%c%p%pcs%livestemc_xfer ! 21 pcs%livestemc_xfer - ! 22 clm3%g%l%c%p%pcs%pft_ctrunc ! 22 pcs%pft_ctrunc - ! 23 clm3%g%l%c%p%pcs%xsmrpool ! 23 pcs%xsmrpool - ! 24 clm3%g%l%c%p%pepv%annavg_t2m ! 24 pepv%annavg_t2m - ! 25 clm3%g%l%c%p%pepv%annmax_retransn ! 25 pepv%annmax_retransn - ! 26 clm3%g%l%c%p%pepv%annsum_npp ! 26 pepv%annsum_npp - ! 27 clm3%g%l%c%p%pepv%annsum_potential_gpp ! 27 pepv%annsum_potential_gpp - ! 28 clm3%g%l%c%p%pepv%dayl ! 28 pepv%dayl - ! 29 clm3%g%l%c%p%pepv%days_active ! 29 pepv%days_active - ! 30 clm3%g%l%c%p%pepv%dormant_flag ! 30 pepv%dormant_flag - ! 31 clm3%g%l%c%p%pepv%offset_counter ! 31 pepv%offset_counter - ! 32 clm3%g%l%c%p%pepv%offset_fdd ! 32 pepv%offset_fdd - ! 33 clm3%g%l%c%p%pepv%offset_flag ! 33 pepv%offset_flag - ! 34 clm3%g%l%c%p%pepv%offset_swi ! 34 pepv%offset_swi - ! 35 clm3%g%l%c%p%pepv%onset_counter ! 35 pepv%onset_counter - ! 36 clm3%g%l%c%p%pepv%onset_fdd ! 36 pepv%onset_fdd - ! 37 clm3%g%l%c%p%pepv%onset_flag ! 37 pepv%onset_flag - ! 38 clm3%g%l%c%p%pepv%onset_gdd ! 38 pepv%onset_gdd - ! 39 clm3%g%l%c%p%pepv%onset_gddflag ! 39 pepv%onset_gddflag - ! 40 clm3%g%l%c%p%pepv%onset_swi ! 40 pepv%onset_swi - ! 41 clm3%g%l%c%p%pepv%prev_frootc_to_litter ! 41 pepv%prev_frootc_to_litter - ! 42 clm3%g%l%c%p%pepv%prev_leafc_to_litter ! 42 pepv%prev_leafc_to_litter - ! 43 clm3%g%l%c%p%pepv%tempavg_t2m ! 43 pepv%tempavg_t2m - ! 44 clm3%g%l%c%p%pepv%tempmax_retransn ! 44 pepv%tempmax_retransn - ! 45 clm3%g%l%c%p%pepv%tempsum_npp ! 45 pepv%tempsum_npp - ! 46 clm3%g%l%c%p%pepv%tempsum_potential_gpp ! 46 pepv%tempsum_potential_gpp - ! 47 clm3%g%l%c%p%pepv%xsmrpool_recover ! 47 pepv%xsmrpool_recover - ! 48 clm3%g%l%c%p%pns%deadcrootn ! 48 pns%deadcrootn - ! 49 clm3%g%l%c%p%pns%deadcrootn_storage ! 49 pns%deadcrootn_storage - ! 50 clm3%g%l%c%p%pns%deadcrootn_xfer ! 50 pns%deadcrootn_xfer - ! 51 clm3%g%l%c%p%pns%deadstemn ! 51 pns%deadstemn - ! 52 clm3%g%l%c%p%pns%deadstemn_storage ! 52 pns%deadstemn_storage - ! 53 clm3%g%l%c%p%pns%deadstemn_xfer ! 53 pns%deadstemn_xfer - ! 54 clm3%g%l%c%p%pns%frootn ! 54 pns%frootn - ! 55 clm3%g%l%c%p%pns%frootn_storage ! 55 pns%frootn_storage - ! 56 clm3%g%l%c%p%pns%frootn_xfer ! 56 pns%frootn_xfer - ! 57 clm3%g%l%c%p%pns%leafn ! 57 pns%leafn - ! 58 clm3%g%l%c%p%pns%leafn_storage ! 58 pns%leafn_storage - ! 59 clm3%g%l%c%p%pns%leafn_xfer ! 59 pns%leafn_xfer - ! 60 clm3%g%l%c%p%pns%livecrootn ! 60 pns%livecrootn - ! 61 clm3%g%l%c%p%pns%livecrootn_storage ! 61 pns%livecrootn_storage - ! 62 clm3%g%l%c%p%pns%livecrootn_xfer ! 62 pns%livecrootn_xfer - ! 63 clm3%g%l%c%p%pns%livestemn ! 63 pns%livestemn - ! 64 clm3%g%l%c%p%pns%livestemn_storage ! 64 pns%livestemn_storage - ! 65 clm3%g%l%c%p%pns%livestemn_xfer ! 65 pns%livestemn_xfer - ! 66 clm3%g%l%c%p%pns%npool ! 66 pns%npool - ! 67 clm3%g%l%c%p%pns%pft_ntrunc ! 67 pns%pft_ntrunc - ! 68 clm3%g%l%c%p%pns%retransn ! 68 pns%retransn - ! 69 clm3%g%l%c%p%pps%elai ! 69 pps%elai - ! 70 clm3%g%l%c%p%pps%esai ! 70 pps%esai - ! 71 clm3%g%l%c%p%pps%hbot ! 71 pps%hbot - ! 72 clm3%g%l%c%p%pps%htop ! 72 pps%htop - ! 73 clm3%g%l%c%p%pps%tlai ! 73 pps%tlai - ! 74 clm3%g%l%c%p%pps%tsai ! 74 pps%tsai - ! 75 pepv%plant_ndemand - ! OLD ! 75 pps%gddplant - ! OLD ! 76 pps%gddtsoi - ! OLD ! 77 pps%peaklai - ! OLD ! 78 pps%idop - ! OLD ! 79 pps%aleaf - ! OLD ! 80 pps%aleafi - ! OLD ! 81 pps%astem - ! OLD ! 82 pps%astemi - ! OLD ! 83 pps%htmx - ! OLD ! 84 pps%hdidx - ! OLD ! 85 pps%vf - ! OLD ! 86 pps%cumvd - ! OLD ! 87 pps%croplive - ! OLD ! 88 pps%cropplant - ! OLD ! 89 pps%harvdate - ! OLD ! 90 pps%gdd1020 - ! OLD ! 91 pps%gdd820 - ! OLD ! 92 pps%gdd020 - ! OLD ! 93 pps%gddmaturity - ! OLD ! 94 pps%huileaf - ! OLD ! 95 pps%huigrain - ! OLD ! 96 pcs%grainc - ! OLD ! 97 pcs%grainc_storage - ! OLD ! 98 pcs%grainc_xfer - ! OLD ! 99 pns%grainn - ! OLD !100 pns%grainn_storage - ! OLD !101 pns%grainn_xfer - ! OLD !102 pepv%fert_counter - ! OLD !103 pnf%fert - ! OLD !104 pepv%grain_flag - - end do OUT_TILE - - i = 1 - do nv = 1,VAR_COL - do nz = 1,nzone - STATUS = NF_PUT_VARA_REAL(OutID,VarID(OutID,'CNCOL'), (/1,i/), (/NTILES,1 /),var_col_out(:, nz,nv)) ; VERIFY_(STATUS) - i = i + 1 - end do - end do - - i = 1 - if(clm45) then - do iv = 1,VAR_PFT - do nv = 1,nveg - do nz = 1,nzone - if(iv <= 74) then - STATUS = NF_PUT_VARA_REAL(OutID,VarID(OutID,'CNPFT'), (/1,i/), (/NTILES,1 /),var_pft_out(:, nz,nv,iv)) ; VERIFY_(STATUS) - else - if((iv == 78) .OR. (iv == 89)) then ! idop and harvdate - var_dum = 999 - STATUS = NF_PUT_VARA_REAL(OutID,VarID(OutID,'CNPFT'), (/1,i/), (/NTILES,1 /),var_dum) ; VERIFY_(STATUS) - else - var_dum = 0. - STATUS = NF_PUT_VARA_REAL(OutID,VarID(OutID,'CNPFT'), (/1,i/), (/NTILES,1 /),var_dum) ; VERIFY_(STATUS) - endif - endif - i = i + 1 - end do - end do - end do - else - do iv = 1,VAR_PFT - do nv = 1,nveg - do nz = 1,nzone - STATUS = NF_PUT_VARA_REAL(OutID,VarID(OutID,'CNPFT'), (/1,i/), (/NTILES,1 /),var_pft_out(:, nz,nv,iv)) ; VERIFY_(STATUS) - i = i + 1 - end do - end do - end do - endif - - VAR_DUM = 0. - - do nz = 1,nzone - STATUS = NF_PUT_VARA_REAL(OutID,VarID(OUTID,'TGWM'), (/1,nz/), (/NTILES,1 /),VAR_DUM(:)) ; VERIFY_(STATUS) - STATUS = NF_PUT_VARA_REAL(OutID,VarID(OUTID,'RZMM'), (/1,nz/), (/NTILES,1 /),VAR_DUM(:)) ; VERIFY_(STATUS) - if(clm45) STATUS = NF_PUT_VARA_REAL(OutID,VarID(OUTID,'SFMM'), (/1,nz/), (/NTILES,1 /),VAR_DUM(:)) ; VERIFY_(STATUS) - end do - - STATUS = NF_PUT_VARA_REAL(OutID,VarID(OUTID,'BFLOWM' ), (/1/), (/NTILES/),VAR_DUM(:)) ; VERIFY_(STATUS) - STATUS = NF_PUT_VARA_REAL(OutID,VarID(OUTID,'TOTWATM'), (/1/), (/NTILES/),VAR_DUM(:)) ; VERIFY_(STATUS) - STATUS = NF_PUT_VARA_REAL(OutID,VarID(OUTID,'TAIRM' ), (/1/), (/NTILES/),VAR_DUM(:)) ; VERIFY_(STATUS) - STATUS = NF_PUT_VARA_REAL(OutID,VarID(OUTID,'TPM' ), (/1/), (/NTILES/),VAR_DUM(:)) ; VERIFY_(STATUS) - STATUS = NF_PUT_VARA_REAL(OutID,VarID(OUTID,'CNSUM' ), (/1/), (/NTILES/),VAR_DUM(:)) ; VERIFY_(STATUS) - STATUS = NF_PUT_VARA_REAL(OutID,VarID(OUTID,'SNDZM' ), (/1/), (/NTILES/),VAR_DUM(:)) ; VERIFY_(STATUS) - STATUS = NF_PUT_VARA_REAL(OutID,VarID(OUTID,'ASNOWM' ), (/1/), (/NTILES/),VAR_DUM(:)) ; VERIFY_(STATUS) - - if(clm45) then - STATUS = NF_PUT_VARA_REAL(OutID,VarID(OUTID,'AR1M' ), (/1/), (/NTILES/),VAR_DUM(:)) ; VERIFY_(STATUS) - STATUS = NF_PUT_VARA_REAL(OutID,VarID(OUTID,'RAINFM' ), (/1/), (/NTILES/),VAR_DUM(:)) ; VERIFY_(STATUS) - STATUS = NF_PUT_VARA_REAL(OutID,VarID(OUTID,'RHM' ), (/1/), (/NTILES/),VAR_DUM(:)) ; VERIFY_(STATUS) - STATUS = NF_PUT_VARA_REAL(OutID,VarID(OUTID,'RUNSRFM' ), (/1/), (/NTILES/),VAR_DUM(:)) ; VERIFY_(STATUS) - STATUS = NF_PUT_VARA_REAL(OutID,VarID(OUTID,'SNOWFM' ), (/1/), (/NTILES/),VAR_DUM(:)) ; VERIFY_(STATUS) - STATUS = NF_PUT_VARA_REAL(OutID,VarID(OUTID,'WINDM' ), (/1/), (/NTILES/),VAR_DUM(:)) ; VERIFY_(STATUS) - STATUS = NF_PUT_VARA_REAL(OutID,VarID(OUTID,'TPREC10D'), (/1/), (/NTILES/),VAR_DUM(:)) ; VERIFY_(STATUS) - STATUS = NF_PUT_VARA_REAL(OutID,VarID(OUTID,'TPREC60D'), (/1/), (/NTILES/),VAR_DUM(:)) ; VERIFY_(STATUS) - STATUS = NF_PUT_VARA_REAL(OutID,VarID(OUTID,'T2M10D' ), (/1/), (/NTILES/),VAR_DUM(:)) ; VERIFY_(STATUS) - else - STATUS = NF_PUT_VARA_REAL(OutID,VarID(OUTID,'SFMCM'), (/1/), (/NTILES/),VAR_DUM(:)) ; VERIFY_(STATUS) - endif - - do nv = 1,nzone - do nz = 1,nveg - STATUS = NF_PUT_VARA_REAL(OutID,VarID(OUTID,'PSNSUNM'), (/1,nz,nv/), (/NTILES,1,1/),VAR_DUM(:)) ; VERIFY_(STATUS) - STATUS = NF_PUT_VARA_REAL(OutID,VarID(OUTID,'PSNSHAM'), (/1,nz,nv/), (/NTILES,1,1/),VAR_DUM(:)) ; VERIFY_(STATUS) - end do - end do - - VAR_DUM = 0.1 - do i = 1,4 - STATUS = NF_PUT_VARA_REAL(OutID,VarID(OUTID,'WW'), (/1,i/), (/NTILES,1 /),VAR_DUM(:)) - end do - - VAR_DUM = 0.25 - do i = 1,4 - STATUS = NF_PUT_VARA_REAL(OutID,VarID(OUTID,'FR'), (/1,i/), (/NTILES,1 /),VAR_DUM(:)) - end do - - VAR_DUM = 0.001 - do i = 1,4 - STATUS = NF_PUT_VARA_REAL(OutID,VarID(OUTID,'CH'), (/1,i/), (/NTILES,1 /),VAR_DUM(:)) - STATUS = NF_PUT_VARA_REAL(OutID,VarID(OUTID,'CM'), (/1,i/), (/NTILES,1 /),VAR_DUM(:)) - STATUS = NF_PUT_VARA_REAL(OutID,VarID(OUTID,'CQ'), (/1,i/), (/NTILES,1 /),VAR_DUM(:)) - end do - - STATUS = NF_CLOSE (NCFID) - - deallocate (var_col_out,var_pft_out) - deallocate (CLMC_pf1, CLMC_pf2, CLMC_sf1, CLMC_sf2) - deallocate (CLMC_pt1, CLMC_pt2, CLMC_st1, CLMC_st2) - - END SUBROUTINE write_regridded_carbon - - ! ***************************************************************************** - - SUBROUTINE put_land_vars (NTILES, ntiles_rst, id_glb, ld_reorder, model, rst_file) - - implicit none - character(*), intent (in) :: model - integer, intent (in) :: NTILES, ntiles_rst - integer, intent (in) :: id_glb(NTILES), ld_reorder (ntiles_rst) - integer :: k, rc - real , dimension (:), allocatable :: var_get, var_put - type(Netcdf4_FileFormatter):: OutFmt, InFmt - type(FileMetadata) :: meta_data - integer :: STATUS, NCFID, OUTID - character(*), intent (in), optional :: rst_file - character(256) :: Iam = "put_land_vars" - - allocate (var_get (NTILES_RST)) - allocate (var_put (NTILES)) - - ! create output catchcn_internal_rst - if(index(model,'catchcn') /=0) then - if (clm45) then - call InFmt%open('/discover/nobackup/projects/gmao/ssd/land/l_data/LandRestarts_for_Regridding/CatchCN/catchcn_internal_clm45',PFIO_READ, __RC__) - else - call InFmt%open(trim(InCNRestart ), pFIO_READ, __RC__) - endif - endif - if(trim(model) == 'catch' ) then - call InFmt%open(trim(InCatRestart), pFIO_READ, __RC__) - endif - meta_data = InFmt%read(__RC__) - call InFmt%close(__RC__) - - call meta_data%modify_dimension('tile', ntiles, __RC__) - - OutFileName = "InData/"//trim(model)//"_internal_rst" - - call OutFmt%create(trim(OutFileName),__RC__) - call OutFmt%write(meta_data,__RC__) - - if (present(rst_file)) then - STATUS = NF_OPEN (trim(rst_file ),NF_NOWRITE,NCFID) ; VERIFY_(STATUS) - else - if(index(model, 'catchcn') /=0 ) then - STATUS = NF_OPEN (trim(InCNRestart ),NF_NOWRITE,NCFID) ; VERIFY_(STATUS) - endif - if(trim(model) == 'catch') then - STATUS = NF_OPEN (trim(InCatRestart),NF_NOWRITE,NCFID) ; VERIFY_(STATUS) - endif - endif - - ! Read catparam - ! ------------- - - STATUS = NF_GET_VARA_REAL(NCFID,VarID(NCFID,'POROS' ), (/1/), (/NTILES_RST/),var_get) - do k = 1, NTILES - VAR_PUT(k) = var_get(ld_reorder(id_glb(k))) - end do - call MAPL_VarWrite(OutFmt,'POROS',var_put) - - STATUS = NF_GET_VARA_REAL(NCFID,VarID(NCFID,'COND' ), (/1/), (/NTILES_RST/),var_get) - do k = 1, NTILES - VAR_PUT(k) = var_get(ld_reorder(id_glb(k))) - end do - call MAPL_VarWrite(OutFmt,'COND',var_put) - - STATUS = NF_GET_VARA_REAL(NCFID,VarID(NCFID,'PSIS' ), (/1/), (/NTILES_RST/),var_get) - do k = 1, NTILES - VAR_PUT(k) = var_get(ld_reorder(id_glb(k))) - end do - call MAPL_VarWrite(OutFmt,'PSIS',var_put) - - STATUS = NF_GET_VARA_REAL(NCFID,VarID(NCFID,'BEE' ), (/1/), (/NTILES_RST/),var_get) - do k = 1, NTILES - VAR_PUT(k) = var_get(ld_reorder(id_glb(k))) - end do - call MAPL_VarWrite(OutFmt,'BEE',var_put) - - STATUS = NF_GET_VARA_REAL(NCFID,VarID(NCFID,'WPWET' ), (/1/), (/NTILES_RST/),var_get) - do k = 1, NTILES - VAR_PUT(k) = var_get(ld_reorder(id_glb(k))) - end do - call MAPL_VarWrite(OutFmt,'WPWET',var_put) - - STATUS = NF_GET_VARA_REAL(NCFID,VarID(NCFID,'GNU' ), (/1/), (/NTILES_RST/),var_get) - do k = 1, NTILES - VAR_PUT(k) = var_get(ld_reorder(id_glb(k))) - end do - call MAPL_VarWrite(OutFmt,'GNU',var_put) - - STATUS = NF_GET_VARA_REAL(NCFID,VarID(NCFID,'VGWMAX' ), (/1/), (/NTILES_RST/),var_get) - do k = 1, NTILES - VAR_PUT(k) = var_get(ld_reorder(id_glb(k))) - end do - call MAPL_VarWrite(OutFmt,'VGWMAX',var_put) - - STATUS = NF_GET_VARA_REAL(NCFID,VarID(NCFID,'BF1' ), (/1/), (/NTILES_RST/),var_get) - do k = 1, NTILES - VAR_PUT(k) = var_get(ld_reorder(id_glb(k))) - end do - call MAPL_VarWrite(OutFmt,'BF1',var_put) - - STATUS = NF_GET_VARA_REAL(NCFID,VarID(NCFID,'BF2' ), (/1/), (/NTILES_RST/),var_get) - do k = 1, NTILES - VAR_PUT(k) = var_get(ld_reorder(id_glb(k))) - end do - call MAPL_VarWrite(OutFmt,'BF2',var_put) - - STATUS = NF_GET_VARA_REAL(NCFID,VarID(NCFID,'BF3' ), (/1/), (/NTILES_RST/),var_get) - do k = 1, NTILES - VAR_PUT(k) = var_get(ld_reorder(id_glb(k))) - end do - call MAPL_VarWrite(OutFmt,'BF3',var_put) - - STATUS = NF_GET_VARA_REAL(NCFID,VarID(NCFID,'CDCR1' ), (/1/), (/NTILES_RST/),var_get) - do k = 1, NTILES - VAR_PUT(k) = var_get(ld_reorder(id_glb(k))) - end do - call MAPL_VarWrite(OutFmt,'CDCR1',var_put) - - STATUS = NF_GET_VARA_REAL(NCFID,VarID(NCFID,'CDCR2' ), (/1/), (/NTILES_RST/),var_get) - do k = 1, NTILES - VAR_PUT(k) = var_get(ld_reorder(id_glb(k))) - end do - call MAPL_VarWrite(OutFmt,'CDCR2',var_put) - - STATUS = NF_GET_VARA_REAL(NCFID,VarID(NCFID,'ARS1' ), (/1/), (/NTILES_RST/),var_get) - do k = 1, NTILES - VAR_PUT(k) = var_get(ld_reorder(id_glb(k))) - end do - call MAPL_VarWrite(OutFmt,'ARS1',var_put) - - STATUS = NF_GET_VARA_REAL(NCFID,VarID(NCFID,'ARS2' ), (/1/), (/NTILES_RST/),var_get) - do k = 1, NTILES - VAR_PUT(k) = var_get(ld_reorder(id_glb(k))) - end do - call MAPL_VarWrite(OutFmt,'ARS2',var_put) - - STATUS = NF_GET_VARA_REAL(NCFID,VarID(NCFID,'ARS3' ), (/1/), (/NTILES_RST/),var_get) - do k = 1, NTILES - VAR_PUT(k) = var_get(ld_reorder(id_glb(k))) - end do - call MAPL_VarWrite(OutFmt,'ARS3',var_put) - - STATUS = NF_GET_VARA_REAL(NCFID,VarID(NCFID,'ARA1' ), (/1/), (/NTILES_RST/),var_get) - do k = 1, NTILES - VAR_PUT(k) = var_get(ld_reorder(id_glb(k))) - end do - call MAPL_VarWrite(OutFmt,'ARA1',var_put) - - STATUS = NF_GET_VARA_REAL(NCFID,VarID(NCFID,'ARA2' ), (/1/), (/NTILES_RST/),var_get) - do k = 1, NTILES - VAR_PUT(k) = var_get(ld_reorder(id_glb(k))) - end do - call MAPL_VarWrite(OutFmt,'ARA2',var_put) - - STATUS = NF_GET_VARA_REAL(NCFID,VarID(NCFID,'ARA3' ), (/1/), (/NTILES_RST/),var_get) - do k = 1, NTILES - VAR_PUT(k) = var_get(ld_reorder(id_glb(k))) - end do - call MAPL_VarWrite(OutFmt,'ARA3',var_put) - - STATUS = NF_GET_VARA_REAL(NCFID,VarID(NCFID,'ARA4' ), (/1/), (/NTILES_RST/),var_get) - do k = 1, NTILES - VAR_PUT(k) = var_get(ld_reorder(id_glb(k))) - end do - call MAPL_VarWrite(OutFmt,'ARA4',var_put) - - STATUS = NF_GET_VARA_REAL(NCFID,VarID(NCFID,'ARW1' ), (/1/), (/NTILES_RST/),var_get) - do k = 1, NTILES - VAR_PUT(k) = var_get(ld_reorder(id_glb(k))) - end do - call MAPL_VarWrite(OutFmt,'ARW1',var_put) - - STATUS = NF_GET_VARA_REAL(NCFID,VarID(NCFID,'ARW2' ), (/1/), (/NTILES_RST/),var_get) - do k = 1, NTILES - VAR_PUT(k) = var_get(ld_reorder(id_glb(k))) - end do - call MAPL_VarWrite(OutFmt,'ARW2',var_put) - - STATUS = NF_GET_VARA_REAL(NCFID,VarID(NCFID,'ARW3' ), (/1/), (/NTILES_RST/),var_get) - do k = 1, NTILES - VAR_PUT(k) = var_get(ld_reorder(id_glb(k))) - end do - call MAPL_VarWrite(OutFmt,'ARW3',var_put) - - STATUS = NF_GET_VARA_REAL(NCFID,VarID(NCFID,'ARW4' ), (/1/), (/NTILES_RST/),var_get) - do k = 1, NTILES - VAR_PUT(k) = var_get(ld_reorder(id_glb(k))) - end do - call MAPL_VarWrite(OutFmt,'ARW4',var_put) - - STATUS = NF_GET_VARA_REAL(NCFID,VarID(NCFID,'TSA1' ), (/1/), (/NTILES_RST/),var_get) - do k = 1, NTILES - VAR_PUT(k) = var_get(ld_reorder(id_glb(k))) - end do - call MAPL_VarWrite(OutFmt,'TSA1',var_put) - - STATUS = NF_GET_VARA_REAL(NCFID,VarID(NCFID,'TSA2' ), (/1/), (/NTILES_RST/),var_get) - do k = 1, NTILES - VAR_PUT(k) = var_get(ld_reorder(id_glb(k))) - end do - call MAPL_VarWrite(OutFmt,'TSA2',var_put) - - STATUS = NF_GET_VARA_REAL(NCFID,VarID(NCFID,'TSB1' ), (/1/), (/NTILES_RST/),var_get) - do k = 1, NTILES - VAR_PUT(k) = var_get(ld_reorder(id_glb(k))) - end do - call MAPL_VarWrite(OutFmt,'TSB1',var_put) - - STATUS = NF_GET_VARA_REAL(NCFID,VarID(NCFID,'TSB2' ), (/1/), (/NTILES_RST/),var_get) - do k = 1, NTILES - VAR_PUT(k) = var_get(ld_reorder(id_glb(k))) - end do - call MAPL_VarWrite(OutFmt,'TSB2',var_put) - - STATUS = NF_GET_VARA_REAL(NCFID,VarID(NCFID,'ATAU' ), (/1/), (/NTILES_RST/),var_get) - do k = 1, NTILES - VAR_PUT(k) = var_get(ld_reorder(id_glb(k))) - end do - call MAPL_VarWrite(OutFmt,'ATAU',var_put) - - STATUS = NF_GET_VARA_REAL(NCFID,VarID(NCFID,'BTAU' ), (/1/), (/NTILES_RST/),var_get) - do k = 1, NTILES - VAR_PUT(k) = var_get(ld_reorder(id_glb(k))) - end do - call MAPL_VarWrite(OutFmt,'BTAU',var_put) - - if(index(model,'catchcn') /=0) then - - STATUS = NF_GET_VARA_REAL(NCFID,VarID(NCFID,'ITY' ), (/1,1/), (/NTILES_RST,1/),var_get) - do k = 1, NTILES - VAR_PUT(k) = var_get(ld_reorder(id_glb(k))) - end do - call MAPL_VarWrite(OutFmt,'ITY',var_put, offset1=1) - - STATUS = NF_GET_VARA_REAL(NCFID,VarID(NCFID,'ITY' ), (/1,2/), (/NTILES_RST,1/),var_get) - do k = 1, NTILES - VAR_PUT(k) = var_get(ld_reorder(id_glb(k))) - end do - call MAPL_VarWrite(OutFmt,'ITY',var_put, offset1=2) - - STATUS = NF_GET_VARA_REAL(NCFID,VarID(NCFID,'ITY' ), (/1,3/), (/NTILES_RST,1/),var_get) - do k = 1, NTILES - VAR_PUT(k) = var_get(ld_reorder(id_glb(k))) - end do - call MAPL_VarWrite(OutFmt,'ITY',var_put, offset1=3) - - STATUS = NF_GET_VARA_REAL(NCFID,VarID(NCFID,'ITY' ), (/1,4/), (/NTILES_RST,1/),var_get) - do k = 1, NTILES - VAR_PUT(k) = var_get(ld_reorder(id_glb(k))) - end do - call MAPL_VarWrite(OutFmt,'ITY',var_put, offset1=4) - - STATUS = NF_GET_VARA_REAL(NCFID,VarID(NCFID,'FVG' ), (/1,1/), (/NTILES_RST,1/),var_get) - do k = 1, NTILES - VAR_PUT(k) = var_get(ld_reorder(id_glb(k))) - end do - call MAPL_VarWrite(OutFmt,'FVG',var_put, offset1=1) - - STATUS = NF_GET_VARA_REAL(NCFID,VarID(NCFID,'FVG' ), (/1,2/), (/NTILES_RST,1/),var_get) - do k = 1, NTILES - VAR_PUT(k) = var_get(ld_reorder(id_glb(k))) - end do - call MAPL_VarWrite(OutFmt,'FVG',var_put, offset1=2) - - STATUS = NF_GET_VARA_REAL(NCFID,VarID(NCFID,'FVG' ), (/1,3/), (/NTILES_RST,1/),var_get) - do k = 1, NTILES - VAR_PUT(k) = var_get(ld_reorder(id_glb(k))) - end do - call MAPL_VarWrite(OutFmt,'FVG',var_put, offset1=3) - - STATUS = NF_GET_VARA_REAL(NCFID,VarID(NCFID,'FVG' ), (/1,4/), (/NTILES_RST,1/),var_get) - do k = 1, NTILES - VAR_PUT(k) = var_get(ld_reorder(id_glb(k))) - end do - call MAPL_VarWrite(OutFmt,'FVG',var_put, offset1=4) - - ! read restart and regrid - ! ----------------------- - - STATUS = NF_GET_VARA_REAL(NCFID,VarID(NCFID,'TG' ), (/1,1/), (/NTILES_RST,1/),var_get) - do k = 1, NTILES - VAR_PUT(k) = var_get(ld_reorder(id_glb(k))) - end do - call MAPL_VarWrite(OutFmt,'TG',var_put, offset1=1) ! if you see offset1=1 it is a 2-D var - - STATUS = NF_GET_VARA_REAL(NCFID,VarID(NCFID,'TG' ), (/1,2/), (/NTILES_RST,1/),var_get) - do k = 1, NTILES - VAR_PUT(k) = var_get(ld_reorder(id_glb(k))) - end do - call MAPL_VarWrite(OutFmt,'TG',var_put, offset1=2) - - STATUS = NF_GET_VARA_REAL(NCFID,VarID(NCFID,'TG' ), (/1,3/), (/NTILES_RST,1/),var_get) - do k = 1, NTILES - VAR_PUT(k) = var_get(ld_reorder(id_glb(k))) - end do - call MAPL_VarWrite(OutFmt,'TG',var_put, offset1=3) - - endif - - STATUS = NF_GET_VARA_REAL(NCFID,VarID(NCFID,'TC' ), (/1,1/), (/NTILES_RST,1/),var_get) - do k = 1, NTILES - VAR_PUT(k) = var_get(ld_reorder(id_glb(k))) - end do - call MAPL_VarWrite(OutFmt,'TC',var_put, offset1=1) - - STATUS = NF_GET_VARA_REAL(NCFID,VarID(NCFID,'TC' ), (/1,2/), (/NTILES_RST,1/),var_get) - do k = 1, NTILES - VAR_PUT(k) = var_get(ld_reorder(id_glb(k))) - end do - call MAPL_VarWrite(OutFmt,'TC',var_put, offset1=2) - - STATUS = NF_GET_VARA_REAL(NCFID,VarID(NCFID,'TC' ), (/1,3/), (/NTILES_RST,1/),var_get) - do k = 1, NTILES - VAR_PUT(k) = var_get(ld_reorder(id_glb(k))) - end do - call MAPL_VarWrite(OutFmt,'TC',var_put, offset1=3) - - STATUS = NF_GET_VARA_REAL(NCFID,VarID(NCFID,'QC' ), (/1,1/), (/NTILES_RST,1/),var_get) - do k = 1, NTILES - VAR_PUT(k) = var_get(ld_reorder(id_glb(k))) - end do - call MAPL_VarWrite(OutFmt,'QC',var_put, offset1=1) - - STATUS = NF_GET_VARA_REAL(NCFID,VarID(NCFID,'QC' ), (/1,2/), (/NTILES_RST,1/),var_get) - do k = 1, NTILES - VAR_PUT(k) = var_get(ld_reorder(id_glb(k))) - end do - call MAPL_VarWrite(OutFmt,'QC',var_put, offset1=2) - - STATUS = NF_GET_VARA_REAL(NCFID,VarID(NCFID,'QC' ), (/1,3/), (/NTILES_RST,1/),var_get) - do k = 1, NTILES - VAR_PUT(k) = var_get(ld_reorder(id_glb(k))) - end do - call MAPL_VarWrite(OutFmt,'QC',var_put, offset1=3) - - STATUS = NF_GET_VARA_REAL(NCFID,VarID(NCFID,'CAPAC' ), (/1/), (/NTILES_RST/),var_get) - do k = 1, NTILES - VAR_PUT(k) = var_get(ld_reorder(id_glb(k))) - end do - call MAPL_VarWrite(OutFmt,'CAPAC',var_put) - - STATUS = NF_GET_VARA_REAL(NCFID,VarID(NCFID,'CATDEF' ), (/1/), (/NTILES_RST/),var_get) - do k = 1, NTILES - VAR_PUT(k) = var_get(ld_reorder(id_glb(k))) - end do - call MAPL_VarWrite(OutFmt,'CATDEF',var_put) - - STATUS = NF_GET_VARA_REAL(NCFID,VarID(NCFID,'RZEXC' ), (/1/), (/NTILES_RST/),var_get) - do k = 1, NTILES - VAR_PUT(k) = var_get(ld_reorder(id_glb(k))) - end do - call MAPL_VarWrite(OutFmt,'RZEXC',var_put) - - STATUS = NF_GET_VARA_REAL(NCFID,VarID(NCFID,'SRFEXC' ), (/1/), (/NTILES_RST/),var_get) - do k = 1, NTILES - VAR_PUT(k) = var_get(ld_reorder(id_glb(k))) - end do - call MAPL_VarWrite(OutFmt,'SRFEXC',var_put) - - STATUS = NF_GET_VARA_REAL(NCFID,VarID(NCFID,'GHTCNT1' ), (/1/), (/NTILES_RST/),var_get) - do k = 1, NTILES - VAR_PUT(k) = var_get(ld_reorder(id_glb(k))) - end do - call MAPL_VarWrite(OutFmt,'GHTCNT1',var_put) - - STATUS = NF_GET_VARA_REAL(NCFID,VarID(NCFID,'GHTCNT2' ), (/1/), (/NTILES_RST/),var_get) - do k = 1, NTILES - VAR_PUT(k) = var_get(ld_reorder(id_glb(k))) - end do - call MAPL_VarWrite(OutFmt,'GHTCNT2',var_put) - - STATUS = NF_GET_VARA_REAL(NCFID,VarID(NCFID,'GHTCNT3' ), (/1/), (/NTILES_RST/),var_get) - do k = 1, NTILES - VAR_PUT(k) = var_get(ld_reorder(id_glb(k))) - end do - call MAPL_VarWrite(OutFmt,'GHTCNT3',var_put) - - STATUS = NF_GET_VARA_REAL(NCFID,VarID(NCFID,'GHTCNT4' ), (/1/), (/NTILES_RST/),var_get) - do k = 1, NTILES - VAR_PUT(k) = var_get(ld_reorder(id_glb(k))) - end do - call MAPL_VarWrite(OutFmt,'GHTCNT4',var_put) - - STATUS = NF_GET_VARA_REAL(NCFID,VarID(NCFID,'GHTCNT5' ), (/1/), (/NTILES_RST/),var_get) - do k = 1, NTILES - VAR_PUT(k) = var_get(ld_reorder(id_glb(k))) - end do - call MAPL_VarWrite(OutFmt,'GHTCNT5',var_put) - - STATUS = NF_GET_VARA_REAL(NCFID,VarID(NCFID,'GHTCNT6' ), (/1/), (/NTILES_RST/),var_get) - do k = 1, NTILES - VAR_PUT(k) = var_get(ld_reorder(id_glb(k))) - end do - call MAPL_VarWrite(OutFmt,'GHTCNT6',var_put) - - STATUS = NF_GET_VARA_REAL(NCFID,VarID(NCFID,'WESNN1' ), (/1/), (/NTILES_RST/),var_get) - do k = 1, NTILES - VAR_PUT(k) = var_get(ld_reorder(id_glb(k))) - end do - call MAPL_VarWrite(OutFmt,'WESNN1',var_put) - - STATUS = NF_GET_VARA_REAL(NCFID,VarID(NCFID,'WESNN2' ), (/1/), (/NTILES_RST/),var_get) - do k = 1, NTILES - VAR_PUT(k) = var_get(ld_reorder(id_glb(k))) - end do - call MAPL_VarWrite(OutFmt,'WESNN2',var_put) - - STATUS = NF_GET_VARA_REAL(NCFID,VarID(NCFID,'WESNN3' ), (/1/), (/NTILES_RST/),var_get) - do k = 1, NTILES - VAR_PUT(k) = var_get(ld_reorder(id_glb(k))) - end do - call MAPL_VarWrite(OutFmt,'WESNN3',var_put) - - STATUS = NF_GET_VARA_REAL(NCFID,VarID(NCFID,'HTSNNN1' ), (/1/), (/NTILES_RST/),var_get) - do k = 1, NTILES - VAR_PUT(k) = var_get(ld_reorder(id_glb(k))) - end do - call MAPL_VarWrite(OutFmt,'HTSNNN1',var_put) - - STATUS = NF_GET_VARA_REAL(NCFID,VarID(NCFID,'HTSNNN2' ), (/1/), (/NTILES_RST/),var_get) - do k = 1, NTILES - VAR_PUT(k) = var_get(ld_reorder(id_glb(k))) - end do - call MAPL_VarWrite(OutFmt,'HTSNNN2',var_put) - - STATUS = NF_GET_VARA_REAL(NCFID,VarID(NCFID,'HTSNNN3' ), (/1/), (/NTILES_RST/),var_get) - do k = 1, NTILES - VAR_PUT(k) = var_get(ld_reorder(id_glb(k))) - end do - call MAPL_VarWrite(OutFmt,'HTSNNN3',var_put) - - STATUS = NF_GET_VARA_REAL(NCFID,VarID(NCFID,'SNDZN1' ), (/1/), (/NTILES_RST/),var_get) - do k = 1, NTILES - VAR_PUT(k) = var_get(ld_reorder(id_glb(k))) - end do - call MAPL_VarWrite(OutFmt,'SNDZN1',var_put) - - STATUS = NF_GET_VARA_REAL(NCFID,VarID(NCFID,'SNDZN2' ), (/1/), (/NTILES_RST/),var_get) - do k = 1, NTILES - VAR_PUT(k) = var_get(ld_reorder(id_glb(k))) - end do - call MAPL_VarWrite(OutFmt,'SNDZN2',var_put) - - STATUS = NF_GET_VARA_REAL(NCFID,VarID(NCFID,'SNDZN3' ), (/1/), (/NTILES_RST/),var_get) - do k = 1, NTILES - VAR_PUT(k) = var_get(ld_reorder(id_glb(k))) - end do - call MAPL_VarWrite(OutFmt,'SNDZN3',var_put) - - ! CH CM CQ FR WW - ! WW - VAR_PUT = 0.1 - do k = 1,4 - call MAPL_VarWrite(OutFmt,'WW',VAR_PUT ,offset1=k) - end do - ! FR - VAR_PUT = 0.25 - do k = 1,4 - call MAPL_VarWrite(OutFmt,'FR',VAR_PUT ,offset1=k) - end do - ! CH CM CQ - VAR_PUT = 0.001 - do k = 1,4 - call MAPL_VarWrite(OutFmt,'CH',VAR_PUT ,offset1=k) - call MAPL_VarWrite(OutFmt,'CM',VAR_PUT ,offset1=k) - call MAPL_VarWrite(OutFmt,'CQ',VAR_PUT ,offset1=k) - end do - - call OutFmt%close(__RC__) - STATUS = NF_CLOSE ( NCFID) - - deallocate (var_get, var_put) - CALL EXECUTE_COMMAND_LINE('/bin/cp InData/'//trim(model)//'_internal_rst OutData/'//trim(model)//'_internal_rst', .TRUE.) - - END SUBROUTINE put_land_vars - - ! ***************************************************************************** - - subroutine init_MPI() - - ! initialize MPI - - call MPI_INIT(mpierr) - - call MPI_COMM_RANK( MPI_COMM_WORLD, myid, mpierr ) - call MPI_COMM_SIZE( MPI_COMM_WORLD, numprocs, mpierr ) - - if (myid .ne. 0) root_proc = .false. - -! call init_MPI_types() - - write (*,*) "MPI process ", myid, " of ", numprocs, " is alive" - write (*,*) "MPI process ", myid, ": root_proc=", root_proc - - end subroutine init_MPI - - ! ----------------------------------------------------------------------- - - SUBROUTINE HANDLE_ERR(STATUS, Line) - - INTEGER, INTENT (IN) :: STATUS - CHARACTER(*), INTENT (IN) :: Line - - IF (STATUS .NE. NF_NOERR) THEN - PRINT *, trim(Line),': ',NF_STRERROR(STATUS) - STOP 'Stopped' - ENDIF - - END SUBROUTINE HANDLE_ERR - - ! ***************************************************************************** - - subroutine compute_dayx ( & - NTILES, AGCM_YY, AGCM_MM, AGCM_DD, AGCM_HR, & - LATT, DAYX) - - implicit none - - integer, intent (in) :: NTILES,AGCM_YY,AGCM_MM,AGCM_DD,AGCM_HR - real, dimension (NTILES), intent (in) :: LATT - real, dimension (NTILES), intent (out) :: DAYX - integer, parameter :: DT = 900 - integer, parameter :: ncycle = 1461 ! number of days in a 4-year leap cycle (365*4 + 1) - real, dimension(ncycle) :: zc, zs - integer :: dofyr, sec,YEARS_PER_CYCLE, DAYS_PER_CYCLE, year, iday, idayp1, nn, n - real :: fac, YEARLEN, zsin, zcos, declin - - dofyr = AGCM_DD - if(AGCM_MM > 1) dofyr = dofyr + 31 - if(AGCM_MM > 2) then - dofyr = dofyr + 28 - if(mod(AGCM_YY,4) == 0) dofyr = dofyr + 1 - endif - if(AGCM_MM > 3) dofyr = dofyr + 31 - if(AGCM_MM > 4) dofyr = dofyr + 30 - if(AGCM_MM > 5) dofyr = dofyr + 31 - if(AGCM_MM > 6) dofyr = dofyr + 30 - if(AGCM_MM > 7) dofyr = dofyr + 31 - if(AGCM_MM > 8) dofyr = dofyr + 31 - if(AGCM_MM > 9) dofyr = dofyr + 30 - if(AGCM_MM > 10) dofyr = dofyr + 31 - if(AGCM_MM > 11) dofyr = dofyr + 30 - - sec = AGCM_HR * 3600 - DT ! subtract DT to get time of previous physics step - fac = real(sec) / 86400. - - call orbit_create(zs,zc,ncycle) ! GEOS5 leap cycle routine - - YEARLEN = 365.25 - - ! Compute length of leap cycle - !------------------------------ - - if(YEARLEN-int(YEARLEN) > 0.) then - YEARS_PER_CYCLE = nint(1./(YEARLEN-int(YEARLEN))) - else - YEARS_PER_CYCLE = 1 - endif - - DAYS_PER_CYCLE=nint(YEARLEN*YEARS_PER_CYCLE) - - ! declination & daylength - ! ----------------------- - - YEAR = mod(AGCM_YY-1,YEARS_PER_CYCLE) - - IDAY = YEAR*int(YEARLEN)+dofyr - IDAYP1 = mod(IDAY,DAYS_PER_CYCLE) + 1 - - ZSin = ZS(IDAYP1)*FAC + ZS(IDAY)*(1.-FAC) ! sine of solar declination - ZCos = ZC(IDAYP1)*FAC + ZC(IDAY)*(1.-FAC) ! cosine of solar declination - - nn = 0 - do n = 1,days_per_cycle - nn = nn + 1 - if(nn > 365) nn = nn - 365 - ! print *, 'cycle:',n,nn,asin(ZS(n)) - end do - - declin = asin(ZSin) - - ! compute daylength on input tile space (accounts for any change in physics time step) - ! do n = 1,ntiles_cn - ! fac = -(sin((latc(n)/zoom)*(MAPL_PI/180.))*zsin)/(cos((latc(n)/zoom)*(MAPL_PI/180.))*zcos) - ! fac = min(1.,max(-1.,fac)) - ! dayl(n) = (86400./MAPL_PI) * acos(fac) ! daylength (seconds) - ! end do - - ! compute daylength on output tile space (accounts for lat shift due to split & change in time step) - - do n = 1,ntiles - fac = -(sin(latt(n)*(MAPL_PI/180.))*zsin)/(cos(latt(n)*(MAPL_PI/180.))*zcos) - fac = min(1.,max(-1.,fac)) - dayx(n) = (86400./MAPL_PI) * acos(fac) ! daylength (seconds) - end do - - ! print *,'DAYX : ', minval(dayx),maxval(dayx), minval(latt), maxval(latt), zsin, zcos, dofyr, iday, idayp1, declin - - end subroutine compute_dayx - - ! ***************************************************************************** - - subroutine orbit_create(zs,zc,ncycle) - - implicit none - - integer, intent(in) :: ncycle - real, intent(out), dimension(ncycle) :: zs, zc - - integer :: YEARS_PER_CYCLE, DAYS_PER_CYCLE - integer :: K, KP !, KM - real*8 :: T1, T2, T3, T4, FUN, Y, SOB, OMG, PRH, TT - real*8 :: YEARLEN - - ! STATEMENT FUNCTION - - FUN(Y) = OMG*(1.0-ECCENTRICITY*cos(Y-PRH))**2 - - YEARLEN = 365.25 - - ! Factors involving the orbital parameters - !------------------------------------------ - - OMG = (2.0*MAPL_PI/YEARLEN) / (sqrt(1.-ECCENTRICITY**2)**3) - PRH = PERIHELION*(MAPL_PI/180.) - SOB = sin(OBLIQUITY*(MAPL_PI/180.)) - - ! Compute length of leap cycle - !------------------------------ - - if(YEARLEN-int(YEARLEN) > 0.) then - YEARS_PER_CYCLE = nint(1./(YEARLEN-int(YEARLEN))) - else - YEARS_PER_CYCLE = 1 - endif - - DAYS_PER_CYCLE=nint(YEARLEN*YEARS_PER_CYCLE) - - if(days_per_cycle /= ncycle) stop 'bad cycle' - - ! ZS: Sine of declination - ! ZC: Cosine of declination - - ! Begin integration at vernal equinox - - KP = EQUINOX - TT = 0.0 - ZS(KP) = sin(TT)*SOB - ZC(KP) = sqrt(1.0-ZS(KP)**2) - - ! Integrate orbit for entire leap cycle using Runge-Kutta - - do K=2,DAYS_PER_CYCLE - T1 = FUN(TT ) - T2 = FUN(TT+T1*0.5) - T3 = FUN(TT+T2*0.5) - T4 = FUN(TT+T3 ) - KP = mod(KP,DAYS_PER_CYCLE) + 1 - TT = TT + (T1 + 2.0*(T2 + T3) + T4) / 6.0 - ZS(KP) = sin(TT)*SOB - ZC(KP) = sqrt(1.0-ZS(KP)**2) - end do - - end subroutine orbit_create - -! ***************************************************************************** - -! function to_radian(degree) result(rad) -! -! ! degrees to radians -! real,intent(in) :: degree -! real :: rad -! -! rad = degree*MAPL_PI/180. -! -! end function to_radian -! -! ! ***************************************************************************** -! -! real function haversine(deglat1,deglon1,deglat2,deglon2) -! ! great circle distance -- adapted from Matlab -! real,intent(in) :: deglat1,deglon1,deglat2,deglon2 -! real :: a,c, dlat,dlon,lat1,lat2 -! real,parameter :: radius = MAPL_radius -! -!! dlat = to_radian(deglat2-deglat1) -!! dlon = to_radian(deglon2-deglon1) -! ! lat1 = to_radian(deglat1) -!! lat2 = to_radian(deglat2) -! dlat = deglat2-deglat1 -! dlon = deglon2-deglon1 -! lat1 = deglat1 -! lat2 = deglat2 -! a = (sin(dlat/2))**2 + cos(lat1)*cos(lat2)*(sin(dlon/2))**2 -! if(a>=0. .and. a<=1.) then -! c = 2*atan2(sqrt(a),sqrt(1-a)) -! haversine = radius*c / 1000. -! else -! haversine = 1.e20 -! endif -! end function -! -! ! ---------------------------------------------------------------------- - - integer function VarID (NCFID, VNAME) - - integer, intent (in) :: NCFID - character(*), intent (in) :: VNAME - integer :: status - - STATUS = NF_INQ_VARID (NCFID, trim(VNAME) ,VarID) - IF (STATUS .NE. NF_NOERR) & - CALL HANDLE_ERR(STATUS, trim(VNAME)) - - end function VarID -! ! ----------------------------------------------------------------------------- -! - - FUNCTION StrUpCase ( Input_String ) RESULT ( Output_String ) - ! -- Argument and result - CHARACTER( * ), INTENT( IN ) :: Input_String - CHARACTER( LEN( Input_String ) ) :: Output_String - ! -- Local variables - INTEGER :: i, n - - - ! -- Copy input string - Output_String = Input_String - ! -- Loop over string elements - DO i = 1, LEN( Output_String ) - ! -- Find location of letter in lower case constant string - n = INDEX( LOWER_CASE, Output_String( i:i ) ) - ! -- If current substring is a lower case letter, make it upper case - IF ( n /= 0 ) Output_String( i:i ) = UPPER_CASE( n:n ) - END DO - END FUNCTION StrUpCase - - ! ----------------------------------------------------------------------------- - - FUNCTION StrLowCase ( Input_String ) RESULT ( Output_String ) - ! -- Argument and result - CHARACTER( * ), INTENT( IN ) :: Input_String - CHARACTER( LEN( Input_String ) ) :: Output_String - ! -- Local variables - INTEGER :: i, n - - ! -- Copy input string - Output_String = Input_String - ! -- Loop over string elements - DO i = 1, LEN( Output_String ) - ! -- Find location of letter in upper case constant string - n = INDEX( UPPER_CASE, Output_String( i:i ) ) - ! -- If current substring is an upper case letter, make it lower case - IF ( n /= 0 ) Output_String( i:i ) = LOWER_CASE( n:n ) - END DO - END FUNCTION StrLowCase - - ! ----------------------------------------------------------------------------- - - FUNCTION StrExtName ( Input_String ) RESULT ( Output_String ) - ! -- Argument and result - CHARACTER( * ), INTENT( IN ) :: Input_String - CHARACTER( LEN( Input_String ) ) :: Output_String - ! -- Local variables - INTEGER :: i, n1, n2, n3, n4, n5, n, k - - ! -- Copy input string - ! Output_String = Input_String - ! -- Loop over string elements - - k = 1 - - DO i = 1, LEN( Input_String ) - - ! -- Find location of letter in upper case constant string - n1 = INDEX( UPPER_CASE, Input_String( i:i ) ) - n2 = INDEX( LOWER_CASE, Input_String( i:i ) ) - n3 = INDEX( '.', Input_String( i:i ) ) - n4 = INDEX( '-', Input_String( i:i ) ) - n5 = INDEX( '_', Input_String( i:i ) ) - - n = 0 - Output_String(i:i) = '' - - if (n1 /= 0) n = n1 - if (n2 /= 0) n = n2 - if (n3 /= 0) n = n3 - if (n4 /= 0) n = n4 - if (n5 /= 0) n = n5 - - ! -- If current substring is acceptable - IF ( n /= 0 ) then - Output_String( k:k ) = Input_String( i:i ) - k = k + 1 - endif - - END DO - - END FUNCTION StrExtName - - ! ---------------------------------------------------------------------------- - - SUBROUTINE write_bin (unit, InFmt, NTILES) - - implicit none - integer :: ntiles - integer :: unit - type(Netcdf4_FileFormatter) :: InFmt - - - real :: bf1(ntiles) - real :: bf2(ntiles) - real :: bf3(ntiles) - real :: vgwmax(ntiles) - real :: cdcr1(ntiles) - real :: cdcr2(ntiles) - real :: psis(ntiles) - real :: bee(ntiles) - real :: poros(ntiles) - real :: wpwet(ntiles) - real :: cond(ntiles) - real :: gnu(ntiles) - real :: ars1(ntiles) - real :: ars2(ntiles) - real :: ars3(ntiles) - real :: ara1(ntiles) - real :: ara2(ntiles) - real :: ara3(ntiles) - real :: ara4(ntiles) - real :: arw1(ntiles) - real :: arw2(ntiles) - real :: arw3(ntiles) - real :: arw4(ntiles) - real :: tsa1(ntiles) - real :: tsa2(ntiles) - real :: tsb1(ntiles) - real :: tsb2(ntiles) - real :: atau(ntiles) - real :: btau(ntiles) - real :: ity(ntiles) - real :: tc(ntiles,4) - real :: qc(ntiles,4) - real :: capac(ntiles) - real :: catdef(ntiles) - real :: rzexc(ntiles) - real :: srfexc(ntiles) - real :: ghtcnt1(ntiles) - real :: ghtcnt2(ntiles) - real :: ghtcnt3(ntiles) - real :: ghtcnt4(ntiles) - real :: ghtcnt5(ntiles) - real :: ghtcnt6(ntiles) - real :: tsurf(ntiles) - real :: wesnn1(ntiles) - real :: wesnn2(ntiles) - real :: wesnn3(ntiles) - real :: htsnnn1(ntiles) - real :: htsnnn2(ntiles) - real :: htsnnn3(ntiles) - real :: sndzn1(ntiles) - real :: sndzn2(ntiles) - real :: sndzn3(ntiles) - real :: ch(ntiles,4) - real :: cm(ntiles,4) - real :: cq(ntiles,4) - real :: fr(ntiles,4) - real :: ww(ntiles,4) - character*256 :: Iam = "Write bin" - integer :: status - - call MAPL_VarRead(InFmt,"BF1",bf1, __RC__) - call MAPL_VarRead(InFmt,"BF2",bf2, __RC__) - call MAPL_VarRead(InFmt,"BF3",bf3, __RC__) - call MAPL_VarRead(InFmt,"VGWMAX",vgwmax, __RC__) - call MAPL_VarRead(InFmt,"CDCR1",cdcr1, __RC__) - call MAPL_VarRead(InFmt,"CDCR2",cdcr2, __RC__) - call MAPL_VarRead(InFmt,"PSIS",psis, __RC__) - call MAPL_VarRead(InFmt,"BEE",bee, __RC__) - call MAPL_VarRead(InFmt,"POROS",poros, __RC__) - call MAPL_VarRead(InFmt,"WPWET",wpwet, __RC__) - call MAPL_VarRead(InFmt,"COND",cond, __RC__) - call MAPL_VarRead(InFmt,"GNU",gnu, __RC__) - call MAPL_VarRead(InFmt,"ARS1",ars1, __RC__) - call MAPL_VarRead(InFmt,"ARS2",ars2, __RC__) - call MAPL_VarRead(InFmt,"ARS3",ars3, __RC__) - call MAPL_VarRead(InFmt,"ARA1",ara1, __RC__) - call MAPL_VarRead(InFmt,"ARA2",ara2, __RC__) - call MAPL_VarRead(InFmt,"ARA3",ara3, __RC__) - call MAPL_VarRead(InFmt,"ARA4",ara4, __RC__) - call MAPL_VarRead(InFmt,"ARW1",arw1, __RC__) - call MAPL_VarRead(InFmt,"ARW2",arw2, __RC__) - call MAPL_VarRead(InFmt,"ARW3",arw3, __RC__) - call MAPL_VarRead(InFmt,"ARW4",arw4, __RC__) - call MAPL_VarRead(InFmt,"TSA1",tsa1, __RC__) - call MAPL_VarRead(InFmt,"TSA2",tsa2, __RC__) - call MAPL_VarRead(InFmt,"TSB1",tsb1, __RC__) - call MAPL_VarRead(InFmt,"TSB2",tsb2, __RC__) - call MAPL_VarRead(InFmt,"ATAU",atau, __RC__) - call MAPL_VarRead(InFmt,"BTAU",btau, __RC__) - call MAPL_VarRead(InFmt,"OLD_ITY",ity, __RC__) - call MAPL_VarRead(InFmt,"TC",tc, __RC__) - call MAPL_VarRead(InFmt,"QC",qc, __RC__) - call MAPL_VarRead(InFmt,"OLD_ITY",ity, __RC__) - call MAPL_VarRead(InFmt,"CAPAC",capac, __RC__) - call MAPL_VarRead(InFmt,"CATDEF",catdef, __RC__) - call MAPL_VarRead(InFmt,"RZEXC",rzexc, __RC__) - call MAPL_VarRead(InFmt,"SRFEXC",srfexc, __RC__) - call MAPL_VarRead(InFmt,"GHTCNT1",ghtcnt1, __RC__) - call MAPL_VarRead(InFmt,"GHTCNT2",ghtcnt2, __RC__) - call MAPL_VarRead(InFmt,"GHTCNT3",ghtcnt3, __RC__) - call MAPL_VarRead(InFmt,"GHTCNT4",ghtcnt4, __RC__) - call MAPL_VarRead(InFmt,"GHTCNT5",ghtcnt5, __RC__) - call MAPL_VarRead(InFmt,"GHTCNT6",ghtcnt6, __RC__) - call MAPL_VarRead(InFmt,"TSURF",tsurf, __RC__) - call MAPL_VarRead(InFmt,"WESNN1",wesnn1, __RC__) - call MAPL_VarRead(InFmt,"WESNN2",wesnn2, __RC__) - call MAPL_VarRead(InFmt,"WESNN3",wesnn3, __RC__) - call MAPL_VarRead(InFmt,"HTSNNN1",htsnnn1, __RC__) - call MAPL_VarRead(InFmt,"HTSNNN2",htsnnn2, __RC__) - call MAPL_VarRead(InFmt,"HTSNNN3",htsnnn3, __RC__) - call MAPL_VarRead(InFmt,"SNDZN1",sndzn1, __RC__) - call MAPL_VarRead(InFmt,"SNDZN2",sndzn2, __RC__) - call MAPL_VarRead(InFmt,"SNDZN3",sndzn3, __RC__) - call MAPL_VarRead(InFmt,"CH",ch, __RC__) - call MAPL_VarRead(InFmt,"CM",cm, __RC__) - call MAPL_VarRead(InFmt,"CQ",cq, __RC__) - call MAPL_VarRead(InFmt,"FR",fr, __RC__) - call MAPL_VarRead(InFmt,"WW",ww, __RC__) - - write(unit) bf1 - write(unit) bf2 - write(unit) bf3 - write(unit) vgwmax - write(unit) cdcr1 - write(unit) cdcr2 - write(unit) psis - write(unit) bee - write(unit) poros - write(unit) wpwet - write(unit) cond - write(unit) gnu - write(unit) ars1 - write(unit) ars2 - write(unit) ars3 - write(unit) ara1 - write(unit) ara2 - write(unit) ara3 - write(unit) ara4 - write(unit) arw1 - write(unit) arw2 - write(unit) arw3 - write(unit) arw4 - write(unit) tsa1 - write(unit) tsa2 - write(unit) tsb1 - write(unit) tsb2 - write(unit) atau - write(unit) btau - write(unit) ity - write(unit) tc - write(unit) qc - write(unit) capac - write(unit) catdef - write(unit) rzexc - write(unit) srfexc - write(unit) ghtcnt1 - write(unit) ghtcnt2 - write(unit) ghtcnt3 - write(unit) ghtcnt4 - write(unit) ghtcnt5 - write(unit) ghtcnt6 - write(unit) tsurf - write(unit) wesnn1 - write(unit) wesnn2 - write(unit) wesnn3 - write(unit) htsnnn1 - write(unit) htsnnn2 - write(unit) htsnnn3 - write(unit) sndzn1 - write(unit) sndzn2 - write(unit) sndzn3 - write(unit) ch - write(unit) cm - write(unit) cq - write(unit) fr - write(unit) ww - - END SUBROUTINE write_bin - - ! ---------------------------------------------------------------------------- - - SUBROUTINE read_ldas_restarts (NTILES, ntiles_rst, id_glb, ld_reorder, rst_file, pfile) - - implicit none - integer, intent (in) :: NTILES, ntiles_rst - integer, intent (in) :: id_glb(NTILES), ld_reorder (ntiles_rst) - integer :: k - character(*), intent (in) :: rst_file, pfile - real , dimension (:), allocatable :: var_get, var_put - type(Netcdf4_FileFormatter) :: OutFmt, InFmt - type(FileMetadata) :: meta_data - - allocate (var_get (NTILES_RST)) - allocate (var_put (NTILES)) - - call InFmt%Open(trim(InCatRestart), pFIO_READ, __RC__) - meta_data = InFmt%read(__RC__) - call InFmt%close() - call meta_data%modify_dimension('tile', ntiles, __RC__) - - OutFileName = "InData/catch_internal_rst" - call OutFmt%create(OutFileName, __RC__) - call OutFmt%write(meta_data, __RC__) - - open(10, file=trim(rst_file), form='unformatted', status='old', & - convert='big_endian', action='read') - - read (10) var_get ! (cat_progn(n)%tc1, n=1,N_catd) - do k = 1, NTILES - VAR_PUT(k) = var_get(ld_reorder(id_glb(k))) - end do - call MAPL_VarWrite(OutFmt,'TC',var_put, offset1=1) - - read (10) var_get ! (cat_progn(n)%tc2, n=1,N_catd) - do k = 1, NTILES - VAR_PUT(k) = var_get(ld_reorder(id_glb(k))) - end do - call MAPL_VarWrite(OutFmt,'TC',var_put, offset1=2) - - read (10) var_get ! (cat_progn(n)%tc4, n=1,N_catd) - do k = 1, NTILES - VAR_PUT(k) = var_get(ld_reorder(id_glb(k))) - end do - call MAPL_VarWrite(OutFmt,'TC',var_put, offset1=3) - - read (10) var_get ! (cat_progn(n)%qa1, n=1,N_catd) - do k = 1, NTILES - VAR_PUT(k) = var_get(ld_reorder(id_glb(k))) - end do - call MAPL_VarWrite(OutFmt,'QC',var_put, offset1=1) - - read (10) var_get ! (cat_progn(n)%qa2, n=1,N_catd) - do k = 1, NTILES - VAR_PUT(k) = var_get(ld_reorder(id_glb(k))) - end do - call MAPL_VarWrite(OutFmt,'QC',var_put, offset1=2) - - read (10) var_get ! (cat_progn(n)%qa4, n=1,N_catd) - do k = 1, NTILES - VAR_PUT(k) = var_get(ld_reorder(id_glb(k))) - end do - call MAPL_VarWrite(OutFmt,'QC',var_put, offset1=3) - call MAPL_VarWrite(OutFmt,'QC',var_put, offset1=4) - - read (10) var_get ! (cat_progn(n)%capac, n=1,N_catd) - do k = 1, NTILES - VAR_PUT(k) = var_get(ld_reorder(id_glb(k))) - end do - call MAPL_VarWrite(OutFmt,'CAPAC',var_put) - - read (10) var_get ! (cat_progn(n)%catdef, n=1,N_catd) - do k = 1, NTILES - VAR_PUT(k) = var_get(ld_reorder(id_glb(k))) - end do - call MAPL_VarWrite(OutFmt,'CATDEF',var_put) - - read (10) var_get ! (cat_progn(n)%rzexc, n=1,N_catd) - do k = 1, NTILES - VAR_PUT(k) = var_get(ld_reorder(id_glb(k))) - end do - call MAPL_VarWrite(OutFmt,'RZEXC',var_put) - - read (10) var_get ! (cat_progn(n)%srfexc, n=1,N_catd) - do k = 1, NTILES - VAR_PUT(k) = var_get(ld_reorder(id_glb(k))) - end do - call MAPL_VarWrite(OutFmt,'SRFEXC',var_put) - - read (10) var_get ! (cat_progn(n)%ght(k), n=1,N_catd) - do k = 1, NTILES - VAR_PUT(k) = var_get(ld_reorder(id_glb(k))) - end do - call MAPL_VarWrite(OutFmt,'GHTCNT1',var_put) - read (10) var_get ! (cat_progn(n)%ght(k), n=1,N_catd) - do k = 1, NTILES - VAR_PUT(k) = var_get(ld_reorder(id_glb(k))) - end do - call MAPL_VarWrite(OutFmt,'GHTCNT2',var_put) - read (10) var_get ! (cat_progn(n)%ght(k), n=1,N_catd) - do k = 1, NTILES - VAR_PUT(k) = var_get(ld_reorder(id_glb(k))) - end do - call MAPL_VarWrite(OutFmt,'GHTCNT3',var_put) - read (10) var_get ! (cat_progn(n)%ght(k), n=1,N_catd) - do k = 1, NTILES - VAR_PUT(k) = var_get(ld_reorder(id_glb(k))) - end do - call MAPL_VarWrite(OutFmt,'GHTCNT4',var_put) - read (10) var_get ! (cat_progn(n)%ght(k), n=1,N_catd) - do k = 1, NTILES - VAR_PUT(k) = var_get(ld_reorder(id_glb(k))) - end do - call MAPL_VarWrite(OutFmt,'GHTCNT5',var_put) - read (10) var_get ! (cat_progn(n)%ght(k), n=1,N_catd) - do k = 1, NTILES - VAR_PUT(k) = var_get(ld_reorder(id_glb(k))) - end do - call MAPL_VarWrite(OutFmt,'GHTCNT6',var_put) - - read (10) var_get !(cat_progn(n)%wesn(k), n=1,N_catd) - do k = 1, NTILES - VAR_PUT(k) = var_get(ld_reorder(id_glb(k))) - end do - call MAPL_VarWrite(OutFmt,'WESNN1',var_put) - read (10) var_get !(cat_progn(n)%wesn(k), n=1,N_catd) - do k = 1, NTILES - VAR_PUT(k) = var_get(ld_reorder(id_glb(k))) - end do - call MAPL_VarWrite(OutFmt,'WESNN2',var_put) - read (10) var_get !(cat_progn(n)%wesn(k), n=1,N_catd) - do k = 1, NTILES - VAR_PUT(k) = var_get(ld_reorder(id_glb(k))) - end do - call MAPL_VarWrite(OutFmt,'WESNN3',var_put) - - read (10) var_get !(cat_progn(n)%htsn(k), n=1,N_catd) - do k = 1, NTILES - VAR_PUT(k) = var_get(ld_reorder(id_glb(k))) - end do - call MAPL_VarWrite(OutFmt,'HTSNNN1',var_put) - read (10) var_get !(cat_progn(n)%htsn(k), n=1,N_catd) - do k = 1, NTILES - VAR_PUT(k) = var_get(ld_reorder(id_glb(k))) - end do - call MAPL_VarWrite(OutFmt,'HTSNNN2',var_put) - read (10) var_get !(cat_progn(n)%htsn(k), n=1,N_catd) - do k = 1, NTILES - VAR_PUT(k) = var_get(ld_reorder(id_glb(k))) - end do - call MAPL_VarWrite(OutFmt,'HTSNNN3',var_put) - - read (10) var_get !(cat_progn(n)%sndz(k), n=1,N_catd) - do k = 1, NTILES - VAR_PUT(k) = var_get(ld_reorder(id_glb(k))) - end do - call MAPL_VarWrite(OutFmt,'SNDZN1',var_put) - read (10) var_get !(cat_progn(n)%sndz(k), n=1,N_catd) - do k = 1, NTILES - VAR_PUT(k) = var_get(ld_reorder(id_glb(k))) - end do - call MAPL_VarWrite(OutFmt,'SNDZN2',var_put) - read (10) var_get !(cat_progn(n)%sndz(k), n=1,N_catd) - do k = 1, NTILES - VAR_PUT(k) = var_get(ld_reorder(id_glb(k))) - end do - call MAPL_VarWrite(OutFmt,'SNDZN3',var_put) - - close (10) - -! PARAM - - open(10, file=trim(pfile), form='unformatted', status='old', & - convert='big_endian', action='read') - - - read (10) var_get !(cat_param(n)%dpth, n=1,N_catd) - - read (10) var_get !(cat_param(n)%dzsf, n=1,N_catd) - read (10) var_get !(cat_param(n)%dzrz, n=1,N_catd) - read (10) var_get !(cat_param(n)%dzpr, n=1,N_catd) - - do k=1,6 - read (10) var_get !(cat_param(n)%dzgt(k), n=1,N_catd) - end do - do k = 1, NTILES - VAR_PUT(k) = id_glb(k) - end do - call MAPL_VarWrite(OutFmt,'TILE_ID',var_put) - - read (10) var_get !(cat_param(n)%poros, n=1,N_catd) - do k = 1, NTILES - VAR_PUT(k) = var_get(ld_reorder(id_glb(k))) - end do - call MAPL_VarWrite(OutFmt,'POROS',var_put) - - read (10) var_get !(cat_param(n)%cond, n=1,N_catd) - do k = 1, NTILES - VAR_PUT(k) = var_get(ld_reorder(id_glb(k))) - end do - call MAPL_VarWrite(OutFmt,'COND',var_put) - - read (10) var_get !(cat_param(n)%psis, n=1,N_catd) - do k = 1, NTILES - VAR_PUT(k) = var_get(ld_reorder(id_glb(k))) - end do - call MAPL_VarWrite(OutFmt,'PSIS',var_put) - - read (10) var_get !(cat_param(n)%bee, n=1,N_catd) - do k = 1, NTILES - VAR_PUT(k) = var_get(ld_reorder(id_glb(k))) - end do - call MAPL_VarWrite(OutFmt,'BEE',var_put) - - read (10) var_get !(cat_param(n)%wpwet, n=1,N_catd) - do k = 1, NTILES - VAR_PUT(k) = var_get(ld_reorder(id_glb(k))) - end do - call MAPL_VarWrite(OutFmt,'WPWET',var_put) - - read (10) var_get !(cat_param(n)%gnu, n=1,N_catd) - do k = 1, NTILES - VAR_PUT(k) = var_get(ld_reorder(id_glb(k))) - end do - call MAPL_VarWrite(OutFmt,'GNU',var_put) - - read (10) var_get !(cat_param(n)%vgwmax, n=1,N_catd) - do k = 1, NTILES - VAR_PUT(k) = var_get(ld_reorder(id_glb(k))) - end do - call MAPL_VarWrite(OutFmt,'VGWMAX',var_put) - - read (10) var_get !(cat_param(n)%vegcls, n=1,N_catd) - do k = 1, NTILES - VAR_PUT(k) = var_get(ld_reorder(id_glb(k))) - end do - call MAPL_VarWrite(OutFmt,'OLD_ITY',var_put) - - read (10) var_get !(cat_param(n)%soilcls30, n=1,N_catd) - read (10) var_get !(cat_param(n)%soilcls100, n=1,N_catd) - - read (10) var_get !(cat_param(n)%bf1, n=1,N_catd) - do k = 1, NTILES - VAR_PUT(k) = var_get(ld_reorder(id_glb(k))) - end do - call MAPL_VarWrite(OutFmt,'BF1',var_put) - - read (10) var_get !(cat_param(n)%bf2, n=1,N_catd) - do k = 1, NTILES - VAR_PUT(k) = var_get(ld_reorder(id_glb(k))) - end do - call MAPL_VarWrite(OutFmt,'BF2',var_put) - - read (10) var_get !(cat_param(n)%bf3, n=1,N_catd) - do k = 1, NTILES - VAR_PUT(k) = var_get(ld_reorder(id_glb(k))) - end do - call MAPL_VarWrite(OutFmt,'BF3',var_put) - - read (10) var_get !(cat_param(n)%cdcr1, n=1,N_catd) - do k = 1, NTILES - VAR_PUT(k) = var_get(ld_reorder(id_glb(k))) - end do - call MAPL_VarWrite(OutFmt,'CDCR1',var_put) - - read (10) var_get !(cat_param(n)%cdcr2, n=1,N_catd) - do k = 1, NTILES - VAR_PUT(k) = var_get(ld_reorder(id_glb(k))) - end do - call MAPL_VarWrite(OutFmt,'CDCR2',var_put) - - read (10) var_get !(cat_param(n)%ars1, n=1,N_catd) - do k = 1, NTILES - VAR_PUT(k) = var_get(ld_reorder(id_glb(k))) - end do - call MAPL_VarWrite(OutFmt,'ARS1',var_put) - - read (10) var_get !(cat_param(n)%ars2, n=1,N_catd) - do k = 1, NTILES - VAR_PUT(k) = var_get(ld_reorder(id_glb(k))) - end do - call MAPL_VarWrite(OutFmt,'ARS2',var_put) - - read (10) var_get !(cat_param(n)%ars3, n=1,N_catd) - do k = 1, NTILES - VAR_PUT(k) = var_get(ld_reorder(id_glb(k))) - end do - call MAPL_VarWrite(OutFmt,'ARS3',var_put) - - read (10) var_get !(cat_param(n)%ara1, n=1,N_catd) - do k = 1, NTILES - VAR_PUT(k) = var_get(ld_reorder(id_glb(k))) - end do - call MAPL_VarWrite(OutFmt,'ARA1',var_put) - - read (10) var_get !(cat_param(n)%ara2, n=1,N_catd) - do k = 1, NTILES - VAR_PUT(k) = var_get(ld_reorder(id_glb(k))) - end do - call MAPL_VarWrite(OutFmt,'ARA2',var_put) - - read (10) var_get !(cat_param(n)%ara3, n=1,N_catd) - do k = 1, NTILES - VAR_PUT(k) = var_get(ld_reorder(id_glb(k))) - end do - call MAPL_VarWrite(OutFmt,'ARA3',var_put) - - read (10) var_get !(cat_param(n)%ara4, n=1,N_catd) - do k = 1, NTILES - VAR_PUT(k) = var_get(ld_reorder(id_glb(k))) - end do - call MAPL_VarWrite(OutFmt,'ARA4',var_put) - - read (10) var_get !(cat_param(n)%arw1, n=1,N_catd) - do k = 1, NTILES - VAR_PUT(k) = var_get(ld_reorder(id_glb(k))) - end do - call MAPL_VarWrite(OutFmt,'ARW1',var_put) - - read (10) var_get !(cat_param(n)%arw2, n=1,N_catd) - do k = 1, NTILES - VAR_PUT(k) = var_get(ld_reorder(id_glb(k))) - end do - call MAPL_VarWrite(OutFmt,'ARW2',var_put) - - read (10) var_get !(cat_param(n)%arw3, n=1,N_catd) - do k = 1, NTILES - VAR_PUT(k) = var_get(ld_reorder(id_glb(k))) - end do - call MAPL_VarWrite(OutFmt,'ARW3',var_put) - - read (10) var_get !(cat_param(n)%arw4, n=1,N_catd) - do k = 1, NTILES - VAR_PUT(k) = var_get(ld_reorder(id_glb(k))) - end do - call MAPL_VarWrite(OutFmt,'ARW4',var_put) - - read (10) var_get !(cat_param(n)%tsa1, n=1,N_catd) - do k = 1, NTILES - VAR_PUT(k) = var_get(ld_reorder(id_glb(k))) - end do - call MAPL_VarWrite(OutFmt,'TSA1',var_put) - - read (10) var_get !(cat_param(n)%tsa2, n=1,N_catd) - do k = 1, NTILES - VAR_PUT(k) = var_get(ld_reorder(id_glb(k))) - end do - call MAPL_VarWrite(OutFmt,'TSA2',var_put) - - read (10) var_get !(cat_param(n)%tsb1, n=1,N_catd) - do k = 1, NTILES - VAR_PUT(k) = var_get(ld_reorder(id_glb(k))) - end do - call MAPL_VarWrite(OutFmt,'TSB1',var_put) - - read (10) var_get !(cat_param(n)%tsb2, n=1,N_catd) - do k = 1, NTILES - VAR_PUT(k) = var_get(ld_reorder(id_glb(k))) - end do - call MAPL_VarWrite(OutFmt,'TSB2',var_put) - - read (10) var_get !(cat_param(n)%atau, n=1,N_catd) - do k = 1, NTILES - VAR_PUT(k) = var_get(ld_reorder(id_glb(k))) - end do - call MAPL_VarWrite(OutFmt,'ATAU',var_put) - - read (10) var_get !(cat_param(n)%btau, n=1,N_catd) - do k = 1, NTILES - VAR_PUT(k) = var_get(ld_reorder(id_glb(k))) - end do - call MAPL_VarWrite(OutFmt,'BTAU',var_put) - - read (10) var_get !(cat_param(n)%gravel30, n=1,N_catd) - read (10) var_get !(cat_param(n)%orgC30 , n=1,N_catd) - read (10) var_get !(cat_param(n)%orgC , n=1,N_catd) - read (10) var_get !(cat_param(n)%sand30 , n=1,N_catd) - read (10) var_get !(cat_param(n)%clay30 , n=1,N_catd) - read (10) var_get !(cat_param(n)%sand , n=1,N_catd) - read (10) var_get !(cat_param(n)%clay , n=1,N_catd) - read (10) var_get !(cat_param(n)%wpwet30 , n=1,N_catd) - read (10) var_get !(cat_param(n)%poros30 , n=1,N_catd) - - close (10, status = 'keep') - deallocate (var_get, var_put) - - call OutFmt%close() - - call system('/bin/cp InData/catch_internal_rst OutData/catch_internal_rst') - - END SUBROUTINE read_ldas_restarts - - END PROGRAM mk_GEOSldasRestarts diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/mk_restarts/mk_Restarts b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/mk_restarts/mk_Restarts deleted file mode 100755 index 7040cf2a65..0000000000 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/mk_restarts/mk_Restarts +++ /dev/null @@ -1,404 +0,0 @@ -#!/usr/bin/env perl -#======================================================================= -# name - mk_Restarts -# purpose - wrapper script to run programs which regrid surface restarts -#======================================================================= -use strict; -use warnings; -use FindBin qw($Bin); -use lib ("$Bin"); -use Cwd qw(getcwd); - -# global variables -#----------------- -my ($saltwater, $openwater, $seaice, $lake, $landice, $route); -my ($catchFLG, $catchcn, $catchcnFLG, @cnlist, @cnlen); -my ($surflay, $rsttime, $grpID, $numtasks, $walltime, $rescale, $qos, $partition, $constraint, $yyyymm); -my ($mk_catch_j, $mk_catch_log, $weminIN, $weminOUT, $weminDFLT); -my ($zoom); - -# mk_catch job and log file names (also applies to catchcn) -#---------------------------------------------------------- -$mk_catch_j = "mk_catch.j"; -$mk_catch_log = "mk_catch.log"; - -# main program -#------------- -{ - my ($cmd, $line, $pid); - - init(); - - #--------------------------- - # catch and catchcn restarts - #--------------------------- - if ($catchFLG or $catchcnFLG) { - write_mk_catch_j() unless -e $mk_catch_j; - - # run interactively if already on interactive job nodes - #------------------------------------------------------ - if (-x $mk_catch_j) { - $cmd = "./$mk_catch_j"; - system_($cmd); - } - else { - $cmd = "sbatch -W $mk_catch_j"; - print "$cmd\n"; - chomp($line = `$cmd`); - $pid = (split /\s+/, $line)[-1]; - } - } - - #------------------ - # saltwater restart - #------------------ - if ($saltwater) { - $cmd = "$Bin/mk_LakeLandiceSaltRestarts " - . "OutData/\*.til " - . "InData/\*.til " - . "InData/\*saltwater_internal_rst\* 0 $zoom"; - system_($cmd); - } - - if ($openwater) { - $cmd = "$Bin/mk_LakeLandiceSaltRestarts " - . "OutData/\*.til " - . "InData/\*.til " - . "InData/\*openwater_internal_rst\* 0 $zoom"; - system_($cmd); - } - - if ($seaice) { - $cmd = "$Bin/mk_LakeLandiceSaltRestarts " - . "OutData/\*.til " - . "InData/\*.til " - . "InData/\*seaicethermo_internal_rst\* 0 $zoom"; - system_($cmd); - } - - #------------- - # lake restart - #------------- - if ($lake) { - $cmd = "$Bin/mk_LakeLandiceSaltRestarts " - . "OutData/\*.til " - . "InData/\*.til " - . "InData/\*lake_internal_rst\* 19 $zoom"; - system_($cmd); - } - - #---------------- - # landice restart - #---------------- - if ($landice) { - $cmd = "$Bin/mk_LakeLandiceSaltRestarts " - . "OutData/\*.til " - . "InData/\*.til " - . "InData/\*landice_internal_rst\* 20 $zoom"; - system_($cmd); - } - - #-------------- - # route restart - #-------------- - if ($route) { - $cmd = "$Bin/mk_RouteRestarts OutData/\*.til $yyyymm"; - system_($cmd); - } - wait_for_pid($pid) if $pid; -} - -#======================================================================= -# name - init -# purpose - get runtime flags to determine which restarts to regrid -#======================================================================= -sub init { - use Getopt::Long; - my $help; - $| = 1; # flush buffer after each output operation - - GetOptions( "saltwater" => \$saltwater, - "openwater" => \$openwater, - "seaice" => \$seaice, - "lake" => \$lake, - "landice" => \$landice, - "catch" => \$catchFLG, - "catchcn=s" => \$catchcn, - "wemin=i" => \$weminIN, - "wemout=i" => \$weminOUT, - "route" => \$route, - - "surflay=i" => \$surflay, - "rsttime=i" => \$rsttime, - "grpID=s" => \$grpID, - - "constraint=s" => \$constraint, - - "ntasks=i" => \$numtasks, - "walltime=s"=> \$walltime, - "rescale" => \$rescale, - "qos=s" => \$qos, - "partition=s" => \$partition, - "zoom=i" => \$zoom, - "h|help" => \$help ); - # defaults - #--------- - $rsttime = 0 unless $rsttime; - $catchcnFLG = 0 unless $catchcn; - $rescale = 0 unless $rescale; - $weminDFLT = 26; - $weminIN = $weminDFLT unless defined($weminIN); - $weminOUT = $weminDFLT unless defined($weminOUT); - $zoom = 8 unless $zoom; - - usage() if $help; - - # unpack catchcn values - #---------------------- - if ($catchcn) { - $catchcnFLG = 1; - @cnlist = split(/,/, $catchcn); - @cnlen = scalar(@cnlist); - } - - # error if no restart specified - #------------------------------ - die "Error. No restart specified;" - unless $saltwater or $lake or $landice or $catchFLG or $catchcnFLG; - - # rsttime and grpID values are needed for catchcn - #---------------------------------------------- - if ($catchcnFLG) { - die "Error. Must specify rsttime for catchcn;" unless $rsttime; - die "Error. rsttime not in yyyymmddhh format: $rsttime;" - unless $rsttime =~ m/^\d{10}$/; - } - if ($catchFLG or $catchcnFLG) { - unless ($grpID) { - $grpID = `$Bin/getsponsor.pl -d`; - print "Using default grpID = $grpID\n"; - } - unless ($walltime) { $walltime = "1:00:00" } - unless ($numtasks) { $numtasks = 84 } - $qos = "" unless $qos; - $partition = "" unless $partition; - $constraint = "" unless $constraint; - } - - # rsttime value is needed for route - #---------------------------------- - if ($route) { - die "Error. Must specify rsttime for route;" unless $rsttime; - die "Error. Cannot extract yyyymm from rsttime: $rsttime" - unless $rsttime =~ m/^\d{6,}$/; - $yyyymm = $1 if $rsttime =~ /^(\d{6})/; - } -} - -#======================================================================= -# name - write_mk_catch_j -# purpose - write job file to make catch and/or catchcn restart -#======================================================================= -sub write_mk_catch_j { - my ($grouplist, $cwd, $QOSline, $PARTline, $CONSline, $FH); - - $grouplist = ""; - $grouplist = "SBATCH --account=$grpID" if $grpID; - - $cwd = getcwd; - - $QOSline = ""; - if ($qos) { - $QOSline = "SBATCH --qos=$qos"; - if ($qos eq "debug") { - $QOSline = "" unless $numtasks <= 532 and $walltime le "1:00:00"; - } - } - $PARTline = ""; - if ($partition) { - $PARTline = "SBATCH --partition=$partition"; - } - $CONSline = ""; - if ($constraint) { - $CONSline = "SBATCH --constraint=$constraint"; - } - print("\nWriting jobscript: $mk_catch_j\n"); - open CNj, ">> $mk_catch_j" or die "Error opening $mk_catch_j: $!"; - - $FH = select; - select CNj; - - print <<"EOF"; -#!/bin/csh -f -#$grouplist -#SBATCH --ntasks=$numtasks -#SBATCH --time=$walltime -#SBATCH --job-name=catchcnj -#SBATCH --output=$cwd/$mk_catch_log -#$QOSline -#$PARTline -#$CONSline - -source $Bin/g5_modules -set echo - -#limit stacksize unlimited -unlimit - -set catchFLG = $catchFLG -set catchcnFLG = $catchcnFLG -set weminIN = $weminIN -set weminOUT = $weminOUT -set rescaleFLG = $rescale - -set numtasks = $numtasks -set rsttime = $rsttime -set surflay = $surflay -set zoom = $zoom - -set esma_mpirun_X = ( $Bin/esma_mpirun -np \$numtasks ) -set mk_CatchRestarts_X = ( \$esma_mpirun_X $Bin/mk_CatchRestarts ) -set mk_CatchCNRestarts_X = ( \$esma_mpirun_X $Bin/mk_CatchCNRestarts ) -set mk_GEOSldasRestarts_X = ( \$esma_mpirun_X $Bin/mk_GEOSldasRestarts ) -set Scale_Catch_X = $Bin/Scale_Catch -set Scale_CatchCN_X = $Bin/Scale_CatchCN - -set OUT_til = OutData/\*.til -set IN_til = InData/\*.til - -if (\$catchFLG) then - set catchIN = InData/\*catch_internal_rst\* - set params = ( \$OUT_til \$IN_til \$catchIN \$surflay ) - \$mk_CatchRestarts_X \$params - - if (\$rescaleFLG) then - set catch_regrid = OutData/\$catchIN:t - set catch_scaled = \${catch_regrid}.scaled - set params = ( \$catchIN \$catch_regrid \$catch_scaled \$surflay ) - set params = ( \$params \$weminIN \$weminOUT ) - \$Scale_Catch_X \$params - - mv \$catch_regrid \${catch_regrid}.1 - mv \$catch_scaled \$catch_regrid - endif -endif - -if (\$catchcnFLG) then - if ($cnlen[0] == 1) then - set catchcnIN = InData/\*catchcn_internal_rst\* - set params = ( \$OUT_til \$IN_til \$catchcnIN \$surflay \$rsttime ) - \$mk_CatchCNRestarts_X \$params - endif - if ($cnlen[0] == 4) then - set OUT_til = `ls OutData/\*.til | cut -d '/' -f2` - /bin/cp OutData/\*.til OutData/OutTileFile - /bin/cp OutData/\*.til InData/OutTileFile - set CN_VERSION = $cnlist[0] - set RESTART_ID = $cnlist[1] - set RESTART_PATH = $cnlist[2] - set RESTART_DOMAIN = $cnlist[3] - set RESTART_short = \${RESTART_PATH}/\${RESTART_ID}/output/\${RESTART_DOMAIN}/ - set YYYY = `echo \${rsttime} | cut -c1-4` - set MM = `echo \${rsttime} | cut -c5-6` - set PARAM_FILE = `ls \$RESTART_short/rc_out/Y\${YYYY}/M\${MM}/*ldas_catparam* | head -1` - set params = ( -b OutData/ -d \$rsttime -e \$RESTART_ID -m catchcn\$CN_VERSION -s \$surflay -j Y -r R -p \$PARAM_FILE -l \$RESTART_short) - \$mk_GEOSldasRestarts_X \$params - endif - if (\$rescaleFLG) then - set catchcnIN = InData/catchcn\${CN_VERSION}_internal_rst\* - set catchcn_regrid = OutData/\$catchcnIN:t - set catchcn_scaled = \${catchcn_regrid}.scaled - set params = ( \$catchcnIN \$catchcn_regrid \$catchcn_scaled \$surflay ) - set params = ( \$params \$weminIN \$weminOUT ) - \$Scale_CatchCN_X \$params - - mv \$catchcn_regrid \${catchcn_regrid}.1 - mv \$catchcn_scaled \$catchcn_regrid - endif -endif -exit -EOF -; - close CNj; - select $FH; - chmod 0755, $mk_catch_j if $ENV{"SLURM_JOBID"}; -} - -#======================================================================= -# name - system_ -# purpose - wrapper for perl system command -#======================================================================= -sub system_ { - my $cmd = shift @_; - print "\n$cmd\n"; - die "Error: $!;" if system($cmd); -} - -#======================================================================= -# name - wait_for_pid -# purpose - wait for batch job to finish -# -# input parameter -# => $pid: process ID of batch job to wait for -#======================================================================= -sub wait_for_pid { - my ($pid, $first, %found, $line, $id); - $pid = shift @_; - return unless $pid; - - $first = 1; - while (1) { - %found = (); - #--foreach $line (`qstat | grep $ENV{"USER"}`) { - foreach $line (`squeue | grep $ENV{"USER"}`) { - $line =~ s/^\s+//; - $id = (split /\s+/, $line)[0]; - $found{$id} = 1; - } - last unless $found{$pid}; - print "\nWaiting for job $pid to finish\n" if $first; - $first = 0; - sleep 10; - } - print "Job $pid is DONE\n\n" unless $first; -} - -#======================================================================= -# name - usage -# purpose - print usage information -#======================================================================= -sub usage { - use File::Basename ("basename"); - my $name = basename $0; - print <<"EOF"; - -usage $name [-saltwater] [-lake] [-landice] [-catch] [-h] - -option flags - -saltwater regrid saltwater internal restart - -lake regrid lake internal restart - -landice regrid landice internal restart - -catch regrid catchment internal restart - -catchcn regrid catchment CN internal restart - -wemin weminIN minimum snow water equivalent threshold for input catch/cn [$weminDFLT] - -wemout weminOUT minimum snow water equivalent threshold for output catch/cn [$weminDFLT] - -route create the route internal restart - -surflay n thickness [mm] of surface soil moisture layer (catch & catchcn) - Ganymed-3 and earlier: SURFLAY=20 - Ganymed-4 and later : SURFLAY=50 - -rsttime n10 restart time in format, yyyymmddhh (catchcn) or yyyymm (route) - -grpID grpID group ID for batch submittal (catchcn) - -ntasks nt number of tasks to assign to catchcn batch job [112] - -walltime wt walltime in format \"hh:mm:ss\" for catchcn batch job [1:00:00] - -rescale - -qos val use \"SBATCH --qos=val directive\" for batch jobs; - \"-qos debug\" will not work unless these conditions are met - -> numtasks <= 532 - -> walltime le \"1:00:00\" - -partition val use \"SBATCH --partition=val directive\" for batch jobs - -zoom n zoom value to send to land regridding codes [8] - -h print usage information - -EOF -exit; -} diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/mk_restarts/obsolete/catchplt b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/mk_restarts/obsolete/catchplt deleted file mode 100755 index dd2d3fc402..0000000000 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/mk_restarts/obsolete/catchplt +++ /dev/null @@ -1,25 +0,0 @@ -n = 1 -while ( n < 64 ) - -m = n -if( m < 10 ) ; m = 0n ; endif - -'set dfile 1' -'setx' -'set y 1' -'set z 1' -'set cmark 0' -'d var'm'.1' - -'set dfile 2' -'setx' -'set y 1' -'set z 1' -'set cmark 0' -'d var'm'.2' - -'draw title Var: 'm -pull flag -'c' -n = n + 1 -endwhile diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/mk_restarts/obsolete/check_land_restarts.pro b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/mk_restarts/obsolete/check_land_restarts.pro deleted file mode 100755 index 54afd3705d..0000000000 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/mk_restarts/obsolete/check_land_restarts.pro +++ /dev/null @@ -1,1167 +0,0 @@ -; ========================================================================= -; USAGE : -; Edit lines to 44-47 specify paths to BCs dir and yjecatch{cn}_internal_rst file -; ========================================================================= -;_____________________________________________________________________ -;_____________________________________________________________________ - -FUNCTION NCDF_ISNCDF, FILENAME - -;- Set return values - -false = 0B -true = 1B - -;- Establish error handler - -catch, error_status -if error_status ne 0 then begin - catch, /cancel - return, false -endif - -;- Try opening the file - -cdfid = ncdf_open( filename ) - -;- If we get this far, open must have worked - -ncdf_close, cdfid -catch, /cancel -return, true - -END - -;_____________________________________________________________________ -;_____________________________________________________________________ - -pro plot_rst - -; ********************************************************************************************************** -; STEP (1) Specify below: -; ----------------------- - -BCSDIR = '/discover/nobackup/smahanam/bcs/Heracles-4_3/Heracles-4_3_MERRA-3/CF0180x6C_DE1440xPE0720/' -GFILE = 'CF0180x6C_DE1440xPE0720-Pfafstetter' -OutDir = 'OutData2/' -int_rst = 'catchcn_internal_rst' - -; STEP (2) save : -; --------------- -; On dali : (a) module load tool/idl-8.5, (b) idl (c) .compile chk_restarts -; and (d) plot_rst - -; ********************************************************************************************************** - -; Setting up and select variables for plotting -; -------------------------------------------- - -TILFILE = BCSDIR + 'til/' + GFILE + '.til' -RSTFILE = BCSDIR + 'rst/' + GFILE + '.rst' - -NTILES = 0l -NG = 0l -NC = 0l -NR = 0l - -openr,1,BCSDIR + 'clsm/catchment.def' -readf,1,NTILES -close,1 - -openr,1,TILFILE -readf,1,NG,NC,NR -close,1 - -Var_Names = [ $ - 'CDCR2' , $ ; 0 - 'BEE' , $ ; 1 - 'POROS' , $ ; 2 - 'ITY1' , $ ; 3 - 'ITY2' , $ ; 4 - 'ITY3' , $ ; 5 - 'ITY4' , $ ; 6 - 'TC1' , $ ; 7 - 'TC2' , $ ; 8 - 'TC3' , $ ; 9 - 'TC4' , $ ;10 - 'CATDEF' , $ ;11 - 'RZEXC' , $ ;12 - 'SFEXC' ] - -N_VARS = N_ELEMENTS (Var_Names) -PLOT_VARS = fltarr (NTILES,N_VARS) -TMP_VAR1 = fltarr (NTILES) -TMP_VAR2 = fltarr (NTILES,4) - - -; Get file information : (1) model, (2) file format -; ------------------------------------------------- - -catch_model = boolean (strcmp(int_rst,'catchcn',7,/fold_case) eq 0) -ncdf_file = boolean (ncdf_isncdf(OutDir + int_rst)) - -; Set up vector to grid for plotting -; ---------------------------------- - -NC_plot = 4320 -NR_plot = 2160 - -tileid_plot = lonarr (NC_plot,NR_plot) - -dx = NC/NC_plot -dy = NR/NR_plot - -catrow = lonarr(nc) -cat = lonarr(nc,dy) - -openr,1,RSTFILE,/F77_UNFORMATTED - -for j = 0l, NR_plot -1 do begin - - for i=0,dy -1 do begin - readu,1,catrow - cat (*,i) = catrow - endfor - - for i = 0, NC_plot -1 do begin - subset = cat (i*dx: (i+1)*dx -1,*) - if (min (subset) le NTILES) then begin - min1 = min(subset) - subset(where (subset gt NTILES)) = 0 - hh = histogram(subset,bin=1,min = min1, locations=loc_val) - dom_tile = max(hh,loc) - tileid_plot[i,j] = loc_val(loc) - endif - endfor - -endfor - -close,1 - -; Reading catch*_internal_rst -; --------------------------- - -if (ncdf_file) then begin - - ncid = NCDF_OPEN(OutDir + int_rst,/NOWRITE) - result = ncdf_inquire( ncid) - if(result.nvars gt 60) then catch_model = boolean (result.nvars lt 60) - NCDF_VARGET, ncid,'CDCR2' ,TMP_VAR1 - PLOT_VARS (*,0) = TMP_VAR1 - NCDF_VARGET, ncid,'BEE' ,TMP_VAR1 - PLOT_VARS (*,1) = TMP_VAR1 - NCDF_VARGET, ncid,'POROS' ,TMP_VAR1 - PLOT_VARS (*,2) = TMP_VAR1 - NCDF_VARGET, ncid,'TC' ,TMP_VAR2 - PLOT_VARS (*,7) = TMP_VAR2(*,0) - PLOT_VARS (*,8) = TMP_VAR2(*,1) - PLOT_VARS (*,9) = TMP_VAR2(*,2) - PLOT_VARS (*,10)= TMP_VAR2(*,3) - NCDF_VARGET, ncid,'CATDEF' ,TMP_VAR1 - PLOT_VARS (*,11) = TMP_VAR1 - NCDF_VARGET, ncid,'RZEXC' ,TMP_VAR1 - PLOT_VARS (*,12) = TMP_VAR1 - NCDF_VARGET, ncid,'SRFEXC' ,TMP_VAR1 - PLOT_VARS (*,13) = TMP_VAR1 - - if(catch_model) then begin - - NCDF_VARGET, ncid,'OLD_ITY' ,TMP_VAR1 - PLOT_VARS (*,3) = TMP_VAR1 - - endif else begin - - NCDF_VARGET, ncid,'ITY' ,TMP_VAR2 - PLOT_VARS (*,3) = TMP_VAR2(*,0) - PLOT_VARS (*,4) = TMP_VAR2(*,1) - PLOT_VARS (*,5) = TMP_VAR2(*,2) - PLOT_VARS (*,6) = TMP_VAR2(*,3) - - endelse - - NCDF_CLOSE, ncid - -endif else begin - - openr,1,OutDir + int_rst, /F77_UNFORMATTED - - if(catch_model) then begin - - for i = 1,30 do begin - readu,1,TMP_VAR1 - if (i eq 6) then PLOT_VARS (*,0) = TMP_VAR1 - if (i eq 8) then PLOT_VARS (*,1) = TMP_VAR1 - if (i eq 9) then PLOT_VARS (*,2) = TMP_VAR1 - if (i eq 30) then PLOT_VARS (*,3) = TMP_VAR1 - endfor - - readu,1,TMP_VAR2 - PLOT_VARS (*,7) = TMP_VAR2(*,0) - PLOT_VARS (*,8) = TMP_VAR2(*,1) - PLOT_VARS (*,9) = TMP_VAR2(*,2) - PLOT_VARS (*,10)= TMP_VAR2(*,3) - - readu,1,TMP_VAR2 - readu,1,TMP_VAR1 - readu,1,TMP_VAR1 - PLOT_VARS (*,11) = TMP_VAR1 - readu,1,TMP_VAR1 - PLOT_VARS (*,12) = TMP_VAR1 - readu,1,TMP_VAR1 - PLOT_VARS (*,13) = TMP_VAR1 - - endif else begin - - for i = 1,37 do begin - readu,1,TMP_VAR1 - if (i eq 6) then PLOT_VARS (*,0) = TMP_VAR1 - if (i eq 8) then PLOT_VARS (*,1) = TMP_VAR1 - if (i eq 9) then PLOT_VARS (*,2) = TMP_VAR1 - if (i eq 30) then PLOT_VARS (*,3) = TMP_VAR1 - if (i eq 31) then PLOT_VARS (*,4) = TMP_VAR1 - if (i eq 32) then PLOT_VARS (*,5) = TMP_VAR1 - if (i eq 33) then PLOT_VARS (*,6) = TMP_VAR1 - endfor - readu,1,TMP_VAR2 - PLOT_VARS (*,7) = TMP_VAR2(*,0) - PLOT_VARS (*,8) = TMP_VAR2(*,1) - PLOT_VARS (*,9) = TMP_VAR2(*,2) - PLOT_VARS (*,10)= TMP_VAR2(*,3) - - readu,1,TMP_VAR2 - readu,1,TMP_VAR2 - readu,1,TMP_VAR1 - readu,1,TMP_VAR1 - PLOT_VARS (*,11) = TMP_VAR1 - readu,1,TMP_VAR1 - PLOT_VARS (*,12) = TMP_VAR1 - readu,1,TMP_VAR1 - PLOT_VARS (*,13) = TMP_VAR1 - - endelse - - close,1 - -endelse - -; Plotting -; -------- - -spawn, 'mkdir -p ' + OutDir + 'plots' -load_colors - -thisDevice = !D.Name -set_plot,'Z' -Device, Set_Resolution=[720,800], Z_Buffer=0 -Erase,255 -!p.background = 255 - -!P.position=0 -!P.Multi = [0, 2, 3, 0, 0] - -plot_6maps, ntiles, tileid_plot, PLOT_VARS(*,0), [min(PLOT_VARS(*,0)), max(PLOT_VARS(*,0))] , Var_Names (0) -plot_6maps, ntiles, tileid_plot, PLOT_VARS(*,1), [min(PLOT_VARS(*,1)), max(PLOT_VARS(*,1))] , Var_Names (1),advance =1 -plot_6maps, ntiles, tileid_plot, PLOT_VARS(*,2), [0.37,0.8] , Var_Names (2),advance =1 -plot_6maps, ntiles, tileid_plot, PLOT_VARS(*,11),[min(PLOT_VARS(*,11)), max(PLOT_VARS(*,11))], Var_Names (11),advance =1 -plot_6maps, ntiles, tileid_plot, PLOT_VARS(*,12),[min(PLOT_VARS(*,12)), max(PLOT_VARS(*,12))], Var_Names (12),advance =1 -plot_6maps, ntiles, tileid_plot, PLOT_VARS(*,13),[min(PLOT_VARS(*,13)), max(PLOT_VARS(*,13))], Var_Names (13),advance =1 - -snapshot = TVRD() -TVLCT, r, g, b, /Get -Device, Z_Buffer=1 -Set_Plot, thisDevice -image24 = BytArr(3, 720, 800) -image24[0,*,*] = r[snapshot] -image24[1,*,*] = g[snapshot] -image24[2,*,*] = b[snapshot] -Write_JPEG, OutDir + 'plots/soil_var.jpg', image24, True=1, Quality=100 - -plot_tc, NTILES, tileid_plot,OutDir + 'plots/', plot_vars (*,7), plot_vars (*,8), plot_vars (*,9), plot_vars (*,10) - -if(catch_model) then begin - plot_mosaic, ntiles, OutDir + 'plots/', tileid_plot, fix(plot_vars (*,3)) -endif else begin - plot_carbon, ntiles, OutDir + 'plots/', tileid_plot, fix(plot_vars (*,3:6)) -endelse - -end - -;_____________________________________________________________________ -;_____________________________________________________________________ - -pro check_regrid_carbon - -; ********************************************************************************************************** -; STEP (1) Specify below: -; ----------------------- - -BCSDIR1 = '/discover/nobackup/smahanam/bcs/Heracles-4_3/Heracles-4_3_MERRA-3/SMAP_EASEv2_M09/' -GFILE1 = 'SMAP_EASEv2_M09_3856x1624' -OutDir1 = '/discover/nobackup/projects/gmao/ssd/land/l_data/LandRestarts_for_Regridding/CatchCN/M09/20151231/' -int_rst1 = 'catchcn_internal_rst' - -BCSDIR2 = '/discover/nobackup/smahanam/bcs/Heracles-4_3/Heracles-4_3_MERRA-3/CF0180x6C_DE1440xPE0720/' -GFILE2 = 'CF0180x6C_DE1440xPE0720-Pfafstetter' -OutDir2 = '' -int_rst2 = 'catchcn_internal_rst' - -; STEP (2) save : -; --------------- -; On dali : (a) module load tool/idl-8.5, (b) idl (c) .compile chk_restarts -; and (d) plot_rst - -; ********************************************************************************************************** - -; Setting up and select variables for plotting -; -------------------------------------------- -Var_Names = [ $ - 'CDCR2' , $ ; 0 - 'BEE' , $ ; 1 - 'POROS' , $ ; 2 - 'ITY1' , $ ; 3 - 'ITY2' , $ ; 4 - 'ITY3' , $ ; 5 - 'ITY4' , $ ; 6 - 'TC1' , $ ; 7 - 'TC2' , $ ; 8 - 'TC3' , $ ; 9 - 'TC4' , $ ;10 - 'CATDEF' , $ ;11 - 'RZEXC' , $ ;12 - 'SFEXC' ] -NC_plot = 4320 -NR_plot = 2160 - -;goto, jump - -for resol = 1,2 do begin - -if(resol eq 1) then begin - BCSDIR = BCSDIR1 - TILFILE = BCSDIR1 + 'til/' + GFILE1 + '.til' - RSTFILE = BCSDIR1 + 'rst/' + GFILE1 + '.rst' -endif else begin - BCSDIR = BCSDIR2 - TILFILE = BCSDIR2 + 'til/' + GFILE2 + '.til' - RSTFILE = BCSDIR2 + 'rst/' + GFILE2 + '.rst' -endelse - - -NTILES = 0l -NG = 0l -NC = 0l -NR = 0l - -openr,1,BCSDIR + 'clsm/catchment.def' -readf,1,NTILES -close,1 - -openr,1,TILFILE -readf,1,NG,NC,NR -close,1 -; Set up vector to grid for plotting -; ---------------------------------- - - - -tileid_plot = lonarr (NC_plot,NR_plot) - -dx = NC/NC_plot -dy = NR/NR_plot - -catrow = lonarr(nc) -cat = lonarr(nc,dy) - -openr,1,RSTFILE,/F77_UNFORMATTED - -for j = 0l, NR_plot -1 do begin - - for i=0,dy -1 do begin - readu,1,catrow - cat (*,i) = catrow - endfor - - for i = 0, NC_plot -1 do begin - subset = cat (i*dx: (i+1)*dx -1,*) - if (min (subset) le NTILES) then begin - min1 = min(subset) - subset(where (subset gt NTILES)) = 0 - hh = histogram(subset,bin=1,min = min1, locations=loc_val) - dom_tile = max(hh,loc) - tileid_plot[i,j] = loc_val(loc) - endif - endfor - -endfor - -close,1 -if (resol eq 1) then begin - tileid_plot1 = tileid_plot - NTILES1 = NTILES -endif else begin - tileid_plot2 = tileid_plot - NTILES2 = NTILES -endelse -endfor - -cnpft1 = fltarr (ntiles1, 888) -cnpft2 = fltarr (ntiles2, 888) -fvg1 = fltarr (ntiles1, 4) -fvg2 = fltarr (ntiles2, 4) -ncid = NCDF_OPEN(OutDir1 + int_rst1,/NOWRITE) -NCDF_VARGET, ncid,'TILE_ID' ,TILE_ID -NCDF_VARGET, ncid,'CNPFT' ,CNPFT1 -NCDF_VARGET, ncid,'FVG' ,fvg1 -TILE_ID = long (TILE_ID) - 1l - -CNPFT=CNPFT1 -FVG =FVG1 - -for k =0l,n_elements (CNPFT1(*,0)) -1l do CNPFT1(TILE_ID(k),*) = CNPFT(k,*) -for k =0l,n_elements (FVG1 (*,0)) -1l do FVG1 (TILE_ID(k),*) = FVG (k,*) - -CNPFT=0. -FVG =0. -NCDF_CLOSE, ncid - -ncid = NCDF_OPEN(OutDir2 + int_rst2,/NOWRITE) -NCDF_VARGET, ncid,'CNPFT' ,CNPFT2 -NCDF_VARGET, ncid,'FVG' ,fvg2 -NCDF_CLOSE, ncid -save,NTILES1,NTILES2,tileid_plot1,tileid_plot2,CNPFT1,CNPFT2, fvg1, fvg2,file = 'temp_file.idl' -;stop - -jump: - -restore,'temp_file.idl' - -; Plotting -; -------- - -spawn, 'mkdir -p plots' -load_colors -limits = [-60,-180,90,180] - -plot_varid = 14 -cnpft1 = reform ( cnpft1,[ntiles1,3,4,74],/overwrite) -cnpft2 = reform ( cnpft2,[ntiles2,3,4,74],/overwrite) - -for iv = 1,4 do begin - -plot_vars1 = cnpft1(*,0,iv - 1,plot_varid-1) -plot_vars2 = cnpft2(*,0,iv - 1,plot_varid-1) - - -thisDevice = !D.Name -set_plot,'Z' -Device, Set_Resolution=[720,1000], Z_Buffer=0 -Erase,255 -!p.background = 255 - -!P.position=0 -!P.Multi = [0, 1, 2, 0, 1] - -plot_2maps, ntiles1, tileid_plot1, plot_vars1(*), [min([PLOT_VARS1,plot_vars2],/nan),max([PLOT_VARS1,plot_vars2],/nan)], string(plot_varid,'(i2.2)')+'_v' + string(iv,'(i1.1)') -plot_2maps, ntiles2, tileid_plot2, plot_vars2(*), [min([PLOT_VARS1,plot_vars2],/nan),max([PLOT_VARS1,plot_vars2],/nan)], string(plot_varid,'(i2.2)')+'_v' + string(iv,'(i1.1)'),advance =1 - -snapshot = TVRD() -TVLCT, r, g, b, /Get -Device, Z_Buffer=1 -Set_Plot, thisDevice -image24 = BytArr(3, 720, 1000) -image24[0,*,*] = r[snapshot] -image24[1,*,*] = g[snapshot] -image24[2,*,*] = b[snapshot] -Write_JPEG, 'plots/pft_'+ string(plot_varid,'(i2.2)')+'_v' + string(iv,'(i1.1)') +'.jpg', image24, True=1, Quality=100 -endfor -fvg1(where (fvg1 le 1.e-4)) = !VALUES.F_NAN -fvg2(where (fvg2 le 1.e-4)) = !VALUES.F_NAN - -plot_fr, NTILES1, tileid_plot1,'plots/offl_', fvg1 (*,0), fvg1 (*,1), fvg1 (*,2), fvg1 (*,3) - -plot_fr, NTILES2, tileid_plot2,'plots/agcm_', fvg2 (*,0), fvg2 (*,1), fvg2 (*,2), fvg2 (*,3) - -end -;_____________________________________________________________________ -;_____________________________________________________________________ - -PRO plot_2maps, ncat, tile_id, data, vlim, vname,advance = advance - -lwval = vlim(0) -upval = vlim(1) - -im = n_elements(tile_id[*,0]) -jm = n_elements(tile_id[0,*]) - -dx = 360. / im -dy = 180. / jm - -x = indgen(im)*dx -180. + dx/2. -y = indgen(jm)*dy -90. + dy/2. - -data_grid = fltarr (im,jm) -data_grid (*,*) = !VALUES.F_NAN - -for j = 0l, jm -1l do begin - for i = 0l, im -1 do begin - if(tile_id[i,j] gt 0) then data_grid(i,j) = data(tile_id[i,j] -1) - endfor -endfor - -limits = [-60,-180,90,180] - -colors = [27,26,25,24,23,22,21,20,40,41,42,43,44,45,46,47,48] -n_levels = n_elements (colors) - -levels = [lwval,lwval+(upval-lwval)/(n_levels -1) +indgen(n_levels -1)*(upval-lwval)/(n_levels -1)] - -if keyword_set (advance) then begin - -MAP_SET,/CYLINDRICAL,/hires,color= 0,/NoErase,limit=limits,/ADVANCE,/ISOTROPIC,/NOBORDER, title =vname -endif else begin -MAP_SET,/CYLINDRICAL,/hires,color= 0,/NoErase,limit=limits,/ISOTROPIC,/NOBORDER, title =vname -endelse - -contour, data_grid,x,y,levels = levels,c_colors=colors,/cell_fill,/overplot - -levels_x = levels - -alpha=fltarr(n_levels,2) -alpha(*,0)=levels -alpha(*,1)=levels -h=[0,1] - -dx = (240.)/(n_levels-1) - -clev = levels -clev (*) = 1 -n=0 -k = 0 -fmt_string = '(f7.2)' -!P.position=[0.30, 0.0+0.005, 0.70, 0.015+0.005] - -contour,alpha,levels_x,h,levels=levels,c_colors=colors,/fill,/xstyle,/ystyle, $ - /noerase,yticks=1,ytickname=[' ',' '] ,xrange=[min(levels),max(levels)], $ - xtitle=' ', color=0,xtickv=levels, $ - C_charsize=1.0, charsize=0.5 ,xtickformat = "(A1)" -contour,alpha,levels_x,h,levels=levels,color=0,/overplot,c_label=clev - for k = 0,n_elements(colors) -1 do xyouts,levels_x[k],1.1,string(levels[k],format=fmt_string) ,orientation=90,color=0,charsize =0.8 - -!P.position=0 - -END - -;_____________________________________________________________________ -;_____________________________________________________________________ - -pro plot_fr, ncat, tile_id,out_path, VISDR, VISDF, NIRDR, NIRDF - -load_colors -thisDevice = !D.Name -set_plot,'Z' -Device, Set_Resolution=[720,500], Z_Buffer=0 -Erase,255 -!p.background = 255 - -!P.position=0 -!P.Multi = [0, 2, 2, 0, 0] -limits = [-60,-180,90,180] - -lwval = 0. -upval = 1. - -im = n_elements(tile_id[*,0]) -jm = n_elements(tile_id[0,*]) - -dx = 360. / im -dy = 180. / jm - -x = indgen(im)*dx -180. + dx/2. -y = indgen(jm)*dy -90. + dy/2. - -colors = [27,26,25,24,23,22,21,20,40,41,42,43,44,45,46,47,48] -n_levels = n_elements (colors) - -for map = 1,4 do begin - - if (map eq 1) then data = VISDR - if (map eq 2) then data = VISDF - if (map eq 3) then data = NIRDR - if (map eq 4) then data = NIRDF - - if (map eq 1) then ctitle = 'PF1' - if (map eq 2) then ctitle = 'PF2' - if (map eq 3) then ctitle = 'SF1' - if (map eq 4) then ctitle = 'SF2' - - levels = [lwval,lwval+(upval-lwval)/(n_levels -1) +indgen(n_levels -1)*(upval-lwval)/(n_levels -1)] - - data_grid = fltarr (im,jm) - data_grid (*,*) = !VALUES.F_NAN - - for j = 0l, jm -1l do begin - for i = 0l, im -1 do begin - if(tile_id[i,j] gt 0) then data_grid(i,j) = data(tile_id[i,j] -1) - endfor - endfor - - if(map eq 1) then begin - MAP_SET,/CYLINDRICAL,/hires,color= 0,/NoErase,limit=limits,/ISOTROPIC,/NOBORDER, title = ctitle - endif else begin - MAP_SET,/CYLINDRICAL,/hires,color= 0,/NoErase,limit=limits,/ADVANCE,/ISOTROPIC,/NOBORDER, title = ctitle - endelse - - contour, data_grid,x,y,levels = levels,c_colors=colors,/cell_fill,/overplot - if(map eq 3) then begin - !P.position=[0.25, 0.05, 0.75, 0.075] - - alpha=fltarr(n_levels,2) - alpha(*,0)=levels - alpha(*,1)=levels - h=[0,1] - clev = levels - clev (*) = 1 - n=0 - k = 0 - fmt_string = '(f6.2)' - contour,alpha,levels,h,levels=levels,c_colors=colors,/fill,/xstyle,/ystyle, $ - /noerase,yticks=1,ytickname=[' ',' '] ,xrange=[min(levels),max(levels)], $ - xtitle=' ', color=0,xtickv=levels, $ - C_charsize=1.0, charsize=0.5 ,xtickformat = "(A1)" - contour,alpha,levels,h,levels=levels,color=0,/overplot,c_label=clev - for k = 0,n_elements(colors) -1 do xyouts,levels[k],1.1,string(levels[k],format=fmt_string) ,orientation=90,color=0,charsize =0.8 - !P.position=0 - endif -endfor - -snapshot = TVRD() -TVLCT, r, g, b, /Get -Device, Z_Buffer=1 -Set_Plot, thisDevice -image24 = BytArr(3, 720, 500) -image24[0,*,*] = r[snapshot] -image24[1,*,*] = g[snapshot] -image24[2,*,*] = b[snapshot] -Write_JPEG, out_path +'FR.jpg', image24, True=1, Quality=100 - -end - -;_____________________________________________________________________ -;_____________________________________________________________________ - -pro load_colors - -R = intarr (256) -G = intarr (256) -B = intarr (256) - -R (*) = 255 -G (*) = 255 -B (*) = 255 - -r_drought = [0, 0, 0, 0, 47, 200, 255, 255, 255, 255, 249, 197] -g_drought = [0, 115, 159, 210, 255, 255, 255, 255, 219, 157, 0, 0] -b_drought = [0, 0, 0, 0, 67, 130, 255, 0, 0, 0, 0, 0] - -colors = indgen (11) + 1 -R (0:11) = r_drought -G (0:11) = g_drought -B (0:11) = b_drought - -r_green = [200, 150, 47, 60, 0, 0, 0, 0] -g_green = [255, 255, 255, 230, 219, 187, 159, 131] -b_green = [200, 150, 67, 15, 0, 0, 0, 0] - -r_blue = [ 55, 0, 0, 0, 0, 0, 0, 0, 0, 0] -g_blue = [255, 255, 227, 195, 167, 115, 83, 0, 0, 0] -b_blue = [199, 255, 255, 255, 255, 255, 255, 255, 200, 130] - -r_red = [255, 240, 255, 255, 255, 255, 255, 233, 197] -g_red = [255, 255, 219, 187, 159, 131, 51, 23, 0] -b_red = [153, 15, 0, 0, 0, 0, 0, 0, 0] - -r_grey = [245, 225, 205, 185, 165, 145, 125, 105, 85] -g_grey = [245, 225, 205, 185, 165, 145, 125, 105, 85] -b_grey = [245, 225, 205, 185, 165, 145, 125, 105, 85] - -r_type = [255,106,202,251, 0, 29, 77,109,142,233,255,255,255,127,164,164,217,217,204,104, 0] -g_type = [245, 91,178,154, 85,115,145,165,185, 23,131,131,191, 39, 53, 53, 72, 72,204,104, 70] -b_type = [215,154,214,153, 0, 0, 0, 0, 13, 0, 0,200, 0, 4, 3,200, 1,200,204,200,200] - -R (20:27) = r_green -G (20:27) = g_green -B (20:27) = b_green - -R (30:39) = r_blue -G (30:39) = g_blue -B (30:39) = b_blue - -R (40:48) = r_red -G (40:48) = g_red -B (40:48) = b_red - -R (50:58) = r_grey -G (50:58) = g_grey -B (50:58) = b_grey - -R (60:80) = r_type -G (60:80) = g_type -B (60:80) = b_type - -TVLCT,R ,G ,B - -end - -;_____________________________________________________________________ -;_____________________________________________________________________ - -PRO plot_6maps, ncat, tile_id, data, vlim, vname,advance = advance - -lwval = vlim(0) -upval = vlim(1) -if (vname eq 'SOILDEPTH') then upval = 5000. - -im = n_elements(tile_id[*,0]) -jm = n_elements(tile_id[0,*]) - -dx = 360. / im -dy = 180. / jm - -x = indgen(im)*dx -180. + dx/2. -y = indgen(jm)*dy -90. + dy/2. - -data_grid = fltarr (im,jm) -data_grid (*,*) = !VALUES.F_NAN - -for j = 0l, jm -1l do begin - for i = 0l, im -1 do begin - if(tile_id[i,j] gt 0) then data_grid(i,j) = data(tile_id[i,j] -1) - endfor -endfor - -limits = [-60,-180,90,180] -if file_test ('limits.idl') then restore,'limits.idl' - -colors = [27,26,25,24,23,22,21,20,40,41,42,43,44,45,46,47,48] -n_levels = n_elements (colors) - -levels = [lwval,lwval+(upval-lwval)/(n_levels -1) +indgen(n_levels -1)*(upval-lwval)/(n_levels -1)] - -if(vname eq 'POROS') then $ -levels = [lwval,lwval+(0.57-lwval)/(n_levels -2) +indgen(n_levels -2)*(0.57-lwval)/(n_levels -2),upval] - -if keyword_set (advance) then begin - -MAP_SET,/CYLINDRICAL,/hires,color= 0,/NoErase,limit=limits,/ADVANCE,/ISOTROPIC,/NOBORDER, title =vname -endif else begin -MAP_SET,/CYLINDRICAL,/hires,color= 0,/NoErase,limit=limits,/ISOTROPIC,/NOBORDER, title =vname -endelse - -contour, data_grid,x,y,levels = levels,c_colors=colors,/cell_fill,/overplot - -levels_x = levels - -if(vname eq 'POROS') then begin -dxp = (0.8-0.37)/16. -levels_x = indgen(17)*dxp+ 0.37 -endif - -alpha=fltarr(n_levels,2) -alpha(*,0)=levels -alpha(*,1)=levels -h=[0,1] - -dx = (240.)/(n_levels-1) - -clev = levels -clev (*) = 1 -n=0 -k = 0 -fmt_string = '(f7.2)' - -if(vname eq 'CDCR2' ) then !P.position=[0.064, 0.675, 0.41, 0.69] -if(vname eq 'BEE' ) then !P.position=[0.58, 0.675, 0.92, 0.69] -if(vname eq 'POROS' ) then !P.position=[0.064, 0.345, 0.41, 0.36] -if(vname eq 'CATDEF') then !P.position=[0.58, 0.345, 0.92, 0.36] -if(vname eq 'RZEXC' ) then !P.position=[0.064, 0.015, 0.41, 0.03] -if(vname eq 'SFEXC' ) then !P.position=[0.58, 0.015, 0.92, 0.03] - -;!P.position=[0.064, 0.675, 0.41, 0.69] -;!P.position=[0.58, 0.0+0.005, 0.92, 0.015+0.005] - -contour,alpha,levels_x,h,levels=levels,c_colors=colors,/fill,/xstyle,/ystyle, $ - /noerase,yticks=1,ytickname=[' ',' '] ,xrange=[min(levels),max(levels)], $ - xtitle=' ', color=0,xtickv=levels, $ - C_charsize=1.0, charsize=0.5 ,xtickformat = "(A1)" -contour,alpha,levels_x,h,levels=levels,color=0,/overplot,c_label=clev - for k = 0,n_elements(colors) -1 do xyouts,levels_x[k],1.1,string(levels[k],format=fmt_string) ,orientation=90,color=0,charsize =0.8 - -;for l = 0,n_levels -2 do begin -; k = l -; xbox = [-120. + k*dx,-120. + k*dx, -120. + (k+1)*dx, -120. + (k+1)*dx,-120. + k*dx] -; ybox = [-65., -55.,-55.,-65.,-65.] -; polyfill, xbox,ybox,color=colors [k] -; -; xyouts,xbox[1],ybox[2]+0.05,string(levels[l],format=fmt_string),color =0, orientation =90,charsize =0.8 -; k = k + 1 -;endfor -; -;l = n_levels -1 -;xyouts,-120. + l*dx,ybox[2]+0.05,string(levels[l],format=fmt_string),color =0, orientation =90,charsize =0.8 -!P.position=0 - -END -;_____________________________________________________________________ -;_____________________________________________________________________ - -pro plot_tc, ncat, tile_id,out_path, VISDR, VISDF, NIRDR, NIRDF - -load_colors -thisDevice = !D.Name -set_plot,'Z' -Device, Set_Resolution=[720,500], Z_Buffer=0 -Erase,255 -!p.background = 255 - -!P.position=0 -!P.Multi = [0, 2, 2, 0, 0] -limits = [-60,-180,90,180] - -lwval = min ([min(VISDR), min(VISDF), min(NIRDR), min(NIRDF)]) -upval = max ([max(VISDR), max(VISDF), max(NIRDR), max(NIRDF)]) - -im = n_elements(tile_id[*,0]) -jm = n_elements(tile_id[0,*]) - -dx = 360. / im -dy = 180. / jm - -x = indgen(im)*dx -180. + dx/2. -y = indgen(jm)*dy -90. + dy/2. - -colors = [27,26,25,24,23,22,21,20,40,41,42,43,44,45,46,47,48] -n_levels = n_elements (colors) - -for map = 1,4 do begin - - if (map eq 1) then data = VISDR - if (map eq 2) then data = VISDF - if (map eq 3) then data = NIRDR - if (map eq 4) then data = NIRDF - - if (map eq 1) then ctitle = 'TC1' - if (map eq 2) then ctitle = 'TC2' - if (map eq 3) then ctitle = 'TC3' - if (map eq 4) then ctitle = 'TC4' - - levels = [lwval,lwval+(upval-lwval)/(n_levels -1) +indgen(n_levels -1)*(upval-lwval)/(n_levels -1)] - - data_grid = fltarr (im,jm) - data_grid (*,*) = !VALUES.F_NAN - - for j = 0l, jm -1l do begin - for i = 0l, im -1 do begin - if(tile_id[i,j] gt 0) then data_grid(i,j) = data(tile_id[i,j] -1) - endfor - endfor - - if(map eq 1) then begin - MAP_SET,/CYLINDRICAL,/hires,color= 0,/NoErase,limit=limits,/ISOTROPIC,/NOBORDER, title = ctitle - endif else begin - MAP_SET,/CYLINDRICAL,/hires,color= 0,/NoErase,limit=limits,/ADVANCE,/ISOTROPIC,/NOBORDER, title = ctitle - endelse - - contour, data_grid,x,y,levels = levels,c_colors=colors,/cell_fill,/overplot - if(map eq 3) then begin - !P.position=[0.25, 0.05, 0.75, 0.075] - - alpha=fltarr(n_levels,2) - alpha(*,0)=levels - alpha(*,1)=levels - h=[0,1] - clev = levels - clev (*) = 1 - n=0 - k = 0 - fmt_string = '(f6.2)' - contour,alpha,levels,h,levels=levels,c_colors=colors,/fill,/xstyle,/ystyle, $ - /noerase,yticks=1,ytickname=[' ',' '] ,xrange=[min(levels),max(levels)], $ - xtitle=' ', color=0,xtickv=levels, $ - C_charsize=1.0, charsize=0.5 ,xtickformat = "(A1)" - contour,alpha,levels,h,levels=levels,color=0,/overplot,c_label=clev - for k = 0,n_elements(colors) -1 do xyouts,levels[k],1.1,string(levels[k],format=fmt_string) ,orientation=90,color=0,charsize =0.8 - !P.position=0 - endif -endfor - -snapshot = TVRD() -TVLCT, r, g, b, /Get -Device, Z_Buffer=1 -Set_Plot, thisDevice -image24 = BytArr(3, 720, 500) -image24[0,*,*] = r[snapshot] -image24[1,*,*] = g[snapshot] -image24[2,*,*] = b[snapshot] -Write_JPEG, out_path +'TC.jpg', image24, True=1, Quality=100 - -end -; ============================================================================== -; Mosaic classes -; ============================================================================== - -PRO plot_mosaic, ncat, outdir, tile_id, mos_type - -im = n_elements(tile_id[*,0]) -jm = n_elements(tile_id[0,*]) - -dx = 360. / im -dy = 180. / jm - -x = indgen(im)*dx -180. + dx/2. -y = indgen(jm)*dy -90. + dy/2. - -mos_grid = intarr (im,jm) -mos_grid (*,*) = !VALUES.F_NAN - -for j = 0l, jm -1l do begin - for i = 0l, im -1 do begin - if(tile_id[i,j] gt 0) then mos_grid(i,j) = mos_type(tile_id[i,j] -1) - endfor -endfor - -limits = [-60,-180,90,180] -if file_test ('limits.idl') then restore,'limits.idl' - -thisDevice = !D.Name -set_plot,'Z' -Device, Set_Resolution=[700,500], Z_Buffer=0 - -r_in = [233,255,255,255,210, 0, 0, 0,204,170,255,220,205, 0, 0,170, 0, 40,120,140,190,150,255,255, 0, 0, 0,195,255, 0,255, 0] -g_in = [ 23,131,191,255,255,255,155, 0,204,240,255,240,205,100,160,200, 60,100,130,160,150,100,180,235,120,150,220, 20,245, 70,255, 0] -b_in = [ 0, 0, 0,178,255,255,255,200,204,240,100,100,102, 0, 0, 0, 0, 0, 0, 0, 0, 0, 50,175, 90,120,130, 0,215,200,255, 0] -vtypes =[ 1, 2, 3, 4, 5, 6, 7, 8, 10, 11, 14, 20, 30, 40, 50, 60, 70, 90,100,110,120,130,140,150,160,170,180,190,200,210,220,230] - -red = intarr (256) -green= intarr (256) -blue = intarr (256) -red (255) = 255 -green(255) = 255 -blue (255) = 255 - -for k = 0, n_elements(vtypes) -1 do begin - red (vtypes(k)) = r_in (k) - green(vtypes(k)) = g_in (k) - blue (vtypes(k)) = b_in (k) -endfor - -TVLCT,red,green,blue - -colors = vtypes -levels = vtypes - -Erase,255 -!p.background = 255 -!P.position=0 -!P.Multi = [0, 1, 1, 0, 1] -MAP_SET,/CYLINDRICAL,/hires,color= 0,/NoErase,limit=limits -contour, mos_grid,x,y,levels = levels,c_colors=colors,/cell_fill,/overplot - -mos_name = strarr(6) -mos_name( 0) = 'BL Evergreen' -mos_name( 1) = 'BL Deciduous' -mos_name( 2) = 'Needleleaf' -mos_name( 3) = 'Grassland' -mos_name( 4) = 'BL Shrubs' -mos_name( 5) = 'Dwarf' - -n_levels = 6;n_elements(vtypes) -alpha=fltarr(n_levels,2) -alpha(*,0)=levels [0:n_levels-1] -alpha(*,1)=levels [0:n_levels-1] -h=[0,1] -!P.position=[0.30, 0.0+0.005, 0.70, 0.015+0.005] -clev = levels -clev (*) = 1 -contour,alpha,levels[0:5],h,levels=levels,c_colors=colors,/fill,/xstyle,/ystyle, $ - /noerase,yticks=1,ytickname=[' ',' '] ,xrange=[1,7], $ - xtitle=' ', color=0,xtickv=levels, $ - C_charsize=1.0, charsize=0.5 ,xtickformat = "(A1)" -contour,alpha,levels[0:5],h,levels=levels,color=0,/overplot,c_label=clev -for k = 0,5 do xyouts,levels[k]+0.5,1.2,mos_name[k] ,orientation=90,color=0 - -snapshot = TVRD() -TVLCT, r, g, b, /Get -Device, Z_Buffer=1 -Set_Plot, thisDevice -image24 = BytArr(3, 700, 500) -image24[0,*,*] = r[snapshot] -image24[1,*,*] = g[snapshot] -image24[2,*,*] = b[snapshot] -Write_JPEG, outdir + '/mosaic_prim.jpg', image24, True=1, Quality=100 - - -END -; ============================================================================== -; CLM-Carbon classes -; ============================================================================== - -PRO plot_carbon,ncat, OutDir, tile_id, clm_type - -im = n_elements(tile_id[*,0]) -jm = n_elements(tile_id[0,*]) - -dx = 360. / im -dy = 180. / jm - -x = indgen(im)*dx -180. + dx/2. -y = indgen(jm)*dy -90. + dy/2. - -clm_grid = intarr (im,jm,4) - -clm_grid (*,*,*) = !VALUES.F_NAN - -for j = 0l, jm -1l do begin - for i = 0l, im -1 do begin - if(tile_id[i,j] gt 0) then begin - clm_grid(i,j,0) = clm_type(tile_id[i,j] -1,0) - clm_grid(i,j,1) = clm_type(tile_id[i,j] -1,1) - clm_grid(i,j,2) = clm_type(tile_id[i,j] -1,2) - clm_grid(i,j,3) = clm_type(tile_id[i,j] -1,3) - endif - endfor -endfor - -clm_type = 0 - -limits = [-60,-180,90,180] -if file_test ('limits.idl') then restore,'limits.idl' - -thisDevice = !D.Name -set_plot,'Z' -Device, Set_Resolution=[700,1000], Z_Buffer=0 -;types= [ 2, 3, 4, 5, 6, 7, 8, 9, 10, 11,11a, 12, 13, 14,14a, 15,15a, 16,16a, 17] -r_in = [106,202,251, 0, 29, 77,109,142,233,255,255,255,127,164,164,217,217,204,104, 0] -g_in = [ 91,178,154, 85,115,145,165,185, 23,131,131,191, 39, 53, 53, 72, 72,204,104, 70] -b_in = [154,214,153, 0, 0, 0, 0, 13, 0, 0,200, 0, 4, 3,200, 1,200,204,200,200] -vtypes= [ 1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11, 12, 13, 14, 15, 16, 17, 18, 19, 20] - -red = intarr (256) -green= intarr (256) -blue = intarr (256) - -red (255) = 255 -green(255) = 255 -blue (255) = 255 - -for k = 0, n_elements(vtypes) -1 do begin - red (vtypes(k)) = r_in (k) - green(vtypes(k)) = g_in (k) - blue (vtypes(k)) = b_in (k) -endfor - -TVLCT,red,green,blue - -colors = vtypes -levels = vtypes - -clm_name = strarr(19) -clm_name( 0) = 'NLEt' ; 1 needleleaf evergreen temperate tree -clm_name( 1) = 'NLEB' ; 2 needleleaf evergreen boreal tree -clm_name( 2) = 'NLDB' ; 3 needleleaf deciduous boreal tree -clm_name( 3) = 'BLET' ; 4 broadleaf evergreen tropical tree -clm_name( 4) = 'BLEt' ; 5 broadleaf evergreen temperate tree -clm_name( 5) = 'BLDT' ; 6 broadleaf deciduous tropical tree -clm_name( 6) = 'BLDt' ; 7 broadleaf deciduous temperate tree -clm_name( 7) = 'BLDB' ; 8 broadleaf deciduous boreal tree -clm_name( 8) = 'BLEtS' ; 9 broadleaf evergreen temperate shrub -clm_name( 9) = 'BLDtS' ; 10 broadleaf deciduous temperate shrub [moisture + deciduous] -clm_name(10) = 'BLDtSm'; 11 broadleaf deciduous temperate shrub [moisture stress only] -clm_name(11) = 'BLDBS' ; 12 broadleaf deciduous boreal shrub -clm_name(12) = 'AC3G' ; 13 arctic c3 grass -clm_name(13) = 'CC3G' ; 14 cool c3 grass [moisture + deciduous] -clm_name(14) = 'CC3Gm' ; 15 cool c3 grass [moisture stress only] -clm_name(15) = 'WC4G' ; 16 warm c4 grass [moisture + deciduous] -clm_name(16) = 'WC4Gm' ; 17 warm c4 grass [moisture stress only] -clm_name(17) = 'CROP' ; 18 crop [moisture + deciduous] -clm_name(18) = 'CROPm' ; 19 crop [moisture stress only] - -Erase,255 -!p.background = 255 -!P.position=0 -!P.Multi = [0, 1, 2, 0, 1] - -MAP_SET,/CYLINDRICAL,/hires,color= 0,/NoErase,limit=limits -contour, clm_grid[*,*,0],x,y,levels = levels,c_colors=colors,/cell_fill,/overplot - -MAP_SET,/CYLINDRICAL,/hires,color= 0,/NoErase,limit=limits,/advance -contour, clm_grid[*,*,1],x,y,levels = levels,c_colors=colors,/cell_fill,/overplot - -n_levels = n_elements(vtypes) -alpha=fltarr(n_levels,2) -alpha(*,0)=levels (0:n_levels-1) -alpha(*,1)=levels (0:n_levels-1) -h=[0,1] - -!P.position=[0.30, 0.0+0.005, 0.70, 0.015+0.005] -clev = levels -clev (*) = 1 -contour,alpha,levels,h,levels=levels,c_colors=colors,/fill,/xstyle,/ystyle, $ - /noerase,yticks=1,ytickname=[' ',' '] ,xrange=[min(levels),max(levels)], $ - xtitle=' ', color=0,xtickv=levels, $ - C_charsize=1.0, charsize=0.5 ,xtickformat = "(A1)" -contour,alpha,levels,h,levels=levels,color=0,/overplot,c_label=clev - for k = 0,n_elements(vtypes) -2 do xyouts,levels[k]+0.5,1.1,clm_name(k) ,orientation=90,color=0 -snapshot = TVRD() - -TVLCT, r, g, b, /Get -Device, Z_Buffer=1 -Set_Plot, thisDevice -image24 = BytArr(3, 700, 1000) -image24[0,*,*] = r[snapshot] -image24[1,*,*] = g[snapshot] -image24[2,*,*] = b[snapshot] -Write_JPEG, OutDir + '/CLM-Carbon_PRIM_veg_typs.jpg', image24, True=1, Quality=100 - -; now plotting secondary -thisDevice = !D.Name -set_plot,'Z' -Device, Set_Resolution=[700,1000], Z_Buffer=0 - -Erase,255 -!p.background = 255 -!P.position=0 -!P.Multi = [0, 1, 2, 0, 1] - -MAP_SET,/CYLINDRICAL,/hires,color= 0,/NoErase,limit=limits -contour, clm_grid[*,*,2],x,y,levels = levels,c_colors=colors,/cell_fill,/overplot - -MAP_SET,/CYLINDRICAL,/hires,color= 0,/NoErase,limit=limits,/advance -contour, clm_grid[*,*,3],x,y,levels = levels,c_colors=colors,/cell_fill,/overplot - -n_levels = n_elements(vtypes) -alpha=fltarr(n_levels,2) -alpha(*,0)=levels (0:n_levels-1) -alpha(*,1)=levels (0:n_levels-1) -h=[0,1] - -!P.position=[0.30, 0.0+0.005, 0.70, 0.015+0.005] -clev = levels -clev (*) = 1 -contour,alpha,levels,h,levels=levels,c_colors=colors,/fill,/xstyle,/ystyle, $ - /noerase,yticks=1,ytickname=[' ',' '] ,xrange=[min(levels),max(levels)], $ - xtitle=' ', color=0,xtickv=levels, $ - C_charsize=1.0, charsize=0.5 ,xtickformat = "(A1)" -contour,alpha,levels,h,levels=levels,color=0,/overplot,c_label=clev - for k = 0,n_elements(vtypes) -2 do xyouts,levels[k]+0.5,1.1,clm_name(k) ,orientation=90,color=0 -snapshot = TVRD() - -TVLCT, r, g, b, /Get -Device, Z_Buffer=1 -Set_Plot, thisDevice -image24 = BytArr(3, 700, 1000) -image24[0,*,*] = r[snapshot] -image24[1,*,*] = g[snapshot] -image24[2,*,*] = b[snapshot] -Write_JPEG, OutDir + '/CLM-Carbon_SEC_veg_typs.jpg', image24, True=1, Quality=100 - -END diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/mk_restarts/obsolete/mk_catch_restart b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/mk_restarts/obsolete/mk_catch_restart deleted file mode 100755 index 0aa20db94a..0000000000 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/mk_restarts/obsolete/mk_catch_restart +++ /dev/null @@ -1,29 +0,0 @@ -#!/bin/csh - -setenv ARCH `uname` -setenv LANDIR /land/l_data/geos5/bcs/SiB2_V2 -setenv HOMDIR /home1/ltakacs/catchment/ -setenv WRKDIR $HOMDIR/wrk -cd $WRKDIR -/bin/rm mk_catch_restart.x - - -setenv old_rslv 540x361 -setenv old_dateline DC -setenv old_tilefile FV_540x361_DC_360x180_DE.til -setenv old_restart d500_eros_01.catch_internal_rst.20060529_21z.bin - -setenv new_rslv 1080x721 -setenv new_tilefile FV_1080x721_DC_360x180_DE.til -setenv new_dateline DC - - -if( $ARCH == 'IRIX64' ) then - f90 -o mk_catch_restart.x -g $HOMDIR/mk_catch_restart.F90 -endif - -if( $ARCH == 'OSF1' ) then - f90 -o mk_catch_restart.x -g -convert big_endian -assume byterecl $HOMDIR/mk_catch_restart.F90 -endif - -./mk_catch_restart.x diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/mk_restarts/obsolete/mk_catch_restart.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/mk_restarts/obsolete/mk_catch_restart.F90 deleted file mode 100755 index 4b54e203af..0000000000 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/mk_restarts/obsolete/mk_catch_restart.F90 +++ /dev/null @@ -1,859 +0,0 @@ -PROGRAM mk_catch_internal -implicit none - -integer :: im_gcm_old, jm_gcm_old -integer :: im_ocn_old, jm_ocn_old -integer :: im_gcm_new, jm_gcm_new -integer :: im_ocn_new, jm_ocn_new -integer :: ntiles_old, ntiles_new -integer :: nland_old, nland_new - -integer qtile -parameter ( qtile = 45848 ) - -real, allocatable :: lats_old(:), lats_new(:), lats_tmp(:) -real, allocatable :: lons_old(:), lons_new(:), lons_tmp(:) -integer, allocatable :: ii_old(:), ii_new(:), ii_tmp(:) -integer, allocatable :: jj_old(:), jj_new(:), jj_tmp(:) -real, allocatable :: fr_old(:), fr_new(:), fr_tmp(:) -integer, allocatable :: typ_tmp(:) - -character*20 :: version1, version2 -character*400 :: landir,wrkdir, old_tilefile, new_tilefile, arch, flag -character*400 :: old_rslv, old_dateline, oldtilnam -character*400 :: new_rslv, new_dateline, newtildir, newtilnam -character*400 :: old_restart, new_restart, sarithpath, home -character*400 :: maxtilnam, maxtildir, logfile -character*400 :: old_diag_grids, new_diag_grids - -logical :: maxoldtoggle, twotiles -integer :: ierr, indr1, indr2, indr3, ig, jg, indx_dum, ip1, ip2 -real :: fr_ocn, rdum -integer :: dum,n,nn,nta,v,loc,idum -character*4 :: bak=char(8)//char(8)//char(8)//char(8) -real, allocatable :: oldprogvars(:,:), oldparmvars(:,:), oldallvars(:,:) -real, allocatable :: newallvars(:,:) -real, allocatable :: oldvargrids(:,:,:) -real, allocatable :: newvargrids(:,:,:), dumtile(:,:), dumgrid(:,:) -real, allocatable :: tiletilevar(:,:), tilevar(:) -integer :: numrecs, allrecs, numparmrecs, numsubtiles -logical, allocatable :: ttlookup(:) -integer, allocatable :: corners_lookup(:,:) -real, allocatable :: weights_lookup(:,:) -real, allocatable :: BF1(:), BF2(:), BF3(:), VGWMAX(:) -real, allocatable :: CDCR1(:), CDCR2(:), PSIS(:), BEE(:) -real, allocatable :: POROS(:), WPWET(:), COND(:), GNU(:) -real, allocatable :: ARS1(:), ARS2(:), ARS3(:) -real, allocatable :: ARA1(:), ARA2(:), ARA3(:), ARA4(:) -real, allocatable :: ARW1(:), ARW2(:), ARW3(:), ARW4(:) -real, allocatable :: TSA1(:), TSA2(:), TSB1(:), TSB2(:) -real, allocatable :: ATAU2(:), BTAU2(:), ITY0(:) -integer, allocatable :: ity_int(:) -integer :: ity2, nmin -real :: frc1, frc2, dmin, dist -real, allocatable :: DP2BR(:), tmp_wgt(:,:), tmp_sum(:,:) -real :: zdep1, zdep2, zdep3, zmet, term1, term2 -integer :: catindex21, catindex22, catindex23 -integer :: catindex24, catindex25, catindex26 -integer :: catid, checksum -integer :: ii0, jj0, i,j -real :: fr0, val0, ESMF_MISSING -real :: lata, latb,lona, lonb, vaa, vbb, vab, vba -real :: lat00_old, lon00_old, dx_old, dy_old -real :: lonIM_old, lon0, lat0, d1,d2,d3,d4 -integer :: ia, ib, ja, jb -real :: waa, wab, wba, wbb, wsum, tol, tempval -!real :: mindist, olddist, thislat, thislon - -! ------------------------------------------------------------------------------- -! Strategy: -! 1. Read in the "old" .til definition file -! 2. Read in the "new" .til definition file -! 3. Read in the "old" restart from a previous run -! 4. Read in Sarith's tilespace catchment parameters -! 5. Convert the prognostic variables from the old restart -! to the new catchment definitions -! a. Create aggregate imxjm grid of progs from old restart -! b. Create reasonable interolated values based on centroids -! in the new .til definitions file. -! 6. Write the restart using stored values -! ------------------------------------------------------------------------------- - -! user parameters -! --------------- - - call getenv ('ARCH' ,arch ) - call getenv ('LANDIR' ,landir ) - call getenv ('WRKDIR' ,wrkdir ) - - call getenv ('old_rslv' ,old_rslv ) - call getenv ('old_dateline',old_dateline) - call getenv ('old_tilefile',old_tilefile) - call getenv ('old_restart' ,old_restart ) - - call getenv ('new_rslv' ,new_rslv ) - call getenv ('new_dateline',new_dateline) - call getenv ('new_tilefile',new_tilefile) - - if( ARCH == 'OSF1' ) flag = 'no' - if( ARCH == 'IRIX64' ) flag = 'yes' - -old_restart = trim(wrkdir) // '/' // trim(old_restart) -new_restart = trim(old_restart) // '.' // trim(new_rslv) // '_' // trim(new_dateline) - sarithpath = trim(landir) // '/' - -numsubtiles = 4 -numrecs = 61 ! number of records in the restart (includes tiletile vars) -numparmrecs = 30 ! number of parameters at the beginning of restart - -allrecs = numrecs + 7*3 ! all records, with tile-tile prognostic variables expanded - -allocate(ttlookup(numrecs)) -ttlookup(:) = .false. ! ttlookup specifies which records in restart are tile-tile -ttlookup(31:32) = .true. ! or tileonly (.false.=tileonly) -ttlookup(53:56) = .true. -ttlookup(61) = .true. - -twotiles=.false. ! set this to true to force a two tile test -ESMF_MISSING=-999.0 ! missing value in old restart prognostic variables -tol=1.0E-6 -logfile='mk_catch_restart.log' - -old_diag_grids = 'old_grids.dat' -new_diag_grids = 'new_grids.dat' - -! ------------------------------------------------------------------------------- -! 1. Read in the old .til file and store the I, J, FR's -! ------------------------------------------------------------------------------- - -newtildir = trim(sarithpath) // trim(new_dateline) // '/FV_' // trim(new_rslv) - -oldtilnam = trim(wrkdir) // '/' // trim(old_tilefile) -newtilnam = trim(wrkdir) // '/' // trim(new_tilefile) -print *, 'newtilenam1 = ',newtilnam -!newtilnam = trim(newtildir) // '/FV_' // trim(new_rslv) //'_'//trim(new_dateline)//'_360x180_DE_NO_TINY.til' -!newtilnam = trim(newtildir) // '/FV_' // trim(new_rslv) //'_'//trim(new_dateline)//'_576x540_DE_NO_TINY.til' -print *, 'newtilenam2 = ',newtilnam - -open(9, file=trim(logfile),action='write',form='formatted') - -write (*,*) -write (*,*) '---------------------------------------------------------------------' -write (*,*) 'Reading source (old) tile definitions from:' -write (9,*) '---------------------------------------------------------------------' -write (9,*) 'Reading source (old) tile definitions from:' -write (9,*) trim(oldtilnam) -write (*,*) trim(oldtilnam) - -open (10,file=trim(oldtilnam),status='old', action='read',form='formatted') -read (10,*) ntiles_old -read (10,*) dum -read (10,'(a)')version1 -read (10,*)im_gcm_old -read (10,*)jm_gcm_old -read (10,'(a)')version2 -read (10,*) im_ocn_old -read (10,*) jm_ocn_old -write(9,*) 'Header: ', ntiles_old, dum, trim(version1), im_gcm_old, jm_gcm_old, & - trim(version2), im_ocn_old, jm_ocn_old - -allocate(lats_tmp(ntiles_old)) -allocate(lons_tmp(ntiles_old)) -allocate( fr_tmp(ntiles_old)) -allocate( ii_tmp(ntiles_old)) -allocate( jj_tmp(ntiles_old)) -allocate( typ_tmp(ntiles_old)) - -write(*, 40, advance=trim(flag)) -nland_old=0 -do n = 1,ntiles_old - read(10,'(i10,i9,2f10.4,2i5,f10.6,3i8,f10.6,i8)',IOSTAT=ierr)typ_tmp(n),& - indr1,lons_tmp(n),lats_tmp(n),ii_tmp(n),jj_tmp(n),fr_tmp(n),indx_dum,indr2,dum,fr_ocn,indr3 - if (typ_tmp(n) == 100) then - ip2=n - nland_old=nland_old+1 - endif - if (typ_tmp(n) == 0) then - ip1=n - endif - if(ierr /= 0) write (*,*) 'Problem reading' - write(*, 50, advance=trim(flag)) bak, floor(float(n)/float(ntiles_old)*100) -end do -close (10,status='keep') - -write(9,*) 'Last ocean index:', ip1 -write(9,*) 'Last land index:', ip2 -write(9,*) 'NTILES LAND:', nland_old -write(*,*) - -!write(*,*) 'Packing land coordinate arrays...' - -allocate ( lats_old(nland_old) ) -allocate ( lons_old(nland_old) ) -allocate ( fr_old(nland_old) ) -allocate ( ii_old(nland_old) ) -allocate ( jj_old(nland_old) ) - -lats_old = pack(lats_tmp, mask=typ_tmp .eq. 100) -lons_old = pack(lons_tmp, mask=typ_tmp .eq. 100) - fr_old = pack( fr_tmp, mask=typ_tmp .eq. 100) - ii_old = pack( ii_tmp, mask=typ_tmp .eq. 100) - jj_old = pack( jj_tmp, mask=typ_tmp .eq. 100) - -write(9,*) 'lats', size(lats_old), minval(lats_old), maxval(lats_old) -write(9,*) 'lons', size(lons_old), minval(lons_old), maxval(lons_old) -write(9,*) 'fr ', size (fr_old), minval (fr_old), maxval (fr_old) -write(9,*) 'ii ', size (ii_old), minval (ii_old), maxval (ii_old) -write(9,*) 'jj ', size (jj_old), minval (jj_old), maxval (jj_old) - -deallocate(lats_tmp) -deallocate(lons_tmp) -deallocate( fr_tmp) -deallocate( ii_tmp) -deallocate( jj_tmp) -deallocate( typ_tmp) - -! ------------------------------------------------------------------------------- -! 2. Read in the new .til file and store the I, J, FR's -! ------------------------------------------------------------------------------- - -write (*,*) -write (*,*) '---------------------------------------------------------------------' -write (*,*) 'Reading source (new) tile definitions from:' -write (*,*) trim(newtilnam) -write (9,*) '---------------------------------------------------------------------' -write (9,*) 'Reading source (new) tile definitions from:' -write (9,*) trim(newtilnam) - -open (10,file=trim(newtilnam),status='old',action='read',form='formatted') -read (10,*) ntiles_new -read (10,*) dum -read (10,'(a)')version1 -read (10,*)im_gcm_new -read (10,*)jm_gcm_new -read (10,'(a)')version2 -read (10,*) im_ocn_new -read (10,*) jm_ocn_new -write(9,*) 'Header: ', ntiles_new, dum, trim(version1), im_gcm_new, jm_gcm_new, & - trim(version2), im_ocn_new, jm_ocn_new - -allocate ( lats_tmp(ntiles_new) ) -allocate ( lons_tmp(ntiles_new) ) -allocate ( fr_tmp(ntiles_new) ) -allocate ( ii_tmp(ntiles_new) ) -allocate ( jj_tmp(ntiles_new) ) -allocate ( typ_tmp(ntiles_new) ) - - write(*, 40, advance=trim(flag)) -nland_new=0 -do n = 1,ntiles_new - read(10,'(i10,i9,2f10.4,2i5,f10.6,3i8,f10.6,i8)',IOSTAT=ierr)typ_tmp(n),& - indr1,lons_tmp(n),lats_tmp(n),ii_tmp(n),jj_tmp(n),fr_tmp(n),indx_dum,indr2,dum,fr_ocn,indr3 - if (typ_tmp(n) == 100) then - ip2=n - nland_new=nland_new+1 - endif - if (typ_tmp(n) == 0) then - ip1=n - endif - if(ierr /= 0) write (*,*) 'Problem reading' - write(*, 50, advance=trim(flag)) bak, floor(float(n)/float(ntiles_new)*100) -end do -close (10,status='keep') - -write(9,*) 'Last ocean index:', ip1 -write(9,*) 'Last land index:', ip2 -write(9,*) 'NTILES LAND:', nland_new -write(*,*) - -allocate ( lats_new(nland_new) ) -allocate ( lons_new(nland_new) ) -allocate ( fr_new(nland_new) ) -allocate ( ii_new(nland_new) ) -allocate ( jj_new(nland_new) ) - -lats_new = pack(lats_tmp, mask=typ_tmp .eq. 100) -lons_new = pack(lons_tmp, mask=typ_tmp .eq. 100) - fr_new = pack( fr_tmp, mask=typ_tmp .eq. 100) - ii_new = pack( ii_tmp, mask=typ_tmp .eq. 100) - jj_new = pack( jj_tmp, mask=typ_tmp .eq. 100) - -write(9,*) 'lats', size(lats_new), minval(lats_new), maxval(lats_new) -write(9,*) 'lons', size(lons_new), minval(lons_new), maxval(lons_new) -write(9,*) 'fr ', size(fr_new), minval(fr_new), maxval(fr_new) -write(9,*) 'ii ', size(ii_new), minval(ii_new), maxval(ii_new) -write(9,*) 'jj ', size(jj_new), minval(jj_new), maxval(jj_new) - -deallocate(lats_tmp) -deallocate(lons_tmp) -deallocate( fr_tmp) -deallocate( ii_tmp) -deallocate( jj_tmp) -deallocate( typ_tmp) - -! ------------------------------------------------------------------------------- -! 3. Read in the old restart from a previous run -! Here, I separate the parameters and prognostic variables. Some of the -! prognostic variables are printed out by catch-finalize as var(ntiles, 4) -! This routine takes that into account, and I put the parameters and -! prognostics in separate arrays. Then, the parameters will be replaced by -! something Sarith makes, while the prognostics will be regridded. If you -! wish, you can also retain the soil parameters in the trivial case (eg. -! you want to keep same land specification but just adjust the initialization -! to a different date) -! ------------------------------------------------------------------------------- - -allocate(oldparmvars(nland_old, numparmrecs)) -allocate(oldprogvars(nland_old,allrecs-numparmrecs)) - -allocate( oldallvars(nland_old,allrecs)) -allocate(tiletilevar(nland_old, numsubtiles)) -allocate( tilevar(nland_old)) - -open(unit=30, file=trim(old_restart),form='unformatted') - -write (*,*) -write (*,*) '---------------------------------------------------------------------' -write (*,*) 'Reading old restart from:' -write (*,*) trim(old_restart) - -write (9,*) -write (9,*) '---------------------------------------------------------------------' -write (9,*) 'Reading '//trim(old_restart) -write (9,*) 'Sizes', size(tiletilevar), size(tilevar) - - write(*, 70, advance=trim(flag)) -open(unit=65, file='old_catch.dat' ,form='unformatted') - -nta=1 -do n=1, numrecs - if (ttlookup(n)) then - read(30) tiletilevar - do nn=1, numsubtiles - oldallvars(:,nta)=tiletilevar(:,nn) - write (65) tiletilevar(:,nn) ! Write Grads-Formatted Catchment File - nta=nta+1 - enddo - else - read(30) tilevar - oldallvars(:,nta)=tilevar(:) - write (65) tilevar(:) ! Write Grads-Formatted Catchment File - nta=nta+1 - endif - write(*, 50, advance=trim(flag)) bak, floor(float(n)/float(numrecs)*100) -enddo - -close(30) -deallocate(tiletilevar) -deallocate(tilevar) - -write(*,*) 'Separating parameter and prognostic variables' -write(9,*) 'Separating parameter and prognostic variables' - -do n=1, numparmrecs - oldparmvars(:,n)=oldallvars(:,n) -enddo -do n=1, allrecs-numparmrecs - oldprogvars(:,n)=oldallvars(:,n+numparmrecs) -end do - -loc = 0 -do n=1,numrecs - nta = 1 - if( ttlookup(n) ) nta = numsubtiles - do nn = 1,nta - loc = loc+1 - if( loc.le.numparmrecs ) then - write(9,*) ' Transferred old parameter (',n,',',nn,') ', & - minval(oldallvars(:,loc)), maxval(oldallvars(:,loc)) - else - write(9,*) ' Transferred old prognostic (',n,',',nn,') ', & - minval(oldallvars(:,loc)), maxval(oldallvars(:,loc)) - endif - enddo -enddo - - -! ------------------------------------------------------------------------------- -! 4. Read in the soil parameter variables (there are 29 of them) from Sarith -! vegetation type is also read in here, from an old Aries format (this needs -! to be changed, so vegtype is in .til file!) -! ------------------------------------------------------------------------------- - -allocate ( BF1(nland_new), BF2 (nland_new), BF3(nland_new) ) -allocate (VGWMAX(nland_new), CDCR1(nland_new), CDCR2(nland_new) ) -allocate ( PSIS(nland_new), BEE(nland_new), POROS(nland_new) ) -allocate ( WPWET(nland_new), COND(nland_new), GNU(nland_new) ) -allocate ( ARS1(nland_new), ARS2(nland_new), ARS3(nland_new) ) -allocate ( ARA1(nland_new), ARA2(nland_new), ARA3(nland_new) ) -allocate ( ARA4(nland_new), ARW1(nland_new), ARW2(nland_new) ) -allocate ( ARW3(nland_new), ARW4(nland_new), TSA1(nland_new) ) -allocate ( TSA2(nland_new), TSB1(nland_new), TSB2(nland_new) ) -allocate ( ATAU2(nland_new), BTAU2(nland_new), DP2BR(nland_new) ) -allocate ( ITY0(nland_new), ity_int(nland_new)) - -write(*,*) -write(*,*) '---------------------------------------------------------------------' -write(9,*) -write(9,*) '---------------------------------------------------------------------' -write(9,*) 'Reading Sarith parameters from:' -write(9,*) trim(newtildir) -write(9,*) 'Sample output ... ' -write(*,*) 'Reading Sarith parameters from:' -write(*,*) trim(newtildir) -write(*,*) 'Sample output ... ' - -open(unit=21, file=trim(newtildir) // '/' //'mosaic_veg_typs_fracs',form='formatted') -open(unit=22, file=trim(newtildir) // '/' //'bf.dat' ,form='formatted') -open(unit=23, file=trim(newtildir) // '/' //'soil_param.dat' ,form='formatted') -open(unit=24, file=trim(newtildir) // '/' //'ar.new' ,form='formatted') -open(unit=25, file=trim(newtildir) // '/' //'ts.dat' ,form='formatted') -open(unit=26, file=trim(newtildir) // '/' //'tau_param.dat' ,form='formatted') - - write(*, 80, advance=trim(flag)) - -do n=1,nland_new -! read (21, *) catindex21, catid, ity_int(n), ity2, frc1, frc2, rdum - read (21, *) catindex21, catid, ity_int(n), ity2, frc1, frc2 ! version 2 doesnt have rdum variable - ITY0(n)=1.0*ity_int(n) - read (22, *) catindex22, catid, GNU(n), BF1(n), BF2(n), BF3(n) - read (23, *) catindex23, catid, idum, idum, BEE(n), PSIS(n), POROS(n), COND(n), WPWET(n), DP2BR(n) - - read (24, *) catindex24, catid, rdum, ARS1(n), ARS2(n), ARS3(n), & - ARA1(n), ARA2(n), ARA3(n), ARA4(n), & - ARW1(n), ARW2(n), ARW3(n), ARW4(n) - - read (25, *) catindex25, catid, rdum, TSA1(n), TSA2(n), TSB1(n), TSB2(n) - - read (26, *) catindex26, catid, ATAU2(n), BTAU2(n), rdum, rdum - - checksum=catindex21+catindex22+catindex23+catindex24+catindex25+catindex26-6*(n+ip1) - zdep2=1000. - zdep3=amax1(1000.,DP2BR(n)) - if (zdep2 .gt.0.75*zdep3) then - zdep2 = 0.75*zdep3 - end if - zdep1=20. - zmet=zdep3/1000. - term1=-1.+((PSIS(n)-zmet)/PSIS(n))**((BEE(n)-1.)/BEE(n)) - term2=PSIS(n)*BEE(n)/(BEE(n)-1) - VGWMAX(n)=POROS(n)*zdep2 - CDCR1(n)=1000.*POROS(n)*(zmet-(-term2*term1)) - CDCR2(n)=(1.-WPWET(n))*POROS(n)*zdep3 - if (checksum .ne. 0) then - write(9,*) 'Catchment id mismatch with following id list at n=', n - write(9,*) catindex22, catindex23, catindex24, catindex25, catindex26, ip1+n - write(*,*) 'Halted on catchment mismatch' - STOP - else - if (modulo(n, 1000).eq.1 .or. n.eq.qtile ) then - write(9,*) - write(9,*) n, 'mosaic_vegtype: ', ity_int(n) - write(9,*) n, 'bf.dat: ', catindex22, catid, GNU(n), BF1(n), BF2(n) - write(9,*) n, 'bf.dat: ', BF3(n) - write(9,*) n, 'soil_param.dat: ', catindex23, catid, rdum, BEE(n), PSIS(n) - write(9,*) n, 'soil_param.dat: ', POROS(n), COND(n), WPWET(n), DP2BR(n) - write(9,*) n, 'ar.dat: ', catindex24, catid, rdum, ARS1(n), ARS2(n) - write(9,*) n, 'ar.dat: ', ARS3(n), ARA1(n), ARA2(n), ARA3(n), ARA4(n) - write(9,*) n, 'ar.dat: ', ARW1(n), ARW2(n), ARW3(n), ARW4(n) - write(9,*) n, 'ts.dat: ', catindex25, catid, rdum, TSA1(n), TSA2(n) - write(9,*) n, 'ts.dat: ', TSB1(n), TSB2(n) - write(9,*) n, 'tau_param.dat: ', catindex26, catid, ATAU2(n), BTAU2(n) - write(9,*) n, 'Computed: ', VGWMAX(n), CDCR1(n), CDCR2(n) - end if - endif - write(*, 50, advance=trim(flag)) bak, floor(float(n)/float(nland_new)*100) -end do - -close (21) -close (22) -close (23) -close (24) -close (25) -close (26) - -! ------------------------------------------------------------------------------- -! 5. Regrid all variables to im_gcm_oldXjm_gcm_old grid -! Then, find interpolated values based upon the centroids of tiles in -! new .til definitions. Missing values: if a single tile is missing, -! it's influence on the gridded value is ignored, except if there are no -! non-missing values in an i,j cell, then the new tile is defined as missing -! -! Alternatives for future development: -! -! a. Nearest neighbor -! b. Nearest neighbor of same/similar vegetation type, latitude, etc. -! c. Gridding, ungridding (this is done currently) -! d. Krieging of some kind, pick a radius of influence and weigh by inverse -! square of distance, or limit to veg type, or whatever. -! -! ------------------------------------------------------------------------------- - -open(unit=8, file=trim(old_diag_grids),form='unformatted') - -allocate( tmp_sum(im_gcm_old,jm_gcm_old)) -allocate( tmp_wgt(im_gcm_old,jm_gcm_old)) -allocate(oldvargrids(im_gcm_old,jm_gcm_old,allrecs)) -allocate( dumgrid(im_gcm_old,jm_gcm_old)) - -loc = 0 -do v=1, numrecs - nta = 1 - if( ttlookup(v) ) nta = numsubtiles - do nn = 1,nta - loc = loc+1 - tmp_sum(:,:)=0.0 - tmp_wgt(:,:)=0.0 - do n=1, nland_old - val0=oldallvars(n,loc) - ii0=ii_old(n) - jj0=jj_old(n) - fr0=fr_old(n) - if (abs(val0-ESMF_MISSING) .gt. tol) then - tmp_sum(ii0,jj0) = tmp_sum(ii0,jj0) + fr0*val0 - tmp_wgt(ii0,jj0) = tmp_wgt(ii0,jj0) + fr0 - else - print *, 'Old_Catch_Val = ',val0,' n = ',n,' loc = ',loc - endif - enddo - do j=1,jm_gcm_old - do i=1,im_gcm_old - if (tmp_wgt(i,j) .gt. tol) then - oldvargrids(i,j,loc)=tmp_sum(i,j)/tmp_wgt(i,j) - else - oldvargrids(i,j,loc)=ESMF_MISSING - endif - dumgrid(i,j) =oldvargrids(i,j,loc) - enddo - enddo - write (8) dumgrid - enddo -enddo - -deallocate(dumgrid) -deallocate(tmp_sum) -deallocate(tmp_wgt) -close(8) - -allocate( corners_lookup(nland_new, 4) ) -allocate( weights_lookup(nland_new, 4) ) - -lat00_old = -90 - dx_old = (360.0)/ im_gcm_old - dy_old = (180.0)/(jm_gcm_old-1) - -if (old_dateline .eq. 'DC') then - lon00_old = -180 - lonIM_old = 180-dx_old -else - lon00_old = -180+0.5*dx_old - lonIM_old = 180-0.5*dx_old -end if - -write(*,*) -write(*,*) '---------------------------------------------------------------------' -write(*,*) 'Computing interpolation lookup table for new tiles' -write(9,*) -write(9,*) '---------------------------------------------------------------------' -write(9,*) 'Computing interpolation lookup table for new tiles' - write(*, 90, advance=trim(flag)) - -do n=1,nland_new - lat0=lats_new(n) ! latitude of tile centroid to find - lon0=lons_new(n) ! longitude of tile centroid - if ((lon0 .gt. lonIM_old) .or. (lon0 .lt. lon00_old)) then - ia=im_gcm_old - ib=1 - lona=lonIM_old - lonb=lon00_old - else - ia=floor((lon0-lon00_old)/dx_old)+1 - ib=ia+1 - lona=(ia-1)*dx_old+lon00_old - lonb=lona+dx_old - end if - ja=floor((lat0-lat00_old)/dy_old)+1 ! left bottom corner y coordinate - jb=ja+1 ! right top corner y coordinate - lata=(ja-1)*dy_old+lat00_old ! latitude of left bottom corner - latb=lata+dy_old - - if( ia.lt.1 .or. ia.gt.im_gcm_old .or. & - ib.lt.1 .or. ib.gt.im_gcm_old .or. & - ja.lt.1 .or. ja.gt.jm_gcm_old .or. & - jb.lt.1 .or. jb.gt.jm_gcm_old ) then - print *, 'Warning, bad indicies!' - print *, 'New Land variable: ',n,ia,ib,ja,jb - stop - endif - - if (modulo(n, 1000).eq.1 .or. n.eq.qtile) then - write (9,*) - write (9,*) n, lona, lon0, lonb, ia, ib - write (9,*) n, lata, lat0, latb, ja, jb - end if - corners_lookup(n,1)=ia - corners_lookup(n,2)=ib - corners_lookup(n,3)=ja - corners_lookup(n,4)=jb - waa=sqrt((lat0-lata)**2+(lon0-lona)**2) - wab=sqrt((lat0-lata)**2+(lon0-lonb)**2) - wba=sqrt((lat0-latb)**2+(lon0-lona)**2) - wbb=sqrt((lat0-latb)**2+(lon0-lonb)**2) - wsum=waa+wab+wba+wbb - weights_lookup(n,1)=waa - weights_lookup(n,2)=wab - weights_lookup(n,3)=wba - weights_lookup(n,4)=wbb - write(*, 50, advance=trim(flag)) bak, floor(float(n)/float(nland_new)*100) -end do - -allocate(newallvars(nland_new, allrecs)) -! new allvars allocated by number of new land tiles X number of total restart records -write(*,*) -write(*,*) '---------------------------------------------------------------------' -write(*,*) 'Interpolating prognostic records to new tile definitions' -write(9,*) -write(9,*) '---------------------------------------------------------------------' -write(9,*) 'Interpolating prognostic records to new tile definitions' - write(*, 90, advance=trim(flag)) - write(*, 50, advance=trim(flag)) bak, 0 - -do v=31, allrecs - do n=1, nland_new - ia=corners_lookup(n,1) - ib=corners_lookup(n,2) - ja=corners_lookup(n,3) - jb=corners_lookup(n,4) - waa=weights_lookup(n,1) - wbb=weights_lookup(n,4) - wab=weights_lookup(n,2) - wba=weights_lookup(n,3) - wsum=0 - tempval=0 - vaa=oldvargrids(ia,ja, v) - vbb=oldvargrids(ib,jb, v) - vab=oldvargrids(ia,jb, v) - vba=oldvargrids(ib,ja, v) - if (abs(vaa-ESMF_MISSING) .gt. tol) then - tempval=tempval+vaa*waa - wsum=waa+wsum - end if - if (abs(vab-ESMF_MISSING) .gt. tol) then - tempval=tempval+vab*wab - wsum=wab+wsum - end if - if (abs(vba-ESMF_MISSING) .gt. tol) then - tempval=tempval+vba*wba - wsum=wsum+wba - end if - if (abs(vbb-ESMF_MISSING) .gt. tol) then - tempval=tempval+vbb*wbb - wsum=wsum+wbb - end if - if (abs(wsum) .lt. tol) then - dmin = 1e15 - nmin = 0 - do nn = 1,nland_old - dist = sqrt( (lats_old(nn)-lats_new(n))**2 & - + (lons_old(nn)-lons_new(n))**2 ) - if( dist.lt.dmin ) then - nmin = nn - dmin = dist - endif - enddo - tempval=oldallvars(nmin,v) ! Find nearest old tile to new tile - print *, 'NewVal = ',tempval,' nmin = ',nmin,' loc = ',v - print *, 'newlat = ',lats_new(n),' oldlat = ',lats_old(nmin) - print *, 'newlon = ',lons_new(n),' oldlon = ',lons_old(nmin) - print * - else - tempval=tempval/(1.0*wsum) - end if - newallvars(n, v)=tempval - if (modulo(n, 1000) .eq. 1) then - write(9,*) - write(9,*) n, 'Interpolation summary' - write(9,*) n, 'Weights:', waa, wab, wba, wbb - write(9,*) n, 'Values:', vaa, vab, vba, vbb - write(9,*) n, 'Results:', tempval, wsum - end if - end do - - write(*,*) v - write(*, 50, advance=trim(flag)) bak, floor((float(v-31)/float(allrecs-31)*100)) -end do - -! I am now finished with the old tiles, get rid of them -deallocate(oldprogvars, oldparmvars, oldallvars) -deallocate(corners_lookup, weights_lookup) - -! ------------------------------------------------------------------------------- -! 6. Create the restart from stored values -! a. 29 Sarith tilespace records from his parameter files -! b. The vegetation type from Sarith's mosaic_veg_typ_file -! (I have used the PRIMARY veg type for this work, as opposed -! to the second one that also has a fraction. I am assuming that -! the catchment fraction is totally composed of the PRIMARY veg type) -! c. The modified/regridded prognostic variables that have been regridded -! At this point, the variable newallvars contains ALL records for the -! restart, including estimates of Sarith's parameters based upon -! the old values interpolated from the old restart. These are skipped, but -! might be useful for comparison in a debugging situation -! ------------------------------------------------------------------------------- - -open(unit=41, file=trim(new_restart),form='unformatted') -open(unit=66, file='new_catch.dat' ,form='unformatted') - -! replace the old interpolated parameters in newallvars with the new Sarith ones - - write(9,*) ' Min/Max for ARS1: ', minval(ARS1), maxval(ARS1) - write(9,*) ' Min/Max for ARS2: ', minval(ARS2), maxval(ARS2) - write(9,*) ' Min/Max for ARS3: ', minval(ARS3), maxval(ARS3) - -newallvars(:,1)=BF1 -newallvars(:,2)=BF2 -newallvars(:,3)=BF3 -newallvars(:,4)=VGWMAX -newallvars(:,5)=CDCR1 -newallvars(:,6)=CDCR2 -newallvars(:,7)=PSIS -newallvars(:,8)=BEE -newallvars(:,9)=POROS -newallvars(:,10)=WPWET -newallvars(:,11)=COND -newallvars(:,12)=GNU -newallvars(:,13)=ARS1 -newallvars(:,14)=ARS2 -newallvars(:,15)=ARS3 -newallvars(:,16)=ARA1 -newallvars(:,17)=ARA2 -newallvars(:,18)=ARA3 -newallvars(:,19)=ARA4 -newallvars(:,20)=ARW1 -newallvars(:,21)=ARW2 -newallvars(:,22)=ARW3 -newallvars(:,23)=ARW4 -newallvars(:,24)=TSA1 -newallvars(:,25)=TSA2 -newallvars(:,26)=TSB1 -newallvars(:,27)=TSB2 -newallvars(:,28)=ATAU2 -newallvars(:,29)=BTAU2 -newallvars(:,30)=ITY0 - -write(*,*) -write(*,*) '---------------------------------------------------------------------' -write(*,*) 'Writing new restart' -write(9,*) -write(9,*) '---------------------------------------------------------------------' -write(9,*) 'Writing new restart' - -loc = 0 -do v=1,numrecs - nta = 1 - if( ttlookup(v) ) nta = numsubtiles - allocate( dumtile(nland_new,nta) ) - do nn = 1,nta - loc = loc+1 - dumtile(:,nn) = newallvars(:,loc) - write (66) dumtile(:,nn) ! Write Grads-Formatted Catchment File - enddo - write (41) dumtile - write(9,*) 'NEW RESTART RECORD #', v , ' Size = ',size(dumtile) - deallocate ( dumtile ) -enddo -close(41) - -loc = 0 -do n=1,numrecs - nta = 1 - if( ttlookup(n) ) nta = numsubtiles - do nn = 1,nta - loc = loc+1 - if( loc.le.numparmrecs ) then - write(9,*) ' Transferred new parameter (',n,',',nn,') ', & - minval(newallvars(:,loc)), maxval(newallvars(:,loc)) - else - write(9,*) ' Transferred new prognostic (',n,',',nn,') ', & - minval(newallvars(:,loc)), maxval(newallvars(:,loc)) - endif - enddo -enddo - - -! ------------------------------------------------------------------------------- -! 7. Save a gridded copy of the new restart on rectangular grid found in the -! new .til file definitions. This can be used to check the results. -! ------------------------------------------------------------------------------- - -open(unit=42, file=trim(new_diag_grids),form='unformatted') - -allocate( tmp_sum(im_gcm_new, jm_gcm_new)) -allocate( tmp_wgt(im_gcm_new, jm_gcm_new)) -allocate( dumgrid(im_gcm_new, jm_gcm_new)) - -loc = 0 -do v=1, numrecs - nta = 1 - if( ttlookup(v) ) nta = numsubtiles - do nn = 1,nta - loc = loc+1 - tmp_sum(:,:)=0.0 - tmp_wgt(:,:)=0.0 - do n=1, nland_new - val0=newallvars(n,loc) - ii0=ii_new(n) - jj0=jj_new(n) - fr0=fr_new(n) - if (abs(val0-ESMF_MISSING) .gt. tol) then - tmp_sum(ii0,jj0)=tmp_sum(ii0,jj0)+fr0*val0 - tmp_wgt(ii0,jj0)=tmp_wgt(ii0,jj0)+fr0 - endif - enddo - do i=1,im_gcm_new - do j=1,jm_gcm_new - if (tmp_wgt(i,j) .gt. tol) then - dumgrid(i,j)=tmp_sum(i,j)/tmp_wgt(i,j) - else - dumgrid(i,j)=ESMF_MISSING - endif - enddo - enddo - write (42) dumgrid - enddo -enddo -close(42) - -deallocate(tmp_sum) -deallocate(tmp_wgt) -deallocate( dumgrid ) - -deallocate(BF1, BF2, BF3, VGWMAX) -deallocate(CDCR1, CDCR2, PSIS, BEE) -deallocate(POROS, WPWET, COND, GNU) -deallocate(ARS1, ARS2, ARS3) -deallocate(ARA1, ARA2, ARA3) -deallocate(ARA4, ARW1, ARW2, ARW3, ARW4) -deallocate(TSA1, TSA2, TSB1, TSB2) -deallocate(DP2BR, ATAU2, BTAU2) -deallocate(ITY0, ity_int) - -deallocate(lats_old) -deallocate(lons_old) -deallocate(fr_old) -deallocate(ii_old) -deallocate(jj_old) -deallocate(lats_new) -deallocate(lons_new) -deallocate(fr_new) -deallocate(ii_new) -deallocate(jj_new) -deallocate(ttlookup) - -40 FORMAT(' Percent tile definitions read: ') -50 FORMAT(A4, I3.3, '%') -60 FORMAT(' Percent MODIS data read: ') -70 FORMAT(' Percent restart read: ') -80 FORMAT(' Percent Sarith catchment parameters read: ') -90 FORMAT(' Percent completed: ') -END diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/mk_restarts/obsolete/mk_vegdyn_restart b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/mk_restarts/obsolete/mk_vegdyn_restart deleted file mode 100755 index 86e90e73ae..0000000000 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/mk_restarts/obsolete/mk_vegdyn_restart +++ /dev/null @@ -1,23 +0,0 @@ -#!/bin/csh - -setenv ARCH `uname` -setenv LANDIR /land/l_data/geos5/bcs/SiB2_V2 -setenv HOMDIR /home1/ltakacs/catchment -setenv WRKDIR $HOMDIR/wrk -cd $WRKDIR - -setenv rslv 1080x721 -setenv dateline DC -setenv nland 374925 # Note, check mk_catch LOG file for number of land tiles - - -if( $ARCH == 'IRIX64' ) then - f90 -o mk_vegdyn_restart.x $HOMDIR/mk_vegdyn_restart.F90 -endif - -if( $ARCH == 'OSF1' ) then - f90 -o mk_vegdyn_restart.x -convert big_endian -assume byterecl $HOMDIR/mk_vegdyn_restart.F90 -endif - -mk_vegdyn_restart.x - diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/mk_restarts/obsolete/mk_vegdyn_restart.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/mk_restarts/obsolete/mk_vegdyn_restart.F90 deleted file mode 100755 index 849e9f8e45..0000000000 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/mk_restarts/obsolete/mk_vegdyn_restart.F90 +++ /dev/null @@ -1,54 +0,0 @@ -PROGRAM mk_vegdyn_internal -implicit none -real, allocatable :: dummy(:),ity0(:) -integer,allocatable :: ity0_int(:) -real :: filler, dum0 -integer :: vvv -integer :: bi,li -integer :: nland, nt, index, id, dum -character*256 outpath, sarithdir, dateline, restag, vegname, numland -character*256 landir - -!--------------------------------------------------------------------------- - call GETENV ( 'LANDIR' , landir ) - call GETENV ( 'rslv' , restag ) - call GETENV ( 'dateline', dateline ) - call GETENV ( 'nland' , numland ) - read(numland,*)nland - -outpath = 'vegdyn_internal_restart.' // trim(restag) // '_' // trim(dateline) -!--------------------------------------------------------------------------- - -allocate(dummy (nland)) -allocate(ity0 (nland)) -allocate(ity0_int(nland)) - -dummy(:)=-999.0 -sarithdir = trim(landir) // '/' // trim(dateline) // '/FV_' // trim(restag) // '/' -vegname = trim(sarithdir)//'mosaic_veg_typs_fracs' -write (*,*) 'Reading '//vegname - -open(unit=21, file=trim(vegname),form='formatted') -DO nt=1,nland -! read (21, *) index, id, ity0_int(nt), dum, dum0, dum0, dum0 - read (21, *) index, id, ity0_int(nt), dum, dum0, dum0 ! version 2 doesn't have frc3 - print *, ity0_int(nt) -ENDDO -ity0=ity0_int*1.0 -close(21) - - -open(unit=30, file=trim(outpath),form='unformatted') -! write out dummy lai_prev, lai_next, grn_prev, grn_next -print *, ' VEGTYPES', minval(ity0), maxval(ity0) -write (30) dummy -write (30) dummy -write (30) dummy -write (30) dummy -write (30) ity0 -close (30) -deallocate(ity0) -deallocate(ity0_int) -deallocate(dummy) -END - diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/mk_restarts/obsolete/new_catch.ctl b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/mk_restarts/obsolete/new_catch.ctl deleted file mode 100755 index b48983d75b..0000000000 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/mk_restarts/obsolete/new_catch.ctl +++ /dev/null @@ -1,73 +0,0 @@ -dset wrk/new_catch.dat -options sequential template big_endian -undef -9999.0 -xdef 45147 linear 1 1 -ydef 1 linear 1 1 -zdef 4 linear 1 1 -tdef 1 linear jan1900 1mo -* -VARS 63 -var01 0 99 topo_baseflow_param_1 -var02 0 99 topo_baseflow_param_2 -var03 0 99 topo_baseflow_param_3 -var04 0 99 max_rootzone_water_content -var05 0 99 moisture_threshold -var06 0 99 max_water_content_unsat_zone -var07 0 99 saturated_matrix_potential -var08 0 99 clapp_hornberger_b -var09 0 99 soil_porosity -var10 0 99 wetness_at_wilting_point -var11 0 99 sfc_sat_hydraulic_conduct -var12 0 99 vertical_transmissivity -var13 0 99 wetness_param_1 -var14 0 99 wetness_param_2 -var15 0 99 wetness_param_3 -var16 0 99 shape_param_1 -var17 0 99 shape_param_2 -var18 0 99 shape_param_3 -var19 0 99 shape_param_4 -var20 0 99 min_theta_1 -var21 0 99 min_theta_2 -var22 0 99 min_theta_3 -var23 0 99 min_theta_4 -var24 0 99 water_transfer_1 -var25 0 99 water_transfer_2 -var26 0 99 water_transfer_3 -var27 0 99 water_transfer_4 -var28 0 99 soil_param_1 -var29 0 99 soil_param_2 -var30 0 99 vegetation_type -var31 4 99 canopy_temperature_1,2,3,4 -var32 4 99 canopy_specific_humidity_1,2,3,4 -var33 0 99 interception_reservoir_capac -var34 0 99 catchment_deficit -var35 0 99 root_zone_excess -var36 0 99 surface_excess -var37 0 99 soil_heat_content_layer1 -var38 0 99 soil_heat_content_layer2 -var39 0 99 soil_heat_content_layer3 -var40 0 99 soil_heat_content_layer4 -var41 0 99 soil_heat_content_layer5 -var42 0 99 soil_heat_content_layer6 -var43 0 99 mean_catchment_temp_incl_snow -var44 0 99 water_eq_snow_layer1 -var45 0 99 water_eq_snow_layer2 -var46 0 99 water_eq_snow_layer3 -var47 0 99 heat_content_snow_layer1 -var48 0 99 heat_content_snow_layer2 -var49 0 99 heat_content_snow_layer3 -var50 0 99 snow_depth_layer1 -var51 0 99 snow_depth_layer2 -var52 0 99 snow_depth_layer3 -var53 4 99 surface_heat_exchange_coefficient_1,2,3,4 -var54 4 99 surface_momentum_exchange_coefficient_1,2,3,4 -var55 4 99 surface_moisture_exchange_coefficient_1,2,3,4 -var56 4 99 subtile_fractions_1,2,3,4 -var57 0 99 observed_albedo_minimum_previous -var58 0 99 observed_albedo_minimum_next -var59 0 99 observed_albedo_mean_previous -var60 0 99 observed_albedo_mean_next -var61 0 99 observed_albedo_maxmindif_previous -var62 0 99 observed_albedo_maxmindir_next -var63 4 99 vertical_velocity_scale_squared_1,2,3,4 -ENDVARS diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/mk_restarts/obsolete/newcatch.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/mk_restarts/obsolete/newcatch.F90 deleted file mode 100644 index 0ad4f26e33..0000000000 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/mk_restarts/obsolete/newcatch.F90 +++ /dev/null @@ -1,91 +0,0 @@ -#define VERIFY_(A) if(A /=0)then;print *,'ERROR code',A,'at',__LINE__;call exit(3);endif - -program newcatch - implicit none - -#ifndef __GFORTRAN__ - integer*4 :: iargc - external :: iargc - integer*8 :: ftell - external :: ftell -#endif - character(256) :: str, f_in, f_out - - integer :: m - integer :: status - integer*8 :: bpos, epos, rsize - real, allocatable :: a(:) - -! Begin - - if (iargc() /= 2) then - call getarg(0,str) - write(*,*) "Usage:",trim(str)," " - call exit(2) - end if - - call getarg(1,f_in) - - open(unit=10, file=trim(f_in), form='unformatted') - -! Count the records in the files -! ------------------------------ -! Valid numbers are: -! 61 - old catch_internal_restart -! 57 - old catch_internal_restart - m=0 - do while(.true.) - read(10, end=50, err=200) ! skip to next record - m = m+1 - end do -50 continue - rewind(10) - - if (m == 57) then - print *,'WARNING: this file contains ', m, ' records and appears to have been already convered' - print *,'Refuse to convert!' - print *,'Exiting ...' - call exit(1) - else if (m /= 61) then - print *,'ERROR: this file contains ',m, & - ' records and does not appear to be a valid catchment internal restart' - print *,'Exiting ...' - call exit(2) - end if - -! Open the output file -! -------------------- - call getarg(2,f_out) - open(unit=20, file=trim(f_out), form='unformatted') - - m=0 - bpos=0 - do while(.true.) - m = m+1 - read(10, end=100, err=200) ! skip to next record - epos = ftell(10) ! ending position of file pointer - backspace(10) - - rsize = (epos-bpos)/4-2 ! record size (in 4 byte words; - bpos = epos - allocate(a(rsize), stat=status) - VERIFY_(status) - read (10) a - if (m < 57 .or. m > 60) then - print *,'Writing record ',m - write(20) a - else - print *,'Skipping record ',m - end if - deallocate(a) - end do -100 continue - close(10) - close(20) - stop - -! If we are here something must have gone wrong -200 VERIFY_(200) - -end program newcatch - diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/mk_restarts/obsolete/newvegdyn.f90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/mk_restarts/obsolete/newvegdyn.f90 deleted file mode 100644 index beafa84247..0000000000 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/mk_restarts/obsolete/newvegdyn.f90 +++ /dev/null @@ -1,57 +0,0 @@ -program newvegdyn - implicit none - - real, pointer :: var(:) - - integer :: i, bpos, epos, status - integer :: rsize - character(256) :: str, f_in, f_out - integer*4 :: ftell - external :: ftell - - integer*4 :: iargc - external :: iargc - -! Begin - - if (iargc() /= 2) then - call getarg(0,str) - write(*,*) "Usage:",trim(str)," " - call exit(2) - end if - - call getarg(1,f_in) - call getarg(2,f_out) - - open(unit=10, file=trim(f_in), form='unformatted') - open(unit=20, file=trim(f_out), form='unformatted') - - print *,'New Restart Format for File: ',trim(f_in) - - bpos=0 - read(10, err=200) ! skip to next record - epos = ftell(10) ! ending position of file pointer - - rsize = (epos-bpos)/4-2 ! record size (in 4 byte words; - ! 2 is the number of fortran control words) - allocate(var(rsize), stat=status) - if (status /= 0) then - print *, 'Error: allocation ', rsize, ' failed!' - call exit(11) - end if - - read(10, err=200) ! skip to next record - read(10, err=200) ! skip to next record - read(10, err=200) ! skip to next record -! alltogather we skip 4 record - read (10) var - write(20) var - deallocate(var) - close(10) - close(20) - stop - -200 print *,'Error reading file ',trim(f_in) - call exit(11) - -end diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/mk_restarts/obsolete/old_catch.ctl b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/mk_restarts/obsolete/old_catch.ctl deleted file mode 100755 index b98d321634..0000000000 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/mk_restarts/obsolete/old_catch.ctl +++ /dev/null @@ -1,73 +0,0 @@ -dset wrk/old_catch.dat -options sequential template big_endian -undef -9999.0 -xdef 76847 linear 1 1 -ydef 1 linear 1 1 -zdef 4 linear 1 1 -tdef 1 linear jan1900 1mo -* -VARS 63 -var01 0 99 topo_baseflow_param_1 -var02 0 99 topo_baseflow_param_2 -var03 0 99 topo_baseflow_param_3 -var04 0 99 max_rootzone_water_content -var05 0 99 moisture_threshold -var06 0 99 max_water_content_unsat_zone -var07 0 99 saturated_matrix_potential -var08 0 99 clapp_hornberger_b -var09 0 99 soil_porosity -var10 0 99 wetness_at_wilting_point -var11 0 99 sfc_sat_hydraulic_conduct -var12 0 99 vertical_transmissivity -var13 0 99 wetness_param_1 -var14 0 99 wetness_param_2 -var15 0 99 wetness_param_3 -var16 0 99 shape_param_1 -var17 0 99 shape_param_2 -var18 0 99 shape_param_3 -var19 0 99 shape_param_4 -var20 0 99 min_theta_1 -var21 0 99 min_theta_2 -var22 0 99 min_theta_3 -var23 0 99 min_theta_4 -var24 0 99 water_transfer_1 -var25 0 99 water_transfer_2 -var26 0 99 water_transfer_3 -var27 0 99 water_transfer_4 -var28 0 99 soil_param_1 -var29 0 99 soil_param_2 -var30 0 99 vegetation_type -var31 4 99 canopy_temperature_1,2,3,4 -var32 4 99 canopy_specific_humidity_1,2,3,4 -var33 0 99 interception_reservoir_capac -var34 0 99 catchment_deficit -var35 0 99 root_zone_excess -var36 0 99 surface_excess -var37 0 99 soil_heat_content_layer1 -var38 0 99 soil_heat_content_layer2 -var39 0 99 soil_heat_content_layer3 -var40 0 99 soil_heat_content_layer4 -var41 0 99 soil_heat_content_layer5 -var42 0 99 soil_heat_content_layer6 -var43 0 99 mean_catchment_temp_incl_snow -var44 0 99 water_eq_snow_layer1 -var45 0 99 water_eq_snow_layer2 -var46 0 99 water_eq_snow_layer3 -var47 0 99 heat_content_snow_layer1 -var48 0 99 heat_content_snow_layer2 -var49 0 99 heat_content_snow_layer3 -var50 0 99 snow_depth_layer1 -var51 0 99 snow_depth_layer2 -var52 0 99 snow_depth_layer3 -var53 4 99 surface_heat_exchange_coefficient_1,2,3,4 -var54 4 99 surface_momentum_exchange_coefficient_1,2,3,4 -var55 4 99 surface_moisture_exchange_coefficient_1,2,3,4 -var56 4 99 subtile_fractions_1,2,3,4 -var57 0 99 observed_albedo_minimum_previous -var58 0 99 observed_albedo_minimum_next -var59 0 99 observed_albedo_mean_previous -var60 0 99 observed_albedo_mean_next -var61 0 99 observed_albedo_maxmindif_previous -var62 0 99 observed_albedo_maxmindir_next -var63 4 99 vertical_velocity_scale_squared_1,2,3,4 -ENDVARS diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/mk_restarts/obsolete/replace_params.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/mk_restarts/obsolete/replace_params.F90 deleted file mode 100644 index 09fa5c26b8..0000000000 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/mk_restarts/obsolete/replace_params.F90 +++ /dev/null @@ -1,296 +0,0 @@ -PROGRAM replace_params - implicit none - - integer :: nland_old, nland_new - character*400 :: tilefile - character*400 :: old_restart, new_restart, sarithpath - - real, allocatable :: var1(:),var2(:,:) - integer :: numrecs, allrecs, numparmrecs - - real, allocatable :: BF1(:), BF2(:), BF3(:), VGWMAX(:) - real, allocatable :: CDCR1(:), CDCR2(:), PSIS(:), BEE(:) - real, allocatable :: POROS(:), WPWET(:), COND(:), GNU(:) - real, allocatable :: ARS1(:), ARS2(:), ARS3(:) - real, allocatable :: ARA1(:), ARA2(:), ARA3(:), ARA4(:) - real, allocatable :: ARW1(:), ARW2(:), ARW3(:), ARW4(:) - real, allocatable :: TSA1(:), TSA2(:), TSB1(:), TSB2(:) - real, allocatable :: ATAU2(:), BTAU2(:), ITY0(:) - integer, allocatable :: ity_int(:) - integer :: ity2, nmin, type - real, allocatable :: DP2BR(:), tmp_wgt(:,:), tmp_sum(:,:) - real :: zdep1, zdep2, zdep3, zmet, term1, term2 - integer :: catindex21, catindex22, catindex23 - integer :: catindex24, catindex25, catindex26 - real :: frc1, frc2, rdum - integer :: catid, checksum, ntilesold - integer :: ii0, jj0, i,j,n, idum,II - integer :: IARGC - - - II = iargc() - - if(II /= 4) then - print *, "Wrong Number of arguments: ", ii - call exit(66) - end if - - call getarg(1,old_restart) - call getarg(2,new_restart) - call getarg(3,tilefile) - call getarg(4,sarithpath) - - sarithpath = "/land/l_data/geos5/bcs/SiB2_V2/DC/"//trim(sarithpath) - - numrecs = 61 - numparmrecs = 30 - - ! read .til file - - open (10,file=trim(tilefile),status='old',form='formatted') - read (10,*) ntilesold - read (10,*) - read (10,*) - read (10,*) - read (10,*) - read (10,*) - read (10,*) - read (10,*) - nland_old=0 - do n = 1,ntilesold - read(10,*) type - if (type == 100) then - nland_old=nland_old+1 - endif - end do - close (10,status='keep') - - print *, ' Number of land tiles = ', nland_old - - nland_new = nland_old - - allocate ( BF1(nland_new), BF2 (nland_new), BF3(nland_new) ) - allocate (VGWMAX(nland_new), CDCR1(nland_new), CDCR2(nland_new) ) - allocate ( PSIS(nland_new), BEE(nland_new), POROS(nland_new) ) - allocate ( WPWET(nland_new), COND(nland_new), GNU(nland_new) ) - allocate ( ARS1(nland_new), ARS2(nland_new), ARS3(nland_new) ) - allocate ( ARA1(nland_new), ARA2(nland_new), ARA3(nland_new) ) - allocate ( ARA4(nland_new), ARW1(nland_new), ARW2(nland_new) ) - allocate ( ARW3(nland_new), ARW4(nland_new), TSA1(nland_new) ) - allocate ( TSA2(nland_new), TSB1(nland_new), TSB2(nland_new) ) - allocate ( ATAU2(nland_new), BTAU2(nland_new), DP2BR(nland_new) ) - allocate ( ITY0(nland_new), ity_int(nland_new)) - - - - open(unit=21, file=trim(sarithpath) // '/' //'mosaic_veg_typs_fracs',form='formatted') - open(unit=22, file=trim(sarithpath) // '/' //'bf.dat' ,form='formatted') - open(unit=23, file=trim(sarithpath) // '/' //'soil_param.dat' ,form='formatted') - open(unit=24, file=trim(sarithpath) // '/' //'ar.new' ,form='formatted') - open(unit=25, file=trim(sarithpath) // '/' //'ts.dat' ,form='formatted') - open(unit=26, file=trim(sarithpath) // '/' //'tau_param.dat' ,form='formatted') - - - print *, 'opened units' - - do n=1,nland_new - read (21, *) catindex21, catid, ity_int(n), ity2, frc1, frc2 - ITY0(n)=1.0*ity_int(n) - - read (22, *) catindex22, catid, GNU(n), BF1(n), BF2(n), BF3(n) - - read (23, *) catindex23, catid, idum, idum, BEE(n), PSIS(n), POROS(n), COND(n), WPWET(n), DP2BR(n) - - read (24, *) catindex24, catid, rdum, ARS1(n), ARS2(n), ARS3(n), & - ARA1(n), ARA2(n), ARA3(n), ARA4(n), & - ARW1(n), ARW2(n), ARW3(n), ARW4(n) - - read (25, *) catindex25, catid, rdum, TSA1(n), TSA2(n), TSB1(n), TSB2(n) - - read (26, *) catindex26, catid, ATAU2(n), BTAU2(n), rdum, rdum - - zdep2=1000. - zdep3=amax1(1000.,DP2BR(n)) - if (zdep2 .gt.0.75*zdep3) then - zdep2 = 0.75*zdep3 - end if - zdep1=20. - zmet=zdep3/1000. - - term1=-1.+((PSIS(n)-zmet)/PSIS(n))**((BEE(n)-1.)/BEE(n)) - term2=PSIS(n)*BEE(n)/(BEE(n)-1) - - VGWMAX(n) = POROS(n)*zdep2 - CDCR1(n) = 1000.*POROS(n)*(zmet-(-term2*term1)) - CDCR2(n) = (1.-WPWET(n))*POROS(n)*zdep3 - enddo - - close (21) - close (22) - close (23) - close (24) - close (25) - close (26) - - - print *, ' Doing restarts' - - open(unit=30, file=trim(old_restart),form='unformatted',status='old',convert='little_endian') - open(unit=40, file=trim(new_restart),form='unformatted',status='unknown',convert='little_endian') - - allocate(var1(nland_old)) - allocate(var2(nland_old,4)) - - print *, 'Opened restart files' - print *, 30, trim(old_restart) - print *, 40, trim(new_restart) - - - - write(40) BF1 - read(30) var1 - print *, "BF1",maxval(BF1), maxval(var1), minval(BF1),minval(var1) - - write(40) BF2 - read(30) var1 - print *, "BF2",maxval(BF2), maxval(var1), minval(BF2),minval(var1) - - write(40) BF3 - read(30) var1 - print *, "BF3",maxval(BF3), maxval(var1), minval(BF3),minval(var1) - - write(40) VGWMAX - read(30) var1 - print *, "VGWMAX",maxval(VGWMAX), maxval(var1), minval(VGWMAX),minval(var1) - - write(40) CDCR1 - read(30) var1 - print *, "CDCR1",maxval(CDCR1), maxval(var1), minval(CDCR1),minval(var1) - - write(40) CDCR2 - read(30) var1 - print *, "CDCR2",maxval(CDCR2), maxval(var1), minval(CDCR2),minval(var1) - - write(40) PSIS - read(30) var1 - print *, "PSIS",maxval(PSIS), maxval(var1), minval(PSIS),minval(var1) - - write(40) BEE - read(30) var1 - print *, "BEE",maxval(BEE), maxval(var1), minval(BEE),minval(var1) - - write(40) POROS - read(30) var1 - print *, "POROS ",maxval(POROS ), maxval(var1), minval(POROS ),minval(var1) - - write(40) WPWET - read(30) var1 - print *, "WPWET",maxval(WPWET), maxval(var1), minval(WPWET),minval(var1) - - write(40) COND - read(30) var1 - print *, "COND",maxval(COND), maxval(var1), minval(COND),minval(var1) - - write(40) GNU - read(30) var1 - print *, "GNU",maxval(GNU), maxval(var1), minval(GNU),minval(var1) - - write(40) ARS1 - read(30) var1 - print *, "ARS1",maxval(ARS1), maxval(var1), minval(ARS1),minval(var1) - - write(40) ARS2 - read(30) var1 - print *, "ARS2",maxval(ARS2), maxval(var1), minval(ARS2),minval(var1) - - write(40) ARS3 - read(30) var1 - print *, "ARS3",maxval(ARS3), maxval(var1), minval(ARS3),minval(var1) - - write(40) ARA1 - read(30) var1 - print *, "ARA1",maxval(ARA1), maxval(var1), minval(ARA1),minval(var1) - - write(40) ARA2 - read(30) var1 - print *, "ARA2",maxval(ARA2), maxval(var1), minval(ARA2),minval(var1) - - write(40) ARA3 - read(30) var1 - print *, "ARA3",maxval(ARA3), maxval(var1), minval(ARA3),minval(var1) - - write(40) ARA4 - read(30) var1 - print *, "ARA4",maxval(ARA4), maxval(var1), minval(ARA4),minval(var1) - - write(40) ARW1 - read(30) var1 - print *, "ARW1",maxval(ARW1), maxval(var1), minval(ARW1),minval(var1) - - write(40) ARW2 - read(30) var1 - print *, "ARW2",maxval(ARW2), maxval(var1), minval(ARW2),minval(var1) - - write(40) ARW3 - read(30) var1 - print *, "ARW3",maxval(ARW3), maxval(var1), minval(ARW3),minval(var1) - - write(40) ARW4 - read(30) var1 - print *, "ARW4",maxval(ARW4), maxval(var1), minval(ARW4),minval(var1) - - write(40) TSA1 - read(30) var1 - print *, "TSA1",maxval(TSA1), maxval(var1), minval(TSA1),minval(var1) - - write(40) TSA2 - read(30) var1 - print *, "TSA2",maxval(TSA2), maxval(var1), minval(TSA2),minval(var1) - - write(40) TSB1 - read(30) var1 - print *, "TSB1",maxval(TSB1), maxval(var1), minval(TSB1),minval(var1) - - write(40) TSB2 - read(30) var1 - print *, "TSB2",maxval(TSB2), maxval(var1), minval(TSB2),minval(var1) - - write(40) ATAU2 - read(30) var1 - print *, "ATAU2",maxval(ATAU2), maxval(var1), minval(ATAU2),minval(var1) - - write(40) BTAU2 - read(30) var1 - print *, "BTAU2",maxval(BTAU2), maxval(var1), minval(BTAU2),minval(var1) - - write(40) ITY0 - read(30) var1 - print *, "ITY0",maxval(ITY0), maxval(var1), minval(ITY0),minval(var1) - - - print *, 'Wrote parameters' - - do n=1,2 - read (30) var2 - write(40) var2 - end do - - do n=1,20 - read (30) var1 - write(40) var1 - enddo - - do n=1,4 - read (30) var2 - write(40) var2 - end do - - do n=1,4 - read (30) var1 - write(40) var1 - enddo - - read (30) var2 - write(40) var2 - -END PROGRAM replace_params diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/mk_restarts/obsolete/strip_vegdyn.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/mk_restarts/obsolete/strip_vegdyn.F90 deleted file mode 100644 index 2fd95d2b8e..0000000000 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/mk_restarts/obsolete/strip_vegdyn.F90 +++ /dev/null @@ -1,78 +0,0 @@ -#define VERIFY_(A) if(A /=0)then;print *,'ERROR code',A,'at',__LINE__;call exit(3);endif - -program checkVegDyn - implicit none - -#ifndef __GFORTRAN__ - integer*4 :: iargc - external :: iargc - integer :: ftell - external :: ftell -#endif - character(256) :: str, f_in, f_out - - integer :: m, n - integer :: status - integer :: bpos, epos, nt - integer, parameter :: unit=10 - real, allocatable :: a(:) - integer, allocatable :: veg(:) - integer :: minVegType - integer :: maxVegType - -! Begin - - if (iargc() /= 2) then - call getarg(0,str) - write(*,*) "Usage:",trim(str)," "," " - call exit(2) - end if - - call getarg(1,f_in) - call getarg(2,f_out) - - open(unit=unit, file=trim(f_in), form='unformatted') - -! count the records - m=0 - do while(.true.) - read(unit, end=50, err=200) ! skip to next record - m = m+1 - end do -50 continue - if (m == 1) then - print *, 'File ', trim(f_in), 'contains only only record. Exiting ...' - goto 100 - end if - - rewind(unit) - - open(unit=20, file=trim(f_out), form='unformatted') - -! determine number of tiles by the size of the first record - - bpos=0 - read(unit, err=200) ! skip to next record - epos = ftell(unit) ! ending position of file pointer - nt = (epos-bpos)/4-2 ! record size (in 4 byte words; - rewind(unit) - - allocate(a(nt), stat=status) - VERIFY_(status) - -! Read and copy first record - read (unit) a - write(20) a - - close(20) - -! clean up -100 continue - close(unit) - stop - -! If we are here, something must have gone wrong -200 VERIFY_(200) - -end program checkVegDyn - From c07b83b4c634e71e9e1c385380b9635d93cefbd4 Mon Sep 17 00:00:00 2001 From: Matt Thompson Date: Mon, 13 Jul 2026 09:13:53 -0400 Subject: [PATCH 35/40] Fix ISSM type (#1476) --- .../GEOS_LandIceGridComp.F90 | 854 +++++++++--------- .../GEOSissm_GridComp/GEOS_ISSMGridComp.F90 | 408 ++++----- 2 files changed, 631 insertions(+), 631 deletions(-) diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSlandice_GridComp/GEOS_LandIceGridComp.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSlandice_GridComp/GEOS_LandIceGridComp.F90 index 290564cd1e..1abc31d675 100644 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSlandice_GridComp/GEOS_LandIceGridComp.F90 +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSlandice_GridComp/GEOS_LandIceGridComp.F90 @@ -10,11 +10,11 @@ module GEOS_LandiceGridCompMod ! !MODULE: GEOS_LandiceGridCompMod -- Implements slab landice tiles. ! !========================================================================== -! An improved version over the slab landice +! An improved version over the slab landice ! TODO : -! - Add multiple elevation classes support to account for ice sheet topo changes +! - Add multiple elevation classes support to account for ice sheet topo changes ! - Add more layers for a more realistic treatment of ice energy budget @@ -30,7 +30,7 @@ module GEOS_LandiceGridCompMod use StieglitzSnow, only: & snowrt => StieglitzSnow_snowrt, & SNOW_ALBEDO => StieglitzSnow_snow_albedo, & - TRID => StieglitzSnow_trid, & + TRID => StieglitzSnow_trid, & MINSWE => StieglitzSnow_MINSWE, & cpw => StieglitzSnow_CPW, & N_CONSTIT, & @@ -43,11 +43,11 @@ module GEOS_LandiceGridCompMod use MAPL use GEOS_UtilsMod use DragCoefficientsMod - + #ifdef HAVE_ISSM use GEOS_IssmGridCompMod, only : IssmSetServices => SetServices use GEOS_IssmGridCompMod, only : T_ISSM_TILE_STATE - use GEOS_IssmGridCompMod, only : ISSM_TILE_WRAP + use GEOS_IssmGridCompMod, only : T_ISSM_TILE_WRAP #endif implicit none @@ -61,11 +61,11 @@ module GEOS_LandiceGridCompMod integer, parameter :: NUM_SNOICE_LAYERS = NUM_SNOW_LAYERS+NUM_ICE_LAYERS real, parameter :: rad_to_deg = 180.0 / 3.1415926 - + ! snowrt related constants - ! will move these to a global module later + ! will move these to a global module later real, parameter :: ALHE = MAPL_ALHL ! J/kg @15C - real, parameter :: ALHM = MAPL_ALHF ! J/kg + real, parameter :: ALHM = MAPL_ALHF ! J/kg real, parameter :: TF = MAPL_TICE ! K real, parameter :: RHOW = MAPL_RHOWTR ! kg/m^3 @@ -73,11 +73,11 @@ module GEOS_LandiceGridCompMod real, parameter :: RHOICE = 917. ! kg/m^3 pure ice density real, parameter :: MAXSNDZ = 15.0 ! m real, parameter :: BIG = 1.e10 - real, parameter :: condice = 2.25 ! @ 0 C [W/m/K] + real, parameter :: condice = 2.25 ! @ 0 C [W/m/K] real, parameter :: MINFRACSNO = 1.e-20 ! mininum sno/ice fraction for ! heat diffusion of ice layers to take effect real, parameter :: LWCTOP = 1. ! top thickness to compute LWC. 1m taken from - ! Fettweis et al 2011 + ! Fettweis et al 2011 real, parameter :: VISMAX = 0.96 ! parameter for snow_albedo real, parameter :: NIRMAX = 0.68 ! parameter for snow_albedo real, parameter :: SLOPE = 1.0 ! parameter for snow_albedo @@ -87,15 +87,15 @@ module GEOS_LandiceGridCompMod AWTVDR = 0.00318, &! visible, direct ! for history and AWTIDR = 0.00182, &! near IR, direct ! diagnostics AWTVDF = 0.63282, &! visible, diffuse - AWTIDF = 0.36218 ! near IR, diffuse + AWTIDF = 0.36218 ! near IR, diffuse !real, dimension(NUM_SNOW_LAYERS), parameter :: DZMAX = (/0.08, 0.12, big/) real, dimension(NUM_SNOW_LAYERS), parameter :: DZMAX = (/0.08, 0.08, 0.08 & - , 0.15, 0.25, big, big, big, big, big, big, big, big, big, big/) + , 0.15, 0.25, big, big, big, big, big, big, big, big, big, big/) real, dimension(NUM_ICE_LAYERS), parameter :: DZMAXI = (/0.08, 0.08, 0.08 & - , 0.15, 0.25, 0.5, 0.75, 1.0, 1.25, 1.5, 1.75, 2.0, 2.5, 3.0, 4.0/) - + , 0.15, 0.25, 0.5, 0.75, 1.0, 1.25, 1.5, 1.75, 2.0, 2.5, 3.0, 4.0/) + integer, parameter :: TAR_PE = 43 @@ -109,7 +109,7 @@ module GEOS_LandiceGridCompMod integer :: ISSM ! !DESCRIPTION: -! +! ! {\tt GEOS\_Landice} is a light-weight gridded component that updates ! the landice tiles ! @@ -130,10 +130,10 @@ subroutine SetServices ( GC, RC ) type(ESMF_GridComp), intent(INOUT) :: GC ! gridded component integer, optional :: RC ! return code -! !DESCRIPTION: +! !DESCRIPTION: ! This version uses the MAPL\_GenericSetServices, which sets ! the Initialize and Finalize services, as well as allocating -! our instance of a generic state and putting it in the +! our instance of a generic state and putting it in the ! gridded component (GC). Here we only need to set the run method and ! add the state variable specifications (also generic) to our instance ! of the generic state. This is the way our true state variables get into @@ -151,7 +151,7 @@ subroutine SetServices ( GC, RC ) integer :: STATUS character(len=ESMF_MAXSTR) :: COMP_NAME character(len=ESMF_MAXSTR) :: SURFRC - type(ESMF_Config) :: SCF + type(ESMF_Config) :: SCF !============================================================================= @@ -178,12 +178,12 @@ subroutine SetServices ( GC, RC ) ! ----------------------- !add initialize method for child (ISSM) call MAPL_GetResource (MAPL, DO_ISSM, label='DO_ISSM:', DEFAULT=0, __RC__ ) - + #ifndef HAVE_ISSM DO_ISSM=0 #endif - - call MAPL_GridCompSetEntryPoint ( GC, ESMF_METHOD_INITIALIZE, Initialize, RC=STATUS ) + + call MAPL_GridCompSetEntryPoint ( GC, ESMF_METHOD_INITIALIZE, Initialize, RC=STATUS ) VERIFY_(STATUS) @@ -246,7 +246,7 @@ subroutine SetServices ( GC, RC ) VLOCATION = MAPL_VLocationNone, & RC=STATUS ) VERIFY_(STATUS) - end if + end if #endif call MAPL_AddExportSpec(GC, & @@ -417,7 +417,7 @@ subroutine SetServices ( GC, RC ) SHORT_NAME = 'EVPICE_GL' ,& DIMS = MAPL_DimsTileOnly ,& VLOCATION = MAPL_VLocationNone ,& - RC=STATUS ) + RC=STATUS ) VERIFY_(STATUS) call MAPL_AddExportSpec(GC, & @@ -426,7 +426,7 @@ subroutine SetServices ( GC, RC ) SHORT_NAME = 'SUBLIM' ,& DIMS = MAPL_DimsTileOnly ,& VLOCATION = MAPL_VLocationNone ,& - RC=STATUS ) + RC=STATUS ) VERIFY_(STATUS) call MAPL_AddExportSpec(GC, & @@ -435,7 +435,7 @@ subroutine SetServices ( GC, RC ) SHORT_NAME = 'SNOMAS_GL' ,& DIMS = MAPL_DimsTileOnly ,& VLOCATION = MAPL_VLocationNone ,& - RC=STATUS ) + RC=STATUS ) VERIFY_(STATUS) @@ -445,7 +445,7 @@ subroutine SetServices ( GC, RC ) SHORT_NAME = 'SNOWMASS' ,& DIMS = MAPL_DimsTileOnly ,& VLOCATION = MAPL_VLocationNone ,& - RC=STATUS ) + RC=STATUS ) VERIFY_(STATUS) call MAPL_AddExportSpec(GC, & @@ -644,7 +644,7 @@ subroutine SetServices ( GC, RC ) SHORT_NAME = 'SMELT' ,& DIMS = MAPL_DimsTileOnly ,& VLOCATION = MAPL_VLocationNone ,& - RC=STATUS ) + RC=STATUS ) VERIFY_(STATUS) call MAPL_AddExportSpec(GC, & @@ -653,7 +653,7 @@ subroutine SetServices ( GC, RC ) SHORT_NAME = 'IMELT' ,& DIMS = MAPL_DimsTileOnly ,& VLOCATION = MAPL_VLocationNone ,& - RC=STATUS ) + RC=STATUS ) VERIFY_(STATUS) call MAPL_AddExportSpec(GC, & @@ -662,7 +662,7 @@ subroutine SetServices ( GC, RC ) SHORT_NAME = 'SNOWALB' ,& DIMS = MAPL_DimsTileOnly ,& VLOCATION = MAPL_VLocationNone ,& - RC=STATUS ) + RC=STATUS ) VERIFY_(STATUS) call MAPL_AddExportSpec(GC, & @@ -671,7 +671,7 @@ subroutine SetServices ( GC, RC ) SHORT_NAME = 'SNICEALB' ,& DIMS = MAPL_DimsTileOnly ,& VLOCATION = MAPL_VLocationNone ,& - RC=STATUS ) + RC=STATUS ) VERIFY_(STATUS) call MAPL_AddExportSpec(GC, & @@ -680,7 +680,7 @@ subroutine SetServices ( GC, RC ) SHORT_NAME = 'MELTWTR' ,& DIMS = MAPL_DimsTileOnly ,& VLOCATION = MAPL_VLocationNone ,& - RC=STATUS ) + RC=STATUS ) VERIFY_(STATUS) call MAPL_AddExportSpec(GC, & @@ -689,7 +689,7 @@ subroutine SetServices ( GC, RC ) SHORT_NAME = 'MELTWTRCONT' ,& DIMS = MAPL_DimsTileOnly ,& VLOCATION = MAPL_VLocationNone ,& - RC=STATUS ) + RC=STATUS ) VERIFY_(STATUS) call MAPL_AddExportSpec(GC, & @@ -698,7 +698,7 @@ subroutine SetServices ( GC, RC ) SHORT_NAME = 'LWC' ,& DIMS = MAPL_DimsTileOnly ,& VLOCATION = MAPL_VLocationNone ,& - RC=STATUS ) + RC=STATUS ) VERIFY_(STATUS) call MAPL_AddExportSpec(GC, & @@ -707,7 +707,7 @@ subroutine SetServices ( GC, RC ) SHORT_NAME = 'RUNOFF' ,& DIMS = MAPL_DimsTileOnly ,& VLOCATION = MAPL_VLocationNone ,& - RC=STATUS ) + RC=STATUS ) VERIFY_(STATUS) call MAPL_AddExportSpec(GC, & @@ -734,7 +734,7 @@ subroutine SetServices ( GC, RC ) SHORT_NAME = 'Z0' ,& DIMS = MAPL_DimsTileOnly ,& VLOCATION = MAPL_VLocationNone ,& - RC=STATUS ) + RC=STATUS ) VERIFY_(STATUS) call MAPL_AddExportSpec(GC, & @@ -743,7 +743,7 @@ subroutine SetServices ( GC, RC ) SHORT_NAME = 'Z0H' ,& DIMS = MAPL_DimsTileOnly ,& VLOCATION = MAPL_VLocationNone ,& - RC=STATUS ) + RC=STATUS ) VERIFY_(STATUS) call MAPL_AddExportSpec(GC, & @@ -842,7 +842,7 @@ subroutine SetServices ( GC, RC ) SHORT_NAME = 'EVAPOUT' ,& DIMS = MAPL_DimsTileOnly ,& VLOCATION = MAPL_VLocationNone ,& - RC=STATUS ) + RC=STATUS ) VERIFY_(STATUS) call MAPL_AddExportSpec(GC, & @@ -851,7 +851,7 @@ subroutine SetServices ( GC, RC ) SHORT_NAME = 'SHOUT' ,& DIMS = MAPL_DimsTileOnly ,& VLOCATION = MAPL_VLocationNone ,& - RC=STATUS ) + RC=STATUS ) VERIFY_(STATUS) call MAPL_AddExportSpec(GC, & @@ -860,7 +860,7 @@ subroutine SetServices ( GC, RC ) SHORT_NAME = 'HLWUP' ,& DIMS = MAPL_DimsTileOnly ,& VLOCATION = MAPL_VLocationNone ,& - RC=STATUS ) + RC=STATUS ) VERIFY_(STATUS) call MAPL_AddExportSpec(GC ,& @@ -869,7 +869,7 @@ subroutine SetServices ( GC, RC ) SHORT_NAME = 'LWNDSRF' ,& DIMS = MAPL_DimsTileOnly ,& VLOCATION = MAPL_VLocationNone ,& - RC=STATUS ) + RC=STATUS ) VERIFY_(STATUS) call MAPL_AddExportSpec(GC ,& @@ -878,7 +878,7 @@ subroutine SetServices ( GC, RC ) SHORT_NAME = 'SWNDSRF' ,& DIMS = MAPL_DimsTileOnly ,& VLOCATION = MAPL_VLocationNone ,& - RC=STATUS ) + RC=STATUS ) VERIFY_(STATUS) call MAPL_AddExportSpec(GC, & @@ -887,7 +887,7 @@ subroutine SetServices ( GC, RC ) SHORT_NAME = 'HLATN' ,& DIMS = MAPL_DimsTileOnly ,& VLOCATION = MAPL_VLocationNone ,& - RC=STATUS ) + RC=STATUS ) VERIFY_(STATUS) call MAPL_AddExportSpec(GC, & @@ -896,7 +896,7 @@ subroutine SetServices ( GC, RC ) SHORT_NAME = 'DNICFLX' ,& DIMS = MAPL_DimsTileOnly ,& VLOCATION = MAPL_VLocationNone ,& - RC=STATUS ) + RC=STATUS ) VERIFY_(STATUS) call MAPL_AddExportSpec(GC, & @@ -905,7 +905,7 @@ subroutine SetServices ( GC, RC ) SHORT_NAME = 'GHSNOW' ,& DIMS = MAPL_DimsTileOnly ,& VLOCATION = MAPL_VLocationNone ,& - RC=STATUS ) + RC=STATUS ) VERIFY_(STATUS) call MAPL_AddExportSpec(GC, & @@ -914,7 +914,7 @@ subroutine SetServices ( GC, RC ) SHORT_NAME = 'GHTSKIN' ,& DIMS = MAPL_DimsTileOnly ,& VLOCATION = MAPL_VLocationNone ,& - RC=STATUS ) + RC=STATUS ) VERIFY_(STATUS) call MAPL_AddExportSpec(GC ,& @@ -923,7 +923,7 @@ subroutine SetServices ( GC, RC ) SHORT_NAME = 'ITY' ,& DIMS = MAPL_DimsTileOnly ,& VLOCATION = MAPL_VLocationNone ,& - RC=STATUS ) + RC=STATUS ) VERIFY_(STATUS) call MAPL_AddExportSpec(GC ,& @@ -932,83 +932,83 @@ subroutine SetServices ( GC, RC ) SHORT_NAME = 'RMELTDU001' ,& DIMS = MAPL_DimsTileOnly ,& VLOCATION = MAPL_VLocationNone ,& - RC=STATUS ) + RC=STATUS ) VERIFY_(STATUS) - + call MAPL_AddExportSpec(GC ,& LONG_NAME = 'flushed_out_dust_mass_flux_from_the_bottom_layer_bin_2',& UNITS = 'kg m-2 s-1' ,& SHORT_NAME = 'RMELTDU002' ,& DIMS = MAPL_DimsTileOnly ,& VLOCATION = MAPL_VLocationNone ,& - RC=STATUS ) + RC=STATUS ) VERIFY_(STATUS) - + call MAPL_AddExportSpec(GC ,& LONG_NAME = 'flushed_out_dust_mass_flux_from_the_bottom_layer_bin_3',& UNITS = 'kg m-2 s-1' ,& SHORT_NAME = 'RMELTDU003' ,& DIMS = MAPL_DimsTileOnly ,& VLOCATION = MAPL_VLocationNone ,& - RC=STATUS ) + RC=STATUS ) VERIFY_(STATUS) - + call MAPL_AddExportSpec(GC ,& LONG_NAME = 'flushed_out_dust_mass_flux_from_the_bottom_layer_bin_4',& UNITS = 'kg m-2 s-1' ,& SHORT_NAME = 'RMELTDU004' ,& DIMS = MAPL_DimsTileOnly ,& VLOCATION = MAPL_VLocationNone ,& - RC=STATUS ) + RC=STATUS ) VERIFY_(STATUS) - + call MAPL_AddExportSpec(GC ,& LONG_NAME = 'flushed_out_dust_mass_flux_from_the_bottom_layer_bin_5',& UNITS = 'kg m-2 s-1' ,& SHORT_NAME = 'RMELTDU005' ,& DIMS = MAPL_DimsTileOnly ,& VLOCATION = MAPL_VLocationNone ,& - RC=STATUS ) + RC=STATUS ) VERIFY_(STATUS) - + call MAPL_AddExportSpec(GC ,& LONG_NAME = 'flushed_out_black_carbon_mass_flux_from_the_bottom_layer_bin_1',& UNITS = 'kg m-2 s-1' ,& SHORT_NAME = 'RMELTBC001' ,& DIMS = MAPL_DimsTileOnly ,& VLOCATION = MAPL_VLocationNone ,& - RC=STATUS ) + RC=STATUS ) VERIFY_(STATUS) - + call MAPL_AddExportSpec(GC ,& LONG_NAME = 'flushed_out_black_carbon_mass_flux_from_the_bottom_layer_bin_2',& UNITS = 'kg m-2 s-1' ,& SHORT_NAME = 'RMELTBC002' ,& DIMS = MAPL_DimsTileOnly ,& VLOCATION = MAPL_VLocationNone ,& - RC=STATUS ) + RC=STATUS ) VERIFY_(STATUS) - + call MAPL_AddExportSpec(GC ,& LONG_NAME = 'flushed_out_organic_carbon_mass_flux_from_the_bottom_layer_bin_1',& UNITS = 'kg m-2 s-1' ,& SHORT_NAME = 'RMELTOC001' ,& DIMS = MAPL_DimsTileOnly ,& VLOCATION = MAPL_VLocationNone ,& - RC=STATUS ) + RC=STATUS ) VERIFY_(STATUS) - + call MAPL_AddExportSpec(GC ,& LONG_NAME = 'flushed_out_organic_carbon_mass_flux_from_the_bottom_layer_bin_2',& UNITS = 'kg m-2 s-1' ,& SHORT_NAME = 'RMELTOC002' ,& DIMS = MAPL_DimsTileOnly ,& VLOCATION = MAPL_VLocationNone ,& - RC=STATUS ) + RC=STATUS ) VERIFY_(STATUS) ! !Internal state: -#ifdef HAVE_ISSM +#ifdef HAVE_ISSM if (DO_ISSM==1) then call MAPL_AddInternalSpec(GC, & SHORT_NAME = 'ICESMB_ISSM', & @@ -1016,10 +1016,10 @@ subroutine SetServices ( GC, RC ) UNITS = 'kg m-2 s-1', & DIMS = MAPL_DimsTileOnly, & VLOCATION = MAPL_VLocationNone, & - RESTART = MAPL_RestartOptional, & + RESTART = MAPL_RestartOptional, & DEFAULT = 0.0 , & RC=STATUS ) - end if + end if #endif call MAPL_AddInternalSpec(GC, & @@ -1139,7 +1139,7 @@ subroutine SetServices ( GC, RC ) VLOCATION = MAPL_VLocationNone, & RESTART = MAPL_RestartOptional, & FRIENDLYTO = trim(COMP_NAME), & - RC=STATUS ) + RC=STATUS ) VERIFY_(STATUS) call MAPL_AddInternalSpec(GC, & @@ -1151,7 +1151,7 @@ subroutine SetServices ( GC, RC ) RESTART = MAPL_RestartOptional, & VLOCATION = MAPL_VLocationNone, & FRIENDLYTO = trim(COMP_NAME), & - RC=STATUS ) + RC=STATUS ) VERIFY_(STATUS) call MAPL_AddInternalSpec(GC, & @@ -1163,7 +1163,7 @@ subroutine SetServices ( GC, RC ) VLOCATION = MAPL_VLocationNone, & RESTART = MAPL_RestartOptional, & FRIENDLYTO = trim(COMP_NAME), & - RC=STATUS ) + RC=STATUS ) VERIFY_(STATUS) call MAPL_AddInternalSpec(GC, & @@ -1175,7 +1175,7 @@ subroutine SetServices ( GC, RC ) VLOCATION = MAPL_VLocationNone, & RESTART = MAPL_RestartOptional, & FRIENDLYTO = trim(COMP_NAME), & - RC=STATUS ) + RC=STATUS ) VERIFY_(STATUS) call MAPL_AddInternalSpec(GC, & @@ -1187,7 +1187,7 @@ subroutine SetServices ( GC, RC ) VLOCATION = MAPL_VLocationNone, & RESTART = MAPL_RestartOptional, & FRIENDLYTO = trim(COMP_NAME), & - RC=STATUS ) + RC=STATUS ) VERIFY_(STATUS) call MAPL_AddInternalSpec(GC, & @@ -1199,7 +1199,7 @@ subroutine SetServices ( GC, RC ) VLOCATION = MAPL_VLocationNone, & RESTART = MAPL_RestartOptional, & FRIENDLYTO = trim(COMP_NAME), & - RC=STATUS ) + RC=STATUS ) VERIFY_(STATUS) call MAPL_AddInternalSpec(GC, & @@ -1211,7 +1211,7 @@ subroutine SetServices ( GC, RC ) VLOCATION = MAPL_VLocationNone, & RESTART = MAPL_RestartOptional, & FRIENDLYTO = trim(COMP_NAME), & - RC=STATUS ) + RC=STATUS ) VERIFY_(STATUS) call MAPL_AddInternalSpec(GC, & @@ -1223,7 +1223,7 @@ subroutine SetServices ( GC, RC ) VLOCATION = MAPL_VLocationNone, & RESTART = MAPL_RestartOptional, & FRIENDLYTO = trim(COMP_NAME), & - RC=STATUS ) + RC=STATUS ) VERIFY_(STATUS) call MAPL_AddInternalSpec(GC, & @@ -1235,7 +1235,7 @@ subroutine SetServices ( GC, RC ) VLOCATION = MAPL_VLocationNone, & RESTART = MAPL_RestartOptional, & FRIENDLYTO = trim(COMP_NAME), & - RC=STATUS ) + RC=STATUS ) VERIFY_(STATUS) end if @@ -1268,7 +1268,7 @@ subroutine SetServices ( GC, RC ) SHORT_NAME = 'DRPAR' ,& DIMS = MAPL_DimsTileOnly ,& VLOCATION = MAPL_VLocationNone ,& - RC=STATUS ) + RC=STATUS ) VERIFY_(STATUS) call MAPL_AddImportSpec(GC ,& @@ -1277,7 +1277,7 @@ subroutine SetServices ( GC, RC ) SHORT_NAME = 'DFPAR' ,& DIMS = MAPL_DimsTileOnly ,& VLOCATION = MAPL_VLocationNone ,& - RC=STATUS ) + RC=STATUS ) VERIFY_(STATUS) call MAPL_AddImportSpec(GC ,& @@ -1286,7 +1286,7 @@ subroutine SetServices ( GC, RC ) SHORT_NAME = 'DRNIR' ,& DIMS = MAPL_DimsTileOnly ,& VLOCATION = MAPL_VLocationNone ,& - RC=STATUS ) + RC=STATUS ) VERIFY_(STATUS) call MAPL_AddImportSpec(GC ,& @@ -1295,7 +1295,7 @@ subroutine SetServices ( GC, RC ) SHORT_NAME = 'DFNIR' ,& DIMS = MAPL_DimsTileOnly ,& VLOCATION = MAPL_VLocationNone ,& - RC=STATUS ) + RC=STATUS ) VERIFY_(STATUS) call MAPL_AddImportSpec(GC ,& @@ -1304,7 +1304,7 @@ subroutine SetServices ( GC, RC ) SHORT_NAME = 'DRUVR' ,& DIMS = MAPL_DimsTileOnly ,& VLOCATION = MAPL_VLocationNone ,& - RC=STATUS ) + RC=STATUS ) VERIFY_(STATUS) call MAPL_AddImportSpec(GC ,& @@ -1313,7 +1313,7 @@ subroutine SetServices ( GC, RC ) SHORT_NAME = 'DFUVR' ,& DIMS = MAPL_DimsTileOnly ,& VLOCATION = MAPL_VLocationNone ,& - RC=STATUS ) + RC=STATUS ) VERIFY_(STATUS) call MAPL_AddImportSpec(GC, & @@ -1498,9 +1498,9 @@ subroutine SetServices ( GC, RC ) DIMS = MAPL_DimsTileOnly, & UNGRIDDED_DIMS = (/NUM_DUDP/), & VLOCATION = MAPL_VLocationNone, & - RC=STATUS ) + RC=STATUS ) VERIFY_(STATUS) - + call MAPL_AddImportSpec(GC, & LONG_NAME = 'dust_wet_depos_conv_scav_all_bins', & UNITS = 'kg m-2 s-1', & @@ -1508,9 +1508,9 @@ subroutine SetServices ( GC, RC ) DIMS = MAPL_DimsTileOnly, & UNGRIDDED_DIMS = (/NUM_DUSV/), & VLOCATION = MAPL_VLocationNone, & - RC=STATUS ) + RC=STATUS ) VERIFY_(STATUS) - + call MAPL_AddImportSpec(GC, & LONG_NAME = 'dust_wet_depos_ls_scav_all_bins', & UNITS = 'kg m-2 s-1', & @@ -1518,9 +1518,9 @@ subroutine SetServices ( GC, RC ) DIMS = MAPL_DimsTileOnly, & UNGRIDDED_DIMS = (/NUM_DUWT/), & VLOCATION = MAPL_VLocationNone, & - RC=STATUS ) + RC=STATUS ) VERIFY_(STATUS) - + call MAPL_AddImportSpec(GC, & LONG_NAME = 'dust_gravity_sett_all_bins', & UNITS = 'kg m-2 s-1', & @@ -1528,9 +1528,9 @@ subroutine SetServices ( GC, RC ) DIMS = MAPL_DimsTileOnly, & UNGRIDDED_DIMS = (/NUM_DUSD/), & VLOCATION = MAPL_VLocationNone, & - RC=STATUS ) + RC=STATUS ) VERIFY_(STATUS) - + call MAPL_AddImportSpec(GC, & LONG_NAME = 'black_carbon_dry_depos_all_bins', & UNITS = 'kg m-2 s-1', & @@ -1538,9 +1538,9 @@ subroutine SetServices ( GC, RC ) DIMS = MAPL_DimsTileOnly, & UNGRIDDED_DIMS = (/NUM_BCDP/), & VLOCATION = MAPL_VLocationNone, & - RC=STATUS ) + RC=STATUS ) VERIFY_(STATUS) - + call MAPL_AddImportSpec(GC, & LONG_NAME = 'black_carbon_wet_depos_conv_scav_all_bins', & UNITS = 'kg m-2 s-1', & @@ -1548,9 +1548,9 @@ subroutine SetServices ( GC, RC ) DIMS = MAPL_DimsTileOnly, & UNGRIDDED_DIMS = (/NUM_BCSV/), & VLOCATION = MAPL_VLocationNone, & - RC=STATUS ) + RC=STATUS ) VERIFY_(STATUS) - + call MAPL_AddImportSpec(GC, & LONG_NAME = 'black_carbon_wet_depos_ls_scav_all_bins', & UNITS = 'kg m-2 s-1', & @@ -1558,9 +1558,9 @@ subroutine SetServices ( GC, RC ) DIMS = MAPL_DimsTileOnly, & UNGRIDDED_DIMS = (/NUM_BCWT/), & VLOCATION = MAPL_VLocationNone, & - RC=STATUS ) + RC=STATUS ) VERIFY_(STATUS) - + call MAPL_AddImportSpec(GC, & LONG_NAME = 'black_carbon_gravity_sett_all_bins', & UNITS = 'kg m-2 s-1', & @@ -1568,9 +1568,9 @@ subroutine SetServices ( GC, RC ) DIMS = MAPL_DimsTileOnly, & UNGRIDDED_DIMS = (/NUM_BCSD/), & VLOCATION = MAPL_VLocationNone, & - RC=STATUS ) + RC=STATUS ) VERIFY_(STATUS) - + call MAPL_AddImportSpec(GC, & LONG_NAME = 'organic_carbon_dry_depos_all_bins', & UNITS = 'kg m-2 s-1', & @@ -1578,9 +1578,9 @@ subroutine SetServices ( GC, RC ) DIMS = MAPL_DimsTileOnly, & UNGRIDDED_DIMS = (/NUM_OCDP/), & VLOCATION = MAPL_VLocationNone, & - RC=STATUS ) + RC=STATUS ) VERIFY_(STATUS) - + call MAPL_AddImportSpec(GC, & LONG_NAME = 'organic_carbon_wet_depos_conv_scav_all_bins', & UNITS = 'kg m-2 s-1', & @@ -1588,9 +1588,9 @@ subroutine SetServices ( GC, RC ) DIMS = MAPL_DimsTileOnly, & UNGRIDDED_DIMS = (/NUM_OCSV/), & VLOCATION = MAPL_VLocationNone, & - RC=STATUS ) + RC=STATUS ) VERIFY_(STATUS) - + call MAPL_AddImportSpec(GC, & LONG_NAME = 'organic_carbon_wet_depos_ls_scav_all_bins', & UNITS = 'kg m-2 s-1', & @@ -1598,9 +1598,9 @@ subroutine SetServices ( GC, RC ) DIMS = MAPL_DimsTileOnly, & UNGRIDDED_DIMS = (/NUM_OCWT/), & VLOCATION = MAPL_VLocationNone, & - RC=STATUS ) + RC=STATUS ) VERIFY_(STATUS) - + call MAPL_AddImportSpec(GC, & LONG_NAME = 'organic_carbon_gravity_sett_all_bins', & UNITS = 'kg m-2 s-1', & @@ -1608,9 +1608,9 @@ subroutine SetServices ( GC, RC ) DIMS = MAPL_DimsTileOnly, & UNGRIDDED_DIMS = (/NUM_OCSD/), & VLOCATION = MAPL_VLocationNone, & - RC=STATUS ) + RC=STATUS ) VERIFY_(STATUS) - + call MAPL_AddImportSpec(GC, & LONG_NAME = 'sulfate_dry_depos_all_bins', & UNITS = 'kg m-2 s-1', & @@ -1618,9 +1618,9 @@ subroutine SetServices ( GC, RC ) DIMS = MAPL_DimsTileOnly, & UNGRIDDED_DIMS = (/NUM_SUDP/), & VLOCATION = MAPL_VLocationNone, & - RC=STATUS ) + RC=STATUS ) VERIFY_(STATUS) - + call MAPL_AddImportSpec(GC, & LONG_NAME = 'sulfate_wet_depos_conv_scav_all_bins', & UNITS = 'kg m-2 s-1', & @@ -1628,9 +1628,9 @@ subroutine SetServices ( GC, RC ) DIMS = MAPL_DimsTileOnly, & UNGRIDDED_DIMS = (/NUM_SUSV/), & VLOCATION = MAPL_VLocationNone, & - RC=STATUS ) + RC=STATUS ) VERIFY_(STATUS) - + call MAPL_AddImportSpec(GC, & LONG_NAME = 'sulfate_wet_depos_ls_scav_all_bins', & UNITS = 'kg m-2 s-1', & @@ -1638,9 +1638,9 @@ subroutine SetServices ( GC, RC ) DIMS = MAPL_DimsTileOnly, & UNGRIDDED_DIMS = (/NUM_SUWT/), & VLOCATION = MAPL_VLocationNone, & - RC=STATUS ) + RC=STATUS ) VERIFY_(STATUS) - + call MAPL_AddImportSpec(GC, & LONG_NAME = 'sulfate_gravity_sett_all_bins', & UNITS = 'kg m-2 s-1', & @@ -1648,9 +1648,9 @@ subroutine SetServices ( GC, RC ) DIMS = MAPL_DimsTileOnly, & UNGRIDDED_DIMS = (/NUM_SUSD/), & VLOCATION = MAPL_VLocationNone, & - RC=STATUS ) + RC=STATUS ) VERIFY_(STATUS) - + call MAPL_AddImportSpec(GC, & LONG_NAME = 'sea_salt_dry_depos_all_bins', & UNITS = 'kg m-2 s-1', & @@ -1658,9 +1658,9 @@ subroutine SetServices ( GC, RC ) DIMS = MAPL_DimsTileOnly, & UNGRIDDED_DIMS = (/NUM_SSDP/), & VLOCATION = MAPL_VLocationNone, & - RC=STATUS ) + RC=STATUS ) VERIFY_(STATUS) - + call MAPL_AddImportSpec(GC, & LONG_NAME = 'sea_salt_wet_depos_conv_scav_all_bins', & UNITS = 'kg m-2 s-1', & @@ -1668,9 +1668,9 @@ subroutine SetServices ( GC, RC ) DIMS = MAPL_DimsTileOnly, & UNGRIDDED_DIMS = (/NUM_SSSV/), & VLOCATION = MAPL_VLocationNone, & - RC=STATUS ) + RC=STATUS ) VERIFY_(STATUS) - + call MAPL_AddImportSpec(GC, & LONG_NAME = 'sea_salt_wet_depos_ls_scav_all_bins', & UNITS = 'kg m-2 s-1', & @@ -1678,9 +1678,9 @@ subroutine SetServices ( GC, RC ) DIMS = MAPL_DimsTileOnly, & UNGRIDDED_DIMS = (/NUM_SSWT/), & VLOCATION = MAPL_VLocationNone, & - RC=STATUS ) + RC=STATUS ) VERIFY_(STATUS) - + call MAPL_AddImportSpec(GC, & LONG_NAME = 'sea_salt_gravity_sett_all_bins', & UNITS = 'kg m-2 s-1', & @@ -1688,19 +1688,19 @@ subroutine SetServices ( GC, RC ) DIMS = MAPL_DimsTileOnly, & UNGRIDDED_DIMS = (/NUM_SSSD/), & VLOCATION = MAPL_VLocationNone, & - RC=STATUS ) + RC=STATUS ) VERIFY_(STATUS) !EOS -#ifdef HAVE_ISSM +#ifdef HAVE_ISSM if (DO_ISSM==1) then - ! Add ISSM child gridcomp + ! Add ISSM child gridcomp ISSM = MAPL_AddChild(GC, NAME='ISSM', SS=IssmSetServices, RC=STATUS) - VERIFY_(STATUS) - + VERIFY_(STATUS) + call MAPL_TerminateImport(GC, CHILD = ISSM, RC=STATUS) VERIFY_(STATUS) - end if + end if #endif ! Set the Profiling timers @@ -1710,7 +1710,7 @@ subroutine SetServices ( GC, RC ) VERIFY_(STATUS) call MAPL_TimerAdd(GC, name="RUN2" ,RC=STATUS) VERIFY_(STATUS) - + ! Set generic init and final methods ! ---------------------------------- @@ -1719,7 +1719,7 @@ subroutine SetServices ( GC, RC ) RETURN_(ESMF_SUCCESS) - + end subroutine SetServices @@ -1727,70 +1727,70 @@ end subroutine SetServices subroutine Initialize ( GC, IMPORT, EXPORT, CLOCK, RC ) - ! this is for ISSM to have access to to the tile locstream + ! this is for ISSM to have access to to the tile locstream ! !ARGUMENTS: - - type(ESMF_GridComp), intent(inout) :: GC ! Gridded component + + type(ESMF_GridComp), intent(inout) :: GC ! Gridded component type(ESMF_State), intent(inout) :: IMPORT ! Import state type(ESMF_State), intent(inout) :: EXPORT ! Export state type(ESMF_Clock), intent(inout) :: CLOCK ! The clock integer, optional, intent( out) :: RC ! Error code - + ! !DESCRIPTION: The Initialize method of the Landice Gridded Component. - + !EOP - + ! ErrLog Variables - - character(len=ESMF_MAXSTR) :: IAm + + character(len=ESMF_MAXSTR) :: IAm integer :: STATUS character(len=ESMF_MAXSTR) :: COMP_NAME - + ! Local derived type aliases - + type (MAPL_MetaComp ), pointer :: MAPL - type (MAPL_MetaComp ), pointer :: CHILD_MAPL + type (MAPL_MetaComp ), pointer :: CHILD_MAPL type (MAPL_LocStream ) :: LOCSTREAM type (ESMF_Config ) :: CF type (ESMF_GridComp ), pointer :: GCS(:) character(len=ESMF_MAXSTR), pointer :: gcnames(:) - + integer :: I #ifdef HAVE_ISSM type(T_ISSM_TILE_STATE), pointer :: issm_tile_state - type(ISSM_TILE_WRAP) :: issm_tile_wrap - real, pointer, dimension(:) :: ICESURF + type(T_ISSM_TILE_WRAP) :: issm_tile_wrap + real, pointer, dimension(:) :: ICESURF real, pointer, dimension(:) :: ICETHICK real, pointer, dimension(:) :: ICEVEL #endif integer :: nt_local integer :: DO_ISSM - real :: LANDICE_DT - + real :: LANDICE_DT + !============================================================================= - - ! Begin... - + + ! Begin... + ! Get the target components name and set-up traceback handle. ! ----------------------------------------------------------- - + call ESMF_GridCompGet ( GC, name=COMP_NAME, RC=STATUS ) VERIFY_(STATUS) Iam = trim(COMP_NAME) // "Initialize" - + ! Get my internal MAPL_Generic state !----------------------------------- - + call MAPL_GetObjectFromGC ( GC, MAPL, RC=STATUS) VERIFY_(STATUS) - + call MAPL_TimerOn(MAPL,"INITIALIZE", RC=STATUS ); VERIFY_(STATUS) call MAPL_TimerOn(MAPL,"TOTAL", RC=STATUS ); VERIFY_(STATUS) - + ! Get the landice tilegrid and the child components - !----------------------------------------------- - + !----------------------------------------------- + call MAPL_Get (MAPL, LOCSTREAM=LOCSTREAM, GCS=GCS, GCNAMES=gcnames, RC=STATUS ) VERIFY_(STATUS) call MAPL_LocStreamGet(locstream, NT_LOCAL=nt_local, rc=STATUS) @@ -1801,10 +1801,10 @@ subroutine Initialize ( GC, IMPORT, EXPORT, CLOCK, RC ) ! get model timestep, overwrite with component-specific timestep if found call MAPL_GetResource (MAPL, LANDICE_DT, label='RUN_DT:',_RC) call MAPL_GetResource (MAPL, LANDICE_DT, label='DT:',default=LANDICE_DT,_RC) - + ! get ISSM flag call MAPL_GetResource (MAPL, DO_ISSM, label='DO_ISSM:', DEFAULT=0, __RC__ ) - + #ifndef HAVE_ISSM DO_ISSM=0 #endif @@ -1831,7 +1831,7 @@ subroutine Initialize ( GC, IMPORT, EXPORT, CLOCK, RC ) end do #endif call MAPL_TimerOff(MAPL,"TOTAL", RC=STATUS ); VERIFY_(STATUS) - + ! Call Initialize for every Child !-------------------------------- call MAPL_GenericInitialize ( GC, IMPORT, EXPORT, CLOCK, RC=STATUS) @@ -1839,19 +1839,19 @@ subroutine Initialize ( GC, IMPORT, EXPORT, CLOCK, RC ) #ifdef HAVE_ISSM if (DO_ISSM==1) then - ! initialize exports to restart values set by ISSM GridComp's Initialize, + ! initialize exports to restart values set by ISSM GridComp's Initialize, ! because ISSM typically has a multi-day timestep and exports will remain empty otherwise call MAPL_GetPointer(EXPORT,ICESURF , 'ICESURF',alloc=.true., RC=STATUS); VERIFY_(STATUS) call MAPL_GetPointer(EXPORT,ICETHICK ,'ICETHICK',alloc=.true., RC=STATUS); VERIFY_(STATUS) call MAPL_GetPointer(EXPORT,ICEVEL ,'ICEVEL',alloc=.true., RC=STATUS); VERIFY_(STATUS) - + if(associated(ICESURF)) ICESURF = issm_tile_state%ICESURF_TILE if(associated(ICETHICK)) ICETHICK = issm_tile_state%ICETHICK_TILE if(associated(ICEVEL)) ICEVEL = issm_tile_state%ICEVEL_TILE - end if -#endif + end if +#endif call MAPL_TimerOff(MAPL,"INITIALIZE", RC=STATUS ); VERIFY_(STATUS) - + RETURN_(ESMF_SUCCESS) end subroutine Initialize @@ -1864,7 +1864,7 @@ subroutine RUN1 ( GC, IMPORT, EXPORT, CLOCK, RC ) !ARGUMENTS: - type(ESMF_GridComp), intent(inout) :: GC ! Gridded component + type(ESMF_GridComp), intent(inout) :: GC ! Gridded component type(ESMF_State), intent(inout) :: IMPORT ! Import state type(ESMF_State), intent(inout) :: EXPORT ! Export state type(ESMF_Clock), intent(inout) :: CLOCK ! The clock @@ -1930,9 +1930,9 @@ subroutine RUN1 ( GC, IMPORT, EXPORT, CLOCK, RC ) real, pointer, dimension(:) :: UU real, pointer, dimension(:) :: UWINDLMTILE real, pointer, dimension(:) :: VWINDLMTILE - real, pointer, dimension(:) :: DZ + real, pointer, dimension(:) :: DZ real, pointer, dimension(:) :: TA - real, pointer, dimension(:) :: QA + real, pointer, dimension(:) :: QA real, pointer, dimension(:) :: PS integer :: N @@ -1983,7 +1983,7 @@ subroutine RUN1 ( GC, IMPORT, EXPORT, CLOCK, RC ) integer :: CHOOSEZ0 !============================================================================= -! Begin... +! Begin... ! Get the target components name and set-up traceback handle. ! ----------------------------------------------------------- @@ -2233,10 +2233,10 @@ subroutine RUN1 ( GC, IMPORT, EXPORT, CLOCK, RC ) CM(:,N) = VKM CH(:,N) = VKH CQ(:,N) = VKH - + CN = (MAPL_KARMAN/ALOG(DZ/Z0(:,N) + 1.0)) * (MAPL_KARMAN/ALOG(DZ/Z0(:,N) + 1.0)) ZT = Z0(:,N) - ZQ = Z0(:,N) + ZQ = Z0(:,N) RE = 0. UUU = UU UCN = 0. @@ -2339,19 +2339,19 @@ subroutine RUN2 ( GC, IMPORT, EXPORT, CLOCK, RC ) !ARGUMENTS: - type(ESMF_GridComp), intent(inout) :: GC ! Gridded component + type(ESMF_GridComp), intent(inout) :: GC ! Gridded component type(ESMF_State), intent(inout) :: IMPORT ! Import state type(ESMF_State), intent(inout) :: EXPORT ! Export state type(ESMF_Clock), intent(inout) :: CLOCK ! The clock integer, optional, intent( out) :: RC ! Error code: - !DESCRIPTION: + !DESCRIPTION: ! Periodically refreshes the ozone mixing ratios. !EOP type(MAPL_MetaComp), pointer :: CHILD_MAPL ! MAPL state for ISSM - type(ESMF_Alarm) :: ISSM_ALARM ! run alarm for ISSM component + type(ESMF_Alarm) :: ISSM_ALARM ! run alarm for ISSM component ! ErrLog Variables @@ -2377,13 +2377,13 @@ subroutine RUN2 ( GC, IMPORT, EXPORT, CLOCK, RC ) type (ESMF_GridComp ), pointer :: GCS(:) character(len=ESMF_MAXSTR), pointer :: gcnames(:) -#ifdef HAVE_ISSM +#ifdef HAVE_ISSM type(T_ISSM_TILE_STATE), pointer :: issm_tile_state - type(ISSM_TILE_WRAP) :: issm_tile_wrap + type(T_ISSM_TILE_WRAP) :: issm_tile_wrap #endif !============================================================================= -! Begin... +! Begin... ! Get the target components name and set-up traceback handle. ! ----------------------------------------------------------- @@ -2403,7 +2403,7 @@ subroutine RUN2 ( GC, IMPORT, EXPORT, CLOCK, RC ) #ifndef HAVE_ISSM DO_ISSM=0 #endif - + ! Start Total timer !------------------ @@ -2419,7 +2419,7 @@ subroutine RUN2 ( GC, IMPORT, EXPORT, CLOCK, RC ) ORBIT = ORBIT, & TILELATS = LATS, & TILELONS = LONS, & - !TILETYPES = TILETYPES, & + !TILETYPES = TILETYPES, & RUNALARM = ALARM, & RC=STATUS ) VERIFY_(STATUS) @@ -2444,7 +2444,7 @@ subroutine RUN2 ( GC, IMPORT, EXPORT, CLOCK, RC ) call MAPL_TimerOff(MAPL,"RUN2") call MAPL_TimerOff(MAPL,"TOTAL") - + RETURN_(ESMF_SUCCESS) contains @@ -2453,7 +2453,7 @@ subroutine RUN2 ( GC, IMPORT, EXPORT, CLOCK, RC ) subroutine LANDICECORE(RC) integer, optional, intent(OUT) :: RC - + ! Locals character(len=ESMF_MAXSTR) :: IAm @@ -2471,10 +2471,10 @@ subroutine LANDICECORE(RC) real, pointer, dimension(: ) :: ICETHICK real, pointer, dimension(: ) :: ICEVEL real, pointer, dimension(: ) :: EMISS - real, pointer, dimension(: ) :: ALBVF - real, pointer, dimension(: ) :: ALBVR - real, pointer, dimension(: ) :: ALBNF - real, pointer, dimension(: ) :: ALBNR + real, pointer, dimension(: ) :: ALBVF + real, pointer, dimension(: ) :: ALBVR + real, pointer, dimension(: ) :: ALBNF + real, pointer, dimension(: ) :: ALBNR real, pointer, dimension(: ) :: DELTS real, pointer, dimension(: ) :: DELQS real, pointer, dimension(: ) :: TST @@ -2503,11 +2503,11 @@ subroutine LANDICECORE(RC) real, pointer, dimension(:,:) :: DRHOS0 real, pointer, dimension(:,:) :: WESNEX real, pointer, dimension(: ) :: WESNEXT - real, pointer, dimension(: ) :: WESC - real, pointer, dimension(: ) :: SDSC - real, pointer, dimension(: ) :: WEPRE + real, pointer, dimension(: ) :: WESC + real, pointer, dimension(: ) :: SDSC + real, pointer, dimension(: ) :: WEPRE real, pointer, dimension(: ) :: SDPRE - real, pointer, dimension(: ) :: SD1PC + real, pointer, dimension(: ) :: SD1PC real, pointer, dimension(:,:) :: WEPERC real, pointer, dimension(:,:) :: WEREP real, pointer, dimension(: ) :: WEBOT @@ -2653,8 +2653,8 @@ subroutine LANDICECORE(RC) real, allocatable :: LAI (:) real, allocatable :: GRN (:) real, allocatable :: MODISFAC(:) - real, allocatable :: SNOVR(:), SNONR(:), SNOVF(:), SNONF(:) - real, allocatable :: LNDVR(:), LNDNR(:), LNDVF(:), LNDNF(:) + real, allocatable :: SNOVR(:), SNONR(:), SNOVF(:), SNONF(:) + real, allocatable :: LNDVR(:), LNDNR(:), LNDVF(:), LNDNF(:) real, allocatable :: VSUVR (:) real, allocatable :: VSUVF (:) real, allocatable :: SWNETSNOW(:) @@ -2662,9 +2662,9 @@ subroutine LANDICECORE(RC) real, allocatable :: FHGND (:) real, allocatable :: DRHO0 (:,:) real, allocatable :: EXCS (:,:) - real, allocatable :: WESNSC(:), SNDZSC(:), WESNPREC(:), & - SNDZPREC(:), SNDZ1PERC(:) - real, allocatable :: WESNPERC(:,:), WESNDENS(:,:), WESNREPAR(:,:) + real, allocatable :: WESNSC(:), SNDZSC(:), WESNPREC(:), & + SNDZPREC(:), SNDZ1PERC(:) + real, allocatable :: WESNPERC(:,:), WESNDENS(:,:), WESNREPAR(:,:) real, allocatable :: WESNBOT(:) real, allocatable :: LANDICELT(:) real, allocatable :: RCONSTIT(:,:,:) @@ -2760,7 +2760,7 @@ subroutine LANDICECORE(RC) #ifdef HAVE_ISSM if (DO_ISSM==1) then call MAPL_GetPointer(INTERNAL,ICESMB_IN , 'ICESMB_ISSM',alloc=.true., RC=STATUS); VERIFY_(STATUS) -end if +end if #endif call MAPL_GetPointer(INTERNAL,TS , 'TS' , RC=STATUS); VERIFY_(STATUS) call MAPL_GetPointer(INTERNAL,QS , 'QS' , RC=STATUS); VERIFY_(STATUS) @@ -2792,9 +2792,9 @@ subroutine LANDICECORE(RC) call MAPL_GetPointer(EXPORT,ICESURF , 'ICESURF',alloc=.true., RC=STATUS); VERIFY_(STATUS) call MAPL_GetPointer(EXPORT,ICETHICK ,'ICETHICK',alloc=.true., RC=STATUS); VERIFY_(STATUS) call MAPL_GetPointer(EXPORT,ICEVEL ,'ICEVEL',alloc=.true., RC=STATUS); VERIFY_(STATUS) -end if +end if #endif - + call MAPL_GetPointer(EXPORT,ICESMB , 'ICESMB',alloc=.true., RC=STATUS); VERIFY_(STATUS) call MAPL_GetPointer(EXPORT,EMISS , 'EMIS' , RC=STATUS); VERIFY_(STATUS) call MAPL_GetPointer(EXPORT,ALBVF , 'ALBVF' , RC=STATUS); VERIFY_(STATUS) @@ -2884,20 +2884,20 @@ subroutine LANDICECORE(RC) NT = size(ALW) ! initialize running mean ICESMB and number of steps since last ISSM solve -#ifdef HAVE_ISSM +#ifdef HAVE_ISSM if(DO_ISSM==1) then if (.not. associated(ICESMB_ISSM)) then allocate(ICESMB_ISSM(NT),STAT=STATUS) VERIFY_(STATUS) ! initialize from restart: - if (associated(ICESMB_IN)) then - ICESMB_ISSM(:) = ICESMB_IN(:) + if (associated(ICESMB_IN)) then + ICESMB_ISSM(:) = ICESMB_IN(:) else ICESMB_ISSM(:) = 0 - end if - end if - + end if + end if + ! get number of timesteps from issm tile internal state call MAPL_Get (MAPL, GCS=GCS, GCNAMES=GCNAMES, RC=STATUS ) VERIFY_(STATUS) @@ -2906,34 +2906,34 @@ subroutine LANDICECORE(RC) call ESMF_UserCompGetInternalState(GCS(N), 'ISSM_TILES', issm_tile_wrap, status) VERIFY_(STATUS) issm_tile_state =>issm_tile_wrap%ptr - ISSM_NSTEPS = issm_tile_state%ISSM_NSTEPS + ISSM_NSTEPS = issm_tile_state%ISSM_NSTEPS end if - end do - end if + end do + end if #endif - + allocate(MLT (NT), STAT=STATUS) - VERIFY_(STATUS) + VERIFY_(STATUS) allocate(DTS (NT), STAT=STATUS) - VERIFY_(STATUS) + VERIFY_(STATUS) allocate(DQS (NT), STAT=STATUS) - VERIFY_(STATUS) + VERIFY_(STATUS) allocate(SHF (NT), STAT=STATUS) - VERIFY_(STATUS) + VERIFY_(STATUS) allocate(LHF (NT), STAT=STATUS) - VERIFY_(STATUS) + VERIFY_(STATUS) allocate(SHD (NT), STAT=STATUS) - VERIFY_(STATUS) + VERIFY_(STATUS) allocate(LHD (NT), STAT=STATUS) - VERIFY_(STATUS) + VERIFY_(STATUS) allocate(CFT (NT), STAT=STATUS) - VERIFY_(STATUS) + VERIFY_(STATUS) allocate(CFQ (NT), STAT=STATUS) - VERIFY_(STATUS) + VERIFY_(STATUS) allocate(SWN (NT), STAT=STATUS) - VERIFY_(STATUS) + VERIFY_(STATUS) allocate(DIF (NT), STAT=STATUS) - VERIFY_(STATUS) + VERIFY_(STATUS) allocate(ULW (NT), STAT=STATUS) VERIFY_(STATUS) @@ -2962,70 +2962,70 @@ subroutine LANDICECORE(RC) allocate(HLWO(NT) , STAT=STATUS) VERIFY_(STATUS) allocate(EVAPO(NT) , STAT=STATUS) - VERIFY_(STATUS) + VERIFY_(STATUS) allocate(LHFO(NT) , STAT=STATUS) - VERIFY_(STATUS) + VERIFY_(STATUS) allocate(SHFO(NT) , STAT=STATUS) - VERIFY_(STATUS) + VERIFY_(STATUS) allocate(ZTH(NT) , STAT=STATUS) - VERIFY_(STATUS) + VERIFY_(STATUS) allocate(SLR(NT) , STAT=STATUS) - VERIFY_(STATUS) + VERIFY_(STATUS) allocate(EVAPI(NT) , STAT=STATUS) - VERIFY_(STATUS) + VERIFY_(STATUS) allocate(DEVAPDT(NT), STAT=STATUS) - VERIFY_(STATUS) + VERIFY_(STATUS) allocate(ITYPE(NT) , STAT=STATUS) - VERIFY_(STATUS) + VERIFY_(STATUS) allocate(LAI(NT) , STAT=STATUS) - VERIFY_(STATUS) + VERIFY_(STATUS) allocate(GRN(NT) , STAT=STATUS) - VERIFY_(STATUS) + VERIFY_(STATUS) allocate(MODISFAC(NT), STAT=STATUS) - VERIFY_(STATUS) + VERIFY_(STATUS) allocate(SNOVR(NT), SNONR(NT), SNOVF(NT), SNONF(NT) , STAT=STATUS) - VERIFY_(STATUS) + VERIFY_(STATUS) allocate(LNDVR(NT), LNDNR(NT), LNDVF(NT), LNDNF(NT) , STAT=STATUS) - VERIFY_(STATUS) + VERIFY_(STATUS) allocate(VSUVR(NT) , STAT=STATUS) - VERIFY_(STATUS) + VERIFY_(STATUS) allocate(VSUVF(NT) , STAT=STATUS) - VERIFY_(STATUS) + VERIFY_(STATUS) allocate(SWNETSNOW(NT) , STAT=STATUS) - VERIFY_(STATUS) + VERIFY_(STATUS) allocate(RADDN(NT) , STAT=STATUS) - VERIFY_(STATUS) + VERIFY_(STATUS) allocate(FHGND(NT) , STAT=STATUS) - VERIFY_(STATUS) + VERIFY_(STATUS) allocate(DRHO0(NT,NUM_SNOW_LAYERS) , STAT=STATUS) VERIFY_(STATUS) allocate(EXCS(NT,NUM_SNOW_LAYERS) , STAT=STATUS) VERIFY_(STATUS) - allocate(WESNSC(NT), SNDZSC(NT), WESNPREC(NT), & - SNDZPREC(NT), SNDZ1PERC(NT), & + allocate(WESNSC(NT), SNDZSC(NT), WESNPREC(NT), & + SNDZPREC(NT), SNDZ1PERC(NT), & WESNBOT(NT), & - STAT=STATUS) + STAT=STATUS) VERIFY_(STATUS) allocate(WESNPERC(NT,NUM_SNOW_LAYERS), & WESNDENS(NT,NUM_SNOW_LAYERS), & WESNREPAR(NT,NUM_SNOW_LAYERS), & - STAT=STATUS) + STAT=STATUS) VERIFY_(STATUS) allocate(LANDICELT(NT) , STAT=STATUS) - VERIFY_(STATUS) + VERIFY_(STATUS) allocate(WESNN (NUM_SNOW_LAYERS,NT)) - VERIFY_(STATUS) + VERIFY_(STATUS) allocate(HTSNN (NUM_SNOW_LAYERS,NT)) - VERIFY_(STATUS) + VERIFY_(STATUS) allocate(SNDZN (NUM_SNOW_LAYERS,NT)) - VERIFY_(STATUS) + VERIFY_(STATUS) allocate(RCONSTIT(NT, NUM_SNOW_LAYERS, N_CONSTIT) , STAT=STATUS) - VERIFY_(STATUS) + VERIFY_(STATUS) allocate(TOTDEPOS(NT, N_CONSTIT) , STAT=STATUS) - VERIFY_(STATUS) + VERIFY_(STATUS) allocate(RMELT(NT, N_CONSTIT) , STAT=STATUS) - VERIFY_(STATUS) + VERIFY_(STATUS) call ESMF_VMGetCurrent(VM, RC=STATUS) VERIFY_(STATUS) @@ -3034,23 +3034,23 @@ subroutine LANDICECORE(RC) call ESMF_VMGet(VM, localPet=mype, rc=status) VERIFY_(STATUS) - if(associated(EVAPOUT )) EVAPOUT = 0.0 + if(associated(EVAPOUT )) EVAPOUT = 0.0 if(associated(SUBLIM )) SUBLIM = 0.0 - if(associated(SHOUT )) SHOUT = 0.0 - if(associated(HLATN )) HLATN = 0.0 - if(associated(DELTS )) DELTS = 0.0 - if(associated(DELQS )) DELQS = 0.0 + if(associated(SHOUT )) SHOUT = 0.0 + if(associated(HLATN )) HLATN = 0.0 + if(associated(DELTS )) DELTS = 0.0 + if(associated(DELQS )) DELQS = 0.0 if(associated(SWNDSRF )) SWNDSRF = 0.0 if(associated(LWNDSRF )) LWNDSRF = 0.0 - if(associated(DNICFLX )) DNICFLX = 0.0 - if(associated(GHSNOW )) GHSNOW = 0.0 - if(associated(GHTSKIN )) GHTSKIN = 0.0 - if(associated(IMELT )) IMELT = 0.0 - if(associated(RUNOFF )) RUNOFF = 0.0 - if(associated(EVPICE )) EVPICE = 0.0 + if(associated(DNICFLX )) DNICFLX = 0.0 + if(associated(GHSNOW )) GHSNOW = 0.0 + if(associated(GHTSKIN )) GHTSKIN = 0.0 + if(associated(IMELT )) IMELT = 0.0 + if(associated(RUNOFF )) RUNOFF = 0.0 + if(associated(EVPICE )) EVPICE = 0.0 if(associated(HLWUP )) HLWUP = 0.0 if(associated(TICE0 )) TICE0 = 0.0 - if(associated(ACCUM )) ACCUM = 0.0 + if(associated(ACCUM )) ACCUM = 0.0 if(associated(MELTWTR )) MELTWTR = 0.0 if (N_constit>0) then @@ -3060,7 +3060,7 @@ subroutine LANDICECORE(RC) end if ! Zero the light-absorbing aerosol (LAA) deposition rates from GOCART: - + select case (AEROSOL_DEPOSITION) case (0) DUDP(:,:)=0. @@ -3075,30 +3075,30 @@ subroutine LANDICECORE(RC) OCSV(:,:)=0. OCWT(:,:)=0. OCSD(:,:)=0. - + case (2) DUDP(:,:)=0. DUSV(:,:)=0. DUWT(:,:)=0. DUSD(:,:)=0. - + case (3) BCDP(:,:)=0. BCSV(:,:)=0. BCWT(:,:)=0. BCSD(:,:)=0. - + case (4) OCDP(:,:)=0. OCSV(:,:)=0. OCWT(:,:)=0. OCSD(:,:)=0. - + end select if (N_CONST_LANDICE4SNWALB /=0) then - + ! Convert the dimentions for LAAs from GEOS_SurfGridComp.F90 to GEOS_LandIceGridComp.F90 ! Note: Explanations of each variable ! TOTDEPOS(:,1): Combined dust deposition from size bin 1 (dry, conv-scav, ls-scav, sed) @@ -3176,17 +3176,17 @@ subroutine LANDICECORE(RC) ! RCONSTIT(:,:,15) = IRSS005(:,:) end if - LANDICELT = 0.0 - ZONEAREA = 1.0 + LANDICELT = 0.0 + ZONEAREA = 1.0 ! zc1 is not the actual thickness, but the vertical coordinate which is +ve upward ZC1 = -DZMAXI(1) * 0.5 TKGND = condice ! use value for ice at 0 degC PRECIP = PCU + PLS + SNO - RAIN = PCU + PLS + RAIN = PCU + PLS PERC = 0.0 MELTI = 0.0 FROZFRAC = 0.0 - TPSN = 0.0 + TPSN = 0.0 AREASC = 0.0 HCORR = 0.0 ghflxsno = 0.0 @@ -3204,13 +3204,13 @@ subroutine LANDICECORE(RC) WESNSC = 0.0 SNDZSC = 0.0 WESNPREC = 0.0 - SNDZPREC = 0.0 - SNDZ1PERC = 0.0 - WESNPERC = 0.0 - WESNDENS = 0.0 - WESNREPAR = 0.0 - RAINRF = 0.0 - MLT = 0.0 + SNDZPREC = 0.0 + SNDZ1PERC = 0.0 + WESNPERC = 0.0 + WESNDENS = 0.0 + WESNREPAR = 0.0 + RAINRF = 0.0 + MLT = 0.0 LNDVR = 0.0 LNDNR = 0.0 LNDVF = 0.0 @@ -3219,7 +3219,7 @@ subroutine LANDICECORE(RC) debugzth = .false. ! -------------------------------------------------------------------------- - ! Get the current time. + ! Get the current time. ! -------------------------------------------------------------------------- call ESMF_ClockGet( CLOCK, currTime=CURRENT_TIME, startTime=MODELSTART, TIMESTEP=DELT, RC=STATUS ) @@ -3283,8 +3283,8 @@ subroutine LANDICECORE(RC) VERIFY_(STATUS) ZTH = max(0.0,ZTH) - - do N=1,NUM_SUBTILES + + do N=1,NUM_SUBTILES if (LANDICE_OFFLINE == 0 ) then CFT = (CH(:,N)/CTATM) CFQ = (CQ(:,N)/CQATM) @@ -3303,7 +3303,7 @@ subroutine LANDICECORE(RC) LHD = CQ(:,N)*MAPL_ALHS*GEOS_DQSAT(TS(:,N), PS, PASCALS=.TRUE., RAMP=0.0) BLWN = LANDICEEMISS*MAPL_STFBOL*TS(:,N)*TS(:,N)*TS(:,N) ALWN = -3.0*BLWN*TS(:,N) - BLWN = 4.0*BLWN + BLWN = 4.0*BLWN endif SWN = ((DRUVR+DRPAR+DRNIR) + (DFUVR+DFPAR+DFNIR))*(1.0-LANDICEALB) @@ -3312,19 +3312,19 @@ subroutine LANDICECORE(RC) LANDICECAP= (MAPL_RHOWTR*MAPL_CAPICE*LANDICEDEPTH) - EVAPI = LHF / MAPL_ALHS + EVAPI = LHF / MAPL_ALHS DEVAPDT = LHD / MAPL_ALHS - RADDN = LWDNSRF + SWN + RADDN = LWDNSRF + SWN - PERC = 0.0 - MELTI = 0.0 + PERC = 0.0 + MELTI = 0.0 if(N==SNOW) then ITYPE = 9 LAI = 0.0 - GRN = 0.0 + GRN = 0.0 MODISFAC = 1.0 !*** have to do a transpose of these internals since their dimensions in SNOW_ALBEDO @@ -3332,9 +3332,9 @@ subroutine LANDICECORE(RC) WESNN = transpose(WESN) HTSNN = transpose(HTSN) SNDZN = transpose(SNDZ) - !*** call new/shared routine to compute albedo + !*** call new/shared routine to compute albedo - call SNOW_ALBEDO(NT, NUM_SNOW_LAYERS, N_CONST_LANDICE4SNWALB, ITYPE, LAI, ZTH, & + call SNOW_ALBEDO(NT, NUM_SNOW_LAYERS, N_CONST_LANDICE4SNWALB, ITYPE, LAI, ZTH, & RHOFRESH, VISMAX, NIRMAX, SLOPE, & !0.96, 0.68, 1.0, & ! WESNN, HTSNN, SNDZN, & ! snow stuff LNDVR, LNDNR, LNDVF, LNDNF, & ! instantaneous snow-free albedos on tiles @@ -3345,7 +3345,7 @@ subroutine LANDICECORE(RC) VSUVR = DRPAR + DRUVR VSUVF = DFPAR + DFUVR SWNETSNOW = (1.-SNOVR)*VSUVR + (1.-SNOVF)*VSUVF + (1.-SNONR)*DRNIR + (1.-SNONF)*DFNIR - RADDN = LWDNSRF + SWNETSNOW + RADDN = LWDNSRF + SWNETSNOW SWN = SWNETSNOW if(associated(SNOWALB)) then where(FR(:,N) > 0.0) @@ -3361,26 +3361,26 @@ subroutine LANDICECORE(RC) if(N==ICE) then do k=1,NT - if(FR(k,N) > MINFRACSNO) then + if(FR(k,N) > MINFRACSNO) then call SOLVEICELAYER(NUM_ICE_LAYERS, DT, TICE(k,N,:), DZMAXI, 0, & MELTI(k), DTSS=DTS(k), RUNOFF=PERC(k), & lhturb=LHF(k),hlwtc=ULW(k),hsturb=SHF(k),raddn=RADDN(k), & dlhdtc=LHD(k),dhsdtc=SHD(k),dhlwtc=BLWN(k),rain=RAIN(k), & - rainrf=RAINRF(k), & + rainrf=RAINRF(k), & lhflux=LHFO(k),shflux=SHFO(k),hlwout=HLWO(k),evapout=EVAPO(k), & ghflxice=ghflxice(k)) else TICE(k,N,:) = TICE(k,SNOW,:) endif - enddo + enddo TS(:,N) = TICE(:,N,1) if(associated(RUNOFF)) RUNOFF = RUNOFF + FR(:,N) * PERC endif - if(N==SNOW) then + if(N==SNOW) then LANDICELT = TICE(:,N,1) - MAPL_TICE do k=1,NT -#if 0 +#if 0 LATSD=LATS(K)*rad_to_deg LONSD=LONS(K)*rad_to_deg !if(abs(LATSD-0.700003698112E+02) < 1.e-3 .and. & @@ -3389,46 +3389,46 @@ subroutine LANDICECORE(RC) ! abs(LONSD-(-0.433431029954E+02)) < 1.e-3 ) then if(abs(LATSD-0.807870232172E+02) < 1.e-3 .and. & abs(LONSD-(-0.154247429558E+02)) < 1.e-3 ) then - print*, 'PE = ', mype, ' tile = ',k - endif + print*, 'PE = ', mype, ' tile = ',k + endif #endif - TKSNO = condice + TKSNO = condice call SNOWRT( LONS(k), LATS(k), & ! in [radians] !!! - 1,NUM_SNOW_LAYERS,MAPL_LANDICE, & ! in - MAXSNDZ, RHOFRESH, DZMAX, & ! in - LANDICELT(k),ZONEAREA,TKGND,PRECIP(k),SNO(k),TA(k),DT, & ! in - EVAPI(k),DEVAPDT(k),SHF(k),SHD(k),ULW(k),BLWN(k), & ! in - RADDN(k),ZC1,TOTDEPOS(k,:), & ! in - WESN(k,:),HTSN(k,:),SNDZ(k,:), RCONSTIT(k,:,:), & ! inout - HLWO(k), FROZFRAC(k,:),TPSN(k,:), RMELT(k,:), & ! out - AREASC(k),FR(K,N),PERC(k),FHGND(k), & ! out - EVAPO(k),SHFO(k),LHFO(k),HCORR(k),ghflxsno(k), & ! out - SNDZSC(k), WESNPREC(k), SNDZPREC(k),SNDZ1PERC(k), & ! out - WESNPERC(k,:), WESNDENS(k,:), WESNREPAR(k,:), MLT(k), & ! out - EXCS(k,:), DRHO0(k,:), WESNBOT(k), TKSNO, DTS(k) ) ! out + 1,NUM_SNOW_LAYERS,MAPL_LANDICE, & ! in + MAXSNDZ, RHOFRESH, DZMAX, & ! in + LANDICELT(k),ZONEAREA,TKGND,PRECIP(k),SNO(k),TA(k),DT, & ! in + EVAPI(k),DEVAPDT(k),SHF(k),SHD(k),ULW(k),BLWN(k), & ! in + RADDN(k),ZC1,TOTDEPOS(k,:), & ! in + WESN(k,:),HTSN(k,:),SNDZ(k,:), RCONSTIT(k,:,:), & ! inout + HLWO(k), FROZFRAC(k,:),TPSN(k,:), RMELT(k,:), & ! out + AREASC(k),FR(K,N),PERC(k),FHGND(k), & ! out + EVAPO(k),SHFO(k),LHFO(k),HCORR(k),ghflxsno(k), & ! out + SNDZSC(k), WESNPREC(k), SNDZPREC(k),SNDZ1PERC(k), & ! out + WESNPERC(k,:), WESNDENS(k,:), WESNREPAR(k,:), MLT(k), & ! out + EXCS(k,:), DRHO0(k,:), WESNBOT(k), TKSNO, DTS(k) ) ! out ! Snow impurities update if (N_CONST_LANDICE4SNWALB /= 0) then - if(associated(IRDU001)) IRDU001(k,:) = RCONSTIT(k,:,1) - if(associated(IRDU002)) IRDU002(k,:) = RCONSTIT(k,:,2) - if(associated(IRDU003)) IRDU003(k,:) = RCONSTIT(k,:,3) - if(associated(IRDU004)) IRDU004(k,:) = RCONSTIT(k,:,4) - if(associated(IRDU005)) IRDU005(k,:) = RCONSTIT(k,:,5) - if(associated(IRBC001)) IRBC001(k,:) = RCONSTIT(k,:,6) - if(associated(IRBC002)) IRBC002(k,:) = RCONSTIT(k,:,7) - if(associated(IROC001)) IROC001(k,:) = RCONSTIT(k,:,8) - if(associated(IROC002)) IROC002(k,:) = RCONSTIT(k,:,9) + if(associated(IRDU001)) IRDU001(k,:) = RCONSTIT(k,:,1) + if(associated(IRDU002)) IRDU002(k,:) = RCONSTIT(k,:,2) + if(associated(IRDU003)) IRDU003(k,:) = RCONSTIT(k,:,3) + if(associated(IRDU004)) IRDU004(k,:) = RCONSTIT(k,:,4) + if(associated(IRDU005)) IRDU005(k,:) = RCONSTIT(k,:,5) + if(associated(IRBC001)) IRBC001(k,:) = RCONSTIT(k,:,6) + if(associated(IRBC002)) IRBC002(k,:) = RCONSTIT(k,:,7) + if(associated(IROC001)) IROC001(k,:) = RCONSTIT(k,:,8) + if(associated(IROC002)) IROC002(k,:) = RCONSTIT(k,:,9) end if if (N_constit>0) then - if(associated(RMELTDU001)) RMELTDU001(k) = RMELT(k,1) - if(associated(RMELTDU002)) RMELTDU002(k) = RMELT(k,2) - if(associated(RMELTDU003)) RMELTDU003(k) = RMELT(k,3) - if(associated(RMELTDU004)) RMELTDU004(k) = RMELT(k,4) - if(associated(RMELTDU005)) RMELTDU005(k) = RMELT(k,5) - if(associated(RMELTBC001)) RMELTBC001(k) = RMELT(k,6) - if(associated(RMELTBC002)) RMELTBC002(k) = RMELT(k,7) - if(associated(RMELTOC001)) RMELTOC001(k) = RMELT(k,8) + if(associated(RMELTDU001)) RMELTDU001(k) = RMELT(k,1) + if(associated(RMELTDU002)) RMELTDU002(k) = RMELT(k,2) + if(associated(RMELTDU003)) RMELTDU003(k) = RMELT(k,3) + if(associated(RMELTDU004)) RMELTDU004(k) = RMELT(k,4) + if(associated(RMELTDU005)) RMELTDU005(k) = RMELT(k,5) + if(associated(RMELTBC001)) RMELTBC001(k) = RMELT(k,6) + if(associated(RMELTBC002)) RMELTBC002(k) = RMELT(k,7) + if(associated(RMELTOC001)) RMELTOC001(k) = RMELT(k,8) if(associated(RMELTOC002)) RMELTOC002(k) = RMELT(k,9) end if @@ -3439,36 +3439,36 @@ subroutine LANDICECORE(RC) LWC(k) = sum(WESN(k,:)*(1.-FROZFRAC(k,:)))/sum(WESN(k,:)) else KL = 0 - ZKL = 0.0 + ZKL = 0.0 do l=1,NUM_SNOW_LAYERS - ZKL = ZKL + SNDZ(k,l) + ZKL = ZKL + SNDZ(k,l) if(ZKL > LWCTOP) then KL = l exit endif - enddo + enddo ALPHA = 1.0 - (ZKL-LWCTOP)/SNDZ(k,KL) LWC(k) = (sum(WESN(k,1:KL-1)*(1.-FROZFRAC(k,1:KL-1)))+ & ALPHA*WESN(k,KL)*(1.-FROZFRAC(k,KL))) / & - (sum(WESN(k,1:KL-1))+ALPHA*WESN(k,KL)) + (sum(WESN(k,1:KL-1))+ALPHA*WESN(k,KL)) endif else LWC(k) = 0.0 - endif + endif endif if(FR(K,N) < MINFRACSNO) then TICE(k,N,:) = TICE(k,ICE,:) else call SOLVEICELAYER(NUM_ICE_LAYERS, DT, TICE(k,N,:), DZMAXI, 1, & MELTI(k), & - condsno=TKSNO(NUM_SNOW_LAYERS), & - !tsn=TPSN(k,NUM_SNOW_LAYERS), & - fhgnd=FHGND(k), & + condsno=TKSNO(NUM_SNOW_LAYERS), & + !tsn=TPSN(k,NUM_SNOW_LAYERS), & + fhgnd=FHGND(k), & sndz=SNDZ(k,NUM_SNOW_LAYERS) & ) if(associated(RUNOFF)) RUNOFF(K) = RUNOFF(K) + FR(K,N) * MELTI(K) - endif - enddo + endif + enddo WESNSC = EVAPO !PERC = PERC + MELTI if(associated(RUNOFF)) RUNOFF = RUNOFF + PERC @@ -3477,11 +3477,11 @@ subroutine LANDICECORE(RC) endif DQS = GEOS_QSAT(TS(:,N), PS, PASCALS=.TRUE.,RAMP=0.0) - QS(:,N) - QS(:,N) = QS(:,N) + DQS + QS(:,N) = QS(:,N) + DQS LHF = LHFO SHF = SHFO - ULW = HLWO + ULW = HLWO if(associated(EVAPOUT)) EVAPOUT = EVAPOUT + FR(:,N)*EVAPO if(associated(SUBLIM )) SUBLIM = SUBLIM + FR(:,N)*EVAPO @@ -3500,21 +3500,21 @@ subroutine LANDICECORE(RC) if(associated(HLWUP )) HLWUP = HLWUP + ULW * FR(:,N) if(associated(DNICFLX )) DNICFLX = DNICFLX + DIF * FR(:,N) if(associated(GHSNOW )) GHSNOW = ghflxsno - if(associated(ACCUM )) ACCUM = ACCUM - FR(:,N) * EVAPO - if(associated(MELTWTR )) MELTWTR = MELTWTR + FR(:,N) * MELTI + if(associated(ACCUM )) ACCUM = ACCUM - FR(:,N) * EVAPO + if(associated(MELTWTR )) MELTWTR = MELTWTR + FR(:,N) * MELTI if(associated(TICE0 )) then do k=1,NT TICE0(k,:) = TICE0(k,:) + TICE(k,N,:) * FR(k,N) enddo - endif + endif - enddo ! NUM_SUBTILES + enddo ! NUM_SUBTILES FR(:,ICE) = max(1.0-FR(:,SNOW), 0.0) if(associated(GHTSKIN )) GHTSKIN = ghflxsno*FR(:,SNOW) + ghflxice*FR(:,ICE) - if(associated(ACCUM )) ACCUM = ACCUM + PRECIP + if(associated(ACCUM )) ACCUM = ACCUM + PRECIP if(associated(EMISS )) EMISS = LANDICEEMISS if(associated(SNOWMASS)) SNOWMASS = sum(WESN,dim=2) @@ -3524,12 +3524,12 @@ subroutine LANDICECORE(RC) if(associated(SMELT )) SMELT = PERC if(associated(RAINRFZ )) RAINRFZ = FR(:,ICE) * RAINRF - if(associated(MELTWTR )) MELTWTR = MELTWTR + MLT + if(associated(MELTWTR )) MELTWTR = MELTWTR + MLT ! Calculate surface mass balance (SMB) for ISSM if(associated(ICESMB)) ICESMB = ACCUM - RUNOFF - + ! average ICESMB over time steps between ISSM runs if(DO_ISSM==1) then if(associated(ICESMB_ISSM)) ICESMB_ISSM = ICESMB_ISSM + (ICESMB-ICESMB_ISSM)/(ISSM_NSTEPS+1) @@ -3537,7 +3537,7 @@ subroutine LANDICECORE(RC) ! update internal state ICESMB_IN(:) = ICESMB_ISSM(:) - end if + end if ! Update snow and landice albedos to anticipate ! next radiation calculation !----------------------------------------------- @@ -3552,7 +3552,7 @@ subroutine LANDICECORE(RC) ITYPE = 9 - call SNOW_ALBEDO(NT, NUM_SNOW_LAYERS, N_CONST_LANDICE4SNWALB, ITYPE, LAI, ZTH, & + call SNOW_ALBEDO(NT, NUM_SNOW_LAYERS, N_CONST_LANDICE4SNWALB, ITYPE, LAI, ZTH, & RHOFRESH, VISMAX, NIRMAX, SLOPE, & ! 0.96, 0.68, 1.0, & ! WESNN, HTSNN, SNDZN, & ! snow stuff LNDVR, LNDNR, LNDVF, LNDNF, & ! instantaneous snow-free albedos on tiles @@ -3567,7 +3567,7 @@ subroutine LANDICECORE(RC) if(associated(SNICEALB )) then - SNICEALB = FR(:,ICE)*LANDICEALB + & + SNICEALB = FR(:,ICE)*LANDICEALB + & FR(:,SNOW)*(SNOVR*AWTVDR + SNOVF*AWTVDF & + SNONR*AWTIDR + SNONF*AWTIDF) where(ZTH < 1.e-6) @@ -3594,23 +3594,23 @@ subroutine LANDICECORE(RC) if(associated(RHOSNOW )) then RHOSNOW = 0.0 - do N=1,NUM_SNOW_LAYERS + do N=1,NUM_SNOW_LAYERS !where(FR(:,SNOW) > 0.0 .and. SNDZ(:,N) > 0.0) where(sum(WESN,dim=2) > MINSWE) RHOSNOW(:,N) = WESN(:,N) / FR(:,SNOW) / SNDZ(:,N) elsewhere - RHOSNOW(:,N) = MAPL_UNDEF + RHOSNOW(:,N) = MAPL_UNDEF endwhere enddo end if if(associated(TSNOW )) then TSNOW = 0.0 - do N=1,NUM_SNOW_LAYERS + do N=1,NUM_SNOW_LAYERS where(FR(:,SNOW) > 0.0 .and. SNDZ(:,N) > 0.0) TSNOW(:,N) = TPSN(:,N) elsewhere - TSNOW(:,N) = MAPL_UNDEF + TSNOW(:,N) = MAPL_UNDEF endwhere enddo end if @@ -3636,7 +3636,7 @@ subroutine LANDICECORE(RC) end if if(associated(WESC )) then - WESC = WESNSC + WESC = WESNSC end if if(associated(SDSC )) then @@ -3671,12 +3671,12 @@ subroutine LANDICECORE(RC) WEBOT = WESNBOT / DT end if -! Run ISSM +! Run ISSM #ifdef HAVE_ISSM if (DO_ISSM==1) then call MAPL_Get (MAPL, GCS=GCS, GCNAMES=GCNAMES, RC=STATUS ) do N=1, size(GCS) - if (index(GCNAMES(N), 'ISSM') /=0 ) then + if (index(GCNAMES(N), 'ISSM') /=0 ) then call MAPL_GetObjectFromGC(GCS(N), CHILD_MAPL, RC=STATUS); VERIFY_(STATUS) call MAPL_Get(CHILD_MAPL, RUNALARM = ISSM_ALARM, RC=STATUS); VERIFY_(STATUS) @@ -3688,7 +3688,7 @@ subroutine LANDICECORE(RC) call MAPL_GenericRunChildren(GC, IMPORT, EXPORT, CLOCK, RC=STATUS) VERIFY_(STATUS) - if (ESMF_AlarmIsRinging (ISSM_ALARM, RC=STATUS)) then + if (ESMF_AlarmIsRinging (ISSM_ALARM, RC=STATUS)) then ! if ISSM solvers were called, get exports on tile space if(associated(ICESURF)) ICESURF = issm_tile_state%ICESURF_TILE if(associated(ICETHICK)) ICETHICK = issm_tile_state%ICETHICK_TILE @@ -3705,29 +3705,29 @@ subroutine LANDICECORE(RC) ! update internal state for running-mean ICESMB ICESMB_IN(:) = ICESMB_ISSM(:) - end if + end if end if end do - end if + end if #endif - if(allocated (MLT)) deallocate(MLT , STAT=STATUS); VERIFY_(STATUS) - if(allocated (DTS)) deallocate(DTS , STAT=STATUS); VERIFY_(STATUS) - if(allocated (DQS)) deallocate(DQS , STAT=STATUS); VERIFY_(STATUS) - if(allocated (SHF)) deallocate(SHF , STAT=STATUS); VERIFY_(STATUS) - if(allocated (LHF)) deallocate(LHF , STAT=STATUS); VERIFY_(STATUS) - if(allocated (SHD)) deallocate(SHD , STAT=STATUS); VERIFY_(STATUS) - if(allocated (LHD)) deallocate(LHD , STAT=STATUS); VERIFY_(STATUS) - if(allocated (CFT)) deallocate(CFT , STAT=STATUS); VERIFY_(STATUS) - if(allocated (CFQ)) deallocate(CFQ , STAT=STATUS); VERIFY_(STATUS) - if(allocated (SWN)) deallocate(SWN , STAT=STATUS); VERIFY_(STATUS) - if(allocated (DIF)) deallocate(DIF , STAT=STATUS); VERIFY_(STATUS) - if(allocated (ULW)) deallocate(ULW , STAT=STATUS); VERIFY_(STATUS) - if(allocated (PRECIP )) deallocate(PRECIP , STAT=STATUS); VERIFY_(STATUS) - if(allocated (RAIN )) deallocate(RAIN , STAT=STATUS); VERIFY_(STATUS) - if(allocated (RAINRF )) deallocate(RAINRF , STAT=STATUS); VERIFY_(STATUS) - if(allocated (PERC )) deallocate(PERC , STAT=STATUS); VERIFY_(STATUS) - if(allocated (MELTI )) deallocate(MELTI , STAT=STATUS); VERIFY_(STATUS) + if(allocated (MLT)) deallocate(MLT , STAT=STATUS); VERIFY_(STATUS) + if(allocated (DTS)) deallocate(DTS , STAT=STATUS); VERIFY_(STATUS) + if(allocated (DQS)) deallocate(DQS , STAT=STATUS); VERIFY_(STATUS) + if(allocated (SHF)) deallocate(SHF , STAT=STATUS); VERIFY_(STATUS) + if(allocated (LHF)) deallocate(LHF , STAT=STATUS); VERIFY_(STATUS) + if(allocated (SHD)) deallocate(SHD , STAT=STATUS); VERIFY_(STATUS) + if(allocated (LHD)) deallocate(LHD , STAT=STATUS); VERIFY_(STATUS) + if(allocated (CFT)) deallocate(CFT , STAT=STATUS); VERIFY_(STATUS) + if(allocated (CFQ)) deallocate(CFQ , STAT=STATUS); VERIFY_(STATUS) + if(allocated (SWN)) deallocate(SWN , STAT=STATUS); VERIFY_(STATUS) + if(allocated (DIF)) deallocate(DIF , STAT=STATUS); VERIFY_(STATUS) + if(allocated (ULW)) deallocate(ULW , STAT=STATUS); VERIFY_(STATUS) + if(allocated (PRECIP )) deallocate(PRECIP , STAT=STATUS); VERIFY_(STATUS) + if(allocated (RAIN )) deallocate(RAIN , STAT=STATUS); VERIFY_(STATUS) + if(allocated (RAINRF )) deallocate(RAINRF , STAT=STATUS); VERIFY_(STATUS) + if(allocated (PERC )) deallocate(PERC , STAT=STATUS); VERIFY_(STATUS) + if(allocated (MELTI )) deallocate(MELTI , STAT=STATUS); VERIFY_(STATUS) if(allocated (FROZFRAC)) deallocate(FROZFRAC, STAT=STATUS); VERIFY_(STATUS) if(allocated (TPSN )) deallocate(TPSN , STAT=STATUS); VERIFY_(STATUS) if(allocated (AREASC )) deallocate(AREASC , STAT=STATUS); VERIFY_(STATUS) @@ -3735,32 +3735,32 @@ subroutine LANDICECORE(RC) if(allocated (ghflxsno)) deallocate(ghflxsno, STAT=STATUS); VERIFY_(STATUS) if(allocated (ghflxice)) deallocate(ghflxice, STAT=STATUS); VERIFY_(STATUS) if(allocated (HLWO )) deallocate(HLWO , STAT=STATUS); VERIFY_(STATUS) - if(allocated (EVAPO )) deallocate(EVAPO , STAT=STATUS); VERIFY_(STATUS) - if(allocated (LHFO )) deallocate(LHFO , STAT=STATUS); VERIFY_(STATUS) - if(allocated (SHFO )) deallocate(SHFO , STAT=STATUS); VERIFY_(STATUS) - if(allocated (ZTH )) deallocate(ZTH , STAT=STATUS); VERIFY_(STATUS) - if(allocated (SLR )) deallocate(SLR , STAT=STATUS); VERIFY_(STATUS) - if(allocated (EVAPI )) deallocate(EVAPI , STAT=STATUS); VERIFY_(STATUS) - if(allocated (DEVAPDT )) deallocate(DEVAPDT , STAT=STATUS); VERIFY_(STATUS) - if(allocated (ITYPE )) deallocate(ITYPE , STAT=STATUS); VERIFY_(STATUS) - if(allocated (LAI )) deallocate(LAI , STAT=STATUS); VERIFY_(STATUS) - if(allocated (GRN )) deallocate(GRN , STAT=STATUS); VERIFY_(STATUS) - if(allocated (MODISFAC)) deallocate(MODISFAC, STAT=STATUS); VERIFY_(STATUS) - if(allocated (SNOVR )) deallocate(SNOVR , STAT=STATUS); VERIFY_(STATUS) - if(allocated (SNONR )) deallocate(SNONR , STAT=STATUS); VERIFY_(STATUS) - if(allocated (SNOVF )) deallocate(SNOVF , STAT=STATUS); VERIFY_(STATUS) - if(allocated (SNONF )) deallocate(SNONF , STAT=STATUS); VERIFY_(STATUS) - if(allocated (LNDVR )) deallocate(LNDVR , STAT=STATUS); VERIFY_(STATUS) - if(allocated (LNDNR )) deallocate(LNDNR , STAT=STATUS); VERIFY_(STATUS) - if(allocated (LNDVF )) deallocate(LNDVF , STAT=STATUS); VERIFY_(STATUS) - if(allocated (LNDNF )) deallocate(LNDNF , STAT=STATUS); VERIFY_(STATUS) - if(allocated (VSUVR )) deallocate(VSUVR , STAT=STATUS); VERIFY_(STATUS) - if(allocated (VSUVF )) deallocate(VSUVF , STAT=STATUS); VERIFY_(STATUS) - if(allocated (SWNETSNOW)) deallocate(SWNETSNOW, STAT=STATUS); VERIFY_(STATUS) - if(allocated (RADDN )) deallocate(RADDN , STAT=STATUS); VERIFY_(STATUS) - if(allocated (FHGND )) deallocate(FHGND , STAT=STATUS); VERIFY_(STATUS) - if(allocated (DRHO0 )) deallocate(DRHO0 , STAT=STATUS); VERIFY_(STATUS) - if(allocated (EXCS )) deallocate(EXCS , STAT=STATUS); VERIFY_(STATUS) + if(allocated (EVAPO )) deallocate(EVAPO , STAT=STATUS); VERIFY_(STATUS) + if(allocated (LHFO )) deallocate(LHFO , STAT=STATUS); VERIFY_(STATUS) + if(allocated (SHFO )) deallocate(SHFO , STAT=STATUS); VERIFY_(STATUS) + if(allocated (ZTH )) deallocate(ZTH , STAT=STATUS); VERIFY_(STATUS) + if(allocated (SLR )) deallocate(SLR , STAT=STATUS); VERIFY_(STATUS) + if(allocated (EVAPI )) deallocate(EVAPI , STAT=STATUS); VERIFY_(STATUS) + if(allocated (DEVAPDT )) deallocate(DEVAPDT , STAT=STATUS); VERIFY_(STATUS) + if(allocated (ITYPE )) deallocate(ITYPE , STAT=STATUS); VERIFY_(STATUS) + if(allocated (LAI )) deallocate(LAI , STAT=STATUS); VERIFY_(STATUS) + if(allocated (GRN )) deallocate(GRN , STAT=STATUS); VERIFY_(STATUS) + if(allocated (MODISFAC)) deallocate(MODISFAC, STAT=STATUS); VERIFY_(STATUS) + if(allocated (SNOVR )) deallocate(SNOVR , STAT=STATUS); VERIFY_(STATUS) + if(allocated (SNONR )) deallocate(SNONR , STAT=STATUS); VERIFY_(STATUS) + if(allocated (SNOVF )) deallocate(SNOVF , STAT=STATUS); VERIFY_(STATUS) + if(allocated (SNONF )) deallocate(SNONF , STAT=STATUS); VERIFY_(STATUS) + if(allocated (LNDVR )) deallocate(LNDVR , STAT=STATUS); VERIFY_(STATUS) + if(allocated (LNDNR )) deallocate(LNDNR , STAT=STATUS); VERIFY_(STATUS) + if(allocated (LNDVF )) deallocate(LNDVF , STAT=STATUS); VERIFY_(STATUS) + if(allocated (LNDNF )) deallocate(LNDNF , STAT=STATUS); VERIFY_(STATUS) + if(allocated (VSUVR )) deallocate(VSUVR , STAT=STATUS); VERIFY_(STATUS) + if(allocated (VSUVF )) deallocate(VSUVF , STAT=STATUS); VERIFY_(STATUS) + if(allocated (SWNETSNOW)) deallocate(SWNETSNOW, STAT=STATUS); VERIFY_(STATUS) + if(allocated (RADDN )) deallocate(RADDN , STAT=STATUS); VERIFY_(STATUS) + if(allocated (FHGND )) deallocate(FHGND , STAT=STATUS); VERIFY_(STATUS) + if(allocated (DRHO0 )) deallocate(DRHO0 , STAT=STATUS); VERIFY_(STATUS) + if(allocated (EXCS )) deallocate(EXCS , STAT=STATUS); VERIFY_(STATUS) if(allocated (WESNSC )) deallocate(WESNSC , STAT=STATUS); VERIFY_(STATUS) if(allocated (SNDZSC )) deallocate(SNDZSC , STAT=STATUS); VERIFY_(STATUS) if(allocated (WESNPREC )) deallocate(WESNPREC , STAT=STATUS); VERIFY_(STATUS) @@ -3775,10 +3775,10 @@ subroutine LANDICECORE(RC) if(allocated (HTSNN )) deallocate(HTSNN , STAT=STATUS); VERIFY_(STATUS) if(allocated (SNDZN )) deallocate(SNDZN , STAT=STATUS); VERIFY_(STATUS) -! All done -!----------- +! All done +!----------- - RETURN_(ESMF_SUCCESS) + RETURN_(ESMF_SUCCESS) end subroutine LANDICECORE @@ -3794,7 +3794,7 @@ subroutine SOLVEICELAYER(NICE, dts, TICE, ICEDZ, UPPER_BND, & lhflux,shflux,hlwout,evapout, & condsno, fhgnd, sndz, ghflxice ) - implicit none + implicit none integer, intent(in) :: NICE real, intent(in ) :: DTS @@ -3810,28 +3810,28 @@ subroutine SOLVEICELAYER(NICE, dts, TICE, ICEDZ, UPPER_BND, & real, optional, intent(in ) :: dlhdtc,dhsdtc,dhlwtc real, optional, intent(in ) :: rain real, optional, intent(out) :: rainrf - real, optional, intent(out) :: lhflux,shflux,hlwout,evapout + real, optional, intent(out) :: lhflux,shflux,hlwout,evapout real, optional, intent(out) :: ghflxice ! UPPER_BND == 1 - real, optional, intent(in ) :: condsno, fhgnd, sndz + real, optional, intent(in ) :: condsno, fhgnd, sndz ! Locals real :: melti,frrain,dtr,tsx,mass,snowd,rainf,denom,alhv,hcorr, & - enew,eold,tdum,fnew,tnew,icedens,densfac,hnew - integer :: i + enew,eold,tdum,fnew,tnew,icedens,densfac,hnew + integer :: i real, dimension(size(TICE) ) :: tpsn real, dimension(size(TICE) ) :: dtc,q,cl,cd,cr real, dimension(size(TICE)+1) :: fhsn,df - + df = 0. dtc = 0. fhsn = 0. MELT = 0. - + if(UPPER_BND == 0) then rainrf = 0.0 RUNOFF = 0.0 @@ -3841,8 +3841,8 @@ subroutine SOLVEICELAYER(NICE, dts, TICE, ICEDZ, UPPER_BND, & alhv = alhe + alhm !randy - fhsn(NICE+1) = 0.0 - df(NICE+1) = 0.0 + fhsn(NICE+1) = 0.0 + df(NICE+1) = 0.0 !**** Calculate heat fluxes between snow layers. @@ -3861,9 +3861,9 @@ subroutine SOLVEICELAYER(NICE, dts, TICE, ICEDZ, UPPER_BND, & else df(1) = -sqrt(condice*condsno)/((ICEDZ(1)+sndz)*0.5) - !fhsn(1) = df(1)*(TSN - tpsn(1)) + !fhsn(1) = df(1)*(TSN - tpsn(1)) fhsn(1) = fhgnd - endif + endif !**** Prepare array elements for solution & coefficient matrices. !**** Terms are as follows: left (cl), central (cd) & right (cr) @@ -3891,42 +3891,42 @@ subroutine SOLVEICELAYER(NICE, dts, TICE, ICEDZ, UPPER_BND, & do i=1,NICE if(tpsn(i)+dtc(i) > 0.) then - melti = (tpsn(i)+dtc(i))*cpw*MAPL_RHOWTR*ICEDZ(i)/MAPL_ALHF - MELT = MELT + melti + melti = (tpsn(i)+dtc(i))*cpw*MAPL_RHOWTR*ICEDZ(i)/MAPL_ALHF + MELT = MELT + melti if(UPPER_BND == 0) then - RUNOFF = RUNOFF + melti + RUNOFF = RUNOFF + melti endif dtc(i) = -tpsn(i) tpsn(i) = tpsn(i) + dtc(i) - if(i == 1) then + if(i == 1) then if(UPPER_BND == 0) then RUNOFF = RUNOFF + rain * dts endif endif elseif(tpsn(i)+dtc(i) == 0.0) then tpsn(i) = tpsn(i) + dtc(i) - if(i == 1) then + if(i == 1) then if(UPPER_BND == 0) then RUNOFF = RUNOFF + rain * dts endif endif else ! temp < 0, refreeze rain if any tpsn(i) = tpsn(i) + dtc(i) - if(i == 1) then + if(i == 1) then if(UPPER_BND == 0) then - !*** only latent heat of rain is used to raise ice temp. + !*** only latent heat of rain is used to raise ice temp. !*** since AGCM assumes rain has 0 heat content - dtr = rain*dts*alhm/(RHOICE*cpw*ICEDZ(i)) + dtr = rain*dts*alhm/(RHOICE*cpw*ICEDZ(i)) if(tpsn(i)+dtr > 0.0) then frrain = max(dtr-(-tpsn(i))/dtr, 1.) dtr = -tpsn(i) - else + else frrain = 0.0 - endif + endif tpsn(i) = tpsn(i) + dtr dtc(i) = dtc(i) + dtr RUNOFF = RUNOFF + frrain * rain * dts - rainrf = rainrf + (1.-frrain) * rain * dts + rainrf = rainrf + (1.-frrain) * rain * dts endif endif endif @@ -3939,17 +3939,17 @@ subroutine SOLVEICELAYER(NICE, dts, TICE, ICEDZ, UPPER_BND, & endif endif enddo - - MELT = MELT / dts - if(present(RUNOFF)) RUNOFF = RUNOFF / dts - if(present(rainrf)) rainrf = rainrf / dts + MELT = MELT / dts + + if(present(RUNOFF)) RUNOFF = RUNOFF / dts + if(present(rainrf)) rainrf = rainrf / dts - if(present(dtss)) dtss = dtc(1) + if(present(dtss)) dtss = dtc(1) TICE = tpsn + tf - end subroutine SOLVEICELAYER + end subroutine SOLVEICELAYER end subroutine RUN2 diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSlandice_GridComp/GEOSissm_GridComp/GEOS_ISSMGridComp.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSlandice_GridComp/GEOSissm_GridComp/GEOS_ISSMGridComp.F90 index 45dd9c023e..0bd5940be6 100644 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSlandice_GridComp/GEOSissm_GridComp/GEOS_ISSMGridComp.F90 +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSlandice_GridComp/GEOSissm_GridComp/GEOS_ISSMGridComp.F90 @@ -6,7 +6,7 @@ module GEOS_IssmGridCompMod !BOP ! !MODULE: GEOS_ISSM --- Runs ISSM (Ice-sheet and Sea-level System Model) -! +! ! ! !DESCRIPTION: ! @@ -15,19 +15,19 @@ module GEOS_IssmGridCompMod ! Exports: ICESURF, ICETHICK, ICESMB_ISSM, ICEVX, ICEVY (defined on mesh) [true export state] ! Exports: ICESURF, ICETHICK, ICEVEL (defined on landice tiles) [via private internal state] ! Internals: ICESURF, ICETHICK, IMLS, OMLS, ISSM_NSTEPS (defined on mesh) [true internal state] -! *** NOTES: +! *** NOTES: ! (*) currently we run over all input files (*.bin) that are found in ISSM_EXPDIR (scratch directory) ! (e.g., Greenland + Antarctica + any other glaciers that have been configured) -! (*) ISSM meshes are internal to ISSM (C++ source)--we create an ESMF_MESH version for regridding +! (*) ISSM meshes are internal to ISSM (C++ source)--we create an ESMF_MESH version for regridding ! imports/exports that is the global combination of all ISSM meshes -! (*) we transform imports from landice tiles to attached grid, then regrid to the mesh -! (*) ISSM outputs are saved with HISTORY via a 'mesh tile space' developed by Weiyuan Jiang (GMAO SI Team) -! (*) ISSM time step is generally larger than LANDICE timestep, or even a job duration. We persist ISSM -! variables across job segments through internal state checkpoints (restarts). We make sure that INTERNAL -! and EXPORT variables are 'filled in' by Initialize so that LANDICE and HISTORY have access to ISSM -! variables before it runs. -! (*) Related, we use a custom ISSM run alarm that is keyed to the last time ISSM ran, not the simulation -! start time. The number of LANDICE time steps since ISSM last ran is tracked via the internal state. +! (*) we transform imports from landice tiles to attached grid, then regrid to the mesh +! (*) ISSM outputs are saved with HISTORY via a 'mesh tile space' developed by Weiyuan Jiang (GMAO SI Team) +! (*) ISSM time step is generally larger than LANDICE timestep, or even a job duration. We persist ISSM +! variables across job segments through internal state checkpoints (restarts). We make sure that INTERNAL +! and EXPORT variables are 'filled in' by Initialize so that LANDICE and HISTORY have access to ISSM +! variables before it runs. +! (*) Related, we use a custom ISSM run alarm that is keyed to the last time ISSM ran, not the simulation +! start time. The number of LANDICE time steps since ISSM last ran is tracked via the internal state. ! !USES: use iso_fortran_env, only: dp=>real64, sp=>real32 @@ -47,7 +47,7 @@ subroutine InitializeISSM(expdir, num_elements, num_nodes, comm) bind(c, name="I integer(c_int) :: num_nodes integer(c_int) :: comm end subroutine InitializeISSM - + subroutine RunISSM(ISSM_DT, gcm_forcings, issm_outputs) bind(C,NAME="RunISSM") import :: c_ptr, c_double real(c_double), value :: ISSM_DT @@ -63,7 +63,7 @@ end subroutine InputFromRestarts subroutine GetNodesISSM(nodeIds, nodeCoords) bind(C,NAME="GetNodesISSM") import :: c_ptr type(c_ptr), value :: nodeIds - type(c_ptr), value :: nodeCoords + type(c_ptr), value :: nodeCoords end subroutine GetNodesISSM subroutine GetElementsISSM(elementIds, elementConn, elementCoords, glacIds) bind(C,NAME="GetElementsISSM") @@ -83,10 +83,10 @@ end subroutine FinalizeISSM public SetServices -! some shared derived types and parameters below: +! some shared derived types and parameters below: public :: T_ISSM_TILE_STATE -public :: ISSM_TILE_WRAP +public :: T_ISSM_TILE_WRAP ! define ISSM export as internal variables, will be used by the landice gridcomp type T_ISSM_TILE_STATE @@ -98,11 +98,11 @@ end subroutine FinalizeISSM real :: LANDICE_DT end type T_ISSM_TILE_STATE -type ISSM_TILE_WRAP +type T_ISSM_TILE_WRAP type(T_ISSM_TILE_STATE), pointer :: ptr=>null() -end type ISSM_TILE_WRAP +end type T_ISSM_TILE_WRAP -! private internal state for regridding +! private internal state for regridding type T_ISSM_STATE private type(ESMF_RouteHandle) :: routehandle_m2g ! routehandle for regridding mesh to grid @@ -128,7 +128,7 @@ end subroutine FinalizeISSM type(T_ISSM_STATE), pointer :: internal_state=>null() ! internal state for regridding and halo operations contains - + !BOP @@ -143,7 +143,7 @@ subroutine SetServices ( GC, RC ) type(ESMF_GridComp), intent(INOUT) :: GC ! gridded component integer, optional :: RC ! return code - ! !DESCRIPTION: + ! !DESCRIPTION: ! This version uses the MAPL\_GenericSetServices Here we set the initialize method, ! run method, and finalize method because we are interfacing with the external ISSM ! library IRF methods. @@ -178,11 +178,11 @@ subroutine SetServices ( GC, RC ) call MAPL_GridCompSetEntryPoint ( GC, ESMF_METHOD_INITIALIZE, Initialize, _RC) call MAPL_GridCompSetEntryPoint ( GC, ESMF_METHOD_RUN, Run, _RC) call MAPL_GridCompSetEntryPoint ( GC, ESMF_METHOD_FINALIZE, Finalize, _RC) - + !----------------------------------- call MAPL_GetObjectFromGC (GC, MAPL, _RC) - + ! Set the state variable specs. !----------------------------------- @@ -196,7 +196,7 @@ subroutine SetServices ( GC, RC ) DIMS = MAPL_DimsTileOnly, & VLOCATION = MAPL_VLocationNone, & _RC ) - + call MAPL_AddExportSpec(GC, & SHORT_NAME = 'ICEVX', & LONG_NAME = 'ice_velocity_x_direction', & @@ -204,7 +204,7 @@ subroutine SetServices ( GC, RC ) DIMS = MAPL_DimsTileOnly, & VLOCATION = MAPL_VLocationNone, & _RC ) - + call MAPL_AddExportSpec(GC, & SHORT_NAME = 'ICEVY', & LONG_NAME = 'ice_velocity_y_direction', & @@ -212,7 +212,7 @@ subroutine SetServices ( GC, RC ) DIMS = MAPL_DimsTileOnly, & VLOCATION = MAPL_VLocationNone, & _RC ) - + call MAPL_AddExportSpec(GC, & SHORT_NAME = 'ICETHICK', & LONG_NAME = 'ice_thickness', & @@ -220,15 +220,15 @@ subroutine SetServices ( GC, RC ) DIMS = MAPL_DimsTileOnly, & VLOCATION = MAPL_VLocationNone, & _RC ) - + call MAPL_AddExportSpec(GC, & SHORT_NAME = 'ICESMB_ISSM', & LONG_NAME = 'issm_surface_mass_balance', & UNITS = 'kg m-2 s-1', & DIMS = MAPL_DimsTileOnly, & VLOCATION = MAPL_VLocationNone, & - _RC ) - + _RC ) + ! Internal states: call MAPL_AddInternalSpec(GC, & SHORT_NAME = 'ICESURF', & @@ -236,36 +236,36 @@ subroutine SetServices ( GC, RC ) UNITS = 'm', & DIMS = MAPL_DimsTileOnly, & VLOCATION = MAPL_VLocationNone, & - RESTART = MAPL_RestartOptional, & + RESTART = MAPL_RestartOptional, & _RC ) - + call MAPL_AddInternalSpec(GC, & SHORT_NAME = 'ICETHICK', & LONG_NAME = 'ice_sheet_thickness', & UNITS = 'm', & DIMS = MAPL_DimsTileOnly, & VLOCATION = MAPL_VLocationNone, & - RESTART = MAPL_RestartOptional, & + RESTART = MAPL_RestartOptional, & _RC ) - + call MAPL_AddInternalSpec(GC, & SHORT_NAME = 'IMLS', & LONG_NAME = 'ice_mask_levelset', & UNITS = 'none', & DIMS = MAPL_DimsTileOnly, & VLOCATION = MAPL_VLocationNone, & - RESTART = MAPL_RestartOptional, & + RESTART = MAPL_RestartOptional, & _RC ) - + call MAPL_AddInternalSpec(GC, & SHORT_NAME = 'OMLS', & LONG_NAME = 'ocean_mask_levelset', & UNITS = 'none', & DIMS = MAPL_DimsTileOnly, & VLOCATION = MAPL_VLocationNone, & - RESTART = MAPL_RestartOptional, & + RESTART = MAPL_RestartOptional, & _RC ) - + call MAPL_AddInternalSpec(GC, & SHORT_NAME = 'ICEVX', & LONG_NAME = 'ice_velocity_x_direction', & @@ -274,7 +274,7 @@ subroutine SetServices ( GC, RC ) VLOCATION = MAPL_VLocationNone, & RESTART = MAPL_RestartOptional, & _RC ) - + call MAPL_AddInternalSpec(GC, & SHORT_NAME = 'ICEVY', & LONG_NAME = 'ice_velocity_y_direction', & @@ -283,7 +283,7 @@ subroutine SetServices ( GC, RC ) VLOCATION = MAPL_VLocationNone, & RESTART = MAPL_RestartOptional, & _RC ) - + call MAPL_AddInternalSpec(GC, & SHORT_NAME = 'ISSM_NSTEPS', & LONG_NAME = 'steps_since_last_issm', & @@ -307,25 +307,25 @@ subroutine SetServices ( GC, RC ) call MAPL_TimerAdd(GC, name="RUN" ,_RC) call MAPL_TimerAdd(GC, name="ISSMCore" ,_RC) - - + + ! ---------------------------------- call MAPL_GenericSetServices ( GC, _RC) - + _RETURN(_SUCCESS) - + end subroutine SetServices ! ! INITIALIZE: - + subroutine Initialize ( GC, IMPORT, EXPORT, CLOCK, RC ) - type(ESMF_GridComp), intent(INOUT) :: GC ! Gridded component + type(ESMF_GridComp), intent(INOUT) :: GC ! Gridded component type(ESMF_State), intent(INOUT) :: IMPORT ! Import state type(ESMF_State), intent(INOUT) :: EXPORT ! Export state type(ESMF_Clock), intent(INOUT) :: CLOCK ! The clock integer, optional, intent(OUT) :: RC ! Error code - - type(MAPL_MetaComp), pointer :: MAPL + + type(MAPL_MetaComp), pointer :: MAPL type(ESMF_State) :: INTERNAL ! internal state ! ISSM alarm variables @@ -336,21 +336,21 @@ subroutine Initialize ( GC, IMPORT, EXPORT, CLOCK, RC ) type(ESMF_Time) :: ringTime ! time of first ring type(ESMF_TimeInterval) :: ringInterval ! ring time interval (ISSM_DT) real :: ISSM_DT ! ISSM time step [s] (ISSM_DT set in AGCM.rc) - real :: LANDICE_DT ! landice time step [s] + real :: LANDICE_DT ! landice time step [s] integer :: NSTEPS_INIT ! landice timesteps since last ISSM run integer :: NSTEPS_RING ! total landice timesteps between ISSM runs real, pointer, dimension(:) :: ISSM_NSTEPS => null() ! steps since last ISSM run (from internal state) - + ! ErrLog Variables character(len=ESMF_MAXSTR) :: IAm integer :: STATUS character(len=ESMF_MAXSTR) :: COMP_NAME ! virtual machine / mpi comm - type(ESMF_VM) :: vm + type(ESMF_VM) :: vm integer(c_int) :: comm ! mpi comm to pass to ISSM integer :: localPET ! ~mpi rank - + ! mesh information type(ESMF_Mesh) :: mesh ! ESMF_Mesh representation of ISSM mesh integer, pointer, dimension(:) :: elementTypes => null() ! element geometry type (triangles) @@ -364,7 +364,7 @@ subroutine Initialize ( GC, IMPORT, EXPORT, CLOCK, RC ) integer, pointer, dimension(:) :: nodeIds => null() ! Global IDs of nodes local to PET integer, pointer, dimension(:) :: nodeOwners => null() ! Specify which PET owns each node integer, pointer, dimension(:) :: glacIds => null() ! glacier ID for each element - + ! regridding varibales type(ESMF_Grid) :: grid ! atmospheric grid type(ESMF_RouteHandle) :: routehandle_m2g ! routehandle for regridding mesh to grid @@ -376,7 +376,7 @@ subroutine Initialize ( GC, IMPORT, EXPORT, CLOCK, RC ) ! tile information integer :: NT ! local number of landice tiles type(T_ISSM_TILE_STATE), pointer :: issm_tile_state - type(ISSM_TILE_WRAP) :: issm_tile_wrap + type(T_ISSM_TILE_WRAP) :: issm_tile_wrap ! field halo variables integer :: num_halo_nodes ! num_nodes minus num_owned_nodes @@ -389,17 +389,17 @@ subroutine Initialize ( GC, IMPORT, EXPORT, CLOCK, RC ) integer, pointer,dimension(:) :: owned_idx => null() ! indices of owned nodes in arrays ! owned node coordinates (longitude,latitude) - real(dp),pointer,dimension(:) :: ownedNodeCoords => null() + real(dp),pointer,dimension(:) :: ownedNodeCoords => null() real, allocatable, dimension(:) :: ownedNodeLons, ownedNodeLats - ! command-line arguments to initialize ISSM + ! command-line arguments to initialize ISSM integer :: i,j,k ! loop indices character(len=ESMF_MAXSTR) :: ISSM_EXPDIR ! directory containing ISSM input files character(len=ESMF_MAXSTR) :: EXPDIR ! C++ compatible ISSM_EXPDIR string ! variables for creating mesh tile space - type(ESMF_Grid) :: mesh_grid - type(MAPL_LocStream) :: mesh_locstream + type(ESMF_Grid) :: mesh_grid + type(MAPL_LocStream) :: mesh_locstream ! variables for masking the mesh seam (triangles that cross +/-180 longitude) ! (needed for elements, this is not currently needed for regridding fields defined on nodes) @@ -444,8 +444,8 @@ subroutine Initialize ( GC, IMPORT, EXPORT, CLOCK, RC ) logical :: distgrid_match ! check if distgrid from restarts matches nodal disgrid (locally) logical :: needRedist ! global check for consistent distgrid across all processes integer,allocatable,dimension(:) :: localFlag, globalFlag ! arrays for vm operations - type(ESMF_Array) :: restartArray ! array corresponding to restartDistgrid - type(ESMF_Array) :: nodalArray ! array corresponding to nodalDistgrid + type(ESMF_Array) :: restartArray ! array corresponding to restartDistgrid + type(ESMF_Array) :: nodalArray ! array corresponding to nodalDistgrid type(ESMF_RouteHandle) :: redisthandle ! routehandle for redistribution @@ -454,7 +454,7 @@ subroutine Initialize ( GC, IMPORT, EXPORT, CLOCK, RC ) Iam = "Initialize" call ESMF_GridCompGet( GC, NAME=COMP_NAME, _RC ) - + Iam = trim(COMP_NAME) // trim(Iam) ! Get my internal MAPL_Generic state @@ -463,17 +463,17 @@ subroutine Initialize ( GC, IMPORT, EXPORT, CLOCK, RC ) call MAPL_GetObjectFromGC ( GC, MAPL, _RC) call ESMF_VMGetCurrent(vm, _RC) - + call ESMF_VMGet(vm,mpiCommunicator=comm,localPet=localPET,_RC) - + ! **************************************************** ! call ISSM initialize C++ code so we can set up mesh ! get directory with ISSM binary input files (can modify if needed) call GET_ENVIRONMENT_VARIABLE("SCRDIR",ISSM_EXPDIR,STATUS=STATUS); _VERIFY(STATUS) - + EXPDIR = trim(ISSM_EXPDIR)//"/"//c_null_char ! create string for C++ - + ! Call the C++ function for initializing ISSM ! gets the number of elements and nodes of the mesh call InitializeISSM(EXPDIR, num_elements, num_nodes, comm) @@ -491,7 +491,7 @@ subroutine Initialize ( GC, IMPORT, EXPORT, CLOCK, RC ) ! get information about nodes and elements ! node coords and element coords (centroids) are in (lon,lat) - call GetNodesISSM(c_loc(nodeIds), c_loc(nodeCoords)) + call GetNodesISSM(c_loc(nodeIds), c_loc(nodeCoords)) call GetElementsISSM(c_loc(elementIds), c_loc(elementConn), c_loc(elementCoords),c_loc(glacIds)) elementTypes(:) = ESMF_MESHELEMTYPE_TRI ! triangular elements @@ -501,7 +501,7 @@ subroutine Initialize ( GC, IMPORT, EXPORT, CLOCK, RC ) ! ! NOTE: This is only relevant in regridding when fields are defined ! on ESMF_MESHLOC_ELEMENT (rather than ESMF_MESHLOC_NODE) - ! so is NOT CURRENTLY USED, but retained for possible future developments + ! so is NOT CURRENTLY USED, but retained for possible future developments elementMask(:) = 0 do j=1,num_elements n1 = elementConn(3*(j-1)+1) @@ -518,12 +518,12 @@ subroutine Initialize ( GC, IMPORT, EXPORT, CLOCK, RC ) ! create the ESMF mesh from ISSM mesh properties mesh = ESMF_MeshCreate(parametricDim=2, spatialDim=2, nodeIds=nodeIds, nodeCoords=nodeCoords, & - elementIds=elementIds, elementTypes=elementTypes, elementConn=elementConn,elementMask=elementMask,& + elementIds=elementIds, elementTypes=elementTypes, elementConn=elementConn,elementMask=elementMask,& elementCoords=elementCoords,coordSys=ESMF_COORDSYS_SPH_DEG, _RC) - - ! associate ESMF_Mesh representation of ISSM mesh with GC for regridding imports/exports in Run method + + ! associate ESMF_Mesh representation of ISSM mesh with GC for regridding imports/exports in Run method call ESMF_GridCompSet(GC,mesh=mesh,_RC) - + ! set up field halos !----------------------------------- call ESMF_MeshGet(mesh=mesh,nodeOwners=nodeOwners,numOwnedNodes=num_owned_nodes,nodalDistgrid=nodalDistgrid) @@ -536,7 +536,7 @@ subroutine Initialize ( GC, IMPORT, EXPORT, CLOCK, RC ) allocate(owned_idx(num_owned_nodes)) call ESMF_MeshGet(mesh=mesh,ownedNodeCoords=ownedNodeCoords) - + ! get list of (global) nodeIds that are halos on this PET ! and create a mask to remove these values from arrays i=1; k=1 @@ -549,47 +549,47 @@ subroutine Initialize ( GC, IMPORT, EXPORT, CLOCK, RC ) ownedNodeIds(k) = nodeIds(j) owned_idx(k) = j k = k+1 - end if + end if end do ! create array with halo information meshArray=ESMF_ArrayCreate(nodalDistgrid,typekind=ESMF_TYPEKIND_R8,haloSeqIndexList=halolist,_RC) - - ! create field on ISSM mesh + + ! create field on ISSM mesh meshField=ESMF_FieldCreate(mesh, array=meshArray, meshLoc=ESMF_MESHLOC_NODE, _RC) - + ! store the halo operation in a routehandle call ESMF_FieldHaloStore(meshField, routehandle=halohandle, _RC) - + ! Set up regridding next !----------------------------------- - ! get atmospheric (attached) grid + ! get atmospheric (attached) grid call ESMF_GridCompGet( GC, GRID=grid, _RC ) - + ! create field on atmospheric grid gridField = ESMF_FieldCreate(grid=grid,typekind=ESMF_TYPEKIND_R4,_RC) - + ! create routehandle for mesh-to-grid regridding (set srcMaskValues to 1 if needed... ) - call ESMF_FieldRegridStore(srcField=meshField, dstField=gridField,routehandle=routehandle_m2g,& + call ESMF_FieldRegridStore(srcField=meshField, dstField=gridField,routehandle=routehandle_m2g,& unmappedaction=ESMF_UNMAPPEDACTION_IGNORE,extrapmethod=ESMF_EXTRAPMETHOD_CREEP,& extrapNumLevels=1,_RC) - + ! create routehandle for grid-to-mesh regridding (set dstMaskValues to 1 if needed... ) - call ESMF_FieldRegridStore(srcField=gridField, dstField=meshField,routehandle=routehandle_g2m,& + call ESMF_FieldRegridStore(srcField=gridField, dstField=meshField,routehandle=routehandle_g2m,& unmappedaction=ESMF_UNMAPPEDACTION_IGNORE,extrapmethod=ESMF_EXTRAPMETHOD_NEAREST_D,_RC) - + ! create component's private internal state ! stores everything needed for regrid and halo operations during run method allocate(internal_state, stat=STATUS); _VERIFY(STATUS) - + allocate(internal_state%halo_idx(num_halo_nodes)) allocate(internal_state%owned_idx(num_owned_nodes)) allocate(internal_state%halolist(num_halo_nodes)) internal_state%routehandle_m2g = routehandle_m2g - internal_state%routehandle_g2m = routehandle_g2m - internal_state%halohandle = halohandle + internal_state%routehandle_g2m = routehandle_g2m + internal_state%halohandle = halohandle internal_state%halo_idx = halo_idx - internal_state%owned_idx = owned_idx + internal_state%owned_idx = owned_idx internal_state%grid = grid internal_state%mesh = mesh internal_state%halolist = halolist @@ -599,7 +599,7 @@ subroutine Initialize ( GC, IMPORT, EXPORT, CLOCK, RC ) ! wrap the private internal state wrap%ptr => internal_state call ESMF_UserCompSetInternalState ( GC, 'ISSM_WRAP', wrap, STATUS ); _VERIFY(STATUS) - + ! Create losctream that match mesh element id, then set it to this GC and MAPL ! note: original attached/atmospheric grid and landice tile locstream have ! been stored in the internal state @@ -622,11 +622,11 @@ subroutine Initialize ( GC, IMPORT, EXPORT, CLOCK, RC ) ! Get private internal state for sending information to/from LANDICE !----------------------------------- - + call ESMF_UserCompGetInternalState(GC, 'ISSM_TILES', issm_tile_wrap, status); _VERIFY(STATUS) issm_tile_state => issm_tile_wrap%ptr - ! Create Custom ISSM Run Alarm + ! Create Custom ISSM Run Alarm !----------------------------------- ! get internal state @@ -636,15 +636,15 @@ subroutine Initialize ( GC, IMPORT, EXPORT, CLOCK, RC ) call MAPL_GetPointer(INTERNAL, ISSM_NSTEPS, 'ISSM_NSTEPS',_RC) NSTEPS_INIT = nint(maxval(ISSM_NSTEPS)) - ! get timestep for landice + ! get timestep for landice LANDICE_DT = issm_tile_state%LANDICE_DT - + ! get timestep for ISSM call MAPL_GetResource(MAPL, ISSM_DT, Label=trim(COMP_NAME)//"_DT:",DEFAULT=302400.0, _RC) - + ! total landice time steps between ISSM runs - NSTEPS_RING = nint(ISSM_DT/LANDICE_DT) - + NSTEPS_RING = nint(ISSM_DT/LANDICE_DT) + ! calculate initial ring time from initial time and remaining timesteps call ESMF_ClockGet(CLOCK,currTime=startTime) sec_to_ring = (NSTEPS_RING-NSTEPS_INIT-1)*nint(LANDICE_DT) @@ -653,10 +653,10 @@ subroutine Initialize ( GC, IMPORT, EXPORT, CLOCK, RC ) ! set ring interval to ISSM time step call ESMF_TimeIntervalSet(ringInterval,s=nint(ISSM_DT),_RC) - + ! create new ISSM_ALARM ISSM_ALARM = ESMF_AlarmCreate(CLOCK,ringTime=ringTime,ringInterval=ringInterval,sticky=.false.,_RC) - + ! set run alarm call MAPL_Set(MAPL, RUNALARM = ISSM_ALARM, _RC) @@ -672,7 +672,7 @@ subroutine Initialize ( GC, IMPORT, EXPORT, CLOCK, RC ) allocate(IMLS_HALO(num_nodes)) allocate(OMLS_HALO(num_nodes)) allocate(ZEROS(num_nodes)) - + ! get pointers to restarts call MAPL_GetPointer(INTERNAL, ICESURF_IN, 'ICESURF', _RC) call MAPL_GetPointer(INTERNAL, ICETHICK_IN, 'ICETHICK',_RC) @@ -681,7 +681,7 @@ subroutine Initialize ( GC, IMPORT, EXPORT, CLOCK, RC ) call MAPL_GetPointer(INTERNAL, IMLS_IN, 'IMLS', _RC) call MAPL_GetPointer(INTERNAL, OMLS_IN, 'OMLS',_RC) call MAPL_GetPointer(INTERNAL, restartNodeIds, 'RS_NODEIDS',_RC) - + ! if restart has been read, apply halo operation and send pointers to ISSM ! else, ISSM will just use default initial values in ISSM*.bin input files if (associated(ICETHICK_IN)) then @@ -689,7 +689,7 @@ subroutine Initialize ( GC, IMPORT, EXPORT, CLOCK, RC ) ! ISSM throws error for zero ice thickness ISSM_RST_FOUND = minval(ICETHICK_IN) > epsilon(ICETHICK_IN) end if - + if (ISSM_RST_FOUND) then ! check if the nodal distgrid created above matches the distgrid read from the restart ! it will only be different if running over a different number of processes than when @@ -701,10 +701,10 @@ subroutine Initialize ( GC, IMPORT, EXPORT, CLOCK, RC ) if (distgrid_match) localFlag(1) = 1 call ESMF_VMAllReduce(vm, sendData=localFlag, recvData=globalFlag, count=1, reduceflag=ESMF_REDUCE_MIN, _RC) needRedist = (globalFlag(1) == 0) - + if (needRedist) then - ! create routehandle for redistribution, and redistribute all restarts from the - ! restart distgrid to the current distgrid (nodalDistgrid) + ! create routehandle for redistribution, and redistribute all restarts from the + ! restart distgrid to the current distgrid (nodalDistgrid) restartDistgrid = ESMF_DistGridCreate(arbSeqIndexList=nint(restartNodeIds), _RC) restartArray=ESMF_ArrayCreate(distgrid=restartDistgrid,typekind=ESMF_TYPEKIND_R4,_RC) nodalArray=ESMF_ArrayCreate(distgrid=nodalDistgrid,typekind=ESMF_TYPEKIND_R4,_RC) @@ -717,13 +717,13 @@ subroutine Initialize ( GC, IMPORT, EXPORT, CLOCK, RC ) call apply_redist(IMLS_IN,_RC) call apply_redist(OMLS_IN,_RC) - call ESMF_VMBarrier(vm, _RC) - + call ESMF_VMBarrier(vm, _RC) + call ESMF_ArrayDestroy(restartArray, _RC) call ESMF_ArrayDestroy(nodalArray, _RC) - - end if - + + end if + ! apply halo operation to all restart variables call apply_halo(ICESURF_IN,ICESURF_HALO,_RC) call apply_halo(ICETHICK_IN,ICETHICK_HALO,_RC) @@ -734,15 +734,15 @@ subroutine Initialize ( GC, IMPORT, EXPORT, CLOCK, RC ) ! package restarts into one pointer GEOS_RESTARTS(:) = 0.0_dp - GEOS_RESTARTS(1:num_nodes) = ICESURF_HALO(:) - GEOS_RESTARTS(num_nodes+1:2*num_nodes) = ICETHICK_HALO(:) - GEOS_RESTARTS(2*num_nodes+1:3*num_nodes) = ICEVX_HALO(:) - GEOS_RESTARTS(3*num_nodes+1:4*num_nodes) = ICEVY_HALO(:) - GEOS_RESTARTS(4*num_nodes+1:5*num_nodes) = OMLS_HALO(:) - GEOS_RESTARTS(5*num_nodes+1:6*num_nodes) = IMLS_HALO(:) + GEOS_RESTARTS(1:num_nodes) = ICESURF_HALO(:) + GEOS_RESTARTS(num_nodes+1:2*num_nodes) = ICETHICK_HALO(:) + GEOS_RESTARTS(2*num_nodes+1:3*num_nodes) = ICEVX_HALO(:) + GEOS_RESTARTS(3*num_nodes+1:4*num_nodes) = ICEVY_HALO(:) + GEOS_RESTARTS(4*num_nodes+1:5*num_nodes) = OMLS_HALO(:) + GEOS_RESTARTS(5*num_nodes+1:6*num_nodes) = IMLS_HALO(:) ! set restarts on the ISSM side - call ESMF_VMBarrier(vm, _RC) + call ESMF_VMBarrier(vm, _RC) call InputFromRestarts(c_loc(GEOS_RESTARTS)) call ESMF_VMBarrier(vm, _RC) @@ -754,13 +754,13 @@ subroutine Initialize ( GC, IMPORT, EXPORT, CLOCK, RC ) call RunISSM(real(ISSM_DT,kind=dp), c_loc(ZEROS), c_loc(GEOS_RESTARTS)) call ESMF_VMBarrier(vm, _RC) - ! Unpack restart array - ICESURF_HALO(:) = GEOS_RESTARTS(1:num_nodes) - ICETHICK_HALO(:) = GEOS_RESTARTS(num_nodes+1:2*num_nodes) + ! Unpack restart array + ICESURF_HALO(:) = GEOS_RESTARTS(1:num_nodes) + ICETHICK_HALO(:) = GEOS_RESTARTS(num_nodes+1:2*num_nodes) ICEVX_HALO(:) = GEOS_RESTARTS(2*num_nodes+1:3*num_nodes) ICEVY_HALO(:) = GEOS_RESTARTS(3*num_nodes+1:4*num_nodes) - OMLS_HALO(:) = GEOS_RESTARTS(4*num_nodes+1:5*num_nodes) - IMLS_HALO(:) = GEOS_RESTARTS(5*num_nodes+1:6*num_nodes) + OMLS_HALO(:) = GEOS_RESTARTS(4*num_nodes+1:5*num_nodes) + IMLS_HALO(:) = GEOS_RESTARTS(5*num_nodes+1:6*num_nodes) ! filter out halo points (keep the owned indices) for restarts if(associated(ICESURF_IN)) ICESURF_IN = ICESURF_HALO(owned_idx) @@ -770,7 +770,7 @@ subroutine Initialize ( GC, IMPORT, EXPORT, CLOCK, RC ) if(associated(OMLS_IN)) OMLS_IN = OMLS_HALO(owned_idx) if(associated(IMLS_IN)) IMLS_IN = IMLS_HALO(owned_idx) - end if + end if ! Initialize Export pointers on mesh tile space so history has something to write !----------------------------------- @@ -789,7 +789,7 @@ subroutine Initialize ( GC, IMPORT, EXPORT, CLOCK, RC ) ! Finally, set the tile export state so landice can access values before ISSM runs !----------------------------------- - + ! Regrid from mesh to tile call MAPL_LocStreamGet(internal_state%locstream, NT_LOCAL=NT, _RC) @@ -849,7 +849,7 @@ subroutine Initialize ( GC, IMPORT, EXPORT, CLOCK, RC ) call ESMF_FieldDestroy(gridField, _RC) call ESMF_FieldDestroy(meshField, _RC) call ESMF_ArrayDestroy(meshArray, _RC) - + _RETURN(_SUCCESS) contains @@ -863,26 +863,26 @@ subroutine apply_halo(VAR_IN,VAR_HALO,RC) ! local variables: real(dp), pointer, dimension(:) :: VAR_DP ! double version of VAR_IN real(dp), pointer, dimension(:) :: MESH_PTR ! pointer for ESMF_FieldGet - real(dp), pointer, dimension(:) :: ARRAY_PTR ! pointer for ESMF_ArrayGet + real(dp), pointer, dimension(:) :: ARRAY_PTR ! pointer for ESMF_ArrayGet type(ESMF_Array) :: meshArray ! array for creating mesh fields type(ESMF_Field) :: meshField ! field associated with meshArray allocate(VAR_DP(num_nodes)) VAR_DP(:) = 0.0_dp VAR_DP(1:num_owned_nodes) = REAL(VAR_IN,kind=dp) - + ! create array with halo information meshArray=ESMF_ArrayCreate(nodalDistgrid,typekind=ESMF_TYPEKIND_R8,haloSeqIndexList=halolist,_RC) call ESMF_ArrayGet(array=meshArray,farrayPtr=ARRAY_PTR) ARRAY_PTR(:) = VAR_DP(:) - ! create field on ISSM mesh + ! create field on ISSM mesh meshField=ESMF_FieldCreate(mesh, array=meshArray, meshLoc=ESMF_MESHLOC_NODE, _RC) - + ! append halo values to end of "owned" array call ESMF_FieldHalo(meshField, routehandle=halohandle, _RC) - + ! get pointer to field on mesh call ESMF_FieldGet(meshField,farrayPtr=MESH_PTR,_RC) @@ -891,8 +891,8 @@ subroutine apply_halo(VAR_IN,VAR_HALO,RC) VAR_HALO(halo_idx) = MESH_PTR(num_owned_nodes+1:num_nodes) ! halo nodes ! destroy field and array, deallocate pointer - call ESMF_FieldDestroy(meshField,_RC) - call ESMF_ArrayDestroy(meshArray,_RC) + call ESMF_FieldDestroy(meshField,_RC) + call ESMF_ArrayDestroy(meshArray,_RC) deallocate(VAR_DP) _RETURN(_SUCCESS) @@ -905,7 +905,7 @@ subroutine apply_redist(VAR_RS,RC) type(ESMF_Array) :: restartArray ! restart array type(ESMF_Array) :: redistArray ! redistributed array - real, pointer, dimension(:) :: redistPtr + real, pointer, dimension(:) :: redistPtr restartArray=ESMF_ArrayCreate(distgrid=restartDistgrid,farrayPtr=VAR_RS,_RC) redistArray=ESMF_ArrayCreate(distgrid=nodalDistgrid,typekind=ESMF_TYPEKIND_R4,_RC) @@ -918,13 +918,13 @@ subroutine apply_redist(VAR_RS,RC) ! make sure all processes have finished redistribution call ESMF_VMBarrier(vm, _RC) - + ! copy values into output VAR_RS(:) = redistPtr(:) call ESMF_VMBarrier(vm, _RC) call ESMF_ArrayDestroy(restartArray,_RC) - call ESMF_ArrayDestroy(redistArray,_RC) + call ESMF_ArrayDestroy(redistArray,_RC) _RETURN(_SUCCESS) end subroutine apply_redist @@ -936,12 +936,12 @@ function create_mesh_grid(rc) result(mesh_grid) real(kind=8), pointer :: centers_lon(:,:) real(kind=8), pointer :: centers_lat(:,:) integer, allocatable :: IMs(:) - + !comm, VM, num_owned_nodes are from containing subroutine - call ESMF_VMGet(vm, petcount=nDEs, _RC) + call ESMF_VMGet(vm, petcount=nDEs, _RC) allocate(IMS(nDEs)) num(1) = num_owned_nodes - call MAPL_CommsAllGather(vm, num, 1, IMs, 1, _RC) + call MAPL_CommsAllGather(vm, num, 1, IMs, 1, _RC) ! create a mesh-grid in 1D mesh_grid = ESMF_GridCreate( & @@ -963,14 +963,14 @@ function create_mesh_grid(rc) result(mesh_grid) call ESMF_GridGetCoord(mesh_grid, coordDim=1, localDE=0, & staggerloc=ESMF_STAGGERLOC_CENTER, & farrayPtr=centers_lon, _RC) - centers_lon(:,1) = ownedNodeLons + centers_lon(:,1) = ownedNodeLons call ESMF_GridGetCoord(mesh_grid, coordDim=2, localDE=0, & staggerloc=ESMF_STAGGERLOC_CENTER, & farrayPtr=centers_lat, _RC) - centers_lat(:,1) = ownedNodeLats + centers_lat(:,1) = ownedNodeLats _RETURN(_SUCCESS) - end function create_mesh_grid + end function create_mesh_grid end subroutine Initialize @@ -981,15 +981,15 @@ subroutine RUN ( GC, IMPORT, EXPORT, CLOCK, RC ) ! ! ****** Run ISSM ice-sheet model ****** ! ! the core C++ solvers and associated pre/post-processing of imports/exports ! ! are only performed at ISSM_DT intervals. However, the Run method is engaged - ! ! at every landice timestep to ensure that ISSM restarts persist + ! ! at every landice timestep to ensure that ISSM restarts persist ! !ARGUMENTS: - type(ESMF_GridComp), intent(inout) :: GC ! Gridded component + type(ESMF_GridComp), intent(inout) :: GC ! Gridded component type(ESMF_State), intent(inout) :: IMPORT ! Import state type(ESMF_State), intent(inout) :: EXPORT ! Export state type(ESMF_Clock), intent(inout) :: CLOCK ! The clock integer, optional, intent( out) :: RC ! Error code - type(ESMF_Alarm) :: ALARM ! run alarm for ISSM component - + type(ESMF_Alarm) :: ALARM ! run alarm for ISSM component + ! ErrLog Variables character(len=ESMF_MAXSTR) :: IAm integer :: STATUS @@ -997,7 +997,7 @@ subroutine RUN ( GC, IMPORT, EXPORT, CLOCK, RC ) type(MAPL_MetaComp), pointer :: MAPL type(ESMF_State) :: INTERNAL - type(ESMF_VM) :: vm + type(ESMF_VM) :: vm ! internal state for regridding and halo operations type(ESMF_Mesh) :: mesh ! ESMF version of ISSM mesh @@ -1006,7 +1006,7 @@ subroutine RUN ( GC, IMPORT, EXPORT, CLOCK, RC ) ! tile information integer :: NT ! number of landice tiles type(T_ISSM_TILE_STATE), pointer :: issm_tile_state - type(ISSM_TILE_WRAP) :: issm_tile_wrap + type(T_ISSM_TILE_WRAP) :: issm_tile_wrap ! surface mass balance on mesh and landice tiles ! note: SMB has been time-averaged between ISSM runs @@ -1047,10 +1047,10 @@ subroutine RUN ( GC, IMPORT, EXPORT, CLOCK, RC ) real(dp), pointer, dimension(:) :: OMLS_MESH => null() ! ocean mask level set real, pointer, dimension(:) :: OMLS_IN => null() ! pointer to internal state (mesh tiles) - ! ice-flow speed on mesh and landice tiles + ! ice-flow speed on mesh and landice tiles real(dp), pointer, dimension(:) :: ICEVEL_MESH => null() ! ice flow speed on mesh tiles real, pointer, dimension(:) :: ICEVEL_TILE => null() ! ice flow speed on landice tiles - + ! physical parameters real(dp), parameter :: rho_ice = 917.0 ! pure ice density [kg m-3] real(dp) :: ISSM_DT ! time step [s] (ISSM_DT set in AGCM.rc) @@ -1059,7 +1059,7 @@ subroutine RUN ( GC, IMPORT, EXPORT, CLOCK, RC ) ! ----------------------------------------------------------- Iam = "Run" call ESMF_GridCompGet(GC,name=COMP_NAME,mesh=mesh,vm=vm,_RC) - + Iam = trim(COMP_NAME) // Iam ! Get my internal MAPL_Generic state @@ -1068,7 +1068,7 @@ subroutine RUN ( GC, IMPORT, EXPORT, CLOCK, RC ) _VERIFY(STATUS) call MAPL_Get(MAPL,INTERNAL_ESMF_STATE = INTERNAL,_RC ) - + ! Start Total timer !------------------ @@ -1076,9 +1076,9 @@ subroutine RUN ( GC, IMPORT, EXPORT, CLOCK, RC ) call MAPL_TimerOn(MAPL,"RUN" ) call MAPL_Get(MAPL, RUNALARM = ALARM, _RC ) - - ! run ISSM at specified time steps, + + ! run ISSM at specified time steps, ! if bootstrapping restart and issm has run not by final time step, run anyways ! with timestep of zero, which just gets restart values if (ESMF_AlarmIsRinging (ALARM, RC=STATUS)) then @@ -1089,12 +1089,12 @@ subroutine RUN ( GC, IMPORT, EXPORT, CLOCK, RC ) ! get timestep for ISSM call MAPL_GetResource(MAPL, ISSM_DT, Label=trim(COMP_NAME)//"_DT:",DEFAULT=302400.0, _RC) - + ! get number of mesh elements call ESMF_MeshGet(mesh,nodeCount=num_nodes) ! allocate ice-elevation output (export from ISSM) - allocate(ISSM_OUTPUTS(num_outputs*num_nodes)) + allocate(ISSM_OUTPUTS(num_outputs*num_nodes)) ! allocate output arrays defined on mesh nodes allocate(ICESURF_MESH(num_nodes)) @@ -1104,11 +1104,11 @@ subroutine RUN ( GC, IMPORT, EXPORT, CLOCK, RC ) allocate(ICEVEL_MESH(num_nodes)) allocate(IMLS_MESH(num_nodes)) allocate(OMLS_MESH(num_nodes)) - + ! allocate input arrays defined on mesh nodes - allocate(ICESMB_MESH(num_nodes)) + allocate(ICESMB_MESH(num_nodes)) - ! initialize ISSM outputs to zero + ! initialize ISSM outputs to zero ICESURF_MESH(:) = 0.0_dp ICETHICK_MESH(:) = 0.0_dp ICEVX_MESH(:) = 0.0_dp @@ -1120,30 +1120,30 @@ subroutine RUN ( GC, IMPORT, EXPORT, CLOCK, RC ) ! get landice tile dimensions call MAPL_LocStreamGet(internal_state%locstream, NT_LOCAL=NT, _RC) - + call ESMF_UserCompGetInternalState(GC, 'ISSM_TILES', issm_tile_wrap, status); _VERIFY(STATUS) issm_tile_state => issm_tile_wrap%ptr - + ! *************************************************************************** ! ! GET ICESMB IMPORT (surface mass balance) - ! *************************************************************************** ! + ! *************************************************************************** ! ! NOTE: ICESMB (from landice) has been time-averaged between ISSM runs ! hence the name ICESMB_ISSM - - ! allocate tiles for ICESMB + + ! allocate tiles for ICESMB if(.not.associated(ICESMB_TILE)) then allocate(ICESMB_TILE(NT), STAT=STATUS) _VERIFY(STATUS) ICESMB_TILE = MAPL_Undef end if - - ! copy import values into tile array + + ! copy import values into tile array ICESMB_TILE = issm_tile_state%ICESMB_ISSM - ! transform ICESMB from landice tiles to mesh + ! transform ICESMB from landice tiles to mesh call tile_to_mesh(ICESMB_TILE,ICESMB_MESH,_RC) - ! save ICESMB on mesh elements + ! save ICESMB on mesh elements call MAPL_GetPointer(EXPORT , ICESMB_EX , 'ICESMB_ISSM' , _RC) if(associated(ICESMB_EX)) ICESMB_EX = ICESMB_MESH(internal_state%owned_idx) @@ -1157,7 +1157,7 @@ subroutine RUN ( GC, IMPORT, EXPORT, CLOCK, RC ) call ESMF_VMBarrier(vm, _RC) call MAPL_TimerOn(MAPL,"ISSMCore" ) - ! call run method from ISSM library + ! call run method from ISSM library call RunISSM(ISSM_DT, c_loc(ICESMB_MESH), c_loc(ISSM_OUTPUTS)) call ESMF_VMBarrier(vm, _RC) @@ -1224,18 +1224,18 @@ subroutine RUN ( GC, IMPORT, EXPORT, CLOCK, RC ) ! *************************************************************************** ! ! Round ISSM output to single precision and reset on the C++ side - ! This ensures the same result as reading in (single-precision) restarts + ! This ensures the same result as reading in (single-precision) restarts ! *************************************************************************** ! - ISSM_OUTPUTS = real(ISSM_OUTPUTS, kind=sp) - call ESMF_VMBarrier(vm, _RC) - call InputFromRestarts(c_loc(ISSM_OUTPUTS)) + ISSM_OUTPUTS = real(ISSM_OUTPUTS, kind=sp) call ESMF_VMBarrier(vm, _RC) + call InputFromRestarts(c_loc(ISSM_OUTPUTS)) + call ESMF_VMBarrier(vm, _RC) + + end if - end if - ! barrier to ensure regridding completes before any deallocates call ESMF_VMBarrier(vm,_RC) - + ! deallocates if(associated(ICESURF_MESH)) deallocate(ICESURF_MESH) if(associated(ICETHICK_MESH)) deallocate(ICETHICK_MESH) @@ -1243,8 +1243,8 @@ subroutine RUN ( GC, IMPORT, EXPORT, CLOCK, RC ) if(associated(ICEVX_MESH)) deallocate(ICEVX_MESH) if(associated(ICEVY_MESH)) deallocate(ICEVY_MESH) if(associated(IMLS_MESH)) deallocate(IMLS_MESH) - if(associated(OMLS_MESH)) deallocate(OMLS_MESH) - if(associated(ICESMB_MESH)) deallocate(ICESMB_MESH) + if(associated(OMLS_MESH)) deallocate(OMLS_MESH) + if(associated(ICESMB_MESH)) deallocate(ICESMB_MESH) if(associated(ISSM_OUTPUTS)) deallocate(ISSM_OUTPUTS) if(associated(ICESMB_TILE)) deallocate(ICESMB_TILE) if(associated(ICESURF_TILE)) deallocate(ICESURF_TILE) @@ -1253,32 +1253,32 @@ subroutine RUN ( GC, IMPORT, EXPORT, CLOCK, RC ) call MAPL_TimerOff(MAPL,"RUN" ) call MAPL_TimerOff(MAPL,"TOTAL") - + _RETURN(_SUCCESS) end subroutine RUN !BOP - -!IROUTINE: Finalize -- Finalize method for ISSM + +!IROUTINE: Finalize -- Finalize method for ISSM !INTERFACE: subroutine Finalize ( GC, IMPORT, EXPORT, CLOCK, RC ) !ARGUMENTS: - type(ESMF_GridComp), intent(INOUT) :: GC ! Gridded component + type(ESMF_GridComp), intent(INOUT) :: GC ! Gridded component type(ESMF_State), intent(INOUT) :: IMPORT ! Import state type(ESMF_State), intent(INOUT) :: EXPORT ! Export state type(ESMF_Clock), intent(INOUT) :: CLOCK ! The supervisor clock integer, optional, intent( OUT) :: RC ! Error code: - + !EOP - type(MAPL_MetaComp), pointer :: MAPL + type(MAPL_MetaComp), pointer :: MAPL type(ESMF_State) :: INTERNAL - + ! ErrLog Variables character(len=ESMF_MAXSTR) :: IAm integer :: STATUS @@ -1286,14 +1286,14 @@ subroutine Finalize ( GC, IMPORT, EXPORT, CLOCK, RC ) type(T_ISSM_TILE_STATE), pointer :: issm_tile_state - type(ISSM_TILE_WRAP) :: issm_tile_wrap + type(T_ISSM_TILE_WRAP) :: issm_tile_wrap real, pointer, dimension(:) :: ISSM_NSTEPS ! Get the target components name and set-up traceback handle. ! ----------------------------------------------------------- Iam = "Finalize" call ESMF_GridCompGet( GC, NAME=COMP_NAME, _RC ) - + Iam = trim(comp_name) // Iam call MAPL_GetObjectFromGC(GC, MAPL, STATUS) @@ -1316,7 +1316,7 @@ subroutine Finalize ( GC, IMPORT, EXPORT, CLOCK, RC ) ! Generic Finalize ! ------------------ call MAPL_GenericFinalize( GC, IMPORT, EXPORT, CLOCK, _RC ) - + ! All Done ! ------------------ @@ -1339,37 +1339,37 @@ subroutine mesh_to_tile(VAR_MESH,VAR_TILE,RC) integer :: num_owned_nodes integer :: NT integer :: STATUS - + num_owned_nodes = size(internal_state%owned_idx) call MAPL_LocStreamGet(internal_state%locstream, NT_LOCAL=NT, _RC) - + allocate(VAR_MESH_OWN(num_owned_nodes)) VAR_MESH_OWN = VAR_MESH(internal_state%owned_idx) - ! allocate tiles + ! allocate tiles if (.not.associated(VAR_TILE)) then allocate(VAR_TILE(NT)) VAR_TILE = MAPL_Undef end if ! create source field: field on mesh nodes - srcField = ESMF_FieldCreate(mesh=internal_state%mesh,farrayPtr=VAR_MESH_OWN,meshloc=ESMF_MESHLOC_NODE, & + srcField = ESMF_FieldCreate(mesh=internal_state%mesh,farrayPtr=VAR_MESH_OWN,meshloc=ESMF_MESHLOC_NODE, & datacopyflag=ESMF_DATACOPY_VALUE,_RC) - + ! create destination field: field on grid dstField = ESMF_FieldCreate(grid=internal_state%grid,typekind=ESMF_TYPEKIND_R4,_RC) - + ! regrid field from mesh to grid call ESMF_FieldRegrid(srcField, dstField, internal_state%routehandle_m2g, _RC) ! get pointer to field on grid call ESMF_FieldGet(dstField,farrayPtr=VAR_GRID,_RC) - ! transform from grid to tiles + ! transform from grid to tiles call MAPL_LocStreamTransform(internal_state%locstream,VAR_TILE,VAR_GRID, _RC) - + ! destroy regridding fields so they can be reused call ESMF_FieldDestroy(srcField,_RC) call ESMF_FieldDestroy(dstField,_RC) @@ -1387,41 +1387,41 @@ subroutine tile_to_mesh(VAR_TILE,VAR_MESH,RC) ! local variables: real, pointer, dimension(:,:) :: VAR_GRID => null() ! var on attached grid - real(dp), pointer, dimension(:) :: MESH_PTR ! pointer for ESMF_FieldGet + real(dp), pointer, dimension(:) :: MESH_PTR ! pointer for ESMF_FieldGet type(ESMF_Field) :: srcField type(ESMF_Field) :: dstField type(ESMF_Array) :: meshArray integer :: num_owned_nodes integer :: num_nodes - integer :: IM, JM, local_dims(3) + integer :: IM, JM, local_dims(3) integer :: STATUS ! get number of nodes call ESMF_MeshGet(internal_state%mesh,nodeCount=num_nodes,numOwnedNodes=num_owned_nodes,_RC) - + ! get grid dimensions call MAPL_GridGet(internal_state%grid, localCellCountPerDim=local_dims, _RC) IM = local_dims(1) JM = local_dims(2) - ! allocate pointer on grid for regridding + ! allocate pointer on grid for regridding allocate(VAR_GRID(IM,JM)) - + ! transform from tile to grid - ! NOTE: we use the "transpose" option with MAPL_LocStreamTransformG2T + ! NOTE: we use the "transpose" option with MAPL_LocStreamTransformG2T ! (rather than MAPL_LocStreamTransformT2G) because the "default" value is zero ! (rather than MAPL_UNDEF, which leads to errors when regridding onto mesh) call MAPL_LocStreamTransform(internal_state%locstream, VAR_TILE, VAR_GRID, TRANSPOSE=.true., _RC) - + ! create source field on grid srcField = ESMF_FieldCreate(grid=internal_state%grid,farrayPtr=VAR_GRID, datacopyflag=ESMF_DATACOPY_VALUE,_RC) - + ! create destination field on mesh elements meshArray=ESMF_ArrayCreate(internal_state%nodalDistgrid,typekind=ESMF_TYPEKIND_R8,haloSeqIndexList=internal_state%halolist,_RC) - + ! create field on ISSM mesh dstField=ESMF_FieldCreate(internal_state%mesh, array=meshArray, meshLoc=ESMF_MESHLOC_NODE, _RC) - + ! regrid from grid to mesh call ESMF_FieldRegrid(srcField, dstField, internal_state%routehandle_g2m, _RC) @@ -1434,7 +1434,7 @@ subroutine tile_to_mesh(VAR_TILE,VAR_MESH,RC) ! copy values into VAR_MESH VAR_MESH(internal_state%owned_idx) = MESH_PTR(1:num_owned_nodes) ! owned nodes VAR_MESH(internal_state%halo_idx) = MESH_PTR(num_owned_nodes+1:num_nodes) ! halo nodes - + ! destroy fields and arrays so they can be reused deallocate(VAR_GRID) call ESMF_FieldDestroy(srcField,_RC) @@ -1443,6 +1443,6 @@ subroutine tile_to_mesh(VAR_TILE,VAR_MESH,RC) _RETURN(_SUCCESS) - end subroutine tile_to_mesh + end subroutine tile_to_mesh end module GEOS_IssmGridCompMod From eb294db7c9e9ffb5b993c721b2293a20a547cf4c Mon Sep 17 00:00:00 2001 From: William Putman Date: Tue, 14 Jul 2026 08:44:51 -0400 Subject: [PATCH 36/40] protections on pgfr and tuning of WBF at coarse res --- .../GEOSmoist_GridComp/gfdl_mp.F90 | 50 +++++++++++++++---- 1 file changed, 41 insertions(+), 9 deletions(-) diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/gfdl_mp.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/gfdl_mp.F90 index cc9786eb50..51dc6d2385 100644 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/gfdl_mp.F90 +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/gfdl_mp.F90 @@ -412,7 +412,7 @@ module gfdl_mp_mod real :: tau_smlt = 900.0 ! snow melting time scale (s) real :: tau_gmlt = 1200.0 ! graupel melting time scale (s) ! subgridz timescales - real :: tau_wbf = 300.0 ! Wegener Bergeron Findeisen time scale (s) + real :: tau_wbf = 1200.0 ! Wegener Bergeron Findeisen time scale (s) real :: ccn_o = 90.0 ! ccn over ocean (1/cm^3) real :: ccn_l = 270.0 ! ccn over land (1/cm^3) @@ -432,7 +432,7 @@ module gfdl_mp_mod real :: ql0_max = 2.0e-3 ! maximum cloud water value (autoconverted to rain) (kg/kg) - real :: psaut_qi_crt = 2.0e-4 ! cloud ice to snow autoconversion threshold (kg/m^3) + real :: psaut_qi_crt = 1.0e-4 ! cloud ice to snow autoconversion threshold (kg/m^3) real :: pwbf_qi_crt = 0.8e-4 ! WBF liquid to ice freezing threshold (kg/m^3) real :: pgaut_qs_crt = 0.6e-3 ! snow to graupel autoconversion threshold (0.6e-3 in Purdue Lin scheme) (kg/m^3) @@ -4249,8 +4249,16 @@ subroutine psacr_pgfr (ks, ke, dts, qa, qv, ql, qr, qi, qs, qg, dp, tz, cvm, te8 acc (3), acc (4), den (k)) endif - pgfr = dts * cgfr (1) / den (k) * (exp (- cgfr (2) * tc) - 1.) * & - exp ((6 + mur) / (mur + 3) * log (6 * qr (k) * den (k))) + ! Homogeneous freezing threshold (e.g., -40 C) + if (tc .lt. -40.0) then + ! Colder than -40C: ALL liquid rain freezes instantaneously. + ! We set pgfr to consume all available qr. + pgfr = qr(k) + else + ! Warmer than -40C: Calculate probabilistic freezing normally. + pgfr = dts * cgfr (1) / den (k) * (exp (- cgfr (2) * tc) - 1.) * & + exp ((6 + mur) / (mur + 3) * log (6 * qr (k) * den (k))) + endif ! --- Apply Mass and Thermal Limits --- sink = psacr + pgfr @@ -4918,8 +4926,9 @@ subroutine pwbf (ks, ke, dts, qa, qv, ql, qr, qi, qs, qg, dp, tz, cvm, te8, den, real :: tc, tin, sink, dqdt, qsw, qsi, qim, tmp, fac_wbf + real :: snow_boost_mult real :: tau_wbf_eff - real, parameter :: wbf_coarse_mult = 9.0 ! How much slower WBF is at 50km vs 2km + real, parameter :: wbf_coarse_mult = 10.0 ! How much slower WBF is at 50km vs 2km if (.not. do_wbf) return @@ -4949,9 +4958,24 @@ subroutine pwbf (ks, ke, dts, qa, qv, ql, qr, qi, qs, qg, dp, tz, cvm, te8, den, (qi (k) .gt. qcmin .or. tc .gt. 15.0) .and. & qv (k) .gt. qsi) then - sink = min (fac_wbf * ql (k), tc / icpk (k)) - qim = pwbf_qi_crt / den (k) - tmp = min (sink, dim (qim, qi (k))) + ! 1. Homogeneous Freezing Limit (-40 C) + if (tc .ge. 40.0) then + sink = ql(k) + tmp = 0.0 ! All frozen liquid instantly becomes snow + else + ! Normal WBF probabilistic freezing + sink = min (fac_wbf * ql (k), tc / icpk (k)) + + ! 2. Temperature-Dependent Snow Boost + ! Scales from 1.0 (at 0 C) down to 0.0 (at -40 C) + ! As tc gets larger (colder), the multiplier shrinks, + ! reducing qim and forcing more mass to spill over into qs. + snow_boost_mult = max(0.0, 1.0 - (tc / 40.0)) + + qim = (pwbf_qi_crt * snow_boost_mult) / den (k) + tmp = min (sink, dim (qim, qi (k))) + endif + mppfw = mppfw + sink * dp (k) * convt call update_qt (qa (k), qv (k), ql (k), qr (k), qi (k), qs (k), qg (k), & @@ -5014,7 +5038,15 @@ subroutine pbigg (ks, ke, dts, qa, qv, ql, qr, qi, qs, qg, dp, tz, cvm, te8, den ccn (k) = ccn (k) / den (k) endif - sink = 100. / (rhow * ccn (k)) * dts * (exp (0.66 * tc) - 1.) * ql (k) ** 2 + ! Homogeneous freezing limit applied here + if (tc .ge. 40.0) then + ! Colder than -40C: ALL cloud liquid freezes instantaneously. + sink = ql(k) + else + ! Warmer than -40C: Calculate probabilistic Bigg freezing normally + sink = 100. / (rhow * ccn (k)) * dts * (exp (0.66 * tc) - 1.) * ql (k) ** 2 + endif + sink = min (ql (k), sink, tc / icpk (k)) mppfw = mppfw + sink * dp (k) * convt From d53b6e75ae07f2c36d4ca3dfb184b45f8ce86ff7 Mon Sep 17 00:00:00 2001 From: William Putman Date: Tue, 14 Jul 2026 08:45:40 -0400 Subject: [PATCH 37/40] tuning of QL/QI fractions for MODIS polynomials --- .../GEOSmoist_GridComp/Process_Library.F90 | 73 ++++++++++--------- 1 file changed, 39 insertions(+), 34 deletions(-) diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/Process_Library.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/Process_Library.F90 index 7b0d60c514..016a5f5256 100644 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/Process_Library.F90 +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/Process_Library.F90 @@ -47,31 +47,45 @@ module GEOSmoist_Process_Library integer :: ICE_FRACTION_POLYNOMIAL = 3 ! ICE_FRACTION constants - ! In anvil/convective clouds - real, parameter :: aT_ICE_ALL = 243.66 - real, parameter :: aT_ICE_MAX = 265.66 - real, parameter :: aT_ICE_PWR = 2.0 - ! Over Land Ice SRF_TYPE == 4 (Antarctica / Greenland) - real, parameter :: liT_ICE_ALL = 233.16 - real, parameter :: liT_ICE_MAX = 258.16 - real, parameter :: liT_ICE_PWR = 6.0 - ! Over Ice SRF_TYPE == 3 (Arctic Sea Ice) - ! OLD: 236.16 / 261.16 / 4.0 - real, parameter :: iT_ICE_ALL = 236.16 - real, parameter :: iT_ICE_MAX = 261.16 - real, parameter :: iT_ICE_PWR = 4.0 - ! Over Snow SRF_TYPE = 2 (Winter high-latitude land) - real, parameter :: sT_ICE_ALL = 235.16 - real, parameter :: sT_ICE_MAX = 260.16 - real, parameter :: sT_ICE_PWR = 6.0 - ! Over Land SRF_TYPE = 1 - real, parameter :: lT_ICE_ALL = 240.16 - real, parameter :: lT_ICE_MAX = 262.16 - real, parameter :: lT_ICE_PWR = 2.0 - ! Over Oceans SRF_TYPE = 0 - real, parameter :: oT_ICE_ALL = 238.16 - real, parameter :: oT_ICE_MAX = 263.16 - real, parameter :: oT_ICE_PWR = 3.0 + ! ========================================================================= + ! FINAL REVISED SURFACE-DEPENDENT CLOUD PHASE CONSTANTS (Bias-Corrected) + ! ========================================================================= + ! 1. Anvil / Convective Clouds (Deep updrafts, clean high-altitude cores) + ! Observations: High updraft velocity dynamically preserves liquid down to deep + ! temperatures. Freezing drops off exponentially close to homogeneous limit. + real, parameter :: aT_ICE_ALL = 233.16 ! Strict homogeneous limit (-40C) + real, parameter :: aT_ICE_MAX = 268.16 ! Latent heat maintains liquid until -5C + real, parameter :: aT_ICE_PWR = 4.5 ! Asymmetric S-curve to shield liquid peak + ! 2. Land Ice (Antarctica / Greenland) + ! Bias Fix: Widens mixed-phase window and raises PWR to fix the severe polar + ! downward LW deficit (-25 W/m²) and clear lower troposphere cold pools. + real, parameter :: liT_ICE_ALL = 234.16 ! Deep absolute freeze floor lowered to -39C + real, parameter :: liT_ICE_MAX = 268.15 ! Delays plateau glaciation onset to -5C + real, parameter :: liT_ICE_PWR = 4.2 ! Highly emissive summer liquid water shield + ! 3. Sea Ice (Arctic / Southern Ocean Pack Ice) + ! Bias Fix: Expands liquid window to restore thin supercooled liquid cloud tops. + ! Eliminates the MAM positive SW surface heating and matches vertical ERA5 QL mass. + real, parameter :: iT_ICE_ALL = 235.16 ! Lowers homogeneous floor to -38C + real, parameter :: iT_ICE_MAX = 271.15 ! Maintains warm liquid threshold near -2C + real, parameter :: iT_ICE_PWR = 4.5 ! High exponent shifts excess QI mass back to QL + ! 4. Snow Surface (High-latitude winter land) + ! Bias Fix: Shuts down spring continental shortwave overestimation and boundary + ! layer cold biases across snow-covered Siberia and northern boreal zones. + real, parameter :: sT_ICE_ALL = 236.16 ! Total freeze-out pushed down to -37C + real, parameter :: sT_ICE_MAX = 268.15 ! Delays land ice crystal production to -5C + real, parameter :: sT_ICE_PWR = 4.0 ! Stronger power curve guards spring liquid path + ! 5. Land (Ice-free, ice-nucleating aerosol rich) + ! Observations: Mineral and biological dust act as potent heterogeneous INPs. + ! Mixed-phase clouds glaciate rapidly and uniformly throughout the -10C to -25C zone. + real, parameter :: lT_ICE_ALL = 241.16 ! Dust forces total glaciation early at -32C + real, parameter :: lT_ICE_MAX = 266.16 ! Active INPs seed ice starting at -7C + real, parameter :: lT_ICE_PWR = 1.5 ! Near-linear transition curve clears liquid pooling + ! 6. Oceans (Open water, mid-to-high latitude marine boundary layers) + ! Bias Fix: Synchronized with Sea Ice limits to maintain high open-water marine + ! cloud optical depths, mitigating mid-latitude high-altitude liquid biases. + real, parameter :: oT_ICE_ALL = 235.16 ! Drops to 100% ice near -38C + real, parameter :: oT_ICE_MAX = 271.15 ! Highly liquid-dominated near 0C to -2C + real, parameter :: oT_ICE_PWR = 4.5 ! High power protects high marine LWP peak ! Jason constants ! In anvil/convective clouds @@ -3010,15 +3024,6 @@ subroutine Bergeron_Partition ( & if (q_tot_mass > 0.0) f_mass_ice = q_tot_ice / q_tot_mass n_ice_active = (1.0 - f_mass_ice) * n_ice - ! Handle completely glaciated or completely liquid regimes immediately - if (t_env >= iT_ICE_MAX) then ! Pure liquid cloud - f_ice = 0.0 - return - elseif (t_env <= iT_ICE_ALL) then ! Pure ice cloud - f_ice = 1.0 - return - end if - ! ======================================================================= ! PHASE 2: Mixed-Phase Regime & Deposition Physics ! Calculate how fast water vapor deposits onto existing ice crystals. From 190c862dd16420c1eb9a4ab6a5d4b7a9279c7e52 Mon Sep 17 00:00:00 2001 From: William Putman Date: Tue, 14 Jul 2026 08:47:08 -0400 Subject: [PATCH 38/40] reset NCAR_ET BKG GWD to constant 1.0 efficiency, and disabled katabatic winds forcing for now --- .../GEOSgwd_GridComp/GEOS_GwdGridComp.F90 | 6 +++--- .../GEOSgwd_GridComp/ncar_gwd/gw_convect.F90 | 9 ++++----- 2 files changed, 7 insertions(+), 8 deletions(-) diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSgwd_GridComp/GEOS_GwdGridComp.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSgwd_GridComp/GEOS_GwdGridComp.F90 index 990f6a49de..adf46ec6ff 100644 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSgwd_GridComp/GEOS_GwdGridComp.F90 +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSgwd_GridComp/GEOS_GwdGridComp.F90 @@ -380,16 +380,16 @@ subroutine Initialize ( GC, IMPORT, EXPORT, CLOCK, RC ) call MAPL_GetResource( MAPL, NCAR_BKG_GW_DC, Label="NCAR_BKG_GW_DC:", default=2.5, _RC) call MAPL_GetResource( MAPL, NCAR_BKG_FCRIT2, Label="NCAR_BKG_FCRIT2:", default=1.0, _RC) call MAPL_GetResource( MAPL, NCAR_BKG_WAVELENGTH, Label="NCAR_BKG_WAVELENGTH:", default=1.e5, _RC) - call MAPL_GetResource( MAPL, NCAR_TR_EFF, Label="NCAR_TR_EFF:", default=0.625, _RC) + call MAPL_GetResource( MAPL, NCAR_TR_EFF, Label="NCAR_TR_EFF:", default=1.0, _RC) call MAPL_GetResource( MAPL, NCAR_ET_EFF, Label="NCAR_ET_EFF:", default=1.0, _RC) call MAPL_GetResource( MAPL, NCAR_ET_USE_DQCDT, Label="NCAR_ET_USE_DQCDT:", default=.TRUE., _RC) - call MAPL_GetResource( MAPL, NCAR_ET_USE_SPEED, Label="NCAR_ET_USE_SPEED:", default=.TRUE., _RC) + call MAPL_GetResource( MAPL, NCAR_ET_USE_SPEED, Label="NCAR_ET_USE_SPEED:", default=.FALSE.,_RC) ! 1. Default to classic rigid latitude tuning NCAR_ET_TAUBGND = 6.4 ! 2. Set baselines for independent runs - if (NCAR_ET_USE_DQCDT .or. NCAR_ET_USE_SPEED) NCAR_ET_TAUBGND = 6.75 + if (NCAR_ET_USE_DQCDT .or. NCAR_ET_USE_SPEED) NCAR_ET_TAUBGND = 10.0 call MAPL_GetResource( MAPL, NCAR_ET_TAUBGND, Label="NCAR_ET_TAUBGND:", default=NCAR_ET_TAUBGND, _RC) call MAPL_GetResource( MAPL, NCAR_BKG_TNDMAX, Label="NCAR_BKG_TNDMAX:", default=250.0, _RC) diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSgwd_GridComp/ncar_gwd/gw_convect.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSgwd_GridComp/ncar_gwd/gw_convect.F90 index 46e4360ac6..322406d5ed 100644 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSgwd_GridComp/ncar_gwd/gw_convect.F90 +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSgwd_GridComp/ncar_gwd/gw_convect.F90 @@ -185,11 +185,10 @@ subroutine gw_beres_init (file_name, band, desc, pgwv, gw_dc, fcrit2, wavelength ! Determine the background stress at c=0 if (desc%et_bkg_dqcdt_forcing .or. desc%et_bkg_speed_forcing) then flat_gw = 0.05 ! weak background forcing - ! Scale the extratropical stress to account for changes in tropical efficiency - ! (e.g., if tau_et=8.0, eff_et=1.0, eff_tr=0.625, tau_et_scaled becomes 12.8) - desc%taubck(i,:) = tau_et*(eff_et/eff_tr)*0.001*flat_gw*cw - ! efficiency function (now constant based on QBO tuning) - desc%effbck(i) = eff_tr + desc%taubck(i,:) = tau_et*0.001*flat_gw*cw + ! efficiency function + desc%effbck(i) = eff_tr*cos(lats(i))**2 + & + eff_et*sin(lats(i))**2 else ! Include dependence on latitude: latdeg = lats(i)*rad2deg From c56562df0909087da06ab542d7e59ec6096efc4f Mon Sep 17 00:00:00 2001 From: Matthew Thompson Date: Tue, 14 Jul 2026 12:13:43 -0400 Subject: [PATCH 39/40] Add WSPD_STABLE300M export to GEOS_DatmoDynGridComp Port the WSPD_STABLE300M diagnostic from FVdycoreCubed_GridComp PR #411 to the datmodyn component. This export provides the maximum wind speed in the lowest 300m of the atmosphere under stable, cold surface conditions (katabatic wind detection). The diagnostic is only nonzero when: - Surface air temperature is at or below freezing (MAPL_TICE) - A temperature inversion exists somewhere in the lowest 300m AGL --- .../GEOS_DatmoDynGridComp.F90 | 52 +++++++++++++++++-- 1 file changed, 48 insertions(+), 4 deletions(-) diff --git a/GEOSagcm_GridComp/GEOSsuperdyn_GridComp/GEOSdatmodyn_GridComp/GEOS_DatmoDynGridComp.F90 b/GEOSagcm_GridComp/GEOSsuperdyn_GridComp/GEOSdatmodyn_GridComp/GEOS_DatmoDynGridComp.F90 index 0c71b5e69e..061f87ab6d 100644 --- a/GEOSagcm_GridComp/GEOSsuperdyn_GridComp/GEOSdatmodyn_GridComp/GEOS_DatmoDynGridComp.F90 +++ b/GEOSagcm_GridComp/GEOSsuperdyn_GridComp/GEOSdatmodyn_GridComp/GEOS_DatmoDynGridComp.F90 @@ -541,7 +541,15 @@ subroutine SetServices ( GC, RC ) UNITS ='m s-1', & DIMS = MAPL_DimsHorzOnly, & VLOCATION = MAPL_VLocationNone, & - __RC__ ) + __RC__ ) + + call MAPL_AddExportSpec(GC, & + SHORT_NAME='WSPD_STABLE300M', & + LONG_NAME ='max_wind_speed_in_stable_cold_surface_layer', & + UNITS ='m s-1', & + DIMS = MAPL_DimsHorzOnly, & + VLOCATION = MAPL_VLocationNone, & + __RC__ ) call MAPL_AddExportSpec(GC, & @@ -1185,6 +1193,7 @@ subroutine RUN ( GC, IMPORT, EXPORT, CLOCK, RC ) ! else: use interactive winds integer :: IM,JM,LM,L,K,NQ,ii,NOT1,COLDSTART,Ktrc,iip1,itr,ntracs + logical :: is_stable real, pointer, dimension(:,:,:) :: PLE,PLEOUT real, pointer, dimension(:,:,:) :: ZLE @@ -1212,6 +1221,7 @@ subroutine RUN ( GC, IMPORT, EXPORT, CLOCK, RC ) real, pointer, dimension(:,:) :: DZ real, pointer, dimension(:,:) :: TA real, pointer, dimension(:,:) :: SPEED + real, pointer, dimension(:,:) :: WSPD_STABLE300M real, pointer, dimension(:,:) :: QA real, pointer, dimension(:,:) :: US real, pointer, dimension(:,:) :: VS @@ -2030,7 +2040,7 @@ subroutine RUN ( GC, IMPORT, EXPORT, CLOCK, RC ) ! Forcing based on Phase 2 of CGILS intercomparison. See Blossey et al. (2016) if ( CFMIP3 ) then - ZLO = 0.5*(ZLE(:,:,0:LM-1)+ZLE(:,:,1:LM)) + ZLO = 0.5*(ZLE(:,:,0:LM-1)+ZLE(:,:,1:LM)) if (CFCSE .eq. 12) then zrel=1200. @@ -2124,10 +2134,44 @@ subroutine RUN ( GC, IMPORT, EXPORT, CLOCK, RC ) if (associated(DQVDTDYN)) DQVDTDYN = DQVDTDYN - CFMIPRLX * ( Q - QOBS ) end if - call MAPL_GetPointer(EXPORT, PREF, 'PREF' , & + call MAPL_GetPointer(EXPORT, WSPD_STABLE300M, 'WSPD_STABLE300M', & ALLOC=.true., __RC__) + if (associated(WSPD_STABLE300M)) then + WSPD_STABLE300M = 0.0 + do J = 1, JM + do I = 1, IM + ! 1. Check if surface air is freezing (T at lowest model level) + if (T(I,J,LM) <= MAPL_TICE) then + ! Assume no inversion until proven otherwise + is_stable = .false. + ! Start max wind tracking with the lowest model level + WSPD_STABLE300M(I,J) = SQRT(U(I,J,LM)**2 + V(I,J,LM)**2) + ! 2. Scan the lowest 300m AGL (ZLE(I,J,LM) is the surface height) + do K = LM-1, 1, -1 + ! Height AGL at mid-level using ZLO (0.5*(ZLE(K-1)+ZLE(K))) + if ( (ZLO(I,J,K) - ZLE(I,J,LM)) <= 300.0 ) then + ! Track maximum wind speed + WSPD_STABLE300M(I,J) = MAX(WSPD_STABLE300M(I,J), & + SQRT(U(I,J,K)**2 + V(I,J,K)**2)) + ! 3. Check for temperature inversion anywhere in the 300m layer + if (T(I,J,K) > T(I,J,LM)) then + is_stable = .true. + endif + else + exit ! Reached top of 300m layer + endif + end do + ! 4. If no inversion found, not a katabatic zone; zero out wind speed + if (.not. is_stable) then + WSPD_STABLE300M(I,J) = 0.0 + endif + endif + end do + end do + end if - + call MAPL_GetPointer(EXPORT, PREF, 'PREF' , & + ALLOC=.true., __RC__) PREF = PREF_IN VARFLT = 0. From e7abd0738780a2f4c75017c3e296f9c8c06de654 Mon Sep 17 00:00:00 2001 From: Scott Rabenhorst Date: Wed, 15 Jul 2026 08:46:09 -0400 Subject: [PATCH 40/40] fix incorrect variable name to JaT_ICE_PWR --- .../GEOSphysics_GridComp/GEOSmoist_GridComp/Process_Library.F90 | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/Process_Library.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/Process_Library.F90 index 016a5f5256..41740f52e3 100644 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/Process_Library.F90 +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/Process_Library.F90 @@ -670,7 +670,7 @@ function ICE_FRACTION_SC (TEMP,CNV_FRACTION,SRF_TYPE) RESULT(ICEFRCT) end if ICEFRCT_C = MIN(ICEFRCT_C,1.00) ICEFRCT_C = MAX(ICEFRCT_C,0.00) - ICEFRCT_C = ICEFRCT_C**aT_ICE_PWR + ICEFRCT_C = ICEFRCT_C**JaT_ICE_PWR ! ------------------------------------------------------------------ ! 2. Grid-Scale / Mesh Cloud Ice Fraction (ICEFRCT_M)