├── docs ├── doc_source │ ├── PGF.pdf │ ├── CDgrid.pdf │ ├── fv3logo.png │ ├── GFDLLogo.png │ ├── KESpectra.pdf │ ├── FV3flowchart.pdf │ ├── gridmetrics1D.pdf │ ├── phasespeedbad.pdf │ ├── phasespeedgood.pdf │ ├── twowayschematic.pdf │ ├── gridmetricsCoordinates.pdf │ ├── gridmetricsReconstructions.pdf │ └── README ├── fv3_technical_2021.pdf ├── HOWTO_tracer-2024.11.md └── examples │ └── README.md ├── model ├── README_nh_core ├── fv_fill.F90 ├── fast_phys.F90 ├── nh_core.F90 ├── a2b_edge.F90 └── fv_thermodynamics.F90 ├── .github ├── .parallelworks │ ├── README.md │ ├── checkout.sh │ ├── compile.sh │ └── run_test.sh ├── ISSUE_TEMPLATE │ ├── support_request.md │ ├── feature_request.md │ └── bug_report.md ├── workflows │ ├── daily_cleanup_parallelworks.yml │ └── SHiELD_parallelworks_intel.yml └── pull_request_template.md ├── driver ├── SHiELD │ └── include │ │ ├── atmosphere_r4.fh │ │ ├── atmosphere_r8.fh │ │ └── atmosphere.inc └── solo │ ├── qs_tables.F90 │ ├── ocean_rough.F90 │ └── hswf.F90 ├── tools ├── external_sst.F90 ├── fv_diagnostics.h ├── w_forcing.F90 ├── fv_timing.F90 ├── statistics.F90 ├── external_aero.F90 └── sim_nc_mod.F90 ├── README.md ├── CODE_STYLE.md ├── CONTRIBUTING_GUIDE.md ├── LICENSE.md └── RELEASE.md /docs/doc_source/PGF.pdf: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/NOAA-GFDL/GFDL_atmos_cubed_sphere/HEAD/docs/doc_source/PGF.pdf -------------------------------------------------------------------------------- /docs/doc_source/CDgrid.pdf: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/NOAA-GFDL/GFDL_atmos_cubed_sphere/HEAD/docs/doc_source/CDgrid.pdf -------------------------------------------------------------------------------- /docs/doc_source/fv3logo.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/NOAA-GFDL/GFDL_atmos_cubed_sphere/HEAD/docs/doc_source/fv3logo.png -------------------------------------------------------------------------------- /docs/fv3_technical_2021.pdf: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/NOAA-GFDL/GFDL_atmos_cubed_sphere/HEAD/docs/fv3_technical_2021.pdf -------------------------------------------------------------------------------- /docs/doc_source/GFDLLogo.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/NOAA-GFDL/GFDL_atmos_cubed_sphere/HEAD/docs/doc_source/GFDLLogo.png -------------------------------------------------------------------------------- /docs/doc_source/KESpectra.pdf: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/NOAA-GFDL/GFDL_atmos_cubed_sphere/HEAD/docs/doc_source/KESpectra.pdf -------------------------------------------------------------------------------- /docs/doc_source/FV3flowchart.pdf: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/NOAA-GFDL/GFDL_atmos_cubed_sphere/HEAD/docs/doc_source/FV3flowchart.pdf -------------------------------------------------------------------------------- /docs/doc_source/gridmetrics1D.pdf: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/NOAA-GFDL/GFDL_atmos_cubed_sphere/HEAD/docs/doc_source/gridmetrics1D.pdf -------------------------------------------------------------------------------- /docs/doc_source/phasespeedbad.pdf: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/NOAA-GFDL/GFDL_atmos_cubed_sphere/HEAD/docs/doc_source/phasespeedbad.pdf -------------------------------------------------------------------------------- /docs/doc_source/phasespeedgood.pdf: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/NOAA-GFDL/GFDL_atmos_cubed_sphere/HEAD/docs/doc_source/phasespeedgood.pdf -------------------------------------------------------------------------------- /docs/doc_source/twowayschematic.pdf: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/NOAA-GFDL/GFDL_atmos_cubed_sphere/HEAD/docs/doc_source/twowayschematic.pdf -------------------------------------------------------------------------------- /docs/doc_source/gridmetricsCoordinates.pdf: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/NOAA-GFDL/GFDL_atmos_cubed_sphere/HEAD/docs/doc_source/gridmetricsCoordinates.pdf -------------------------------------------------------------------------------- /docs/doc_source/gridmetricsReconstructions.pdf: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/NOAA-GFDL/GFDL_atmos_cubed_sphere/HEAD/docs/doc_source/gridmetricsReconstructions.pdf -------------------------------------------------------------------------------- /docs/doc_source/README: -------------------------------------------------------------------------------- 1 | These are LaTeX and BibTeX source files and associated graphics files. They should not require any special LaTeX packages not present in current TeX distributions. 2 | -------------------------------------------------------------------------------- /model/README_nh_core: -------------------------------------------------------------------------------- 1 | The standard nh_core version has been temporarily separated into two files to work around an Intel bug in which "fast transcendentals" do not give run-to-run reproducibility for one subroutine inside of the non-hydrostatic extensions. 2 | -------------------------------------------------------------------------------- /.github/.parallelworks/README.md: -------------------------------------------------------------------------------- 1 | # .parallelworks Directory 2 | 3 | The .parallelworks directory stores the CI scripts that reside on Parallelworks 4 | These scripts are executed via the GitHub Actions Workflows in .github/workflows 5 | 6 | On Parallelworks these scripts are installed at: /contrib/fv3/GFDL_atmos_cubed_sphere_CI 7 | -------------------------------------------------------------------------------- /.github/ISSUE_TEMPLATE/support_request.md: -------------------------------------------------------------------------------- 1 | --- 2 | name: Support request 3 | about: Request for help 4 | title: '' 5 | labels: 'question' 6 | assignees: '' 7 | --- 8 | 9 | **Is your question related to a problem? Please describe.** 10 | A clear and concise description of what the problem is. 11 | 12 | **Describe what you have tried** 13 | A clear and concise description of what steps you have taken. Include command 14 | lines, and any messages from the command. 15 | -------------------------------------------------------------------------------- /driver/SHiELD/include/atmosphere_r4.fh: -------------------------------------------------------------------------------- 1 | #undef ATMOSPHERE_KIND_ 2 | #define ATMOSPHERE_KIND_ r4_kind 3 | 4 | #undef ATMOSPHERE_GRID_BDRY_ 5 | #define ATMOSPHERE_GRID_BDRY_ atmosphere_grid_bdry_r4 6 | 7 | #undef ATMOSPHERE_PREF_ 8 | #define ATMOSPHERE_PREF_ atmosphere_pref_r4 9 | 10 | #undef ATMOSPHERE_CELL_AREA_ 11 | #define ATMOSPHERE_CELL_AREA_ atmosphere_cell_area_r4 12 | 13 | #undef GET_BOTTOM_MASS_ 14 | #define GET_BOTTOM_MASS_ get_bottom_mass_r4 15 | 16 | #undef GET_BOTTOM_WIND_ 17 | #define GET_BOTTOM_WIND_ get_bottom_wind_r4 18 | 19 | #undef GET_STOCK_PE_ 20 | #define GET_STOCK_PE_ get_stock_pe_r4 21 | 22 | #include "atmosphere.inc" 23 | -------------------------------------------------------------------------------- /driver/SHiELD/include/atmosphere_r8.fh: -------------------------------------------------------------------------------- 1 | #undef ATMOSPHERE_KIND_ 2 | #define ATMOSPHERE_KIND_ r8_kind 3 | 4 | #undef ATMOSPHERE_GRID_BDRY_ 5 | #define ATMOSPHERE_GRID_BDRY_ atmosphere_grid_bdry_r8 6 | 7 | #undef ATMOSPHERE_PREF_ 8 | #define ATMOSPHERE_PREF_ atmosphere_pref_r8 9 | 10 | #undef ATMOSPHERE_CELL_AREA_ 11 | #define ATMOSPHERE_CELL_AREA_ atmosphere_cell_area_r8 12 | 13 | #undef GET_BOTTOM_MASS_ 14 | #define GET_BOTTOM_MASS_ get_bottom_mass_r8 15 | 16 | #undef GET_BOTTOM_WIND_ 17 | #define GET_BOTTOM_WIND_ get_bottom_wind_r8 18 | 19 | #undef GET_STOCK_PE_ 20 | #define GET_STOCK_PE_ get_stock_pe_r8 21 | 22 | #include "atmosphere.inc" 23 | -------------------------------------------------------------------------------- /.github/ISSUE_TEMPLATE/feature_request.md: -------------------------------------------------------------------------------- 1 | --- 2 | name: Feature request 3 | about: Suggest an idea for this project 4 | title: '' 5 | labels: 'enhancement' 6 | assignees: '' 7 | --- 8 | 9 | **Is your feature request related to a problem? Please describe.** 10 | A clear and concise description of what the problem is. Ex. I'm always frustrated when [...] 11 | 12 | **Describe the solution you'd like** 13 | A clear and concise description of what you want to happen. 14 | 15 | **Describe alternatives you've considered** 16 | A clear and concise description of any alternative solutions or features you've considered. 17 | 18 | **Additional context** 19 | Add any other context or screenshots about the feature request here. 20 | -------------------------------------------------------------------------------- /.github/workflows/daily_cleanup_parallelworks.yml: -------------------------------------------------------------------------------- 1 | name: Old Build Cleanup 2 | 3 | # This GitHub Action Workflow is runing on the gclustercigfdlacs cluster 4 | # This will delete all build directories older than 30 days 5 | # Build directories are on the cloud at /contrib/fv3/2023.2.0 6 | 7 | on: 8 | schedule: 9 | # run daily at midnight 10 | - cron: '0 0 * * *' 11 | 12 | jobs: 13 | delete: 14 | if: github.repository == 'NOAA-GFDL/GFDL_atmos_cubed_sphere' 15 | runs-on: [gfdlacsciintel] 16 | name: Delete Builds 17 | steps: 18 | - run: find /contrib/fv3/2023.2.0/GFDL_atmos_cubed_sphere/refs/pull -maxdepth 1 -mindepth 1 -mtime +30 -type d -print -exec rm -rf "{}" \; 19 | - run: find /contrib/fv3/2023.2.0/GFDL_atmos_cubed_sphere/refs/heads -maxdepth 1 -mindepth 1 -mtime +30 -type d -print -exec rm -rf "{}" \; 20 | -------------------------------------------------------------------------------- /docs/HOWTO_tracer-2024.11.md: -------------------------------------------------------------------------------- 1 | NOTE: these tracers are not specific ratios and so should not be mass-adjusted. 2 | To activate, add the following to your field_table: 3 | 4 | ``` 5 | "TRACER", "atmos_mod", "w_diff" 6 | "longname", "w_diff" 7 | "units", "m/s" 8 | "adjust_mass", "false" 9 | "profile_type", "fixed", "surface_value=0" / 10 | "TRACER", "atmos_mod", "pbl_age" 11 | "longname", "Age of air from PBL" 12 | "units", "d" 13 | "adjust_mass", "false" 14 | "profile_type", "fixed", "surface_value=0." / 15 | "TRACER", "atmos_mod", "tro_pbl_age" 16 | "longname", "Age of air from tropical PBL" 17 | "units", "d" 18 | "adjust_mass", "false" 19 | "profile_type", "fixed", "surface_value=0." / 20 | ``` 21 | -------------------------------------------------------------------------------- /.github/ISSUE_TEMPLATE/bug_report.md: -------------------------------------------------------------------------------- 1 | --- 2 | name: Bug Report 3 | about: Create a bug report to help us improve 4 | title: '' 5 | labels: Bug 6 | --- 7 | 8 | **Describe the bug** 9 | A clear and concise description of what the bug is 10 | 11 | **To Reproduce** 12 | Steps to reproduce the behavior 13 | 14 | **Expected behavior** 15 | A clear and concise description of what you expected to happen. 16 | 17 | **System Environment** 18 | Describe the system environment, include: 19 | - OS: [e.g. RHEL 7.2] 20 | - Compiler(s): Type and version [e.g. Intel 19.1] 21 | - MPI type, and version (e.g. MPICH, Cray MPI, openMPI) 22 | - netCDF Version: For both C and Fortran 23 | - Configure options: Any additional flags, or macros passed to configure 24 | 25 | **Additional context** 26 | Add any other context about the problem. If applicable, include where any files 27 | that help describe, or reproduce the problem exist. 28 | -------------------------------------------------------------------------------- /.github/pull_request_template.md: -------------------------------------------------------------------------------- 1 | **Description** 2 | 3 | Include a summary of the change and which issue is fixed. Please also include 4 | relevant motivation and context. List any dependencies that are required for 5 | this change. 6 | 7 | Fixes # (issue) 8 | 9 | **How Has This Been Tested?** 10 | 11 | Please describe the tests that you ran to verify your changes. Please also note 12 | any relevant details for your test configuration (e.g. compiler, OS). Include 13 | enough information so someone can reproduce your tests. 14 | 15 | **Checklist:** 16 | 17 | Please check all whether they apply or not 18 | - [ ] My code follows the style guidelines of this project 19 | - [ ] I have performed a self-review of my own code 20 | - [ ] I have commented my code, particularly in hard-to-understand areas 21 | - [ ] I have made corresponding changes to the documentation 22 | - [ ] My changes generate no new warnings 23 | - [ ] Any dependent changes have been merged and published in downstream modules 24 | -------------------------------------------------------------------------------- /tools/external_sst.F90: -------------------------------------------------------------------------------- 1 | !*********************************************************************** 2 | !* GNU Lesser General Public License 3 | !* 4 | !* This file is part of the FV3 dynamical core. 5 | !* 6 | !* The FV3 dynamical core is free software: you can redistribute it 7 | !* and/or modify it under the terms of the 8 | !* GNU Lesser General Public License as published by the 9 | !* Free Software Foundation, either version 3 of the License, or 10 | !* (at your option) any later version. 11 | !* 12 | !* The FV3 dynamical core is distributed in the hope that it will be 13 | !* useful, but WITHOUT ANY WARRANTY; without even the implied warranty 14 | !* of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. 15 | !* See the GNU General Public License for more details. 16 | !* 17 | !* You should have received a copy of the GNU Lesser General Public 18 | !* License along with the FV3 dynamical core. 19 | !* If not, see . 20 | !*********************************************************************** 21 | 22 | module external_sst_mod 23 | 24 | use amip_interp_mod, only: i_sst, j_sst, forecast_mode, use_ncep_sst 25 | 26 | real, allocatable, dimension(:,:) :: sst_ncep, sst_anom 27 | 28 | public i_sst, j_sst, sst_ncep, sst_anom, forecast_mode, use_ncep_sst 29 | 30 | end module external_sst_mod 31 | -------------------------------------------------------------------------------- /.github/.parallelworks/checkout.sh: -------------------------------------------------------------------------------- 1 | #!/bin/sh -xe 2 | 3 | ############################################################################## 4 | ## User set up variables 5 | ## Root directory for CI 6 | dirRoot=/contrib/fv3 7 | ## Intel version to be used 8 | intelVersion=2023.2.0 9 | ############################################################################## 10 | ## HPC-ME container 11 | container=/contrib/containers/noaa-intel-prototype_2023.09.25.sif 12 | container_env_script=/contrib/containers/load_spack_noaa-intel.sh 13 | ############################################################################## 14 | 15 | #Parse Arguments 16 | branch=main 17 | commit=none 18 | while [[ $# -gt 0 ]]; do 19 | case $1 in 20 | -b|--branch) 21 | branch="$2" 22 | shift # past argument 23 | shift # past value 24 | ;; 25 | -h|--hash) 26 | commit="$2" 27 | shift # past argument 28 | shift # past value 29 | ;; 30 | *) 31 | echo "unknown argument" 32 | exit 1 33 | ;; 34 | esac 35 | done 36 | 37 | echo "branch is $branch" 38 | echo "commit is $commit" 39 | 40 | ## Set up the directories 41 | testDir=${dirRoot}/${intelVersion}/GFDL_atmos_cubed_sphere/${branch}/${commit} 42 | logDir=${testDir}/log 43 | export MODULESHOME=/usr/share/lmod/lmod 44 | ## create directories 45 | rm -rf ${testDir} 46 | mkdir -p ${logDir} 47 | # salloc commands to start up 48 | #2 tests layout 8,8 (16 nodes) 49 | #2 tests layout 4,8 (8 nodes) 50 | #9 tests layout 4,4 (18 nodes) 51 | #5 tests layout 4,1 (5 nodes) 52 | #17 tests layout 2,2 (17 nodes) 53 | #salloc --partition=p2 -N 64 -J ${branch} sleep 20m & 54 | 55 | ## clone code 56 | cd ${testDir} 57 | git clone --recursive https://github.com/NOAA-GFDL/SHiELD_build.git && cd SHiELD_build && ./CHECKOUT_code |& tee ${logDir}/checkout.log 58 | ## Check out the PR 59 | cd ${testDir}/SHiELD_SRC/GFDL_atmos_cubed_sphere && git fetch origin ${branch}:toMerge && git merge toMerge 60 | -------------------------------------------------------------------------------- /.github/.parallelworks/compile.sh: -------------------------------------------------------------------------------- 1 | #!/bin/sh -xe 2 | 3 | ############################################################################## 4 | ## User set up variables 5 | ## Root directory for CI 6 | dirRoot=/contrib/fv3 7 | ## Intel version to be used 8 | intelVersion=2023.2.0 9 | ############################################################################## 10 | ## HPC-ME container 11 | container=/contrib/containers/noaa-intel-prototype_2023.09.25.sif 12 | container_env_script=/contrib/containers/load_spack_noaa-intel.sh 13 | ############################################################################## 14 | 15 | #Parse Arguments 16 | branch=main 17 | commit=none 18 | while [[ $# -gt 0 ]]; do 19 | case $1 in 20 | -b|--branch) 21 | branch="$2" 22 | shift # past argument 23 | shift # past value 24 | ;; 25 | -h|--hash) 26 | commit="$2" 27 | shift # past argument 28 | shift # past value 29 | ;; 30 | -c|--config) 31 | config="$2" 32 | shift # past argument 33 | shift # past value 34 | ;; 35 | --hydro) 36 | hydro="$2" 37 | shift # past argument 38 | shift # past value 39 | ;; 40 | --bit) 41 | bit="$2" 42 | shift # past argument 43 | shift # past value 44 | ;; 45 | -m|--mode) 46 | mode="$2" 47 | shift # past argument 48 | shift # past value 49 | ;; 50 | *) 51 | echo "unknown argument" 52 | exit 1 53 | ;; 54 | esac 55 | done 56 | 57 | if [ -z $mode ] || [ -z $bit ] || [ -z $hydro ] || [ -z $config ] 58 | then 59 | echo "must specify config, hydro, bit, and mode options for compile" 60 | exit 1 61 | fi 62 | 63 | echo "branch is $branch" 64 | echo "commit is $commit" 65 | echo "mode is $mode" 66 | echo "bit is $bit" 67 | echo "hydro is $hydro" 68 | echo "config is $config" 69 | 70 | if [ $hydro = "sw" ] && [ $config = "shield" ] 71 | then 72 | echo "this combination should not be tested" 73 | else 74 | ## Set up the directories 75 | testDir=${dirRoot}/${intelVersion}/GFDL_atmos_cubed_sphere/${branch}/${commit} 76 | logDir=${testDir}/log 77 | # Set up build 78 | cd ${testDir}/SHiELD_build/Build 79 | #Define External Libs path 80 | export EXTERNAL_LIBS=${dirRoot}/externallibs 81 | # Build SHiELD 82 | set -o pipefail 83 | singularity exec -B /contrib ${container} ${container_env_script} "./COMPILE ${config} ${hydro} ${bit} ${mode} intel clean" |& tee ${logDir}/compile_${config}_${hydro}_${bit}_${mode}_intel.out 84 | fi 85 | -------------------------------------------------------------------------------- /.github/.parallelworks/run_test.sh: -------------------------------------------------------------------------------- 1 | #!/bin/bash -xe 2 | ulimit -s unlimited 3 | ############################################################################## 4 | ## User set up variables 5 | ## Root directory for CI 6 | dirRoot=/contrib/fv3 7 | ## Intel version to be used 8 | intelVersion=2023.2.0 9 | ############################################################################## 10 | ## HPC-ME container 11 | container=/contrib/containers/noaa-intel-prototype_2023.09.25.sif 12 | container_env_script=/contrib/containers/load_spack_noaa-intel-mlong.sh 13 | 14 | #Parse Arguments 15 | branch=main 16 | commit=none 17 | while [[ $# -gt 0 ]]; do 18 | case $1 in 19 | -b|--branch) 20 | branch="$2" 21 | shift # past argument 22 | shift # past value 23 | ;; 24 | -h|--hash) 25 | commit="$2" 26 | shift # past argument 27 | shift # past value 28 | ;; 29 | -t|--test) 30 | testname="$2" 31 | shift # past argument 32 | shift # past value 33 | ;; 34 | *) 35 | echo "unknown argument" 36 | exit 1 37 | ;; 38 | esac 39 | done 40 | 41 | if [ -z $testname ] 42 | then 43 | echo "must specify a test name with -t" 44 | exit 1 45 | fi 46 | 47 | echo "branch is $branch" 48 | echo "commit is $commit" 49 | echo "test is $testname" 50 | 51 | ## Set up the directories 52 | MODULESHOME=/usr/share/lmod/lmod 53 | testDir=${dirRoot}/${intelVersion}/GFDL_atmos_cubed_sphere/${branch}/${commit} 54 | logDir=${testDir}/log 55 | baselineDir=${dirRoot}/baselines/intel/${intelVersion} 56 | 57 | ## Run the CI Test 58 | # Define the builddir testscriptdir and rundir BUILDDIR is used by test scripts 59 | # Set the BUILDDIR for the test script to use 60 | export BUILDDIR="${testDir}/SHiELD_build" 61 | testscriptDir=${BUILDDIR}/RTS/CI 62 | runDir=${BUILDDIR}/CI/BATCH-CI 63 | 64 | # Run CI test scripts 65 | cd ${testscriptDir} 66 | set -o pipefail 67 | # Execute the test piping output to log file 68 | ./${testname} " --partition=compute --mpi=pmi2 --job-name=${commit}_${testname} singularity exec -B /contrib -B /apps ${container} ${container_env_script}" |& tee ${logDir}/run_${testname}.log 69 | 70 | ## Compare Restarts to Baseline 71 | source $MODULESHOME/init/sh 72 | export MODULEPATH=/mnt/shared/manual_modules:/usr/share/modulefiles/Linux:/usr/share/modulefiles/Core:/usr/share/lmod/lmod/modulefiles/Core:/apps/modules/modulefiles:/apps/modules/modulefamilies/intel 73 | module load intel/2022.1.2 74 | module load netcdf 75 | module load nccmp 76 | for resFile in `ls ${baselineDir}/${testname}` 77 | do 78 | nccmp -d ${baselineDir}/${testname}/${resFile} ${runDir}/${testname}/RESTART/${resFile} 79 | done 80 | -------------------------------------------------------------------------------- /docs/examples/README.md: -------------------------------------------------------------------------------- 1 | # FV3 Examples 2 | 3 | This directory contains Python (Jupyter) notebooks demonstrating basic FV3 capabilities, including characteristics of the solver, physics-dynamics coupling, output using FMS `diag_manager`, and basic analyses of the model output. The notebooks should all be viewable in any browser; you can also download any of them and use them in an up-to-date Python/Jupyter environment. 4 | 5 | ## 1D Cases 6 | tp_core 7 | : 1D advection operators in FV3. This is designed to be an *interactive* notebook for downloading and playing with the options, initial conditions, zooms, and so on. 8 | 9 | fv3_level_transmogrifier 10 | : An *interactive* notebook that shows different hybrid-level setups within FV3, and allows detection of discontinuities within the levels that may cause errors or instabilities. The directory contains the notebook and its dependencies, including source for a Python-wrapped version of `set_eta()`. 11 | 12 | ## 2D Global Shallow-water Cases 13 | RHwave 14 | : Rossby-Haurwitz wave, a test of height-vorticity consistency 15 | 16 | BTwave 17 | : Barotropic instability, demonstrating vorticity preservation and wave breaking (cf. Galewsky et al. 2004; Scott, Harris, and Polvani 2016) 18 | 19 | BLvortex 20 | : Bates-Li forced polar vortex 21 | 22 | SWmodon 23 | : Lin-Chen-Yao modon demonstrating the crucial nature of nonlinear vorticity dynamics. Notebook forthcoming; see [Lin et al. (JAMES, 2017)](http://dx.doi.org/10.1002/2017MS000965) 24 | 25 | ## 3D Global Cases 26 | 27 | BCwave 28 | : Hydrostatic baroclinic wave, with and without moisture 29 | 30 | TC 31 | : Reed-Jablonowski TC tests, demonstrating the effect of advection schemes and numerical diffusion 32 | 33 | mtn_rest_100km 34 | : Resting atmosphere over oscilliatory topography, to diagnose pressure-gradient force truncation error on large scales 35 | 36 | TornadicSupercell 37 | : Global super-stretched grid with Toy semi-circle hodograph creating supercell thunderstorms with tornado-like vortices, demonstrating the importance of vorticity preservation at kilometer scales. See animations on [Google Drive](https://drive.google.com/drive/folders/1pVNAuKrYKwxVAlCdVa5faIVRBaK2hdVI) (noaa.gov only). 38 | 39 | HSzuritasuperrotation 40 | : The classic Held-Suarez idealized climate, with modifications from [Zurita-Gotor et al. (JAS, 2022)](https://journals.ametsoc.org/view/journals/atsc/79/5/JAS-D-21-0269.1.xml) to demonstrate superrotation. 41 | 42 | ## 2D Periodic 43 | 44 | MountainWaveIC 45 | : A demonstration of how to rigorously compute thermodynamic quantities in FV3 of importance for mountain wave simulation 46 | 47 | mtn_wave_tests 48 | : Standard mountain wave over Schar topography, to demonstrate mountain-wave propagation and 2D FV3 capabilities; and a resting atmosphere over Schar topography, to diagnose pressure-gradient force truncation error on small scales and errors due to hybridization of the vertical coordinate 49 | 50 | ## 3D Doubly-periodic Cases 51 | 52 | DPsupercell 53 | : Supercell on a doubly-periodic using Weisman (WK82) sounding and a straight-line hodograph. Demonstrates pressure partitioning between moist, dry, and nonhydrostatic contributions. 54 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # GFDL_atmos_cubed_sphere 2 | 3 | The source contained herein reflects the 202411 release of the Finite Volume Cubed-Sphere Dynamical Core (FV3) from GFDL 4 | 5 | The GFDL Microphysics is also available within this repository. 6 | 7 | # Where to find information 8 | 9 | Visit the [FV3 website](https://www.gfdl.noaa.gov/fv3/) for more information. Reference material is available at [FV3 documentation and references](https://www.gfdl.noaa.gov/fv3/fv3-documentation-and-references/). 10 | 11 | # Proper usage attribution 12 | 13 | Cite _Putman and Lin (2007)_ and _Harris and Lin (2013)_ when describing a model using the FV3 dynamical core. 14 | 15 | Cite _Chen et al (2013)_ and _Zhou et al (2019)_ when using the GFDL Microphysics. 16 | 17 | # Documentation 18 | 19 | The up-to-date FV3 Scientific reference guide is included in LaTex and PDF formats in the ```docs/``` directory. There are also some notebooks in docs/examples demonstrating basic FV3 capabilities and analysis techniques. 20 | 21 | A [DOI referenceable version](https://doi.org/10.25923/6nhs-5897) is available in the [_NOAA Institutional Repository_](https://repository.library.noaa.gov/view/noaa/30725) 22 | 23 | # What files are what 24 | 25 | The top level directory structure groups source code and input files as follow: 26 | 27 | | File/directory | Purpose | 28 | | -------------- | ------- | 29 | | ```LICENSE.md``` | a copy of the Gnu lesser general public license, version 3. | 30 | | ```README.md``` | this file with basic pointers to more information | 31 | | ```RELEASE.md``` | notes describing each release in the main branch | 32 | | ```model/``` | contains the source code for core of the FV3 dyanmical core | 33 | | ```driver/``` | contains drivers used by different models/modeling systems | 34 | | ```tools/``` | contains source code of tools used within the core | 35 | | ```GFDL_tools/``` | contains source code of tools specific to GFDL models | 36 | | ```docs/``` | contains documentation for the FV3 dynamical core, and Python notebooks demonstrating basic capabilities. | 37 | 38 | # Disclaimer 39 | 40 | The United States Department of Commerce (DOC) GitHub project code is provided 41 | on an "as is" basis and the user assumes responsibility for its use. DOC has 42 | relinquished control of the information and no longer has responsibility to 43 | protect the integrity, confidentiality, or availability of the information. Any 44 | claims against the Department of Commerce stemming from the use of its GitHub 45 | project will be governed by all applicable Federal law. Any reference to 46 | specific commercial products, processes, or services by service mark, 47 | trademark, manufacturer, or otherwise, does not constitute or imply their 48 | endorsement, recommendation or favoring by the Department of Commerce. The 49 | Department of Commerce seal and logo, or the seal and logo of a DOC bureau, 50 | shall not be used in any manner to imply endorsement of any commercial product 51 | or activity by DOC or the United States Government. 52 | 53 | This project code is made available through GitHub but is managed by NOAA-GFDL 54 | at https://gitlab.gfdl.noaa.gov. 55 | -------------------------------------------------------------------------------- /driver/solo/qs_tables.F90: -------------------------------------------------------------------------------- 1 | !*********************************************************************** 2 | !* GNU Lesser General Public License 3 | !* 4 | !* This file is part of the FV3 dynamical core. 5 | !* 6 | !* The FV3 dynamical core is free software: you can redistribute it 7 | !* and/or modify it under the terms of the 8 | !* GNU Lesser General Public License as published by the 9 | !* Free Software Foundation, either version 3 of the License, or 10 | !* (at your option) any later version. 11 | !* 12 | !* The FV3 dynamical core is distributed in the hope that it will be 13 | !* useful, but WITHOUT ANY WARRANTY; without even the implied warranty 14 | !* of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. 15 | !* See the GNU General Public License for more details. 16 | !* 17 | !* You should have received a copy of the GNU Lesser General Public 18 | !* License along with the FV3 dynamical core. 19 | !* If not, see . 20 | !*********************************************************************** 21 | 22 | module qs_tables_mod 23 | 24 | use constants_mod, only: rdgas, rvgas, cp_air, cp_vapor, hlv 25 | use gfdl_mp_mod, only: c_liq 26 | 27 | implicit none 28 | logical:: qs_table_is_initialized = .false. 29 | real, allocatable, dimension(:,:) :: table_w(:), des_w(:) 30 | public :: qs_wat0, qs_wat, qs_wat_init 31 | 32 | real, parameter:: e0 = 610.71 ! saturation vapor pressure at T0 33 | real, parameter:: tice = 273.16 34 | real, parameter:: cp_vap = cp_vapor ! 1846. 35 | ! For consistency, cv_vap derived FMS constants: 36 | real, parameter:: cv_vap = cp_vap - rvgas ! 1384.5 37 | real, parameter:: cv_air = cp_air - rdgas 38 | #ifdef SIM_NGGPS 39 | real, parameter:: dc_vap = 0. 40 | #else 41 | real, parameter:: dc_vap = cp_vap - c_liq ! = -2344. isobaric heating/cooling 42 | #endif 43 | real, parameter:: Lv0 = hlv - dc_vap*tice 44 | ! L = hlv + (Cp_vapor-C_liq)*(T-T_ice) 45 | 46 | contains 47 | 48 | real function qs_wat0(ta, den) 49 | ! Pure water phase; universal dry/moist formular using air density 50 | ! Input "den" can be either dry or moist air density 51 | real, intent(in):: ta, den 52 | ! local: 53 | real es, ap1, dem 54 | real, parameter:: tmin = tice - 160. 55 | integer it 56 | 57 | ! if (.not. qs_table_is_initialized) call qs_wat_init 58 | ap1 = 10.*dim(ta, tmin) + 1. ! lower bound enforced 59 | ap1 = min(2621., ap1) ! upper bound enforced 60 | it = ap1 61 | es = table_w(it) + (ap1-it)*des_w(it) 62 | dem = rvgas*ta*den 63 | qs_wat0 = es / dem 64 | 65 | end function qs_wat0 66 | 67 | real function qs_wat(ta, den, dqdt) 68 | ! Pure water phase; universal dry/moist formular using air density 69 | ! Input "den" can be either dry or moist air density 70 | ! Full-form: 71 | ! qsat = e0*rdgas/(rvgas*p_in)*exp((dc_vap*log(T_in/tice)+Lv0*(T_in-tice)/(T_in*tice))/rvgas) 72 | ! simple-form: 73 | ! qsat = e0*rdgas/(rvgas*p_in)*exp( hlv/rvgas*(T_in-tice)/(T_in*tice) ) 74 | ! 75 | real, intent(in):: ta, den 76 | real, intent(out):: dqdt 77 | ! local: 78 | real es, ap1, dem 79 | real, parameter:: tmin = tice - 160. 80 | integer it 81 | 82 | ! if (.not. qs_table_is_initialized) call qs_wat_init 83 | ap1 = 10.*dim(ta, tmin) + 1. ! lower bound enforced 84 | ap1 = min(2621., ap1) ! upper bound enforced 85 | it = ap1 86 | es = table_w(it) + (ap1-it)*des_w(it) 87 | dem = rvgas*ta*den 88 | qs_wat = es / dem 89 | it = ap1 - 0.5 90 | ! Finite diff, del_T = 0.1: 91 | dqdt = 10.*(des_w(it) + (ap1-it)*(des_w(it+1)-des_w(it))) / dem 92 | 93 | end function qs_wat 94 | 95 | subroutine qs_wat_init 96 | integer, parameter:: length=2621 97 | integer i 98 | 99 | if( .not. qs_table_is_initialized ) then 100 | ! generate es table (dt = 0.1 deg. c) 101 | allocate ( table_w(length) ) 102 | allocate ( des_w(length) ) 103 | 104 | call qs_table_w(length ) 105 | 106 | do i=1,length-1 107 | des_w(i) = max(0., table_w(i+1) - table_w(i)) 108 | enddo 109 | des_w(length) = des_w(length-1) 110 | 111 | qs_table_is_initialized = .true. 112 | endif 113 | 114 | end subroutine qs_wat_init 115 | 116 | subroutine qs_table_w(n) 117 | integer, intent(in):: n 118 | real, parameter:: del_t=0.1 119 | real:: tmin, tem, f0 120 | integer i 121 | 122 | ! constants 123 | tmin = tice - 160. 124 | 125 | do i=1,n 126 | tem = tmin + del_t*real(i-1) 127 | ! compute es over water 128 | ! Lv0 = hlv - dc_vap*tice 129 | table_w(i) = e0*exp((dc_vap*log(tem/tice)+Lv0*(tem-tice)/(tem*tice))/rvgas) 130 | enddo 131 | 132 | end subroutine qs_table_w 133 | 134 | end module qs_tables_mod 135 | -------------------------------------------------------------------------------- /CODE_STYLE.md: -------------------------------------------------------------------------------- 1 | # Coding Style 2 | 3 | ## General 4 | 5 | * Trim all trailing whitespace from every line (some editors can do this 6 | automatically). 7 | * No tab characters. 8 | * A copy of the FV3 Gnu Lesser General Public License Header 9 | must be included at the top of each file. 10 | * Supply an author block for each file with a description of the file and the author(s) 11 | name or GitHub ID. 12 | * Documentation may be written so that it can be parsed by [Doxygen](http://www.doxygen.nl/). 13 | * All variables should be defined, and include units. Unit-less variables should be marked `unitless` 14 | * Provide detailed descriptions of modules, interfaces, functions, and subroutines 15 | * Define all function/subroutine arguments, and function results (see below) 16 | * Follow coding style of the current file, as much as possible. 17 | 18 | ## Fortran 19 | 20 | ### General 21 | 22 | * Use Fortran 95 standard or newer 23 | * Two space indentation 24 | * Never use implicit variables (i.e., always specify `IMPLICIT NONE`) 25 | * Lines must be <= 120 characters long (including comments) 26 | * logical, compound logical, and relational if statements may be one line, 27 | using “&” for line continuation if necessary: 28 | ```Fortran 29 | if(file_exists(fileName)) call open_file(fileObj,fileName, is_restart=.false) 30 | ``` 31 | * Avoid the use of `GOTO` statements 32 | * Avoid the use of Fortran reserved words as variables (e.g. `DATA`, `NAME`) 33 | * `COMMON` blocks should never be used 34 | 35 | ### Derived types 36 | 37 | * Type names must be in CapitalWord format. 38 | * Description on the line before the type definition. 39 | * Inline doxygen descriptions for all member variables. 40 | 41 | ## Functions 42 | * Functions should include a result variable on its own line, that does not have 43 | a specific intent. 44 | * Inline descriptions for all arguments, except the result variable. 45 | * Description on the line(s) before the function definition. Specify what the function is returning (with the `@return` doxygen keyword if using doxygen). 46 | 47 | ## Blocks 48 | * terminate `do` loops with `enddo` 49 | * terminate block `if`, `then` statements with `endif` 50 | 51 | ## OpenMP 52 | 53 | * All openMP directives should specify default(none), and then explicitly list 54 | all shared and private variables. 55 | * All critical sections must have a unique name. 56 | 57 | ## Fortran Example 58 | 59 | ```Fortran 60 | 61 | !*********************************************************************** 62 | !* GNU Lesser General Public License 63 | !* 64 | !* This file is part of the FV3 dynamical core. 65 | !* 66 | !* The FV3 dynamical core is free software: you can redistribute it 67 | !* and/or modify it under the terms of the 68 | !* GNU Lesser General Public License as published by the 69 | !* Free Software Foundation, either version 3 of the License, or 70 | !* (at your option) any later version. 71 | !* 72 | !* The FV3 dynamical core is distributed in the hope that it will be 73 | !* useful, but WITHOUT ANY WARRANTY; without even the implied warranty 74 | !* of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. 75 | !* See the GNU General Public License for more details. 76 | !* 77 | !* You should have received a copy of the GNU Lesser General Public 78 | !* License along with the FV3 dynamical core. 79 | !* If not, see . 80 | 81 | !*********************************************************************** 82 | 83 | !> @file 84 | !! @brief Example code 85 | !! @author 86 | !! @email 87 | 88 | module example_mod 89 | use util_mod, only: util_func1 90 | implicit none 91 | private 92 | 93 | public :: sub1 94 | public :: func1 95 | 96 | !> @brief Doxygen description of type. 97 | type,public :: CustomType 98 | integer(kind=) :: a_var !< Inline doxygen description. 99 | real(kind=),dimension(:),allocatable :: b_arr !< long description 100 | !! continued on 101 | !! multiple lines. 102 | endtype CustomType 103 | 104 | contains 105 | 106 | !> @brief Doxygen description. 107 | subroutine sub1(arg1, & 108 | & arg2, & 109 | & arg3) 110 | real(kind=),intent(in) :: arg1 !< Inline doxygen description. 111 | integer(kind=),intent(inout) :: arg2 !< Inline doxygen description. 112 | character(len=*),intent(inout) :: arg3 !< Long inline doxygen 113 | !! description. 114 | end subroutine sub1 115 | 116 | !> @brief Doxygen description 117 | !! @return Function return value. 118 | function func1(arg1, & 119 | & arg2) & 120 | & result(res) 121 | integer(kind=),intent(in) :: arg1 !< Inline doxygen description 122 | integer(kind=),intent(in) :: arg2 !< Inline doxygen description 123 | integer(kind=) :: res 124 | end function func1 125 | 126 | end module example_mod 127 | ``` 128 | -------------------------------------------------------------------------------- /tools/fv_diagnostics.h: -------------------------------------------------------------------------------- 1 | !*********************************************************************** ! -*-f90-*-* 2 | !* GNU Lesser General Public License 3 | !* 4 | !* This file is part of the FV3 dynamical core. 5 | !* 6 | !* The FV3 dynamical core is free software: you can redistribute it 7 | !* and/or modify it under the terms of the 8 | !* GNU Lesser General Public License as published by the 9 | !* Free Software Foundation, either version 3 of the License, or 10 | !* (at your option) any later version. 11 | !* 12 | !* The FV3 dynamical core is distributed in the hope that it will be 13 | !* useful, but WITHOUT ANY WARRANTY; without even the implied warranty 14 | !* of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. 15 | !* See the GNU General Public License for more details. 16 | !* 17 | !* You should have received a copy of the GNU Lesser General Public 18 | !* License along with the FV3 dynamical core. 19 | !* If not, see . 20 | !*********************************************************************** 21 | 22 | #ifndef _FV_DIAG__ 23 | #define _FV_DIAG__ 24 | 25 | integer ::id_ps, id_slp, id_ua, id_va, id_pt, id_omga, id_vort, & 26 | id_tm, id_pv, id_zsurf, id_zsurf_t, id_oro, id_sgh, id_w, & 27 | id_ke, id_zs, id_ze, id_mq, id_vorts, id_us, id_vs, & 28 | id_tq, id_rh, id_c15, id_c25, id_c35, id_c45, & 29 | id_f15, id_f25, id_f35, id_f45, id_ctp, & 30 | id_ppt, id_ts, id_tb, id_ctt, id_pmask, id_pmaskv2, & 31 | id_delp, id_delz, id_iw, id_lw, & 32 | id_pfhy, id_pfnh, id_ppnh, & 33 | id_qn, id_qn200, id_qn500, id_qn850, id_qp, & 34 | id_qdt, id_acly, id_acl, id_acl2, & 35 | id_dbz, id_maxdbz, id_basedbz, id_dbz4km, & 36 | id_dbztop, id_dbz_m10C, id_40dbzht, & 37 | id_ctz, id_w1km, id_wmaxup, id_wmaxdn, id_cape, id_cin, id_brn, id_shear06 38 | 39 | ! Selected theta-level fields from 3D variables: 40 | integer :: id_pv350K, id_pv550K 41 | 42 | ! Selected p-level fields from 3D variables: 43 | integer :: id_x850, id_srh25, & 44 | id_uh03, id_uh25, id_theta_e, & 45 | id_s200, id_sl12, id_sl13, id_w5km, id_rain5km, id_w2500m 46 | integer :: id_srh1, id_srh3, id_ustm, id_vstm 47 | ! plev and plev_ave diagnostics 48 | integer, allocatable :: id_u_levs(:), id_v_levs(:), id_t_levs(:), id_h_levs(:), id_q_levs(:), id_omg_levs(:) 49 | integer, allocatable :: id_ql_levs(:), id_qi_levs(:), id_qr_levs(:), id_qs_levs(:), id_qg_levs(:), id_cf_levs(:) 50 | integer, allocatable :: id_w_levs(:), id_vort_levs(:), id_rh_levs(:), id_dp_levs(:), id_theta_e_levs(:), id_theta_levs(:) 51 | 52 | integer:: id_u_plev, id_v_plev, id_t_plev, id_h_plev, id_q_plev, id_omg_plev 53 | integer:: id_ql_plev, id_qi_plev, id_qr_plev, id_qs_plev, id_qg_plev, id_cf_plev 54 | integer:: id_t_plev_ave, id_q_plev_ave, id_qv_dt_gfdlmp_plev_ave, id_t_dt_gfdlmp_plev_ave, id_qv_dt_phys_plev_ave, id_t_dt_phys_plev_ave 55 | integer:: id_w_plev, id_vort_plev, id_rh_plev, id_dp_plev, id_theta_e_plev, id_theta_plev 56 | 57 | ! IPCC diag 58 | 59 | integer :: id_rh1000_cmip, id_rh925_cmip, id_rh850_cmip, id_rh700_cmip, id_rh500_cmip, & 60 | id_rh300_cmip, id_rh250_cmip, id_rh100_cmip, id_rh50_cmip, id_rh10_cmip 61 | 62 | integer :: id_hght3d, id_any_hght 63 | integer :: id_u100m, id_v100m, id_w100m, id_wind100m 64 | 65 | ! For initial conditions: 66 | integer ic_ps, ic_ua, ic_va, ic_ppt 67 | integer ic_sphum 68 | integer, allocatable :: id_tracer(:) 69 | 70 | ! dissipation estimates 71 | integer :: id_diss, id_diss_heat 72 | 73 | ! ESM requested diagnostics - dry mass/volume mixing ratios 74 | integer, allocatable :: id_tracer_dmmr(:) 75 | integer, allocatable :: id_tracer_dvmr(:) 76 | integer, allocatable :: id_tracer_burden(:) 77 | logical, allocatable :: conv_vmr_mmr(:) 78 | 79 | ! Microphysical diagnostics 80 | integer :: id_pret, id_prew, id_prer, id_prei, id_pres, id_preg 81 | integer :: id_prefluxw, id_prefluxr, id_prefluxi, id_prefluxs, id_prefluxg 82 | integer :: id_qv_dt_gfdlmp, id_T_dt_gfdlmp, id_ql_dt_gfdlmp, id_qi_dt_gfdlmp 83 | integer :: id_qr_dt_gfdlmp, id_qg_dt_gfdlmp, id_qs_dt_gfdlmp 84 | integer :: id_liq_wat_dt_gfdlmp, id_ice_wat_dt_gfdlmp 85 | integer :: id_u_dt_gfdlmp, id_v_dt_gfdlmp 86 | integer :: id_t_dt_phys, id_qv_dt_phys, id_ql_dt_phys, id_qi_dt_phys, id_u_dt_phys, id_v_dt_phys 87 | integer :: id_qr_dt_phys, id_qg_dt_phys, id_qs_dt_phys 88 | integer :: id_liq_wat_dt_phys, id_ice_wat_dt_phys 89 | integer :: id_intqv, id_intql, id_intqi, id_intqr, id_intqs, id_intqg 90 | integer :: id_t_dt_diabatic, id_qv_dt_diabatic 91 | 92 | integer :: id_mppcw, id_mppew, id_mppe1, id_mpper, id_mppdi 93 | integer :: id_mppd1, id_mppds, id_mppdg, id_mppsi, id_mpps1 94 | integer :: id_mppss, id_mppsg, id_mppfw, id_mppfr, id_mppmi 95 | integer :: id_mppms, id_mppmg, id_mppar, id_mppas, id_mppag 96 | integer :: id_mpprs, id_mpprg, id_mppxr, id_mppxs, id_mppxg 97 | integer :: id_mppm1, id_mppm2, id_mppm3 98 | 99 | integer :: id_qcw, id_qcr, id_qci, id_qcs, id_qcg 100 | integer :: id_rew, id_rer, id_rei, id_res, id_reg, id_cld 101 | 102 | ! ESM/CM 3-D diagostics 103 | integer :: id_uq, id_vq, id_wq, id_iuq, id_ivq, id_iwq, & ! moisture flux & vertical integral 104 | id_ut, id_vt, id_wt, id_iut, id_ivt, id_iwt, & ! heat flux 105 | id_uu, id_uv, id_vv, id_ww, & ! momentum flux 106 | id_iuu, id_iuv, id_iuw, id_ivv, id_ivw, id_iww ! vertically integral of momentum flux 107 | 108 | integer :: id_uw, id_vw 109 | integer :: id_t_dt_nudge, id_ps_dt_nudge, id_delp_dt_nudge, id_u_dt_nudge, id_v_dt_nudge, id_qv_dt_nudge 110 | #ifdef GFS_PHYS 111 | integer :: id_delp_total 112 | #endif 113 | #endif _FV_DIAG__ 114 | -------------------------------------------------------------------------------- /tools/w_forcing.F90: -------------------------------------------------------------------------------- 1 | 2 | module w_forcing_mod 3 | 4 | use fv_arrays_mod, only: fv_grid_type, fv_flags_type, fv_grid_bounds_type, R_GRID 5 | use mpp_domains_mod, only: mpp_update_domains, domain2d 6 | use mpp_mod, only: mpp_error, FATAL, mpp_root_pe, mpp_broadcast, mpp_sum, mpp_sync 7 | use fv_mp_mod, only: is_master 8 | implicit none 9 | public 10 | 11 | !settings 12 | integer :: w_forcing_type = 101 13 | real :: w_forcing_L = 40000. !m 14 | real :: w_forcing_R = 2000. !m --- ?!? 15 | real :: w_forcing_D = 4000. !m, depth 16 | real :: w_forcing_H = 0. 17 | real :: w_forcing_start = 0.0 !s 18 | real :: w_forcing_end = -1. !2400.0 !s 19 | real :: w_forcing_a = 2.0 !acceleration, m/s**2 20 | 21 | real :: w_forcing_Divg = 3.75e-6 !1/s 22 | real :: w_forcing_tau = 3600. !s 23 | 24 | !saved data 25 | real :: w_forcing_i0 26 | real :: w_forcing_j0 27 | 28 | 29 | contains 30 | 31 | subroutine init_w_forcing(bd, npx, npy, npz, grid_type, agrid, flagstruct)!, wft) 32 | 33 | type(fv_grid_bounds_type), intent(IN) :: bd 34 | real , intent(IN) :: agrid(bd%isd:bd%ied, bd%jsd:bd%jed) 35 | integer,intent(IN) :: npx, npy, npz, grid_type!, wft 36 | type(fv_flags_type), target, intent(IN) :: flagstruct 37 | 38 | !w_forcing_type = wft 39 | 40 | if (grid_type == 4) then 41 | 42 | select case (w_forcing_type) 43 | case(1) ! half-ellipse acceleration (Ziegler et al., 2010; Prein et al. 2021) 44 | w_forcing_i0 = real(npx-1)*0.5 45 | w_forcing_j0 = real(npy-1)*0.5 46 | case default 47 | 48 | end select 49 | 50 | endif 51 | 52 | if (is_master()) print*, ' CALLING INIT_W_FORCING ', w_forcing_type, w_forcing_i0, w_forcing_j0 53 | 54 | end subroutine init_w_forcing 55 | 56 | subroutine do_w_forcing(bd, npx, npy, npz, w, delz, phis, grid_type, agrid, domain, flagstruct, dt, time) 57 | 58 | implicit none 59 | 60 | type(fv_grid_bounds_type), intent(IN) :: bd 61 | real , intent(INOUT) :: w(bd%isd:, bd%jsd:,1:) 62 | real , intent(IN) :: delz(bd%is: , bd%js: ,1:) 63 | real , intent(IN) :: phis(bd%isd:bd%ied, bd%jsd:bd%jed) 64 | real , intent(IN) :: agrid(bd%isd:bd%ied, bd%jsd:bd%jed,2) 65 | integer,intent(IN) :: npx, npy, npz, grid_type 66 | real , intent(IN) :: dt, time 67 | type(fv_flags_type), target, intent(IN) :: flagstruct 68 | type(domain2d), intent(INOUT) :: domain 69 | 70 | real :: Htop(bd%is:bd%ie,bd%js:bd%je) !height at the top of the current layer 71 | real :: rad,radm1,ht,xL,wls,forc,dttau,lev 72 | 73 | integer :: i,j,k 74 | 75 | integer :: is, ie, js, je 76 | integer :: isd, ied, jsd, jed 77 | 78 | logical, SAVE :: first_time = .true. 79 | 80 | is = bd%is 81 | ie = bd%ie 82 | js = bd%js 83 | je = bd%je 84 | isd = bd%isd 85 | ied = bd%ied 86 | jsd = bd%jsd 87 | jed = bd%jed 88 | 89 | if (grid_type < 4) then 90 | call mpp_error(FATAL, "Not implemented for grid_type < 4 yet.") 91 | endif 92 | 93 | if (w_forcing_end > 0) then 94 | if (time < w_forcing_start .or. time > w_forcing_end) return 95 | endif 96 | 97 | if (first_time .and. is_master()) print*, ' CALLING DO_W_FORCING ' 98 | 99 | if (grid_type == 4) then 100 | 101 | select case (w_forcing_type) 102 | case(1) 103 | 104 | 105 | do j=js,je 106 | do i=is,ie 107 | Htop(i,j) = phis(i,j) !Height above MSL 108 | enddo 109 | enddo 110 | do k=npz,1,-1 111 | do j=js,je 112 | do i=is,ie 113 | Htop(i,j) = Htop(i,j) - delz(i,j,k) 114 | 115 | xL = abs(i-w_forcing_i0)*flagstruct%dx_const 116 | if (xL <= w_forcing_L) then 117 | rad = (j-w_forcing_j0)*flagstruct%dx_const 118 | rad = rad*rad/(w_forcing_R*w_forcing_R) 119 | ht = Htop(i,j) + 0.5*delz(i,j,k) - w_forcing_H 120 | rad = rad + ht*ht/(w_forcing_D*w_forcing_D) 121 | radm1 = max(1.-sqrt(rad),0.) 122 | w(i,j,k) = w(i,j,k) + w_forcing_a*radm1*radm1*dt 123 | endif 124 | 125 | enddo 126 | enddo 127 | enddo 128 | 129 | case(101) 130 | !PBL simulations with specified divergence 131 | !Nudging domain to w = Dz 132 | !do not apply in sponge layer 133 | 134 | dttau=dt/w_forcing_tau 135 | forc = 1./(1.+dttau) 136 | do j=js,je 137 | do i=is,ie 138 | Htop(i,j) = -delz(i,j,npz)*0.5 139 | wls = -w_forcing_Divg*Htop(i,j) 140 | w(i,j,npz) = (w(i,j,npz) + dttau*wls)*forc 141 | enddo 142 | enddo 143 | do k=npz-1,3,-1 144 | do j=js,je 145 | do i=is,ie 146 | Htop(i,j) = Htop(i,j) - 0.5*(delz(i,j,k-1)+delz(i,j,k)) 147 | wls = -w_forcing_Divg*Htop(i,j) 148 | w(i,j,k) = (w(i,j,k) + dttau*wls)*forc 149 | enddo 150 | enddo 151 | enddo 152 | 153 | if (first_time .and. is_master()) then 154 | i=is 155 | j=js 156 | lev=-delz(i,j,npz)*0.5 157 | wls = -w_forcing_Divg*lev 158 | print*, npz, wls, w(i,j,npz), dttau 159 | do k=npz,3,-1 160 | lev = lev - 0.5*(delz(i,j,k-1)+delz(i,j,k)) 161 | wls = -w_forcing_divg*lev 162 | print*, k, wls, w(i,j,k) 163 | enddo 164 | endif 165 | 166 | case default 167 | call mpp_error(FATAL, " Value of w_forcing_type not implemented.") 168 | 169 | end select 170 | 171 | end if 172 | 173 | call mpp_update_domains(w, domain) 174 | 175 | first_time = .false. 176 | 177 | end subroutine do_w_forcing 178 | 179 | 180 | end module w_forcing_mod 181 | -------------------------------------------------------------------------------- /driver/SHiELD/include/atmosphere.inc: -------------------------------------------------------------------------------- 1 | subroutine ATMOSPHERE_GRID_BDRY_ (blon, blat, global) 2 | !--------------------------------------------------------------- 3 | ! returns the longitude and latitude grid box edges 4 | ! for either the local PEs grid (default) or the global grid 5 | !--------------------------------------------------------------- 6 | real(ATMOSPHERE_KIND_), intent(out) :: blon(:,:), blat(:,:) ! Unit: radian 7 | logical, intent(in), optional :: global 8 | ! Local data: 9 | integer i,j 10 | 11 | if( PRESENT(global) ) then 12 | if (global) call mpp_error(FATAL, '==> global grid is no longer available & 13 | & in the Cubed Sphere') 14 | endif 15 | 16 | if (ATMOSPHERE_KIND_ .eq. r8_kind) then 17 | do j=jsc,jec+1 18 | do i=isc,iec+1 19 | blon(i-isc+1,j-jsc+1) = Atm(mygrid)%gridstruct%grid_64(i,j,1) 20 | blat(i-isc+1,j-jsc+1) = Atm(mygrid)%gridstruct%grid_64(i,j,2) 21 | enddo 22 | end do 23 | else 24 | do j=jsc,jec+1 25 | do i=isc,iec+1 26 | blon(i-isc+1,j-jsc+1) = Atm(mygrid)%gridstruct%grid(i,j,1) 27 | blat(i-isc+1,j-jsc+1) = Atm(mygrid)%gridstruct%grid(i,j,2) 28 | enddo 29 | end do 30 | endif 31 | end subroutine ATMOSPHERE_GRID_BDRY_ 32 | 33 | subroutine ATMOSPHERE_PREF_ (p_ref) 34 | real(ATMOSPHERE_KIND_), dimension(:,:), intent(inout) :: p_ref 35 | 36 | p_ref = _DBL_(pref) 37 | 38 | end subroutine ATMOSPHERE_PREF_ 39 | 40 | subroutine ATMOSPHERE_CELL_AREA_ (area_out) 41 | real(ATMOSPHERE_KIND_), dimension(:,:), intent(out) :: area_out 42 | 43 | area_out(1:iec-isc+1, 1:jec-jsc+1) = _DBL_(Atm(mygrid)%gridstruct%area (isc:iec,jsc:jec)) 44 | 45 | end subroutine ATMOSPHERE_CELL_AREA_ 46 | 47 | subroutine GET_BOTTOM_MASS_ ( t_bot, tr_bot, p_bot, z_bot, p_surf, slp ) 48 | !-------------------------------------------------------------- 49 | ! returns temp, sphum, pres, height at the lowest model level 50 | ! and surface pressure 51 | !-------------------------------------------------------------- 52 | real(ATMOSPHERE_KIND_), intent(out), dimension(isc:iec,jsc:jec):: t_bot, p_bot, z_bot, p_surf 53 | real(ATMOSPHERE_KIND_), intent(out), optional, dimension(isc:iec,jsc:jec):: slp 54 | real(ATMOSPHERE_KIND_), intent(out), dimension(isc:iec,jsc:jec,nq):: tr_bot 55 | integer :: i, j, m, k, kr 56 | real(ATMOSPHERE_KIND_) :: rrg, sigtop, sigbot 57 | real(ATMOSPHERE_KIND_), dimension(isc:iec,jsc:jec) :: tref 58 | real(ATMOSPHERE_KIND_), parameter :: tlaps = 6.5e-3 59 | 60 | rrg = _DBL_(rdgas / grav) 61 | 62 | do j=jsc,jec 63 | do i=isc,iec 64 | p_surf(i,j) = _DBL_(Atm(mygrid)%ps(i,j)) 65 | t_bot(i,j) = _DBL_(Atm(mygrid)%pt(i,j,npz)) 66 | p_bot(i,j) = _DBL_(Atm(mygrid)%delp(i,j,npz)/(Atm(mygrid)%peln(i,npz+1,j)-Atm(mygrid)%peln(i,npz,j))) 67 | z_bot(i,j) = rrg*t_bot(i,j)*_DBL_((1.+zvir*Atm(mygrid)%q(i,j,npz,sphum))) * & 68 | _DBL_((1. - Atm(mygrid)%pe(i,npz,j)/p_bot(i,j))) 69 | enddo 70 | enddo 71 | 72 | if ( present(slp) ) then 73 | ! determine 0.8 sigma reference level 74 | sigtop = _DBL_(Atm(mygrid)%ak(1)/pstd_mks+Atm(mygrid)%bk(1)) 75 | do k = 1, npz 76 | sigbot = _DBL_(Atm(mygrid)%ak(k+1)/pstd_mks+Atm(mygrid)%bk(k+1)) 77 | if (sigbot+sigtop > 1.6) then 78 | kr = k 79 | exit 80 | endif 81 | sigtop = sigbot 82 | enddo 83 | do j=jsc,jec 84 | do i=isc,iec 85 | ! sea level pressure 86 | tref(i,j) = _DBL_(Atm(mygrid)%pt(i,j,kr) * (Atm(mygrid)%delp(i,j,kr)/ & 87 | ((Atm(mygrid)%peln(i,kr+1,j)-Atm(mygrid)%peln(i,kr,j))*Atm(mygrid)%ps(i,j)))**(-rrg*tlaps)) 88 | slp(i,j) = _DBL_(Atm(mygrid)%ps(i,j)*(1.+tlaps*Atm(mygrid)%phis(i,j)/(real(tref(i,j))*grav))**(1./(rrg*tlaps))) 89 | enddo 90 | enddo 91 | endif 92 | 93 | ! Copy tracers 94 | do m=1,nq 95 | do j=jsc,jec 96 | do i=isc,iec 97 | tr_bot(i,j,m) = _DBL_(Atm(mygrid)%q(i,j,npz,m)) 98 | enddo 99 | enddo 100 | enddo 101 | 102 | end subroutine GET_BOTTOM_MASS_ 103 | 104 | subroutine GET_BOTTOM_WIND_ ( u_bot, v_bot ) 105 | !----------------------------------------------------------- 106 | ! returns u and v on the mass grid at the lowest model level 107 | !----------------------------------------------------------- 108 | real(ATMOSPHERE_KIND_), intent(out), dimension(isc:iec,jsc:jec):: u_bot, v_bot 109 | integer i, j 110 | 111 | do j=jsc,jec 112 | do i=isc,iec 113 | u_bot(i,j) = _DBL_(Atm(mygrid)%u_srf(i,j)) 114 | v_bot(i,j) = _DBL_(Atm(mygrid)%v_srf(i,j)) 115 | enddo 116 | enddo 117 | 118 | end subroutine GET_BOTTOM_WIND_ 119 | 120 | subroutine GET_STOCK_PE_(index, value) 121 | integer, intent(in) :: index 122 | real(ATMOSPHERE_KIND_), intent(out) :: value 123 | real(ATMOSPHERE_KIND_) wm(isc:iec,jsc:jec) 124 | integer i,j,k 125 | 126 | select case (index) 127 | 128 | case (1) 129 | 130 | !---------------------- 131 | ! Perform vertical sum: 132 | !---------------------- 133 | wm = 0. 134 | do j=jsc,jec 135 | do k=1,npz 136 | do i=isc,iec 137 | ! Warning: the following works only with AM2 physics: water vapor; cloud water, cloud ice. 138 | wm(i,j) = wm(i,j) + _DBL_(Atm(mygrid)%delp(i,j,k) * ( Atm(mygrid)%q(i,j,k,sphum) + & 139 | Atm(mygrid)%q(i,j,k,liq_wat) + & 140 | Atm(mygrid)%q(i,j,k,ice_wat) )) 141 | enddo 142 | enddo 143 | enddo 144 | 145 | !---------------------- 146 | ! Horizontal sum: 147 | !---------------------- 148 | value = 0. 149 | do j=jsc,jec 150 | do i=isc,iec 151 | value = value + wm(i,j)*_DBL_(Atm(mygrid)%gridstruct%area(i,j)) 152 | enddo 153 | enddo 154 | value = value/_DBL_(grav) 155 | 156 | case default 157 | value = 0.0 158 | end select 159 | 160 | end subroutine GET_STOCK_PE_ 161 | -------------------------------------------------------------------------------- /.github/workflows/SHiELD_parallelworks_intel.yml: -------------------------------------------------------------------------------- 1 | name: Compile SHiELD SOLO and run tests 2 | 3 | # This GitHub Action Workflow is running on the cloud devcimultiintel cluster 4 | # The tests are run inside of a container with the following software/libraries: 5 | # -intel: 2023.2.0 6 | # -hdf5: 1.14.0 7 | # -netcdf-c: 4.9.2 8 | # -netcdf-fortran: 4.6.0 9 | # -cmake 10 | # -libyaml 11 | 12 | on: 13 | pull_request: 14 | branches: 15 | - main 16 | # run weekly on Sunday 17 | schedule: 18 | - cron: '0 0 * * 0' 19 | 20 | #this should cancel in progress ci runs for the same PR 21 | #(e.g. a second commit on the same PR comes in while CI is still running) 22 | concurrency: 23 | group: ${{ github.workflow }}-${{ github.ref }} 24 | cancel-in-progress: true 25 | 26 | jobs: 27 | checkout: 28 | if: github.repository == 'NOAA-GFDL/GFDL_atmos_cubed_sphere' 29 | runs-on: [gfdlacsciintel] 30 | name: Checkout Code 31 | steps: 32 | # It can take a long time (5-15 minutes) to spinup nodes 33 | # so this salloc will prompt 46 nodes to startup and stay active for 20 min 34 | # this is enough nodes for the first 17 tests to run in parallel, and we 35 | # have 17 runners configured. 36 | - run: salloc --partition=compute -N 46 -J $GITHUB_SHA sleep 20m & 37 | - run: /contrib/fv3/GFDL_atmos_cubed_sphere_CI/checkout.sh -b $GITHUB_REF -h $GITHUB_SHA 38 | 39 | build: 40 | if: github.repository == 'NOAA-GFDL/GFDL_atmos_cubed_sphere' 41 | runs-on: [gfdlacsciintel] 42 | name: SOLO SHiELD build 43 | needs: [checkout] 44 | strategy: 45 | fail-fast: true 46 | max-parallel: 17 47 | matrix: 48 | runscript: [/contrib/fv3/GFDL_atmos_cubed_sphere_CI/compile.sh] 49 | config: [solo] 50 | hydro: [sw, nh, hydro] 51 | bit: [64bit] 52 | mode: [repro] 53 | steps: 54 | - env: 55 | RUNSCRIPT: ${{ matrix.runscript }} 56 | CONFIG: ${{ matrix.config }} 57 | HYDRO: ${{ matrix.hydro }} 58 | BIT: ${{ matrix.bit }} 59 | MODE: ${{ matrix.mode }} 60 | run: $RUNSCRIPT -b $GITHUB_REF -h $GITHUB_SHA -c $CONFIG --hydro $HYDRO --bit $BIT -m $MODE 61 | 62 | test: 63 | if: github.repository == 'NOAA-GFDL/GFDL_atmos_cubed_sphere' 64 | runs-on: [gfdlacsciintel] 65 | name: SOLO SHiELD test suite 66 | needs: [checkout, build] 67 | strategy: 68 | fail-fast: false 69 | max-parallel: 17 70 | matrix: 71 | runscript: [/contrib/fv3/GFDL_atmos_cubed_sphere_CI/run_test.sh] 72 | argument: 73 | # These are placed in order of largest to smallest jobs 74 | #layout 8,8 needs 8 nodes on dvcimultiintel cluster 75 | - C512r20.solo.superC 76 | - C768.sw.BTwave 77 | #layout 4,8 needs 4 nodes on dvcimultiintel cluster 78 | - C256r20.solo.superC 79 | - C384.sw.BLvortex 80 | #layout 4,4 needs 2 nodes on dvcimultiintel cluster 81 | - C128r20.solo.superC 82 | - C128r3.solo.TC.d1 83 | - C128r3.solo.TC.h6 84 | - C128r3.solo.TC 85 | - C128r3.solo.TC.tr8 86 | - C192.sw.BLvortex 87 | - C192.sw.BTwave 88 | - C192.sw.modon 89 | - C384.sw.BTwave 90 | #layout 4,1 and 2,2 need 1 node on dvcimultiintel cluster 91 | - C96.solo.BCdry.hyd 92 | - C96.solo.BCdry 93 | - C96.solo.BCmoist.hyd.d3 94 | - C96.solo.BCmoist.hyd 95 | - C96.solo.BCmoist.nhK 96 | - C96.solo.BCmoist 97 | - C96.solo.mtn_rest.hyd.diff2 98 | - C96.solo.mtn_rest.hyd 99 | - C96.solo.mtn_rest.nonmono.diff2 100 | - C96.solo.mtn_rest 101 | - C96.sw.BLvortex 102 | - C96.sw.BTwave 103 | - C96.sw.modon 104 | - C96.sw.RHwave 105 | - d96_1k.solo.mtn_rest_shear.olddamp 106 | - d96_1k.solo.mtn_rest_shear 107 | - d96_1k.solo.mtn_schar.mono 108 | - d96_1k.solo.mtn_schar 109 | - d96_2k.solo.bubble.n0 110 | - d96_2k.solo.bubble.nhK 111 | - d96_2k.solo.bubble 112 | - d96_500m.solo.mtn_schar 113 | steps: 114 | # This will end the slurm job started in the checkout job 115 | - run: scancel -n $GITHUB_SHA 116 | - env: 117 | RUNSCRIPT: ${{ matrix.runscript }} 118 | ARG1: ${{ matrix.argument }} 119 | run: $RUNSCRIPT -t $ARG1 -b $GITHUB_REF -h $GITHUB_SHA 120 | shutdown: 121 | if: always() && github.repository == 'NOAA-GFDL/GFDL_atmos_cubed_sphere' 122 | runs-on: [gfdlacsciintel] 123 | name: Shutdown Processes 124 | needs: [checkout, build, test] 125 | strategy: 126 | fail-fast: false 127 | max-parallel: 17 128 | matrix: 129 | test: 130 | - C512r20.solo.superC 131 | - C768.sw.BTwave 132 | - C256r20.solo.superC 133 | - C384.sw.BLvortex 134 | - C128r20.solo.superC 135 | - C128r3.solo.TC.d1 136 | - C128r3.solo.TC.h6 137 | - C128r3.solo.TC 138 | - C128r3.solo.TC.tr8 139 | - C192.sw.BLvortex 140 | - C192.sw.BTwave 141 | - C192.sw.modon 142 | - C384.sw.BTwave 143 | - C96.solo.BCdry.hyd 144 | - C96.solo.BCdry 145 | - C96.solo.BCmoist.hyd.d3 146 | - C96.solo.BCmoist.hyd 147 | - C96.solo.BCmoist.nhK 148 | - C96.solo.BCmoist 149 | - C96.solo.mtn_rest.hyd.diff2 150 | - C96.solo.mtn_rest.hyd 151 | - C96.solo.mtn_rest.nonmono.diff2 152 | - C96.solo.mtn_rest 153 | - C96.sw.BLvortex 154 | - C96.sw.BTwave 155 | - C96.sw.modon 156 | - C96.sw.RHwave 157 | - d96_1k.solo.mtn_rest_shear.olddamp 158 | - d96_1k.solo.mtn_rest_shear 159 | - d96_1k.solo.mtn_schar.mono 160 | - d96_1k.solo.mtn_schar 161 | - d96_2k.solo.bubble.n0 162 | - d96_2k.solo.bubble.nhK 163 | - d96_2k.solo.bubble 164 | - d96_500m.solo.mtn_schar 165 | steps: 166 | - run: scancel -n $GITHUB_SHA 167 | - env: 168 | JOB: ${{ github.sha }}_${{ matrix.test }} 169 | run: scancel -n $JOB 170 | -------------------------------------------------------------------------------- /CONTRIBUTING_GUIDE.md: -------------------------------------------------------------------------------- 1 | # Contributing Guide for the GFDL_atmos_cubed_sphere Repository 2 | 3 | This guide will walk a developer through the correct process for making a Pull Request in this repository. 4 | GFDL_atmos_cubed_sphere is a repository with 4 different development branches. It is imperitive that the developer understands the difference between each branch. 5 | 6 | ## Understanding the Development Branches 7 | 8 | There are 4 different development branches being supported in this repository. 9 | 10 | | Branch | Description | 11 | | :--- | :--- | 12 | | main | This branch is the main development branch. The SHiELD model will compile with this branch. When there is a Public Release of the FV3 Dynamical Core, updates will first be introduced to this branch. | 13 | | dev/gfdl | This branch is used for all AM4 based GFDL Models. | 14 | | dev/emc | This branch is used for the UFS Weather Model development. | 15 | | dev/gfdl_am5 | This branch is being used for GFDL AM5 development. | 16 | 17 | ## How to contribute code changes 18 | 19 | 1. Create a Fork 20 | 1. Click on **Fork** in the top right of the repository GitHub page 21 | 2. The **Owner** should be set to your GitHub username 22 | 3. The **Repository Name** should be GFDL_atmos_cubed_sphere 23 | 4. Click **Create fork** 24 | 25 | 2. Create an Issue describing the change that you would like to implement. 26 | 1. Navigate to the **Issue** tab at the top of the repository GitHub page 27 | 2. Click on the **New issue** button 28 | 3. Choose from one of the suggested templates (Bug Report, Feature Request, or Support Request) 29 | 4. Fill out the Issue with specifics and submit issue 30 | 31 | 3. Clone the repository locally on your machine 32 | 33 | `git clone https://github.com/NOAA-GFDL/GFDL_atmos_cubed_sphere.git` 34 | 35 | 4. Add your fork locally 36 | 37 | This guide will refer to the fork as `myFork`, but you can name this anything. 38 | 39 | `git remote add myFork https://github.com//GFDL_atmos_cubed_sphere.git` 40 | 41 | `git remote -v` will display all remote repositories that you have added. The repository that you cloned will be named `origin` by default. 42 | 43 | The ouput of `git remote -v` should be similar to: 44 | 45 | ``` 46 | myFork https://github.com//GFDL_atmos_cubed_sphere.git (fetch) 47 | myFork https://github.com//GFDL_atmos_cubed_sphere.git (push) 48 | origin https://github.com/NOAA-GFDL/GFDL_atmos_cubed_sphere.git (fetch) 49 | origin https://github.com/NOAA-GFDL/GFDL_atmos_cubed_sphere.git (push) 50 | ``` 51 | 52 | 5. Checkout the branch that you would like your changes added to 53 | 54 | Refer to section [Understanding the Development Branches](#Understanding-the-Development-Branches) to choose which branch to checkout 55 | 56 | This guide will reference this branch as `baseBranch` 57 | 58 | `git checkout baseBranch ` 59 | 60 | 6. Create a feature branch to make your changes to 61 | 62 | This guide will refer to this new branch as `newBranch`, but you should name this branch with a unique name related to the task 63 | 64 | `git checkout -b newBranch` 65 | 66 | 7. Update the code 67 | 1. To see the files you have modified use the command `git status` 68 | 2. To see exactly what you changed in each file use the command `git diff` 69 | 3. When you are satisfied with your changes stage them for a commit 70 | 71 | `git add ` 72 | 73 | 4. Make a commit 74 | 75 | `git commit -m "Descriptive message describing what you have changed in this commit"` 76 | 77 | 5. Make sure branch is up to date with the base branch (main, dev/gfdl, dev/emc, or dev/gfdl_am5) 78 | 79 | `git fetch origin baseBranch` 80 | 81 | `git merge origin/baseBranch` 82 | 83 | 6. Push that commit to your fork 84 | 85 | `git push myFork newBranch` 86 | 87 | 8. Create a Pull Request 88 | 1. Navigate to your fork on GitHub 89 | 90 | The URL to get you to your fork should be `https://github.com//GFDL_atmos_cubed_sphere` 91 | 92 | 2. Navigate to the **Pull requests** tab at the top of the repository GitHub page 93 | 3. Click on the **New pull request** button 94 | 4. The **base repository** should be *NOAA-GFDL/GFDL_atmos_cubed_sphere* 95 | 5. The **base** branch is the branch you would like to add your changes to 96 | 97 | Refer to section [Understanding the Development Branches](#Understanding-the-Development-Branches) 98 | 99 | This is the same branch that you originally checked out in Step 5 of this guide that was referred to as `baseBranch` 100 | 101 | 6. The **head repository** should be your fork (e.g. *\/GFDL_atmos_cubed_sphere*) 102 | 7. The **compare** branch is the feeature branch containing your updates. This was referred to as `newBranch` in this guide 103 | 104 | You should now see a comparison of the two branches 105 | 106 | 8. Click on the **Create pull request** button 107 | 9. Fill in the details of the Pull request, being sure to follow the template provided: 108 | 1. Provide a desciption: Include a summary of the change and which issue is fixed. 109 | Please also include relevant motivation and context. 110 | List any dependencies that are required for this change. 111 | 2. Link the Issue from Step 2 by including a line `Fixes #123` where *123* is the Issue # 112 | 3. Please describe the tests that you ran to verify your changes. 113 | Please also note any relevant details for your test configuration (e.g. compiler, OS). 114 | Include enough information so someone can reproduce your tests. 115 | 4. Ensure that all checkboxes are populated. If something does not apply, please check it and note that it does not apply somewhere in the PR. 116 | If you have not completed an item in the checklist, the PR will not be merged. 117 | 118 | To check a box replace the space in `[ ]` with an x `[x]` 119 | 5. Click on the **Create pull request** button. 120 | 10. Code managers will assign reviewers to the PR. 121 | If you would like someone specific to review your PR please leave a comment on the PR requesting that. 122 | When all reviewers approve the code, a code manager will merge the code and your changes will now be in the relevant development branch. 123 | -------------------------------------------------------------------------------- /model/fv_fill.F90: -------------------------------------------------------------------------------- 1 | !*********************************************************************** 2 | !* GNU Lesser General Public License 3 | !* 4 | !* This file is part of the FV3 dynamical core. 5 | !* 6 | !* The FV3 dynamical core is free software: you can redistribute it 7 | !* and/or modify it under the terms of the 8 | !* GNU Lesser General Public License as published by the 9 | !* Free Software Foundation, either version 3 of the License, or 10 | !* (at your option) any later version. 11 | !* 12 | !* The FV3 dynamical core is distributed in the hope that it will be 13 | !* useful, but WITHOUT ANY WARRANTY; without even the implied warranty 14 | !* of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. 15 | !* See the GNU General Public License for more details. 16 | !* 17 | !* You should have received a copy of the GNU Lesser General Public 18 | !* License along with the FV3 dynamical core. 19 | !* If not, see . 20 | !*********************************************************************** 21 | 22 | module fv_fill_mod 23 | 24 | use mpp_domains_mod, only: mpp_update_domains, domain2D 25 | use platform_mod, only: kind_phys => r8_kind 26 | 27 | implicit none 28 | public fillz 29 | public fill_gfs 30 | public fill2D 31 | 32 | contains 33 | 34 | subroutine fillz(im, km, nq, q, dp) 35 | integer, intent(in):: im ! No. of longitudes 36 | integer, intent(in):: km ! No. of levels 37 | integer, intent(in):: nq ! Total number of tracers 38 | real , intent(in):: dp(im,km) ! pressure thickness 39 | real , intent(inout) :: q(im,km,nq) ! tracer mixing ratio 40 | ! !LOCAL VARIABLES: 41 | logical:: zfix(im) 42 | real :: dm(km) 43 | integer i, k, ic, k1 44 | real qup, qly, dup, dq, sum0, sum1, fac 45 | 46 | do ic=1,nq 47 | #ifdef DEV_GFS_PHYS 48 | ! Bottom up: 49 | do k=km,2,-1 50 | k1 = k-1 51 | do i=1,im 52 | if( q(i,k,ic) < 0. ) then 53 | q(i,k1,ic) = q(i,k1,ic) + q(i,k,ic)*dp(i,k)/dp(i,k1) 54 | q(i,k ,ic) = 0. 55 | endif 56 | enddo 57 | enddo 58 | ! Top down: 59 | do k=1,km-1 60 | k1 = k+1 61 | do i=1,im 62 | if( q(i,k,ic) < 0. ) then 63 | q(i,k1,ic) = q(i,k1,ic) + q(i,k,ic)*dp(i,k)/dp(i,k1) 64 | q(i,k ,ic) = 0. 65 | endif 66 | enddo 67 | enddo 68 | #else 69 | ! Top layer 70 | do i=1,im 71 | if( q(i,1,ic) < 0. ) then 72 | q(i,2,ic) = q(i,2,ic) + q(i,1,ic)*dp(i,1)/dp(i,2) 73 | q(i,1,ic) = 0. 74 | endif 75 | enddo 76 | 77 | ! Interior 78 | zfix(:) = .false. 79 | do k=2,km-1 80 | do i=1,im 81 | if( q(i,k,ic) < 0. ) then 82 | zfix(i) = .true. 83 | if ( q(i,k-1,ic) > 0. ) then 84 | ! Borrow from above 85 | dq = min ( q(i,k-1,ic)*dp(i,k-1), -q(i,k,ic)*dp(i,k) ) 86 | q(i,k-1,ic) = q(i,k-1,ic) - dq/dp(i,k-1) 87 | q(i,k ,ic) = q(i,k ,ic) + dq/dp(i,k ) 88 | endif 89 | if ( q(i,k,ic)<0.0 .and. q(i,k+1,ic)>0. ) then 90 | ! Borrow from below: 91 | dq = min ( q(i,k+1,ic)*dp(i,k+1), -q(i,k,ic)*dp(i,k) ) 92 | q(i,k+1,ic) = q(i,k+1,ic) - dq/dp(i,k+1) 93 | q(i,k ,ic) = q(i,k ,ic) + dq/dp(i,k ) 94 | endif 95 | endif 96 | enddo 97 | enddo 98 | 99 | ! Bottom layer 100 | k = km 101 | do i=1,im 102 | if( q(i,k,ic)<0. .and. q(i,k-1,ic)>0.) then 103 | zfix(i) = .true. 104 | ! Borrow from above 105 | qup = q(i,k-1,ic)*dp(i,k-1) 106 | qly = -q(i,k ,ic)*dp(i,k ) 107 | dup = min(qly, qup) 108 | q(i,k-1,ic) = q(i,k-1,ic) - dup/dp(i,k-1) 109 | q(i,k, ic) = q(i,k, ic) + dup/dp(i,k ) 110 | endif 111 | enddo 112 | 113 | ! Perform final check and non-local fix if needed 114 | do i=1,im 115 | if ( zfix(i) ) then 116 | 117 | sum0 = 0. 118 | do k=2,km 119 | dm(k) = q(i,k,ic)*dp(i,k) 120 | sum0 = sum0 + dm(k) 121 | enddo 122 | 123 | if ( sum0 > 0. ) then 124 | sum1 = 0. 125 | do k=2,km 126 | sum1 = sum1 + max(0., dm(k)) 127 | enddo 128 | fac = sum0 / sum1 129 | do k=2,km 130 | q(i,k,ic) = max(0., fac*dm(k)/dp(i,k)) 131 | enddo 132 | endif 133 | 134 | endif 135 | enddo 136 | #endif 137 | 138 | enddo 139 | end subroutine fillz 140 | 141 | subroutine fill_gfs(im, km, pe2, q) 142 | !SJL: this routine is the equivalent of fillz except that the vertical index is upside down 143 | integer, intent(in):: im, km 144 | real(kind=kind_phys), intent(in):: pe2(im,km+1) ! pressure interface 145 | real(kind=kind_phys), intent(inout):: q(im,km) 146 | ! LOCAL VARIABLES: 147 | real(kind=kind_phys) :: dp(im,km) 148 | integer:: i, k, k1 149 | 150 | do k=1,km 151 | do i=1,im 152 | dp(i,k) = pe2(i,k) - pe2(i,k+1) 153 | enddo 154 | enddo 155 | 156 | do i=1,im 157 | 158 | ! From bottom up: 159 | do k=1,km-1 160 | k1 = k+1 161 | if ( q(i,k)<0.0 ) then 162 | ! Take mass from above 163 | q(i,k1) = q(i,k1) + q(i,k)*dp(i,k)/dp(i,k1) 164 | q(i,k ) = 0. 165 | endif 166 | enddo 167 | 168 | ! From top down: 169 | do k=km,2,-1 170 | k1 = k-1 171 | if ( q(i,k)<0.0 ) then 172 | ! Take mass from below 173 | q(i,k1) = q(i,k1) + q(i,k)*dp(i,k)/dp(i,k1) 174 | q(i,k ) = 0. 175 | endif 176 | enddo 177 | 178 | enddo 179 | 180 | end subroutine fill_gfs 181 | 182 | 183 | subroutine fill2D(is, ie, js, je, ng, km, q, delp, area, domain, bounded_domain, npx, npy) 184 | ! This is a diffusive type filling algorithm 185 | type(domain2D), intent(INOUT) :: domain 186 | integer, intent(in):: is, ie, js, je, ng, km, npx, npy 187 | logical, intent(IN):: bounded_domain 188 | real, intent(in):: area(is-ng:ie+ng, js-ng:je+ng) 189 | real, intent(in):: delp(is-ng:ie+ng, js-ng:je+ng, km) 190 | real, intent(inout):: q(is-ng:ie+ng, js-ng:je+ng, km) 191 | ! LOCAL VARIABLES: 192 | real, dimension(is-ng:ie+ng, js-ng:je+ng,km):: qt 193 | real, dimension(is:ie+1, js:je):: fx 194 | real, dimension(is:ie, js:je+1):: fy 195 | real, parameter:: dif = 0.25 196 | integer:: i, j, k 197 | integer :: is1, ie1, js1, je1 198 | 199 | if (bounded_domain) then 200 | if (is == 1) then 201 | is1 = is-1 202 | else 203 | is1 = is 204 | endif 205 | if (ie == npx-1) then 206 | ie1 = ie+1 207 | else 208 | ie1 = ie 209 | endif 210 | if (js == 1) then 211 | js1 = js-1 212 | else 213 | js1 = js 214 | endif 215 | if (je == npy-1) then 216 | je1 = je+1 217 | else 218 | je1 = je 219 | endif 220 | else 221 | is1 = is 222 | ie1 = ie 223 | js1 = js 224 | je1 = je 225 | endif 226 | 227 | !$OMP parallel do default(shared) 228 | do k=1, km 229 | do j=js1,je1 230 | do i=is1,ie1 231 | qt(i,j,k) = q(i,j,k)*delp(i,j,k)*area(i,j) 232 | enddo 233 | enddo 234 | enddo 235 | call mpp_update_domains(qt, domain, whalo=1, ehalo=1, shalo=1, nhalo=1) 236 | 237 | !$OMP parallel do default(shared) private(fx,fy) 238 | do k=1, km 239 | fx(:,:) = 0. 240 | do j=js,je 241 | do i=is,ie+1 242 | if( qt(i-1,j,k)*qt(i,j,k)<0. ) fx(i,j) = qt(i-1,j,k) - qt(i,j,k) 243 | enddo 244 | enddo 245 | fy(:,:) = 0. 246 | do j=js,je+1 247 | do i=is,ie 248 | if( qt(i,j-1,k)*qt(i,j,k)<0. ) fy(i,j) = qt(i,j-1,k) - qt(i,j,k) 249 | enddo 250 | enddo 251 | do j=js,je 252 | do i=is,ie 253 | q(i,j,k) = q(i,j,k)+dif*(fx(i,j)-fx(i+1,j)+fy(i,j)-fy(i,j+1))/(delp(i,j,k)*area(i,j)) 254 | enddo 255 | enddo 256 | enddo 257 | 258 | end subroutine fill2D 259 | 260 | end module fv_fill_mod 261 | -------------------------------------------------------------------------------- /LICENSE.md: -------------------------------------------------------------------------------- 1 | ### GNU LESSER GENERAL PUBLIC LICENSE 2 | 3 | Version 3, 29 June 2007 4 | 5 | Copyright (C) 2007 Free Software Foundation, Inc. 6 | 7 | 8 | Everyone is permitted to copy and distribute verbatim copies of this 9 | license document, but changing it is not allowed. 10 | 11 | This version of the GNU Lesser General Public License incorporates the 12 | terms and conditions of version 3 of the GNU General Public License, 13 | supplemented by the additional permissions listed below. 14 | 15 | #### 0. Additional Definitions. 16 | 17 | As used herein, "this License" refers to version 3 of the GNU Lesser 18 | General Public License, and the "GNU GPL" refers to version 3 of the 19 | GNU General Public License. 20 | 21 | "The Library" refers to a covered work governed by this License, other 22 | than an Application or a Combined Work as defined below. 23 | 24 | An "Application" is any work that makes use of an interface provided 25 | by the Library, but which is not otherwise based on the Library. 26 | Defining a subclass of a class defined by the Library is deemed a mode 27 | of using an interface provided by the Library. 28 | 29 | A "Combined Work" is a work produced by combining or linking an 30 | Application with the Library. The particular version of the Library 31 | with which the Combined Work was made is also called the "Linked 32 | Version". 33 | 34 | The "Minimal Corresponding Source" for a Combined Work means the 35 | Corresponding Source for the Combined Work, excluding any source code 36 | for portions of the Combined Work that, considered in isolation, are 37 | based on the Application, and not on the Linked Version. 38 | 39 | The "Corresponding Application Code" for a Combined Work means the 40 | object code and/or source code for the Application, including any data 41 | and utility programs needed for reproducing the Combined Work from the 42 | Application, but excluding the System Libraries of the Combined Work. 43 | 44 | #### 1. Exception to Section 3 of the GNU GPL. 45 | 46 | You may convey a covered work under sections 3 and 4 of this License 47 | without being bound by section 3 of the GNU GPL. 48 | 49 | #### 2. Conveying Modified Versions. 50 | 51 | If you modify a copy of the Library, and, in your modifications, a 52 | facility refers to a function or data to be supplied by an Application 53 | that uses the facility (other than as an argument passed when the 54 | facility is invoked), then you may convey a copy of the modified 55 | version: 56 | 57 | - a) under this License, provided that you make a good faith effort 58 | to ensure that, in the event an Application does not supply the 59 | function or data, the facility still operates, and performs 60 | whatever part of its purpose remains meaningful, or 61 | - b) under the GNU GPL, with none of the additional permissions of 62 | this License applicable to that copy. 63 | 64 | #### 3. Object Code Incorporating Material from Library Header Files. 65 | 66 | The object code form of an Application may incorporate material from a 67 | header file that is part of the Library. You may convey such object 68 | code under terms of your choice, provided that, if the incorporated 69 | material is not limited to numerical parameters, data structure 70 | layouts and accessors, or small macros, inline functions and templates 71 | (ten or fewer lines in length), you do both of the following: 72 | 73 | - a) Give prominent notice with each copy of the object code that 74 | the Library is used in it and that the Library and its use are 75 | covered by this License. 76 | - b) Accompany the object code with a copy of the GNU GPL and this 77 | license document. 78 | 79 | #### 4. Combined Works. 80 | 81 | You may convey a Combined Work under terms of your choice that, taken 82 | together, effectively do not restrict modification of the portions of 83 | the Library contained in the Combined Work and reverse engineering for 84 | debugging such modifications, if you also do each of the following: 85 | 86 | - a) Give prominent notice with each copy of the Combined Work that 87 | the Library is used in it and that the Library and its use are 88 | covered by this License. 89 | - b) Accompany the Combined Work with a copy of the GNU GPL and this 90 | license document. 91 | - c) For a Combined Work that displays copyright notices during 92 | execution, include the copyright notice for the Library among 93 | these notices, as well as a reference directing the user to the 94 | copies of the GNU GPL and this license document. 95 | - d) Do one of the following: 96 | - 0) Convey the Minimal Corresponding Source under the terms of 97 | this License, and the Corresponding Application Code in a form 98 | suitable for, and under terms that permit, the user to 99 | recombine or relink the Application with a modified version of 100 | the Linked Version to produce a modified Combined Work, in the 101 | manner specified by section 6 of the GNU GPL for conveying 102 | Corresponding Source. 103 | - 1) Use a suitable shared library mechanism for linking with 104 | the Library. A suitable mechanism is one that (a) uses at run 105 | time a copy of the Library already present on the user's 106 | computer system, and (b) will operate properly with a modified 107 | version of the Library that is interface-compatible with the 108 | Linked Version. 109 | - e) Provide Installation Information, but only if you would 110 | otherwise be required to provide such information under section 6 111 | of the GNU GPL, and only to the extent that such information is 112 | necessary to install and execute a modified version of the 113 | Combined Work produced by recombining or relinking the Application 114 | with a modified version of the Linked Version. (If you use option 115 | 4d0, the Installation Information must accompany the Minimal 116 | Corresponding Source and Corresponding Application Code. If you 117 | use option 4d1, you must provide the Installation Information in 118 | the manner specified by section 6 of the GNU GPL for conveying 119 | Corresponding Source.) 120 | 121 | #### 5. Combined Libraries. 122 | 123 | You may place library facilities that are a work based on the Library 124 | side by side in a single library together with other library 125 | facilities that are not Applications and are not covered by this 126 | License, and convey such a combined library under terms of your 127 | choice, if you do both of the following: 128 | 129 | - a) Accompany the combined library with a copy of the same work 130 | based on the Library, uncombined with any other library 131 | facilities, conveyed under the terms of this License. 132 | - b) Give prominent notice with the combined library that part of it 133 | is a work based on the Library, and explaining where to find the 134 | accompanying uncombined form of the same work. 135 | 136 | #### 6. Revised Versions of the GNU Lesser General Public License. 137 | 138 | The Free Software Foundation may publish revised and/or new versions 139 | of the GNU Lesser General Public License from time to time. Such new 140 | versions will be similar in spirit to the present version, but may 141 | differ in detail to address new problems or concerns. 142 | 143 | Each version is given a distinguishing version number. If the Library 144 | as you received it specifies that a certain numbered version of the 145 | GNU Lesser General Public License "or any later version" applies to 146 | it, you have the option of following the terms and conditions either 147 | of that published version or of any later version published by the 148 | Free Software Foundation. If the Library as you received it does not 149 | specify a version number of the GNU Lesser General Public License, you 150 | may choose any version of the GNU Lesser General Public License ever 151 | published by the Free Software Foundation. 152 | 153 | If the Library as you received it specifies that a proxy can decide 154 | whether future versions of the GNU Lesser General Public License shall 155 | apply, that proxy's public statement of acceptance of any version is 156 | permanent authorization for you to choose that version for the 157 | Library. 158 | -------------------------------------------------------------------------------- /model/fast_phys.F90: -------------------------------------------------------------------------------- 1 | !*********************************************************************** 2 | !* GNU Lesser General Public License 3 | !* 4 | !* This file is part of the FV3 dynamical core. 5 | !* 6 | !* The FV3 dynamical core is free software: you can redistribute it 7 | !* and/or modify it under the terms of the 8 | !* GNU Lesser General Public License as published by the 9 | !* Free Software Foundation, either version 3 of the License, or 10 | !* (at your option) any later version. 11 | !* 12 | !* The FV3 dynamical core is distributed in the hope that it will be 13 | !* useful, but WITHOUT ANY WARRANTY; without even the implied warranty 14 | !* of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. 15 | !* See the GNU General Public License for more details. 16 | !* 17 | !* You should have received a copy of the GNU Lesser General Public 18 | !* License along with the FV3 dynamical core. 19 | !* If not, see . 20 | !*********************************************************************** 21 | 22 | ! ======================================================================= 23 | ! Fast Physics Interface 24 | ! Developer: Linjiong Zhou 25 | ! Last Update: 5/19/2022 26 | ! ======================================================================= 27 | 28 | module fast_phys_mod 29 | 30 | #ifdef OVERLOAD_R4 31 | use constantsR4_mod, only: rdgas, grav 32 | #else 33 | use constants_mod, only: rdgas, grav 34 | #endif 35 | use fv_grid_utils_mod, only: cubed_to_latlon, update_dwinds_phys 36 | use fv_arrays_mod, only: fv_grid_type, fv_grid_bounds_type, fv_thermo_type 37 | use mpp_domains_mod, only: domain2d, mpp_update_domains 38 | use tracer_manager_mod, only: get_tracer_index, get_tracer_names 39 | use field_manager_mod, only: model_atmos 40 | use gfdl_mp_mod, only: mtetw 41 | 42 | implicit none 43 | 44 | private 45 | 46 | real, parameter :: consv_min = 0.001 47 | 48 | public :: fast_phys 49 | 50 | ! ----------------------------------------------------------------------- 51 | ! precision definition 52 | ! ----------------------------------------------------------------------- 53 | 54 | integer, parameter :: r8 = 8 ! double precision 55 | 56 | contains 57 | 58 | subroutine fast_phys (is, ie, js, je, isd, ied, jsd, jed, km, npx, npy, nq, & 59 | mdt, consv, akap, ptop, hs, te0_2d, u, v, w, pt, & 60 | delp, delz, q_con, cappa, q, pkz, r_vir, te_err, tw_err, & 61 | gridstruct, thermostruct, domain, bd, hydrostatic, do_adiabatic_init, & 62 | consv_checker, adj_mass_vmr) 63 | 64 | implicit none 65 | 66 | ! ----------------------------------------------------------------------- 67 | ! input / output arguments 68 | ! ----------------------------------------------------------------------- 69 | 70 | integer, intent (in) :: is, ie, js, je, isd, ied, jsd, jed, km, npx, npy, nq, adj_mass_vmr 71 | 72 | logical, intent (in) :: hydrostatic, do_adiabatic_init, consv_checker 73 | 74 | real, intent (in) :: consv, mdt, akap, r_vir, ptop, te_err, tw_err 75 | 76 | real, intent (in), dimension (isd:ied, jsd:jed) :: hs 77 | 78 | real, intent (inout), dimension (is:, js:, 1:) :: delz 79 | 80 | real, intent (inout), dimension (isd:, jsd:, 1:) :: q_con, cappa, w 81 | 82 | real, intent (inout), dimension (is:ie, js:je) :: te0_2d 83 | 84 | real, intent (inout), dimension (isd:ied, jsd:jed, km) :: pt, delp 85 | 86 | real, intent (inout), dimension (isd:ied, jsd:jed, km, *) :: q 87 | 88 | real, intent (inout), dimension (isd:ied, jsd:jed+1, km) :: u 89 | 90 | real, intent (inout), dimension (isd:ied+1, jsd:jed, km) :: v 91 | 92 | real, intent (out), dimension (is:ie, js:je, km) :: pkz 93 | 94 | type (fv_grid_type), intent (in), target :: gridstruct 95 | 96 | type (fv_thermo_type), intent (in), target :: thermostruct 97 | 98 | type (fv_grid_bounds_type), intent (in) :: bd 99 | 100 | type (domain2d), intent (inout) :: domain 101 | 102 | 103 | ! ----------------------------------------------------------------------- 104 | ! local variables 105 | ! ----------------------------------------------------------------------- 106 | 107 | logical, allocatable, dimension (:) :: conv_vmr_mmr 108 | 109 | integer :: i, j, k, m, kmp, sphum, liq_wat, ice_wat 110 | integer :: rainwat, snowwat, graupel, cld_amt, ccn_cm3, cin_cm3, aerosol 111 | 112 | real :: rrg 113 | 114 | real, dimension (is:ie) :: gsize 115 | 116 | real, dimension (is:ie, km) :: q2, q3, qliq, qsol, adj_vmr 117 | 118 | real, dimension (is:ie, km+1) :: phis, pe, peln 119 | 120 | real, dimension (isd:ied, jsd:jed, km) :: te, ua, va 121 | 122 | real, allocatable, dimension (:) :: wz 123 | 124 | real, allocatable, dimension (:,:) :: dz, wa 125 | 126 | real, allocatable, dimension (:,:,:) :: u_dt, v_dt, dp0, u0, v0 127 | 128 | real (kind = r8), allocatable, dimension (:) :: tz 129 | 130 | real (kind = r8), dimension (is:ie) :: te_b_beg, te_b_end, tw_b_beg, tw_b_end, dte, te_loss 131 | 132 | real (kind = r8), dimension (is:ie, 1:km) :: te_beg, te_end, tw_beg, tw_end 133 | 134 | character (len = 32) :: tracer_units, tracer_name 135 | 136 | sphum = get_tracer_index (model_atmos, 'sphum') 137 | liq_wat = get_tracer_index (model_atmos, 'liq_wat') 138 | ice_wat = get_tracer_index (model_atmos, 'ice_wat') 139 | rainwat = get_tracer_index (model_atmos, 'rainwat') 140 | snowwat = get_tracer_index (model_atmos, 'snowwat') 141 | graupel = get_tracer_index (model_atmos, 'graupel') 142 | cld_amt = get_tracer_index (model_atmos, 'cld_amt') 143 | ccn_cm3 = get_tracer_index (model_atmos, 'ccn_cm3') 144 | cin_cm3 = get_tracer_index (model_atmos, 'cin_cm3') 145 | aerosol = get_tracer_index (model_atmos, 'aerosol') 146 | 147 | rrg = - rdgas / grav 148 | 149 | ! decide which tracer needs adjustment 150 | if (.not. allocated (conv_vmr_mmr)) allocate (conv_vmr_mmr (nq)) 151 | conv_vmr_mmr (:) = .false. 152 | if (adj_mass_vmr .gt. 0) then 153 | do m = 1, nq 154 | call get_tracer_names (model_atmos, m, name = tracer_name, units = tracer_units) 155 | if (trim (tracer_units) .eq. 'vmr') then 156 | conv_vmr_mmr (m) = .true. 157 | else 158 | conv_vmr_mmr (m) = .false. 159 | endif 160 | enddo 161 | endif 162 | 163 | !----------------------------------------------------------------------- 164 | ! pt conversion 165 | !----------------------------------------------------------------------- 166 | 167 | if (thermostruct%moist_kappa) then 168 | do k = 1, km 169 | do j = js, je 170 | do i = is, ie 171 | pt (i, j, k) = pt (i, j, k) * exp (cappa (i, j, k) / (1. - cappa (i, j, k)) * & 172 | log (rrg * delp (i, j, k) / delz (i, j, k) * pt (i, j, k))) 173 | enddo 174 | enddo 175 | enddo 176 | else 177 | do k = 1, km 178 | do j = js, je 179 | do i = is, ie 180 | pt (i, j, k) = pt (i, j, k) * exp (akap / (1 - akap) * & 181 | log (rrg * delp (i, j, k) / delz (i, j, k) * pt (i, j, k))) 182 | enddo 183 | enddo 184 | enddo 185 | endif 186 | 187 | !----------------------------------------------------------------------- 188 | ! pt conversion 189 | !----------------------------------------------------------------------- 190 | 191 | if (thermostruct%moist_kappa) then 192 | do k = 1, km 193 | do j = js, je 194 | do i = is, ie 195 | pkz (i, j, k) = exp (cappa (i, j, k) * & 196 | log (rrg * delp (i, j, k) / & 197 | delz (i, j, k) * pt (i, j, k))) 198 | pt (i, j, k) = pt (i, j, k) / pkz (i, j, k) 199 | enddo 200 | enddo 201 | enddo 202 | else 203 | do k = 1, km 204 | do j = js, je 205 | do i = is, ie 206 | pkz (i, j, k) = exp (akap * & 207 | log (rrg * delp (i, j, k) / & 208 | delz (i, j, k) * pt (i, j, k))) 209 | pt (i, j, k) = pt (i, j, k) / pkz (i, j, k) 210 | enddo 211 | enddo 212 | enddo 213 | endif 214 | 215 | end subroutine fast_phys 216 | 217 | end module fast_phys_mod 218 | -------------------------------------------------------------------------------- /model/nh_core.F90: -------------------------------------------------------------------------------- 1 | !*********************************************************************** 2 | !* GNU Lesser General Public License 3 | !* 4 | !* This file is part of the FV3 dynamical core. 5 | !* 6 | !* The FV3 dynamical core is free software: you can redistribute it 7 | !* and/or modify it under the terms of the 8 | !* GNU Lesser General Public License as published by the 9 | !* Free Software Foundation, either version 3 of the License, or 10 | !* (at your option) any later version. 11 | !* 12 | !* The FV3 dynamical core is distributed in the hope that it will be 13 | !* useful, but WITHOUT ANY WARRANTY; without even the implied warranty 14 | !* of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. 15 | !* See the GNU General Public License for more details. 16 | !* 17 | !* You should have received a copy of the GNU Lesser General Public 18 | !* License along with the FV3 dynamical core. 19 | !* If not, see . 20 | !*********************************************************************** 21 | 22 | module nh_core_mod 23 | ! Developer: S.-J. Lin, NOAA/GFDL 24 | ! To do list: 25 | ! include moisture effect in pt 26 | !------------------------------ 27 | #ifdef OVERLOAD_R4 28 | use constantsR4_mod, only: rdgas, cp_air, grav 29 | #else 30 | use constants_mod, only: rdgas, cp_air, grav 31 | #endif 32 | use tp_core_mod, only: fv_tp_2d 33 | use nh_utils_mod, only: update_dz_c, update_dz_d, nh_bc 34 | use nh_utils_mod, only: sim_solver, sim1_solver, sim3_solver 35 | use nh_utils_mod, only: sim3p0_solver, rim_2d 36 | use nh_utils_mod, only: Riem_Solver_c, imp_diff_w 37 | use nh_utils_mod, only: edge_profile1 38 | 39 | implicit none 40 | private 41 | 42 | public Riem_Solver3, Riem_Solver_c, update_dz_c, update_dz_d, nh_bc, edge_profile1 43 | real, parameter:: r3 = 1./3. 44 | 45 | CONTAINS 46 | 47 | subroutine Riem_Solver3(ms, dt, is, ie, js, je, km, ng, & 48 | isd, ied, jsd, jed, akap, cappa, cp, & 49 | ptop, zs, q_con, w, delz, pt, & 50 | delp, zh, pe, ppe, pk3, pk, peln, & 51 | ws, p_fac, a_imp, & 52 | use_logp, use_cond, moist_kappa, last_call, & 53 | fp_out, d2bg_zq, debug, fast_tau_w_sec) 54 | !-------------------------------------------- 55 | ! !OUTPUT PARAMETERS 56 | ! Ouput: gz: grav*height at edges 57 | ! pe: full hydrostatic pressure 58 | ! ppe: non-hydrostatic pressure perturbation 59 | !-------------------------------------------- 60 | integer, intent(in):: ms, is, ie, js, je, km, ng 61 | integer, intent(in):: isd, ied, jsd, jed 62 | real, intent(in):: dt ! the BIG horizontal Lagrangian time step 63 | real, intent(in):: akap, cp, ptop, p_fac, a_imp, d2bg_zq, fast_tau_w_sec 64 | real, intent(in):: zs(isd:ied,jsd:jed) 65 | logical, intent(in):: last_call, use_logp, fp_out, use_cond, moist_kappa, debug 66 | real, intent(in):: ws(is:ie,js:je) 67 | real, intent(in), dimension(isd:,jsd:,1:):: q_con, cappa 68 | real, intent(in), dimension(isd:ied,jsd:jed,km):: delp, pt 69 | real, intent(inout), dimension(isd:ied,jsd:jed,km+1):: zh 70 | real, intent(inout), dimension(isd:ied,jsd:jed,km):: w 71 | real, intent(inout):: pe(is-1:ie+1,km+1,js-1:je+1) 72 | real, intent(out):: peln(is:ie,km+1,js:je) ! ln(pe) 73 | real, intent(out), dimension(isd:ied,jsd:jed,km+1):: ppe 74 | real, intent(out):: delz(is:ie,js:je,km) 75 | real, intent(out):: pk(is:ie,js:je,km+1) 76 | real, intent(out):: pk3(isd:ied,jsd:jed,km+1) 77 | ! Local: 78 | real, dimension(is:ie,km):: dm, dz2, pm2, w2, gm2, cp2 79 | real, dimension(is:ie,km+1)::pem, pe2, peln2, peg, pelng 80 | real gama, rgrav, ptk, peln1 81 | integer i, j, k 82 | real, parameter :: scale_m = 0.0 ! diff_z = scale_m**2 * 0.25 83 | 84 | gama = 1./(1.-akap) 85 | rgrav = 1./grav 86 | peln1 = log(ptop) 87 | ptk = exp(akap*peln1) 88 | 89 | !$OMP parallel do default(none) shared(is,ie,js,je,km,delp,ptop,peln1,pk3,ptk,akap,rgrav,zh,pt, & 90 | !$OMP w,a_imp,dt,gama,ws,p_fac,ms,delz,last_call, & 91 | !$OMP peln,pk,fp_out,ppe,use_logp,zs,pe,cappa,q_con,& 92 | !$OMP use_cond,moist_kappa,d2bg_zq,debug,fast_tau_w_sec ) & 93 | !$OMP private(cp2, gm2, dm, dz2, pm2, pem, peg, pelng, pe2, peln2, w2) 94 | do 2000 j=js, je 95 | 96 | if (moist_kappa) then 97 | do k=1,km 98 | do i=is, ie 99 | dm(i,k) = delp(i,j,k) 100 | cp2(i,k) = cappa(i,j,k) 101 | enddo 102 | enddo 103 | else 104 | do k=1,km 105 | do i=is, ie 106 | dm(i,k) = delp(i,j,k) 107 | cp2(i,k) = akap 108 | enddo 109 | enddo 110 | endif 111 | 112 | if (use_cond) then 113 | do i=is,ie 114 | pem(i,1) = ptop 115 | peln2(i,1) = peln1 116 | pk3(i,j,1) = ptk 117 | peg(i,1) = ptop 118 | pelng(i,1) = peln1 119 | enddo 120 | do k=2,km+1 121 | do i=is,ie 122 | pem(i,k) = pem(i,k-1) + dm(i,k-1) 123 | peln2(i,k) = log(pem(i,k)) 124 | ! Excluding contribution from condensates: 125 | ! peln used during remap; pk3 used only for p_grad 126 | peg(i,k) = peg(i,k-1) + dm(i,k-1)*(1.-q_con(i,j,k-1)) 127 | pelng(i,k) = log(peg(i,k)) 128 | pk3(i,j,k) = exp(akap*peln2(i,k)) 129 | enddo 130 | enddo 131 | else 132 | do i=is,ie 133 | pem(i,1) = ptop 134 | peln2(i,1) = peln1 135 | pk3(i,j,1) = ptk 136 | enddo 137 | do k=2,km+1 138 | do i=is,ie 139 | pem(i,k) = pem(i,k-1) + dm(i,k-1) 140 | peln2(i,k) = log(pem(i,k)) 141 | pk3(i,j,k) = exp(akap*peln2(i,k)) 142 | enddo 143 | enddo 144 | endif 145 | 146 | if (use_cond) then 147 | do k=1,km 148 | do i=is, ie 149 | pm2(i,k) = (peg(i,k+1)-peg(i,k))/(pelng(i,k+1)-pelng(i,k)) 150 | gm2(i,k) = 1. / (1.-cp2(i,k)) 151 | dm(i,k) = dm(i,k) * rgrav 152 | dz2(i,k) = zh(i,j,k+1) - zh(i,j,k) 153 | w2(i,k) = w(i,j,k) 154 | enddo 155 | enddo 156 | else 157 | do k=1,km 158 | do i=is, ie 159 | pm2(i,k) = dm(i,k)/(peln2(i,k+1)-peln2(i,k)) 160 | gm2(i,k) = 1. / (1.-cp2(i,k)) 161 | dm(i,k) = dm(i,k) * rgrav 162 | dz2(i,k) = zh(i,j,k+1) - zh(i,j,k) 163 | w2(i,k) = w(i,j,k) 164 | enddo 165 | enddo 166 | endif 167 | 168 | 169 | if ( a_imp < -0.999 ) then 170 | call SIM3p0_solver(dt, is, ie, km, rdgas, gama, akap, pe2, dm, & 171 | pem, w2, dz2, pt(is:ie,j,1:km), ws(is,j), p_fac, scale_m ) 172 | elseif ( a_imp < -0.5 ) then 173 | call SIM3_solver(dt, is, ie, km, rdgas, gama, akap, pe2, dm, & 174 | pem, w2, dz2, pt(is:ie,j,1:km), ws(is,j), abs(a_imp), p_fac, scale_m) 175 | elseif ( a_imp <= 0.5 ) then 176 | call RIM_2D(ms, dt, is, ie, km, rdgas, gama, gm2, pe2, & 177 | dm, pm2, w2, dz2, pt(is:ie,j,1:km), ws(is,j), .false.) 178 | elseif ( a_imp > 0.999 ) then 179 | call SIM1_solver(dt, is, ie, km, rdgas, gama, gm2, cp2, akap, pe2, dm, & 180 | pm2, pem, w2, dz2, pt(is:ie,j,1:km), ws(is,j), p_fac, fast_tau_w_sec) 181 | else 182 | call SIM_solver(dt, is, ie, km, rdgas, gama, gm2, cp2, akap, pe2, dm, & 183 | pm2, pem, w2, dz2, pt(is:ie,j,1:km), ws(is,j), & 184 | a_imp, p_fac, scale_m, fast_tau_w_sec) 185 | endif 186 | 187 | if (d2bg_zq > 0.0001) then 188 | call imp_diff_w(is, ie, km, d2bg_zq, dz2, ws(is,j), w2) 189 | endif 190 | 191 | do k=1, km 192 | do i=is, ie 193 | w(i,j,k) = w2(i,k) 194 | delz(i,j,k) = dz2(i,k) 195 | enddo 196 | enddo 197 | 198 | if ( last_call ) then 199 | do k=1,km+1 200 | do i=is,ie 201 | peln(i,k,j) = peln2(i,k) 202 | pk(i,j,k) = pk3(i,j,k) 203 | pe(i,k,j) = pem(i,k) 204 | enddo 205 | enddo 206 | endif 207 | 208 | if( fp_out ) then 209 | do k=1,km+1 210 | do i=is, ie 211 | ppe(i,j,k) = pe2(i,k) + pem(i,k) 212 | enddo 213 | enddo 214 | else 215 | do k=1,km+1 216 | do i=is, ie 217 | ppe(i,j,k) = pe2(i,k) 218 | enddo 219 | enddo 220 | endif 221 | 222 | if ( use_logp ) then 223 | do k=2,km+1 224 | do i=is, ie 225 | pk3(i,j,k) = peln2(i,k) 226 | enddo 227 | enddo 228 | endif 229 | 230 | do i=is, ie 231 | zh(i,j,km+1) = zs(i,j) 232 | enddo 233 | do k=km,1,-1 234 | do i=is, ie 235 | zh(i,j,k) = zh(i,j,k+1) - dz2(i,k) 236 | enddo 237 | enddo 238 | 239 | 2000 continue 240 | 241 | end subroutine Riem_Solver3 242 | 243 | end module nh_core_mod 244 | -------------------------------------------------------------------------------- /driver/solo/ocean_rough.F90: -------------------------------------------------------------------------------- 1 | !*********************************************************************** 2 | !* GNU Lesser General Public License 3 | !* 4 | !* This file is part of the FV3 dynamical core. 5 | !* 6 | !* The FV3 dynamical core is free software: you can redistribute it 7 | !* and/or modify it under the terms of the 8 | !* GNU Lesser General Public License as published by the 9 | !* Free Software Foundation, either version 3 of the License, or 10 | !* (at your option) any later version. 11 | !* 12 | !* The FV3 dynamical core is distributed in the hope that it will be 13 | !* useful, but WITHOUT ANY WARRANTY; without even the implied warranty 14 | !* of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. 15 | !* See the GNU General Public License for more details. 16 | !* 17 | !* You should have received a copy of the GNU Lesser General Public 18 | !* License along with the FV3 dynamical core. 19 | !* If not, see . 20 | !*********************************************************************** 21 | 22 | module ocean_rough_mod 23 | 24 | !----------------------------------------------------------------------- 25 | 26 | use fms_mod, only: error_mesg, FATAL, & 27 | check_nml_error, mpp_pe, mpp_root_pe 28 | use mpp_mod, only: input_nml_file 29 | 30 | implicit none 31 | private 32 | 33 | public :: compute_ocean_roughness, fixed_ocean_roughness 34 | 35 | !----------------------------------------------------------------------- 36 | !----- namelist ----- 37 | 38 | real :: roughness_init = 0.00044 ! not used in this version 39 | real :: roughness_min = 1.e-6 40 | real :: charnock = 0.032 41 | 42 | real :: roughness_mom = 5.8e-5 43 | real :: roughness_heat = 5.8e-5 ! was 4.00e-4 44 | real :: roughness_moist = 5.8e-5 45 | ! real, parameter :: zcoh1 = 1.4e-5 46 | ! real, parameter :: zcoq1 = 1.3e-4 47 | real :: zcoh1 = 0.0 !miz 48 | real :: zcoq1 = 0.0 !miz 49 | logical :: do_highwind = .false. 50 | logical :: do_cap40 = .false. 51 | real :: v10m = 32.5 !jhc 52 | real :: v10n = 17.5 !jhc 53 | logical :: do_init = .true. 54 | 55 | character(len=32) :: rough_scheme = 'fixed' ! possible values: 56 | ! 'fixed' 57 | ! 'charnock' 58 | ! 'beljaars' 59 | logical:: read_namelist = .true. 60 | 61 | namelist /ocean_rough_nml/ roughness_init, roughness_heat, & 62 | roughness_mom, roughness_moist, & 63 | roughness_min, & 64 | charnock, & 65 | rough_scheme, do_highwind, &!miz 66 | v10m, v10n, do_cap40, do_init, zcoh1, zcoq1 !sjl 67 | 68 | !----------------------------------------------------------------------- 69 | ! ---- constants ---- 70 | 71 | ! ..... high wind speed - rough sea 72 | real, parameter :: zcom1 = 1.8e-2 ! Charnock's constant 73 | ! ..... low wind speed - smooth sea 74 | real, parameter :: gnu = 1.5e-5 75 | real, parameter :: zcom2 = 0.11 76 | real, parameter :: zcoh2 = 0.40 77 | real, parameter :: zcoq2 = 0.62 78 | real, parameter :: grav = 9.80 79 | real, parameter :: us10_adj = 0.9 ! reduction factor; added by SJL 80 | 81 | contains 82 | 83 | !####################################################################### 84 | 85 | subroutine compute_ocean_roughness (u_star, speed, & 86 | rough_mom, rough_heat, rough_moist, master ) 87 | 88 | real, intent(in) :: speed(:,:) 89 | real, intent(inout) :: u_star(:,:) 90 | real, intent(out) :: rough_mom(:,:), rough_heat(:,:), rough_moist(:,:) 91 | logical:: master 92 | !----------------------------------------------------------------------- 93 | ! computes ocean roughness for momentum using wind stress 94 | ! and sets roughness for heat/moisture using namelist value 95 | !----------------------------------------------------------------------- 96 | 97 | real, dimension(size(speed,1),size(speed,2)) :: ustar2, xx1, xx2, w10 !miz 98 | real:: zt1 99 | integer :: i, j 100 | integer :: unit, ierr, io 101 | 102 | ! ----- read and write namelist ----- 103 | if ( read_namelist ) then 104 | read (input_nml_file, nml=ocean_rough_nml, iostat=io) 105 | ierr = check_nml_error(io,'ocean_rough_nml') 106 | if(master) write(*,*)'ierr =',ierr 107 | if(master) write(*,*)'do_init=',do_init 108 | if(master) write(*,*)'rough_scheme=',rough_scheme 109 | read_namelist = .false. 110 | endif 111 | 112 | 113 | if (do_init) then 114 | 115 | call ocean_rough_init(us10_adj*speed, rough_mom, rough_heat, rough_moist) 116 | ! SJL: compute u_star using Eq (2), Moon et al. 117 | u_star(:,:) = 0.4*speed(:,:)*us10_adj/log(10./rough_mom(:,:)) 118 | 119 | else 120 | if (trim(rough_scheme) == 'fixed') then 121 | ! --- set roughness for momentum and heat/moisture --- 122 | 123 | call fixed_ocean_roughness (speed, rough_mom, rough_heat, rough_moist ) 124 | 125 | 126 | ! --- compute roughness for momentum, heat, moisture --- 127 | 128 | else if (trim(rough_scheme) == 'beljaars' .or. & 129 | trim(rough_scheme) == 'charnock') then 130 | 131 | ustar2(:,:) = max(gnu*gnu, u_star(:,:)*u_star(:,:)) 132 | xx1(:,:) = gnu / sqrt(ustar2(:,:)) 133 | xx2(:,:) = ustar2(:,:) / grav 134 | 135 | if (trim(rough_scheme) == 'charnock') then 136 | rough_mom (:,:) = charnock * xx2(:,:) 137 | rough_mom (:,:) = max( rough_mom(:,:), roughness_min ) 138 | rough_heat (:,:) = rough_mom (:,:) 139 | rough_moist(:,:) = rough_mom (:,:) 140 | else if (trim(rough_scheme) == 'beljaars') then 141 | if (do_highwind) then ! Moon et al. formular 142 | ! --- SJL ---- High Wind correction following Moon et al 2007 ------ 143 | do j=1,size(speed,2) 144 | do i=1,size(speed,1) 145 | w10(i,j) = 2.458 + u_star(i,j)*(20.255-0.56*u_star(i,j)) ! Eq(7) Moon et al. 146 | if ( w10(i,j) > 12.5 ) then 147 | rough_mom(i,j) = 0.001*(0.085*w10(i,j) - 0.58) ! Eq(8b) Moon et al. 148 | ! SJL mods: cap the growth of z0 with w10 up to 40 m/s 149 | ! z0 (w10=40) = 2.82E-3 150 | if(do_cap40) rough_mom(i,j) = min( rough_mom(i,j), 2.82E-3) 151 | else 152 | rough_mom(i,j) = 0.0185/grav*u_star(i,j)**2 ! (8a) Moon et al. 153 | endif 154 | ! Ramp up the coefficient: 155 | zt1 = min( 1., (w10(i,j)-v10n)/(v10m-v10n) ) 156 | rough_heat (i,j) = zcoh1*zt1*xx2(i,j) + zcoh2 * xx1(i,j) 157 | rough_moist(i,j) = zcoq1*zt1*xx2(i,j) + zcoq2 * xx1(i,j) 158 | ! --- lower limit on roughness? --- 159 | rough_mom (i,j) = max( rough_mom (i,j), roughness_min ) 160 | rough_heat (i,j) = max( rough_heat (i,j), roughness_min ) 161 | rough_moist(i,j) = max( rough_moist(i,j), roughness_min ) 162 | enddo 163 | enddo 164 | ! SJL ----------------------------------------------------------------------------------- 165 | else 166 | rough_mom (:,:) = zcom1 * xx2(:,:) + zcom2 * xx1(:,:) 167 | rough_heat (:,:) = zcoh1 * xx2(:,:) + zcoh2 * xx1(:,:) 168 | rough_moist(:,:) = zcoq1 * xx2(:,:) + zcoq2 * xx1(:,:) 169 | ! --- lower limit on roughness? --- 170 | rough_mom (:,:) = max( rough_mom (:,:), roughness_min ) 171 | rough_heat (:,:) = max( rough_heat (:,:), roughness_min ) 172 | rough_moist(:,:) = max( rough_moist(:,:), roughness_min ) 173 | endif 174 | endif 175 | endif 176 | endif 177 | !----------------------------------------------------------------------- 178 | 179 | end subroutine compute_ocean_roughness 180 | 181 | !####################################################################### 182 | 183 | subroutine fixed_ocean_roughness ( speed, rough_mom, rough_heat, rough_moist ) 184 | 185 | real, intent(in) :: speed(:,:) 186 | real, intent(out) :: rough_mom(:,:), rough_heat(:,:), rough_moist(:,:) 187 | 188 | rough_mom = roughness_mom 189 | rough_heat = roughness_heat 190 | rough_moist = roughness_moist 191 | end subroutine fixed_ocean_roughness 192 | 193 | !####################################################################### 194 | 195 | subroutine ocean_rough_init(speed, z0, zt, zq) 196 | 197 | real, intent(in) :: speed(:,:) ! 10-m wind speed 198 | real, intent(out) :: z0(:,:), zt(:,:), zq(:,:) 199 | integer i,j 200 | integer :: unit, ierr, io 201 | 202 | do j=1, size(speed,2) 203 | do i=1, size(speed,1) 204 | if ( speed(i,j) > 12.5 ) then 205 | z0(i,j) = 0.001*(0.085*speed(i,j) - 0.58) 206 | else 207 | z0(i,j) = 0.0185/grav*(0.001*speed(i,j)**2+0.028*speed(i,j))**2 208 | endif 209 | z0(i,j) = max(z0(i,j), roughness_min) ! prevents blowup if cold start (V=0) 210 | zt(i,j) = z0(i,j) 211 | zq(i,j) = z0(i,j) 212 | enddo 213 | enddo 214 | 215 | do_init = .false. 216 | 217 | end subroutine ocean_rough_init 218 | 219 | end module ocean_rough_mod 220 | 221 | -------------------------------------------------------------------------------- /driver/solo/hswf.F90: -------------------------------------------------------------------------------- 1 | !*********************************************************************** 2 | !* GNU Lesser General Public License 3 | !* 4 | !* This file is part of the FV3 dynamical core. 5 | !* 6 | !* The FV3 dynamical core is free software: you can redistribute it 7 | !* and/or modify it under the terms of the 8 | !* GNU Lesser General Public License as published by the 9 | !* Free Software Foundation, either version 3 of the License, or 10 | !* (at your option) any later version. 11 | !* 12 | !* The FV3 dynamical core is distributed in the hope that it will be 13 | !* useful, but WITHOUT ANY WARRANTY; without even the implied warranty 14 | !* of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. 15 | !* See the GNU General Public License for more details. 16 | !* 17 | !* You should have received a copy of the GNU Lesser General Public 18 | !* License along with the FV3 dynamical core. 19 | !* If not, see . 20 | !*********************************************************************** 21 | 22 | module hswf_mod 23 | 24 | use constants_mod, only: grav, rdgas, cp_air, RADIAN, kappa, pi 25 | use fv_arrays_mod, only: radius ! scaled for small earth 26 | 27 | use fv_grid_utils_mod, only: g_sum 28 | use mpp_domains_mod, only: mpp_update_domains, domain2d 29 | use time_manager_mod, only: time_type, get_date, get_time 30 | use diag_manager_mod, only: send_data 31 | 32 | implicit none 33 | !----------------------------------------------------------------------- 34 | private 35 | public :: Held_Suarez_Tend, age_of_air 36 | 37 | contains 38 | 39 | !----------------------------------------------------------------------- 40 | 41 | subroutine Held_Suarez_Tend(npx, npy, npz, is, ie, js, je, ng, nq, & 42 | u, v, pt, q, pe, delp, peln, pkz, pdt, & 43 | ua, va, u_dt, v_dt, t_dt, q_dt, agrid, & 44 | delz, phis, hydrostatic, ak, bk, ks, & 45 | strat, zurita, rd_zur, master, Time, time_total) 46 | 47 | integer, INTENT(IN ) :: npx, npy, npz 48 | integer, INTENT(IN ) :: is, ie, js, je, ng, nq 49 | logical, intent(IN) :: hydrostatic 50 | real , INTENT(IN ) :: phis(is-ng:ie+ng,js-ng:je+ng) 51 | real , INTENT(IN ) :: delz(is:,js:,1:) 52 | real , INTENT(IN) :: pkz(is :ie ,js :je ,1:npz) 53 | 54 | real , INTENT(INOUT) :: u(is-ng:ie+ ng,js-ng:je+1+ng,npz) 55 | real , INTENT(INOUT) :: v(is-ng:ie+1+ng,js-ng:je+ ng,npz) 56 | real , INTENT(INOUT) :: pt(is-ng:ie+ ng,js-ng:je+ ng,npz) 57 | real , INTENT(INOUT) :: delp(is-ng:ie+ ng,js-ng:je+ ng,npz) 58 | real , INTENT(INOUT) :: q(is-ng:ie+ ng,js-ng:je+ ng,npz, nq) 59 | real , INTENT(INOUT) :: pe(is-1:ie+1 ,1:npz+1,js-1:je+1) 60 | real , INTENT(INOUT) :: peln(is :ie ,1:npz+1,js :je ) 61 | 62 | real , INTENT(INOUT) :: ua(is-ng:ie+ng,js-ng:je+ng,npz) 63 | real , INTENT(INOUT) :: va(is-ng:ie+ng,js-ng:je+ng,npz) 64 | 65 | ! Tendencies: 66 | real, INTENT(INOUT):: u_dt(is-ng:ie+ng,js-ng:je+ng,npz) 67 | real, INTENT(INOUT):: v_dt(is-ng:ie+ng,js-ng:je+ng,npz) 68 | real, INTENT(INOUT):: t_dt(is:ie,js:je,npz) 69 | real, INTENT(INOUT):: q_dt(is:ie,js:je,npz,nq) 70 | 71 | 72 | real , INTENT(IN ) :: agrid(is-ng:ie+ng,js-ng:je+ng, 2) 73 | real , INTENT(IN ) :: ak(npz+1), bk(npz+1) 74 | integer, INTENT(IN ) :: ks 75 | 76 | real , INTENT(IN ) :: pdt, rd_zur 77 | logical, INTENT(IN ) :: strat, zurita, master 78 | 79 | type(time_type), intent(in) :: Time 80 | real, INTENT(IN), optional:: time_total 81 | 82 | ! Local 83 | real, dimension(is:ie,npz):: teq, pl 84 | real, dimension(is:ie):: u1, v1 85 | integer i,j,k 86 | integer seconds, days 87 | real ty, tz, akap, rakap 88 | real p0, t0, sday, rkv, rka, rks, rkt, sigb, rsgb 89 | real tmp, solar_ang, solar_rate 90 | real ap0k, algpk 91 | real tey, tez, fac, pw, sigl 92 | real h0, dz 93 | real dt_tropic 94 | real rmr, rms 95 | real relx, tau 96 | real t_st, t_ms 97 | real rdt, f1 98 | real rad_ratio, kf_day 99 | real rd_zur_rad 100 | 101 | ty = 60.0 102 | tz = 10.0 ! Original value from H-S was 10. 103 | akap = 2./7. 104 | rakap = 1./akap 105 | 106 | p0 = 100000. 107 | t0 = 200. 108 | h0 = 7. 109 | sday = 24.*3600. 110 | rdt = 1. / pdt 111 | 112 | !-------------------------- 113 | rad_ratio = radius / 6371.0e3 114 | 115 | kf_day = sday * rad_ratio 116 | rkv = pdt / kf_day 117 | rka = pdt / (40.*kf_day) 118 | rks = pdt / (4.0*kf_day) 119 | 120 | ! For strat-mesosphere 121 | t_ms = 10.*rad_ratio 122 | t_st = 40.*rad_ratio 123 | 124 | tau = (t_st - t_ms) / log(100.) 125 | rms = pdt/(t_ms*sday) 126 | rmr = 1./(1.+rms) 127 | 128 | sigb = 0.7 129 | rsgb = 1./(1.-sigb) 130 | ap0k = 1./p0**akap 131 | algpk = log(ap0k) 132 | 133 | rd_zur_rad = rd_zur*pi/180. 134 | 135 | ! Temperature forcing... 136 | !$OMP parallel do default(none) shared(is,ie,js,je,npz,delp,peln,ap0k,ty,agrid,tz,akap, & 137 | !$OMP strat,h0,t_dt,pt,rms,rmr,rdt,t_ms,tau,pdt,sday,pe, & 138 | !$OMP sigb,rsgb,pkz,algpk,t0,rka,rks,rkv,u_dt,ua,v_dt,va,& 139 | !$OMP zurita,rd_zur_rad,rakap) & 140 | !$OMP private(pl, teq, tey, tez, dz, relx, dt_tropic, sigl, f1, rkt,tmp,u1,v1) 141 | do j=js,je 142 | do k=1,npz 143 | do i=is,ie 144 | pl(i,k) = delp(i,j,k) / ( peln(i,k+1,j)-peln(i,k,j)) 145 | enddo 146 | enddo 147 | do k=npz,1,-1 148 | do i=is,ie 149 | if (strat .and. pl(i,k) <= 1.E2) then 150 | ! Mesosphere: defined as the region above 1 mb 151 | dz = h0 * log(pl(i,k+1)/pl(i,k)) 152 | dt_tropic = -2.25*COS(agrid(i,j,2)) * dz 153 | teq(i,k) = teq(i,k+1) + dt_tropic 154 | t_dt(i,j,k) = t_dt(i,j,k) + ((pt(i,j,k)+rms*teq(i,k))*rmr - pt(i,j,k))*rdt 155 | ! Stratosphere: 156 | elseif (strat .and. pl(i,k)>1.E2 .and. pl(i,k)<=100.E2 ) then 157 | dz = h0 * log(pl(i,k+1)/pl(i,k)) 158 | ! Lapse rate above tropic stratopause is 2.25 deg/km 159 | ! Relaxation time is t_st days at 100 mb (as H-S) and gradually 160 | ! decreases to t_ms Days at and above the stratopause 161 | relx = t_ms + tau*log(0.01*pl(i,k)) 162 | relx = pdt/(relx*sday) 163 | dt_tropic = 2.25*COS(agrid(i,j,2)) * dz 164 | teq(i,k) = teq(i,k+1) + dt_tropic 165 | t_dt(i,j,k) = t_dt(i,j,k) + relx*(teq(i,k)-pt(i,j,k))/(1.+relx) * rdt 166 | else 167 | ! Troposphere: standard Held-Suarez 168 | sigl = pl(i,k)/pe(i,npz+1,j) 169 | f1 = max(0., (sigl-sigb) * rsgb ) 170 | if (zurita) then 171 | tmp = agrid(i,j,2)/rd_zur_rad 172 | tey = 1.0 - 0.19*(1.-exp(-tmp*tmp)) 173 | tmp = exp(akap*log(sigl)) 174 | tez = 0.1*(1.-tmp)*rakap 175 | tmp = tmp*315.0 176 | teq(i,k) = max(t0, tmp*(tey + tez)) 177 | !t_dt(i,j,k) = t_dt(i,j,k) + rka*(teq(i,k)-pt(i,j,k)) * rdt 178 | rkt = rka 179 | else 180 | tey = ap0k*( 315.0 - ty*SIN(agrid(i,j,2))*SIN(agrid(i,j,2)) ) 181 | tez = tz*( ap0k/akap )*COS(agrid(i,j,2))*COS(agrid(i,j,2)) 182 | tmp = tey - tez*(log(pkz(i,j,k))+algpk) 183 | teq(i,k) = max(t0, tmp*pkz(i,j,k)) 184 | rkt = rka + (rks-rka)*f1*(COS(agrid(i,j,2))**4.0) 185 | endif 186 | t_dt(i,j,k) = t_dt(i,j,k) + rkt*(teq(i,k)-pt(i,j,k))/(1.+rkt) * rdt 187 | ! Bottom friction: 188 | sigl = pl(i,k) / pe(i,npz+1,j) 189 | sigl = (sigl-sigb)*rsgb * rkv 190 | if (sigl > 0.) then 191 | tmp = sigl / (1.+sigl) * rdt 192 | u1(i) = ua(i,j,k) + u_dt(i,j,k) 193 | v1(i) = va(i,j,k) + v_dt(i,j,k) 194 | u_dt(i,j,k) = u_dt(i,j,k) - u1(i)*tmp 195 | v_dt(i,j,k) = v_dt(i,j,k) - v1(i)*tmp 196 | endif 197 | endif 198 | enddo !i-loop 199 | enddo !k-loop 200 | enddo !j-loop 201 | 202 | #ifdef DO_AGE 203 | if( nq/=0 ) & 204 | call age_of_air(is, ie, js, je, npz, ng, time_total, pe, q(is-ng,js-ng,1,nq)) 205 | #endif 206 | 207 | end subroutine Held_Suarez_Tend 208 | 209 | subroutine age_of_air(is, ie, js, je, km, ng, time, pe, q) 210 | 211 | integer is, ie, js, je 212 | integer km 213 | integer ng 214 | 215 | ! q is the age tracer 216 | ! Need to be converted to mixing ratio (mass of tracer / dry_air-mass) 217 | ! Ignore this inconsistency for now. 218 | 219 | real, intent(inout):: pe(is-1:ie+1, km+1, js-1:je+1) 220 | real, intent(in):: time ! accumulated time since init 221 | real, intent(inout):: q(is-ng:ie+ng,js-ng:je+ng,km) 222 | 223 | ! Local 224 | integer i, j, k 225 | real p_source ! source level (pa) 226 | real ascale 227 | real tiny 228 | parameter ( tiny = 1.e-6 ) 229 | parameter ( p_source = 75000. ) 230 | parameter ( ascale = 5.e-6 / 60. ) 231 | 232 | !$OMP parallel do default(none) shared(is,ie,js,je,km,time,q,pe) 233 | do k=1,km 234 | do j=js,je 235 | do i=is,ie 236 | if( time < tiny ) then 237 | q(i,j,k) = 0. 238 | elseif( pe(i,k,j) >= p_source ) then 239 | q(i,j,k) = ascale * time 240 | endif 241 | enddo 242 | enddo ! j-loop 243 | enddo ! k-loop 244 | 245 | end subroutine age_of_air 246 | 247 | end module hswf_mod 248 | -------------------------------------------------------------------------------- /tools/fv_timing.F90: -------------------------------------------------------------------------------- 1 | !*********************************************************************** 2 | !* GNU Lesser General Public License 3 | !* 4 | !* This file is part of the FV3 dynamical core. 5 | !* 6 | !* The FV3 dynamical core is free software: you can redistribute it 7 | !* and/or modify it under the terms of the 8 | !* GNU Lesser General Public License as published by the 9 | !* Free Software Foundation, either version 3 of the License, or 10 | !* (at your option) any later version. 11 | !* 12 | !* The FV3 dynamical core is distributed in the hope that it will be 13 | !* useful, but WITHOUT ANY WARRANTY; without even the implied warranty 14 | !* of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. 15 | !* See the GNU General Public License for more details. 16 | !* 17 | !* You should have received a copy of the GNU Lesser General Public 18 | !* License along with the FV3 dynamical core. 19 | !* If not, see . 20 | !*********************************************************************** 21 | 22 | module fv_timing_mod 23 | 24 | use mpp_mod, only: mpp_error, FATAL 25 | #if defined(SPMD) 26 | use fv_mp_mod, only: is_master, mp_reduce_max 27 | #endif 28 | ! 29 | ! ... Use system etime() function for timing 30 | ! 31 | implicit none 32 | 33 | integer, private :: nblks 34 | parameter (nblks = 100) 35 | 36 | character(len=20), private :: blkname(nblks) 37 | 38 | integer , private :: tblk 39 | 40 | #if defined(SPMD) 41 | real(kind=8) , external :: MPI_Wtime 42 | #endif 43 | real , private :: etime 44 | real(kind=8) , private :: totim 45 | real , private :: tarray(2) 46 | type tms 47 | private 48 | real (kind=8) :: usr, sys 49 | end type tms 50 | 51 | 52 | type (tms), private :: accum(nblks), last(nblks) 53 | 54 | real , private :: us_tmp1(nblks,2) 55 | real , private :: us_tmp2(nblks,2) 56 | 57 | logical, private :: module_initialized = .false. 58 | 59 | contains 60 | subroutine timing_init 61 | ! 62 | ! init 63 | ! 64 | implicit none 65 | 66 | integer :: C, R, M 67 | real (kind=8) :: wclk 68 | 69 | integer n 70 | 71 | if ( module_initialized ) return 72 | 73 | tblk=0 74 | do n = 1, nblks 75 | accum(n)%usr = 0. 76 | accum(n)%sys = 0. 77 | last(n)%usr = 0. 78 | last(n)%sys = 0. 79 | end do 80 | ! 81 | ! ... To reduce the overhead for the first call 82 | ! 83 | #if defined(SPMD) 84 | wclk = MPI_Wtime() 85 | totim = wclk 86 | #else 87 | # if defined( IRIX64 ) || ( defined FFC ) 88 | totim = etime(tarray) 89 | # else 90 | CALL SYSTEM_CLOCK(Count=C, Count_Rate=R, Count_Max=M) 91 | wclk = REAL(C) / REAL(R) 92 | totim = wclk 93 | # endif 94 | #endif 95 | 96 | module_initialized = .true. 97 | end subroutine timing_init 98 | 99 | 100 | subroutine timing_on(blk_name) 101 | ! 102 | ! timing_on 103 | ! 104 | 105 | implicit none 106 | 107 | character(len=*) :: blk_name 108 | 109 | 110 | 111 | character(len=20) :: UC_blk_name 112 | character(len=20) :: ctmp 113 | integer i 114 | integer iblk 115 | 116 | integer :: C, R, M 117 | real (kind=8) :: wclk 118 | 119 | integer ierr 120 | 121 | if ( .not. module_initialized ) then 122 | call timing_init() 123 | end if 124 | 125 | UC_blk_name = blk_name 126 | 127 | call upper(UC_blk_name,len_trim(UC_blk_name)) 128 | !c ctmp=UC_blk_name(:len_trim(UC_blk_name)) 129 | ctmp=trim(UC_blk_name) 130 | 131 | ! write(*,*) 'timing_on ', ctmp 132 | iblk=0 133 | do i=1, tblk 134 | if ( ctmp .EQ. blkname(i) ) then 135 | iblk =i 136 | endif 137 | enddo 138 | 139 | if ( iblk .eq. 0 ) then 140 | tblk=tblk+1 141 | iblk=tblk 142 | call upper(UC_blk_name,len_trim(UC_blk_name)) 143 | !C blkname(iblk)=UC_blk_name(:len_trim(UC_blk_name)) 144 | blkname(iblk)=trim(UC_blk_name) 145 | 146 | endif 147 | 148 | #if defined(SPMD) 149 | wclk = MPI_Wtime() 150 | last(iblk)%usr = wclk 151 | last(iblk)%sys = 0.0 152 | #else 153 | # if defined( IRIX64 ) || ( defined FFC ) 154 | totim = etime(tarray) 155 | last(iblk)%usr = tarray(1) 156 | last(iblk)%sys = tarray(2) 157 | # else 158 | CALL SYSTEM_CLOCK(Count=C, Count_Rate=R, Count_Max=M) 159 | wclk = REAL(C) / REAL(R) 160 | last(iblk)%usr = wclk 161 | last(iblk)%sys = 0.0 162 | # endif 163 | #endif 164 | 165 | end subroutine timing_on 166 | 167 | 168 | subroutine timing_off(blk_name) 169 | ! 170 | ! Timing_off 171 | ! 172 | 173 | implicit none 174 | character(len=*) :: blk_name 175 | 176 | character(len=20) :: UC_blk_name 177 | character(len=20) :: ctmp 178 | integer i 179 | 180 | integer :: C, R, M 181 | real (kind=8) :: wclk 182 | 183 | integer iblk 184 | 185 | UC_blk_name = blk_name 186 | 187 | call upper(UC_blk_name,len_trim(UC_blk_name)) 188 | !v ctmp=UC_blk_name(:len_trim(UC_blk_name)) 189 | ctmp=trim(UC_blk_name) 190 | 191 | iblk=0 192 | do i=1, tblk 193 | if ( ctmp .EQ. blkname(i) ) then 194 | iblk =i 195 | endif 196 | enddo 197 | 198 | ! write(*,*) 'timing_off ', ctmp, tblk, tblk 199 | if ( iblk .eq. 0 ) then 200 | call mpp_error(FATAL,'fv_timing_mod: timing_off called before timing_on for: '//trim(blk_name)) 201 | ! write(*,*) 'stop in timing off in ', ctmp 202 | ! stop 203 | endif 204 | 205 | #if defined(SPMD) 206 | wclk = MPI_Wtime() 207 | accum(iblk)%usr = accum(iblk)%usr + wclk - last(iblk)%usr 208 | accum(iblk)%sys = 0.0 209 | last(iblk)%usr = wclk 210 | last(iblk)%sys = 0.0 211 | #else 212 | # if defined( IRIX64 ) || ( defined FFC ) 213 | totim = etime(tarray) 214 | accum(iblk)%usr = accum(iblk)%usr + & 215 | tarray(1) - last(iblk)%usr 216 | accum(iblk)%sys = accum(iblk)%sys + & 217 | tarray(2) - last(iblk)%sys 218 | last(iblk)%usr = tarray(1) 219 | last(iblk)%sys = tarray(2) 220 | # else 221 | CALL SYSTEM_CLOCK(Count=C, Count_Rate=R, Count_Max=M) 222 | wclk = REAL(C) / REAL(R) 223 | accum(iblk)%usr = accum(iblk)%usr + wclk - last(iblk)%usr 224 | accum(iblk)%sys = 0.0 225 | last(iblk)%usr = wclk 226 | last(iblk)%sys = 0.0 227 | # endif 228 | #endif 229 | end subroutine timing_off 230 | 231 | 232 | subroutine timing_clear() 233 | integer n 234 | do n = 1, nblks 235 | accum(n)%usr = 0 236 | accum(n)%sys = 0 237 | enddo 238 | end subroutine timing_clear 239 | 240 | 241 | subroutine timing_prt(gid) 242 | ! 243 | ! Timing_prt 244 | ! 245 | implicit none 246 | integer gid 247 | integer n 248 | 249 | type (tms) :: others, tmp(nblks) 250 | real :: tmpmax 251 | 252 | #if defined( SPMD ) 253 | do n = 1, nblks !will clean these later 254 | tmpmax = accum(n)%usr 255 | call mp_reduce_max(tmpmax) 256 | tmp(n)%usr = tmpmax 257 | tmpmax = accum(n)%sys 258 | call mp_reduce_max(tmpmax) 259 | tmp(n)%sys = tmpmax 260 | enddo 261 | if ( is_master() ) then 262 | #else 263 | do n = 1, nblks 264 | tmp(n)%usr = accum(n)%usr 265 | tmp(n)%sys = accum(n)%sys 266 | enddo 267 | #endif 268 | 269 | print * 270 | print *, & 271 | ' ---------------------------------------------------------------------' 272 | print *, & 273 | ' Block User time System Time Total Time GID' 274 | print *, & 275 | ' ---------------------------------------------------------------------' 276 | 277 | do n = 1, tblk 278 | print '(3x,a20,2x,3(1x,f12.4), 2x, I6)', blkname(n), & 279 | tmp(n)%usr, tmp(n)%sys, tmp(n)%usr + tmp(n)%sys, gid 280 | end do 281 | 282 | 283 | print * 284 | #if defined( SPMD ) 285 | endif ! masterproc 286 | #endif 287 | 288 | end subroutine timing_prt 289 | 290 | subroutine upper(string,length) 291 | 292 | !*********************************************************************** 293 | ! 294 | ! upper.f - change lower case letter to upper case letter * 295 | ! * 296 | ! George Lai Tue Jun 28 16:37:00 1994 * 297 | ! * 298 | !*********************************************************************** 299 | 300 | implicit none 301 | 302 | ! character string(length) 303 | ! character(len=20) string 304 | ! character, dimension(length) :: string 305 | ! character (len=*), intent(inout) :: string 306 | ! character (len=*) :: string 307 | ! character (len=1), intent(inout) :: string(20) 308 | !ok character (len=20), intent(inout) :: string 309 | character (len=*), intent(inout) :: string 310 | character char1 311 | integer, intent(in) :: length 312 | integer i 313 | integer a, z, dist 314 | a = ichar('a') 315 | z = ichar('z') 316 | dist = ichar('A') - a 317 | 318 | do i = 1,length 319 | char1=string(i:i) 320 | if (ichar(char1) .ge. a .and. & 321 | ichar(char1) .le. z) then 322 | string(i:i) = char(ichar(char1)+dist) 323 | endif 324 | end do 325 | 326 | return 327 | end subroutine upper 328 | 329 | end module fv_timing_mod 330 | -------------------------------------------------------------------------------- /tools/statistics.F90: -------------------------------------------------------------------------------- 1 | !*********************************************************************** 2 | !* GNU Lesser General Public License 3 | !* 4 | !* This file is part of the FV3 dynamical core. 5 | !* 6 | !* The FV3 dynamical core is free software: you can redistribute it 7 | !* and/or modify it under the terms of the 8 | !* GNU Lesser General Public License as published by the 9 | !* Free Software Foundation, either version 3 of the License, or 10 | !* (at your option) any later version. 11 | !* 12 | !* The FV3 dynamical core is distributed in the hope that it will be 13 | !* useful, but WITHOUT ANY WARRANTY; without even the implied warranty 14 | !* of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. 15 | !* See the GNU General Public License for more details. 16 | !* 17 | !* You should have received a copy of the GNU Lesser General Public 18 | !* License along with the FV3 dynamical core. 19 | !* If not, see . 20 | !*********************************************************************** 21 | 22 | module statistics_mod 23 | 24 | implicit none 25 | 26 | interface mode 27 | module procedure mode_1d_real4 28 | module procedure mode_2d_real4 29 | module procedure masked_mode_2d_real4 30 | module procedure mode_1d_real8 31 | module procedure mode_2d_real8 32 | module procedure masked_mode_2d_real8 33 | end interface mode 34 | 35 | contains 36 | 37 | ! qksrt implementation copied and adapted for real arrays from implementation 38 | ! in FMS: FMS/drifters/quicksort.F90 39 | function qksrt_partition_real4(n, list, start, end) result(top) 40 | implicit none 41 | integer, intent(in) :: n 42 | real(kind=4), intent(inout) :: list(n) 43 | integer, intent(in) :: start, end 44 | 45 | real(kind=4) :: pivot 46 | integer :: bottom, top 47 | logical :: done 48 | 49 | pivot = list(end) ! Partition around the last value 50 | bottom = start-1 ! Start outside the area to be partitioned 51 | top = end ! Ditto 52 | 53 | done = .false. 54 | do while (.not. done) ! Until all elements are partitioned... 55 | 56 | do while (.not. done) ! Until we find an out of place element... 57 | bottom = bottom+1 ! ... move the bottom up. 58 | 59 | if(bottom == top) then ! If we hit the top... 60 | done = .true. ! ... we are done. 61 | exit 62 | endif 63 | 64 | if(list(bottom) > pivot) then ! Is the bottom out of place? 65 | list(top) = list(bottom) ! Then put it at the top... 66 | exit ! ... and start searching from the top. 67 | endif 68 | enddo 69 | 70 | do while (.not. done) ! Until we find an out of place element... 71 | top = top-1 ! ... move the top down. 72 | 73 | if(top == bottom) then ! If we hit the bottom... 74 | done = .true. ! ... we are done. 75 | exit 76 | endif 77 | 78 | if(list(top) < pivot) then ! Is the top out of place? 79 | list(bottom) = list(top) ! Then put it at the bottom... 80 | exit ! ...and start searching from the bottom. 81 | endif 82 | enddo 83 | enddo 84 | 85 | list(top) = pivot ! Put the pivot in its place. 86 | ! Return the split point 87 | end function qksrt_partition_real4 88 | 89 | recursive subroutine qksrt_quicksort_real4(n, list, start, end) 90 | implicit none 91 | integer, intent(in) :: n 92 | real(kind=4), intent(inout) :: list(n) 93 | integer, intent(in) :: start, end 94 | integer :: split 95 | 96 | if(start < end) then ! If there are two or more elements... 97 | split = qksrt_partition_real4(n, list, start, end) ! ... partition the sublist... 98 | call qksrt_quicksort_real4(n, list, start, split-1) ! ... and sort both halves. 99 | call qksrt_quicksort_real4(n, list, split+1, end) 100 | endif 101 | end subroutine qksrt_quicksort_real4 102 | 103 | ! This procedure produces the same results as scipy.stats.mode; if there is a 104 | ! tie in counts, the minimum mode value is returned. 105 | function mode_1d_real4(array) 106 | real(kind=4), dimension(:), intent(in) :: array 107 | 108 | real(kind=4) :: mode_1d_real4 109 | 110 | integer :: i, run, max_run 111 | real(kind=4), dimension(size(array)) :: sorted_array 112 | 113 | run = 1 114 | max_run = 0 115 | 116 | sorted_array = array 117 | call qksrt_quicksort_real4(size(sorted_array), sorted_array, 1, size(sorted_array)) 118 | 119 | if (size(sorted_array) == 1) then 120 | mode_1d_real4 = sorted_array(1) 121 | else 122 | do i = 2, size(sorted_array) 123 | if (sorted_array(i) == sorted_array(i - 1)) then 124 | run = run + 1 125 | else 126 | run = 1 127 | endif 128 | if (run > max_run) then 129 | max_run = run 130 | mode_1d_real4 = sorted_array(i - 1) 131 | endif 132 | enddo 133 | endif 134 | end function mode_1d_real4 135 | 136 | function mode_2d_real4(array) 137 | real(kind=4), dimension(:,:), intent(in) :: array 138 | 139 | real(kind=4) :: mode_2d_real4 140 | 141 | mode_2d_real4 = mode_1d_real4(pack(array, .true.)) 142 | end function mode_2d_real4 143 | 144 | function masked_mode_2d_real4(array, mask) 145 | real(kind=4), dimension(:,:), intent(in) :: array 146 | logical, dimension(:,:), intent(in) :: mask 147 | real(kind=4) :: masked_mode_2d_real4 148 | 149 | masked_mode_2d_real4 = mode_1d_real4(pack(array, mask)) 150 | end function masked_mode_2d_real4 151 | 152 | ! qksrt implementation copied and adapted for real arrays from implementation 153 | ! in FMS: FMS/drifters/quicksort.F90 154 | function qksrt_partition_real8(n, list, start, end) result(top) 155 | implicit none 156 | integer, intent(in) :: n 157 | real(kind=8), intent(inout) :: list(n) 158 | integer, intent(in) :: start, end 159 | 160 | real(kind=8) :: pivot 161 | integer :: bottom, top 162 | logical :: done 163 | 164 | pivot = list(end) ! Partition around the last value 165 | bottom = start-1 ! Start outside the area to be partitioned 166 | top = end ! Ditto 167 | 168 | done = .false. 169 | do while (.not. done) ! Until all elements are partitioned... 170 | 171 | do while (.not. done) ! Until we find an out of place element... 172 | bottom = bottom+1 ! ... move the bottom up. 173 | 174 | if(bottom == top) then ! If we hit the top... 175 | done = .true. ! ... we are done. 176 | exit 177 | endif 178 | 179 | if(list(bottom) > pivot) then ! Is the bottom out of place? 180 | list(top) = list(bottom) ! Then put it at the top... 181 | exit ! ... and start searching from the top. 182 | endif 183 | enddo 184 | 185 | do while (.not. done) ! Until we find an out of place element... 186 | top = top-1 ! ... move the top down. 187 | 188 | if(top == bottom) then ! If we hit the bottom... 189 | done = .true. ! ... we are done. 190 | exit 191 | endif 192 | 193 | if(list(top) < pivot) then ! Is the top out of place? 194 | list(bottom) = list(top) ! Then put it at the bottom... 195 | exit ! ...and start searching from the bottom. 196 | endif 197 | enddo 198 | enddo 199 | 200 | list(top) = pivot ! Put the pivot in its place. 201 | ! Return the split point 202 | end function qksrt_partition_real8 203 | 204 | recursive subroutine qksrt_quicksort_real8(n, list, start, end) 205 | implicit none 206 | integer, intent(in) :: n 207 | real(kind=8), intent(inout) :: list(n) 208 | integer, intent(in) :: start, end 209 | integer :: split 210 | 211 | if(start < end) then ! If there are two or more elements... 212 | split = qksrt_partition_real8(n, list, start, end) ! ... partition the sublist... 213 | call qksrt_quicksort_real8(n, list, start, split-1) ! ... and sort both halves. 214 | call qksrt_quicksort_real8(n, list, split+1, end) 215 | endif 216 | end subroutine qksrt_quicksort_real8 217 | 218 | ! This procedure produces the same results as scipy.stats.mode; if there is a 219 | ! tie in counts, the minimum mode value is returned. 220 | function mode_1d_real8(array) 221 | real(kind=8), dimension(:), intent(in) :: array 222 | 223 | real(kind=8) :: mode_1d_real8 224 | 225 | integer :: i, run, max_run 226 | real(kind=8), dimension(size(array)) :: sorted_array 227 | 228 | run = 1 229 | max_run = 0 230 | 231 | sorted_array = array 232 | call qksrt_quicksort_real8(size(sorted_array), sorted_array, 1, size(sorted_array)) 233 | 234 | if (size(sorted_array) == 1) then 235 | mode_1d_real8 = sorted_array(1) 236 | else 237 | do i = 2, size(sorted_array) 238 | if (sorted_array(i) == sorted_array(i - 1)) then 239 | run = run + 1 240 | else 241 | run = 1 242 | endif 243 | if (run > max_run) then 244 | max_run = run 245 | mode_1d_real8 = sorted_array(i - 1) 246 | endif 247 | enddo 248 | endif 249 | end function mode_1d_real8 250 | 251 | function mode_2d_real8(array) 252 | real(kind=8), dimension(:,:), intent(in) :: array 253 | 254 | real(kind=8) :: mode_2d_real8 255 | 256 | mode_2d_real8 = mode_1d_real8(pack(array, .true.)) 257 | end function mode_2d_real8 258 | 259 | function masked_mode_2d_real8(array, mask) 260 | real(kind=8), dimension(:,:), intent(in) :: array 261 | logical, dimension(:,:), intent(in) :: mask 262 | real(kind=8) :: masked_mode_2d_real8 263 | 264 | masked_mode_2d_real8 = mode_1d_real8(pack(array, mask)) 265 | end function masked_mode_2d_real8 266 | end module statistics_mod 267 | -------------------------------------------------------------------------------- /RELEASE.md: -------------------------------------------------------------------------------- 1 | # RELEASE NOTES for FV3 202411: Summary 2 | FV3-202411-public --- November 2024 3 | Primary Point of Contact: Lucas Harris, GFDL lucas.harris@noaa.gov 4 | 5 | This version has been tested with: 6 | SHiELD physics release FV3-202411-public from https://github.com/NOAA-GFDL/SHiELD_physics 7 | FMS release 2024.03 from https://github.com/NOAA-GFDL/FMS 8 | FMS Coupler release 2024.03.01 from https://github.com/NOAA-GFDL/FMScoupler 9 | Atmos Drivers release FV3-202411-public from https://github.com/NOAA-GFDL/atmos_drivers 10 | 11 | This release includes the following: 12 | - Numerics updates (Lucas, Joseph, Linjiong): 13 | - Removed `USE_COND` and `MOIST_CAPPA` compiler directives and replaced with runtime options `use_cond` and `moist_kappa` in the new namelist `fv_thermo_nml`. Both default to `.T.` in nonhydrostatic simulation and `.F.` in hydrostatic. 14 | - Added a simple limiter to prevent dissipative heating from creating spurious cooling. Set `prevent_diss_cooling = .F.` to turn off. 15 | - Fixed bugs in hydrostatic nesting for west and east BCs in `setup_pt_BC_k()` and calculated true pressure in BCs if no BC remapping is done (compute_peBC, compute_peBC_k). 16 | - Revision of `Lagrangian_to_Eulerian` to fix variable dimension mismatch. 17 | - Revision of FV3's dissipation heating `diss_est` option to improve numerical consistency with other dissipation options. 18 | - Fixed edge noise for hord 6 and 7 (suggested by Bill Putman, GMAO). 19 | - Add mixed precision compilation mode to support 32bit FV3 with other 64bit components (with Uriel Ramirez). 20 | - New tracers: 21 | - `w_diff` to allow subgrid mixing of vertical velocity by physics. This requires compiling with the option `-DW_DIFF` to enable. 22 | - `pbl_age` and `tro_pbl_age` tracers representing the age of air since leaving the PBL and tropical PBL, respectively. 23 | - Removed obsolete clock tracers 24 | - Refer to `docs/HOWTO_tracer-2024.11.md` for more information 25 | - GFDL Microphysics updates (Linjiong) 26 | - Included fast microphysics tendencies diagnostics 27 | - Added two namelist options (`fast_fr_mlt` and `fast_dep_sub`) to control freezing/melting and deposition/sublimation in the fast microphysics. 28 | - Included a missing term in the energy conservation formula (credit: Tristan Abbott). May affect prediction of processes depending strongly on microphysics. Compile the model with `-DENG_CNV_OLD` to revert this change. 29 | - Added a namelist option, `prog_cin`, to define the source of CIN (cloud ice nuclei) concentration. This is similar to `prog_ccn` but for ice nuclei. 30 | - Added diagnostics for cloud content and cloud effective radii of all cloud hydrometeors (qc*, re*). 31 | - Added diagnostics for microphysical process rates (mpp*). 32 | - Removed unused Keihl et al. (1994) cloud water effective radius diagnosis 33 | - Driver update (Joseph): 34 | - Implemented a new atmosphere driver to run SHiELD and SHiEMOM with the full FMScoupler. 35 | - Updates to $2\delta z$ filter (fv_sg) (Lucas, Linjiong): 36 | - Included a missing term in the energy conservation formula (credit: Tristan Abbott). May affect prediction of processes depending strongly on microphysics. Compile the model with `-DENG_CNV_OLD` to revert this change. 37 | - Added option, `fv_sg_adj_weak`, to apply a weaker 2dz filter below sg_cutoff. This may be useful in controlling tropospheric instabilities without interfering with the behavior of the PBL scheme. 38 | - Renamed routines and eliminated ifdefs for SHiELD vs. AM4 versions. 39 | - Physics interface updates (Linjiong, Kai, Spencer): 40 | - Fixed negative tracers in the dynamics-physics interface. 41 | - Enhanced the fill_gfs function to remove negative tracers. 42 | - Enabled data_override for nest domain 43 | - Fixed a precipitation diagnostic issue when `ntimes > 1` in the GFDL MP. 44 | - MPI fix for sedimentation mass transport in GFDL MP. 45 | - Updates to nudging (Lucas): 46 | - Added an option to turn TC breeding off. 47 | - Bugfixes for nudging on a nest/regional domain (in which tendencies in the halo are undefined). 48 | - Coarse-graining updates (Spencer, Kai): 49 | - Added options `strategy = 'pressure_level_extrapolate' ’blended_area_weighted’` (developed with support from Chris Bretherton, AI2), and simplest `model_level_area_weighted` (like FREgrid first-order conservative scheme). 50 | - Renamed `model_level` strategy to `model_level_mass_weighted`. 51 | - Coarse-grained plev diagnostics for u, v, w, omega, vorticity, height, temperature, tracers, and RH. 52 | - Coarse-grained plev diagnostics use plevs defined in coarse-grained plev diagnostics for `fv_diag_plevs_nml` 53 | - OpenMP multi-threaded calculations 54 | - Code refactors (Lucas): 55 | - Cleaned up `external_ic_nml` and `fv_surf_map_nml`. 56 | - Cleaned up `fv_mapz.F90` to move vertical remapping operators and thermodynamics/energetics routines into their own modules 57 | - Diagnostics (Lucas, Linjiong, Kai, Spencer): 58 | - Fixes for nudging and fv_sg diagnostics 59 | - Cleaned up fv_diagnostics stdout messages 60 | - True instantaneous and timestep-mean divergence and dissipative heating. 61 | - 40 dBz reflectivity height diagnostic. 62 | - Dissipative heating and dissipation estimate as, even if stochastic physics isn't enabled. 63 | - Introduced a flag `PRT_LEVEL` (now hard-coded) to control which min/max fields are written to stdout. 64 | - Fixed a bug for CAPE/CIN/BRN when nonhydrostatic pressure perturbation is also being output. 65 | - Refactor of plev and standard pressure level diagnostics, added new variables (vort, theta, theta_e, w, RH, dew point) to plevs, and removed unnecessary arguments to cs3_interpolator 66 | - Deprecated/removed options (Lucas): 67 | - Removed outdated options: scale_z, w_max, w_limiter, z_min, d2_divg_max_k[12], damp_k_k[12], old_divg_damp, do_am4_remap, use_new_ncep, use_ncep_phy, a2b_ord, c2l_ord. 68 | - Interpolation from cell-means to corner values (a2b) and from local staggered winds to A-grid lat-lon winds, have been hard-coded to be fourth-order, except where it had previously been hard-coded to be second-order. Supporting codes have been cleaned up. 69 | - Deprecation notice for conserve_ke 70 | - Added warning messages for poorly-chosen advection scheme options (hord_xx), and a FATAL is thrown for invalid scheme choices. 71 | 72 | 73 | # RELEASE NOTES for FV3 202305: Summary 74 | FV3-202305-public --- May 2023 75 | Lucas Harris, GFDL lucas.harris@noaa.gov 76 | 77 | This version has been tested with SHiELD physics release 202305 78 | and with FMS release 2023.01 from https://github.com/NOAA-GFDL/FMS 79 | 80 | - Revised Vertical Remapping Operators (Lucas) 81 | - kord=10 reverted back to AM4 version. 82 | - Post-AM4 version of kord=10 is now kord=12. 83 | - do_am4_remap no longer does anything and is deprecated. 84 | - New strictly-monotone operators kord=14, 15 for improving tracer correlations, and kord=13 without subgrid limiting. 85 | - kord <= 7 now deprecated; may be removed in a future release. 86 | - New Test Cases: (Joseph, Kun, Lucas) 87 | - Idealized TC test case with SHiELD physics 88 | - Zurita-Gotor et al. 2022 Held-Suarez variant 89 | - New Stable Boundary Layer (Beale at al.) doubly-periodic test case 90 | - New nesting updates: (Joseph) 91 | - Enable nesting in solo core and add a new idealized test case (58) 92 | - Enable adding multiple nests in doubly-periodic test cases using absolute coordinates 93 | - Additional idealized capability (Linjiong, Kun, Lucas) 94 | - Added namelist variable is_ideal_case, which must be used for runs starting (or re-starting) from idealized states. 95 | - Begin saving the initial wind fields (u0 and v0) to the restart files 96 | - GFDL MP and Integrated Physics (Linjiong): 97 | - Added options to sub-cycling condensation evaporation (nconds), control timescale or evaporation (do_evap_timescale), and delay condensation and evaporation (delay_cond_evap) 98 | - Removed unused 3d microphysics diagnostics to save time and memory 99 | - Optimized the mpp domain updates for fast physics 100 | - Update gfdl_mp_nml reading code to avoid model crash for absent gfdl_mp_nml 101 | - Added an option (do_intermediate_phys) to disable intermediate phys 102 | - Removed grid size in GFDL MP energy and mass calculation 103 | - Updates to use dry_cp instead of moist_cp in a hydrostatic case 104 | - Added a function to use O3 data from IFS ICs (Jan-Huey) 105 | - Namelist parameter: “use_gfsO3” with the default value = “false” 106 | - This function only works when ecmwf_ic = T 107 | - If the IFS IC does not include O3 data, or the run would like to use GFS O3 with other IFS ICs, set use_gfsO3 = T 108 | - Solver Updates (Lucas) 109 | - Revised semi-implicit solver to partially linearize vertical sound wave propagation about the hydrostatic state. This removes a specific instability causing deep “columnar” modes in the vertical velocity field due to the equation for the pressure perturbation being updated partially forward-in-time. This removes the spurious modes, reduces vertical velocities, and makes the solver slightly more stable. 110 | - MPI bug fix for tracer diffusion 111 | - Fast Rayleigh Damping on w controlled by fast_tau_w_sec. 112 | 113 | 114 | # RELEASE NOTES for FV3 202210: Summary 115 | FV3-202210-public --- October 2022 116 | Lucas Harris, GFDL lucas.harris@noaa.gov 117 | 118 | This version has been tested with SHiELD physics release 202210 119 | and with FMS release 2022.03 from https://github.com/NOAA-GFDL/FMS 120 | 121 | This release includes the following: 122 | - Release of the GFDL Microphysics Version 3 123 | - Fix pressure-coarse-graining weighting from AI2's fork of FV3GFS 124 | - Add A-grid restart functionality from AI2's fork of FV3GFS 125 | - Fix for telescoping nest and GFS FIX file read 126 | - Total precipitation diag field has changed from prec to pret 127 | - Clean-up of the diagnostic messages to stdout 128 | 129 | 130 | # RELEASE NOTES for FV3 202204: Summary 131 | FV3-202204-public --- April 2022 132 | Lucas Harris, GFDL lucas.harris@noaa.gov 133 | 134 | This version has been tested against the current SHiELD physics 135 | and with FMS release 2022.01 from https://github.com/NOAA-GFDL/FMS 136 | 137 | This release includes the following: 138 | - Release of stand-alone solo_core functionality with simple physics. 139 | - Updated GFDL Microphysics, used for real-time 2021 C-SHiELD and T-SHiELD. (L Zhou) 140 | - Merges numerous updates from dev/emc. 141 | - Leverage DA functionality from UFS with additional changes (M Tong). 142 | - Updates to use the latest FMS release, including fms2_io. 143 | - Adds license header to missing files and fixes typo in header. 144 | - Fixes a bug where long_name and units attributes were not being captured in restart files. 145 | - Adds the ability to specify prefix and directory when reading and writing restarts. 146 | - The planetary radius and rotation rate are now re-scalable by a namelist parameter (small_earth_scale) instead of using exclusively the hard-coded FMS constant. 147 | - Removes obsolete driver/SHiELD files. 148 | - Removes unused function fv_diagnostics::max_vorticity_hy1. 149 | - Removes avec timer remnants. 150 | - Removes old style namelist read in favor of read from internal character variable. 151 | - Adds option for a mean wind. 152 | - Addresses GNU warnings. 153 | 154 | 155 | # RELEASE NOTES for FV3 202107: Summary 156 | 157 | FV3-202107-public --- 08 July 2021 158 | Lucas Harris, GFDL lucas.harris@noaa.gov 159 | 160 | This version has been tested against the current SHiELD physics 161 | and with FMS release 2021.02 from https://github.com/NOAA-GFDL/FMS 162 | 163 | This release includes the following: 164 | 165 | - Comprehensive documentation in LaTEX format (FV3 team) 166 | - Default changes to some namelist options and updated inline documentation 167 | - Multiple same-level and telescoping nests for the Regional domain (J Mouallem) 168 | - Updated fms2_io functionality (L Chilutti) 169 | - Revised Regional domain code (K-Y Cheng) 170 | - Reproducibility fixes for global+nests and regional+nests (tested for absolute reproducibility across PE counts, restarts) 171 | - Other updates and general cleanup 172 | 173 | 174 | # RELEASE NOTES for FV3 202101: Summary 175 | 176 | FV3-202101-public --- 22 January 2021 177 | Lucas Harris, GFDL 178 | 179 | This version has been tested against the current SHiELD (formerly fvGFS) physics 180 | and with FMS release candidate 2020.04 from https://github.com/NOAA-GFDL/FMS 181 | 182 | This release includes the following: 183 | 184 | - Positive-definite advection scheme 185 | - In-line GFDL Microphysics 186 | - Fast-timescale Rayleigh damping 187 | - Updated namelist documentation 188 | - Implemented multiple same-level and telescoping nests for the global system (J Mouallem) 189 | - Updated coarse-graining capabilities (S Clark) 190 | - Re-organized fv_diagnostics, moving the revised fv_diag_column functionality and the declaration of diagnostic IDs to separate files 191 | - and other updates and general cleanup 192 | 193 | This version of FV3 is described as component of SHiELD in Harris et al. (2020, JAMES). 194 | 195 | ## Interface changes in 202101 196 | 197 | atmosphere.F90: if using the in-line GFDL microphysics the precipitation rates (available in the structure Atm%inline_mp for rain, ice, snow, and graupel separately) must be passed into the physics and/or land model as appropriate. Here we demonstrate how to do this in SHiELD by copying them into IPD_Data(nb)%Statein%prep (and so on), which are newly defined in the IPD_Data structure within the SHiELD physics. 198 | 199 | 200 | # RELEASE NOTES for FV3 201912: Summary 201 | 202 | FV3-201912-public --- 10 January 2020 203 | Lucas Harris, GFDL 204 | 205 | This version has been tested against the current SHiELD (formerly fvGFS) physics 206 | and with FMS release candidate 2020.02 from https://github.com/NOAA-GFDL/FMS 207 | 208 | Includes all of the features of the GFDL Release to EMC, as well as: 209 | 210 | - Updated 2017 GFDL Microphysics (S-J Lin and L Zhou included in GFSv15) 211 | - Updates for GFSv15 ICs (T Black/J Abeles, EMC) 212 | - Updates to support new nesting capabilities in FMS (Z Liang) 213 | - Re-written grid nesting code for efficiency and parallelization 214 | - Re-organized fv_eta for improved vertical level selection 215 | - 2018 Stand-alone regional capabilities (T Black/J Abeles, EMC) 216 | - Refactored model front-end (fv_control, fv_restart) 217 | - Support for point soundings 218 | - And other updates 219 | 220 | ## Interface changes 221 | 222 | drivers: renamed 'fvGFS' directory to SHiELD 223 | 224 | atmosphere.F90: 'mytile' is renamed 'mygrid' 225 | 226 | The non-functional gfdl_cloud_microphys.F90 has been removed and replaced with the 2017 public release given to EMC. Also added a proper initialization routine, that includes the use of INTERNAL_FILE_NML and thereby requires the input_nml_file argument. If you do not define the compiler flag INTERNAL_FILE_NML then you can delete this argument. 227 | 228 | The namelist nggps_diag_nml has been eliminated. 'fdiag' is no longer handled by the dynamical core, and should be handled by the physics driver. 229 | 230 | For a complete technical description see the NOAA Technical Memorandum OAR GFDL: https://repository.library.noaa.gov/view/noaa/23432 231 | -------------------------------------------------------------------------------- /tools/external_aero.F90: -------------------------------------------------------------------------------- 1 | !*********************************************************************** 2 | !* GNU Lesser General Public License 3 | !* 4 | !* This file is part of the FV3 dynamical core. 5 | !* 6 | !* The FV3 dynamical core is free software: you can redistribute it 7 | !* and/or modify it under the terms of the 8 | !* GNU Lesser General Public License as published by the 9 | !* Free Software Foundation, either version 3 of the License, or 10 | !* (at your option) any later version. 11 | !* 12 | !* The FV3 dynamical core is distributed in the hope that it will be 13 | !* useful, but WITHOUT ANYWARRANTY; without even the implied warranty 14 | !* of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. 15 | !* See the GNU General Public License for more details. 16 | !* 17 | !* You should have received a copy of the GNU Lesser General Public 18 | !* License along with the FV3 dynamical core. 19 | !* If not, see . 20 | !*********************************************************************** 21 | 22 | ! ======================================================================= 23 | ! this module is designed to read 12 months climatology aerosol and 24 | ! interpolate to daily aerosol 25 | ! developer: linjiong zhou 26 | ! ======================================================================= 27 | 28 | module external_aero_mod 29 | 30 | use fms_mod, only: mpp_error, FATAL 31 | use fms2_io_mod, only: file_exists 32 | use mpp_mod, only: mpp_pe, mpp_root_pe, mpp_npes, mpp_get_current_pelist 33 | use time_manager_mod, only: time_type 34 | use fv_operators_mod, only: map1_q2 35 | use fv_fill_mod, only: fillz 36 | 37 | public :: load_aero, read_aero, clean_aero 38 | 39 | ! MERRA2 aerosol: # month = 12, # vertical layer = 72 40 | integer :: nmon = 12, nlev = 72 41 | integer :: id_aero, id_aero_now 42 | 43 | ! share arrays for time and level interpolation 44 | real, allocatable, dimension(:,:,:) :: aero_ps 45 | real, allocatable, dimension(:,:,:,:) :: aero_p 46 | real, allocatable, dimension(:,:,:,:) :: aero_pe 47 | real, allocatable, dimension(:,:,:,:) :: aero_dp 48 | real, allocatable, dimension(:,:,:,:) :: aerosol 49 | 50 | contains 51 | 52 | ! ======================================================================= 53 | ! load aerosol 12 months climatological dataset 54 | 55 | subroutine load_aero(Atm, Time) 56 | 57 | use fms2_io_mod, only: FmsNetcdfDomainFile_t, open_file, close_file, & 58 | register_restart_field, register_axis, & 59 | read_restart, get_variable_dimension_names, & 60 | get_dimension_size, close_file 61 | use fv_arrays_mod, only: fv_atmos_type 62 | use diag_manager_mod, only: register_static_field, register_diag_field 63 | 64 | implicit none 65 | 66 | type(time_type), intent(in) :: Time 67 | type(fv_atmos_type), intent(in), target :: Atm 68 | type(FmsNetcdfDomainFile_t) :: aero_restart 69 | 70 | integer :: k 71 | integer :: is, ie, js, je 72 | character(len=8), dimension(4) :: dim_names_4d 73 | character(len=8), dimension(3) :: dim_names_3d 74 | integer, dimension(2) :: dim_size 75 | 76 | real, allocatable, dimension(:,:,:,:) :: aero_lndp 77 | 78 | character(len=64) :: file_name = "MERRA2_400.inst3_3d_aer_Nv.climatology.nc" 79 | 80 | is = Atm%bd%is 81 | ie = Atm%bd%ie 82 | js = Atm%bd%js 83 | je = Atm%bd%je 84 | 85 | if (mpp_pe() .eq. mpp_root_pe()) then 86 | write(*,*) "aerosol 12 months climatological dataset is used for forecast." 87 | endif 88 | 89 | ! ----------------------------------------------------------------------- 90 | ! load aerosol data 91 | 92 | if (open_file(aero_restart, 'INPUT/'//trim(file_name), "read", Atm%domain, & 93 | & is_restart=.true., dont_add_res_to_filename=.true.)) then 94 | 95 | ! allocate share arrays 96 | if (.not. allocated(aero_ps)) allocate(aero_ps(is:ie,js:je,nmon)) 97 | if (.not. allocated(aero_p)) allocate(aero_p(is:ie,js:je,nlev,nmon)) 98 | if (.not. allocated(aero_pe)) allocate(aero_pe(is:ie,js:je,nlev+1,nmon)) 99 | if (.not. allocated(aero_dp)) allocate(aero_dp(is:ie,js:je,nlev,nmon)) 100 | if (.not. allocated(aerosol)) allocate(aerosol(is:ie,js:je,nlev,nmon)) 101 | 102 | ! read in restart files 103 | call get_variable_dimension_names(aero_restart, "PS", dim_names_3d) 104 | call get_variable_dimension_names(aero_restart, "DELP", dim_names_4d) 105 | call get_dimension_size(aero_restart, dim_names_4d(3), dim_size(1)) 106 | call get_dimension_size(aero_restart, dim_names_4d(4), dim_size(2)) 107 | call register_axis(aero_restart, dim_names_4d(1), "x") 108 | call register_axis(aero_restart, dim_names_4d(2), "y") 109 | call register_axis(aero_restart, dim_names_4d(3), dim_size(1)) 110 | call register_axis(aero_restart, dim_names_4d(4), dim_size(2)) 111 | call register_restart_field(aero_restart,"PS",& 112 | aero_ps, dim_names_3d) 113 | call register_restart_field(aero_restart,"DELP",& 114 | aero_dp, dim_names_4d) 115 | call register_restart_field(aero_restart,"SO4",& 116 | aerosol, dim_names_4d) 117 | call read_restart(aero_restart) 118 | call close_file(aero_restart) 119 | else 120 | 121 | ! stop when aerosol does not exist 122 | call mpp_error("external_aero_mod",& 123 | "file: "//trim(file_name)//" does not exist.",FATAL) 124 | 125 | endif 126 | 127 | ! ----------------------------------------------------------------------- 128 | ! calculate layer mean pressure 129 | 130 | ! allocate local array 131 | if (.not. allocated(aero_lndp)) allocate(aero_lndp(is:ie,js:je,nlev,nmon)) 132 | 133 | ! calcuate edge pressure 134 | aero_p = -999.9 135 | aero_pe(:,:,nlev+1,:) = aero_ps 136 | do k = nlev, 1, -1 137 | aero_pe(:,:,k,:) = aero_pe(:,:,k+1,:) - aero_dp(:,:,k,:) 138 | enddo 139 | 140 | ! stop when minimum value is less and equal to zero 141 | if (minval(aero_pe) .le. 0.0) then 142 | call mpp_error("external_aero_mod","aero_pe has value <= 0.",FATAL) 143 | endif 144 | 145 | ! calcuate layer mean pressure 146 | do k = 1, nlev 147 | aero_lndp(:,:,k,:) = log(aero_pe(:,:,k+1,:)) - log(aero_pe(:,:,k,:)) 148 | enddo 149 | aero_p = aero_dp / aero_lndp 150 | 151 | ! stop when minimum value is less and equal to zero 152 | if (minval(aero_p) .le. 0.0) then 153 | call mpp_error("external_aero_mod","aero_p has value <= 0.",FATAL) 154 | endif 155 | 156 | ! deallocate local array 157 | if (allocated(aero_lndp)) deallocate(aero_lndp) 158 | 159 | ! ----------------------------------------------------------------------- 160 | ! register for diagnostic output 161 | 162 | id_aero = register_static_field('dynamics','aero_ann',& 163 | Atm%atmos_axes(1:2),'none','none') 164 | id_aero_now= register_diag_field('dynamics','aero_now',& 165 | Atm%atmos_axes(1:2),Time,'none','none') 166 | 167 | end subroutine load_aero 168 | 169 | ! ======================================================================= 170 | ! read aerosol climatological dataset 171 | 172 | subroutine read_aero(is, ie, js, je, npz, nq, Time, pe, peln, qa, kord_tr, fill) 173 | 174 | #ifdef OVERLOAD_R4 175 | use constantsR4_mod, only: grav 176 | #else 177 | use constants_mod, only: grav 178 | #endif 179 | 180 | use diag_manager_mod, only: send_data 181 | use time_manager_mod, only: get_date, set_date, get_time, operator(-) 182 | use tracer_manager_mod, only: get_tracer_index 183 | use field_manager_mod, only: MODEL_ATMOS 184 | 185 | implicit none 186 | 187 | type(time_type), intent(in) :: Time 188 | type(time_type) :: Time_before 189 | type(time_type) :: Time_after 190 | 191 | integer :: i, j, k, n 192 | integer, intent(in) :: is, ie, js, je, npz, nq, kord_tr 193 | integer :: year, month, day, hour, minute, second 194 | integer :: seconds, days01, days21, month1, month2 195 | integer :: aero_id 196 | 197 | real, dimension(is:ie,js:je,npz,nq), intent(inout) :: qa 198 | real, dimension(is:ie,npz+1,js:je), intent(in) :: pe, peln 199 | 200 | real, allocatable, dimension(:,:) :: vi_aero 201 | real, allocatable, dimension(:,:) :: vi_aero_now 202 | real, allocatable, dimension(:,:,:) :: aero_now_a 203 | real, allocatable, dimension(:,:,:) :: aero_now_p 204 | real, allocatable, dimension(:,:,:) :: aero_now_pe 205 | real, allocatable, dimension(:,:,:) :: aero_now_dp 206 | real, allocatable, dimension(:,:,:) :: pm 207 | 208 | logical :: used, use_fv3_interp = .true. 209 | logical, intent (in) :: fill 210 | 211 | ! ----------------------------------------------------------------------- 212 | ! diagnostic output of annual mean vertical integral aerosol 213 | 214 | if (id_aero > 0) then 215 | 216 | ! allocate local array 217 | if (.not. allocated(vi_aero)) allocate(vi_aero(is:ie,js:je)) 218 | 219 | ! calcualte annual mean vertical intergral aerosol 220 | vi_aero = 0.0 221 | do n = 1, nmon 222 | do k = 1, nlev 223 | vi_aero = vi_aero + aerosol(:,:,k,n) * aero_dp(:,:,k,n) 224 | enddo 225 | enddo 226 | vi_aero = vi_aero / nmon / grav * 1.e6 227 | 228 | ! diagnostic output 229 | used = send_data(id_aero,vi_aero,Time) 230 | 231 | ! deallocate local array 232 | if (allocated(vi_aero)) deallocate(vi_aero) 233 | 234 | endif 235 | 236 | ! ----------------------------------------------------------------------- 237 | ! linearly interpolate monthly aerosol to today 238 | 239 | ! allocate local array 240 | if (.not. allocated(aero_now_a)) allocate(aero_now_a(is:ie,js:je,nlev)) 241 | if (.not. allocated(aero_now_p)) allocate(aero_now_p(is:ie,js:je,nlev)) 242 | if (.not. allocated(aero_now_pe)) allocate(aero_now_pe(is:ie,js:je,nlev+1)) 243 | 244 | ! get current date information 245 | call get_date(Time, year, month, day, hour, minute, second) 246 | 247 | ! get previous day 15 and next day 15 time 248 | if (day .ge. 15) then 249 | Time_before = set_date(year, month, 15, 0, 0, 0) 250 | if (month .eq. 12) then 251 | Time_after = set_date(year+1, 1, 15, 0, 0, 0) 252 | else 253 | Time_after = set_date(year, month+1, 15, 0, 0, 0) 254 | endif 255 | else 256 | if (month .eq. 1) then 257 | Time_before = set_date(year-1, 12, 15, 0, 0, 0) 258 | else 259 | Time_before = set_date(year, month-1, 15, 0, 0, 0) 260 | endif 261 | Time_after = set_date(year, month, 15, 0, 0, 0) 262 | endif 263 | 264 | ! get day difference between current day and previous day 15, 265 | ! and between next day 15 and previous day 15 266 | call get_time(Time - Time_before, seconds, days01) 267 | call get_time(Time_after - Time_before, seconds, days21) 268 | call get_date(Time_before, year, month1, day, hour, minute, second) 269 | call get_date(Time_after, year, month2, day, hour, minute, second) 270 | 271 | ! get aerosol for current date 272 | aero_now_a = aerosol(:,:,:,month2) - aerosol(:,:,:,month1) 273 | aero_now_a = 1.0 * days01 / days21 * aero_now_a + aerosol(:,:,:,month1) 274 | aero_now_p = aero_p(:,:,:,month2) - aero_p(:,:,:,month1) 275 | aero_now_p = 1.0 * days01 / days21 * aero_now_p + aero_p(:,:,:,month1) 276 | aero_now_pe = aero_pe(:,:,:,month2) - aero_pe(:,:,:,month1) 277 | aero_now_pe = 1.0 * days01 / days21 * aero_now_pe + aero_pe(:,:,:,month1) 278 | 279 | ! ----------------------------------------------------------------------- 280 | ! diagnostic output of current vertical integral aerosol 281 | 282 | if (id_aero_now > 0) then 283 | 284 | ! allocate local array 285 | if (.not. allocated(vi_aero_now)) allocate(vi_aero_now(is:ie,js:je)) 286 | if (.not. allocated(aero_now_dp)) allocate(aero_now_dp(is:ie,js:je,nlev)) 287 | 288 | ! get pressure thickness for current date 289 | aero_now_dp = aero_dp(:,:,:,month2) - aero_dp(:,:,:,month1) 290 | aero_now_dp = 1.0 * days01 / days21 * aero_now_dp + aero_dp(:,:,:,month1) 291 | 292 | ! calcualte annual mean vertical intergral aerosol 293 | vi_aero_now = 0.0 294 | do k = 1, nlev 295 | vi_aero_now = vi_aero_now + aero_now_a(:,:,k) * aero_now_dp(:,:,k) 296 | enddo 297 | vi_aero_now = vi_aero_now / grav * 1.e6 298 | 299 | ! diagnostic output 300 | used = send_data(id_aero_now,vi_aero_now,Time) 301 | 302 | ! deallocate local array 303 | if (allocated(vi_aero_now)) deallocate(vi_aero_now) 304 | if (allocated(aero_now_dp)) deallocate(aero_now_dp) 305 | 306 | endif 307 | 308 | ! ----------------------------------------------------------------------- 309 | ! vertically interpolate aeorosol 310 | 311 | ! allocate local array 312 | if (.not. allocated(pm)) allocate(pm(is:ie,js:je,npz)) 313 | 314 | ! calculate layer mean pressure 315 | do k = 1, npz 316 | pm(:,:,k) = (pe(:,k+1,:) - pe(:,k,:)) / (peln(:,k+1,:) - peln(:,k,:)) 317 | enddo 318 | 319 | ! stop when minimum value is less and equal to zero 320 | if (minval(pm) .le. 0.0) then 321 | call mpp_error("external_aero_mod","pm has value <= 0.",FATAL) 322 | endif 323 | 324 | ! get aerosol tracer id 325 | aero_id = get_tracer_index(MODEL_ATMOS, 'aerosol') 326 | 327 | ! vertically interpolation 328 | if (use_fv3_interp) then 329 | do j = js, je 330 | call map1_q2 (nlev, aero_now_pe (is:ie, j, :), aero_now_a (is:ie, js:je, :), & 331 | npz, pe (is:ie, :, j), qa (is:ie, j, :, aero_id), & 332 | pe (is:ie, 2:npz+1, j) - pe (is:ie, 1:npz, j), & 333 | is, ie, 0, kord_tr, j, is, ie, js, je, 0.) 334 | if (fill) call fillz (ie-is+1, npz, 1, qa (is:ie, j, :, aero_id), & 335 | pe (is:ie, 2:npz+1, j) - pe (is:ie, 1:npz, j)) 336 | enddo 337 | else 338 | do j = js, je 339 | do i = is, ie 340 | do k = 1, npz 341 | if (pm(i,j,k) .lt. aero_now_p(i,j,1)) then 342 | qa(i,j,k,aero_id) = aero_now_a(i,j,1) 343 | !qa(i,j,k,aero_id) = aero_now_a(i,j,1) + & 344 | ! (log(pm(i,j,k)) - log(aero_now_p(i,j,1))) / & 345 | ! (log(aero_now_p(i,j,2)) - log(aero_now_p(i,j,1))) * & 346 | ! (aero_now_a(i,j,2) - aero_now_a(i,j,1)) 347 | else if (pm(i,j,k) .ge. aero_now_p(i,j,nlev)) then 348 | qa(i,j,k,aero_id) = aero_now_a(i,j,nlev) 349 | !qa(i,j,k,aero_id) = aero_now_a(i,j,nlev-1) + & 350 | ! (log(pm(i,j,k)) - log(aero_now_p(i,j,nlev-1))) / & 351 | ! (log(aero_now_p(i,j,nlev)) - log(aero_now_p(i,j,nlev-1))) * & 352 | ! (aero_now_a(i,j,nlev) - aero_now_a(i,j,nlev-1)) 353 | else 354 | do n = 1, nlev-1 355 | if (pm(i,j,k) .ge. aero_now_p(i,j,n) .and. & 356 | pm(i,j,k) .lt. aero_now_p(i,j,n+1)) then 357 | qa(i,j,k,aero_id) = aero_now_a(i,j,n) + & 358 | (log(pm(i,j,k)) - log(aero_now_p(i,j,n))) / & 359 | (log(aero_now_p(i,j,n+1)) - log(aero_now_p(i,j,n))) * & 360 | (aero_now_a(i,j,n+1) - aero_now_a(i,j,n)) 361 | endif 362 | enddo 363 | endif 364 | enddo 365 | enddo 366 | enddo 367 | endif 368 | 369 | ! deallocate local array 370 | if (allocated(pm)) deallocate(pm) 371 | 372 | ! ----------------------------------------------------------------------- 373 | ! deallocate local array 374 | 375 | if (allocated(aero_now_a)) deallocate(aero_now_a) 376 | if (allocated(aero_now_p)) deallocate(aero_now_p) 377 | 378 | end subroutine read_aero 379 | 380 | ! ======================================================================= 381 | ! clean aerosol climatological dataset 382 | 383 | subroutine clean_aero() 384 | 385 | implicit none 386 | 387 | if (allocated(aero_ps)) deallocate(aero_ps) 388 | if (allocated(aero_p)) deallocate(aero_p) 389 | if (allocated(aero_pe)) deallocate(aero_pe) 390 | if (allocated(aero_dp)) deallocate(aero_dp) 391 | if (allocated(aerosol)) deallocate(aerosol) 392 | 393 | end subroutine clean_aero 394 | 395 | end module external_aero_mod 396 | -------------------------------------------------------------------------------- /tools/sim_nc_mod.F90: -------------------------------------------------------------------------------- 1 | !*********************************************************************** 2 | !* GNU Lesser General Public License 3 | !* 4 | !* This file is part of the FV3 dynamical core. 5 | !* 6 | !* The FV3 dynamical core is free software: you can redistribute it 7 | !* and/or modify it under the terms of the 8 | !* GNU Lesser General Public License as published by the 9 | !* Free Software Foundation, either version 3 of the License, or 10 | !* (at your option) any later version. 11 | !* 12 | !* The FV3 dynamical core is distributed in the hope that it will be 13 | !* useful, but WITHOUT ANY WARRANTY; without even the implied warranty 14 | !* of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. 15 | !* See the GNU General Public License for more details. 16 | !* 17 | !* You should have received a copy of the GNU Lesser General Public 18 | !* License along with the FV3 dynamical core. 19 | !* If not, see . 20 | !*********************************************************************** 21 | 22 | module sim_nc_mod 23 | 24 | ! This is S-J Lin's private netcdf file reader 25 | ! This code is needed because FMS utilitty (read_data) led to too much 26 | ! memory usage and too many files openned. Perhaps lower-level FMS IO 27 | ! calls should be used instead. 28 | 29 | #if defined(OLD_PT_TO_T) || defined(OLD_COS_SG) 30 | #error 31 | #error Compile time options -DOLD_PT_TO_T and -DOLD_COS_SG are no longer supported. Please remove them from your XML. 32 | #error 33 | #endif 34 | 35 | use mpp_mod, only: mpp_error, FATAL 36 | 37 | implicit none 38 | #include 39 | 40 | private 41 | public open_ncfile, close_ncfile, get_ncdim1, get_var1_double, get_var2_double, & 42 | get_var3_real, get_var3_double, get_var3_r4, get_var2_real, get_var2_r4, & 43 | handle_err, check_var, get_var1_real, get_var_att_double, & 44 | check_var_exists 45 | 46 | contains 47 | 48 | subroutine open_ncfile( iflnm, ncid ) 49 | character(len=*), intent(in):: iflnm 50 | integer, intent(out):: ncid 51 | integer:: status 52 | 53 | status = nf_open (iflnm, NF_NOWRITE, ncid) 54 | if (status .ne. NF_NOERR) call handle_err(status) 55 | 56 | 57 | end subroutine open_ncfile 58 | 59 | 60 | subroutine close_ncfile( ncid ) 61 | integer, intent(in):: ncid 62 | integer:: status 63 | 64 | status = nf_close (ncid) 65 | if (status .ne. NF_NOERR) call handle_err(status) 66 | 67 | 68 | end subroutine close_ncfile 69 | 70 | 71 | subroutine get_ncdim1( ncid, var1_name, im ) 72 | integer, intent(in):: ncid 73 | character(len=*), intent(in):: var1_name 74 | integer, intent(out):: im 75 | integer:: status, var1id 76 | 77 | status = nf_inq_dimid (ncid, var1_name, var1id) 78 | if (status .ne. NF_NOERR) call handle_err(status) 79 | 80 | status = nf_inq_dimlen (ncid, var1id, im) 81 | if (status .ne. NF_NOERR) call handle_err(status) 82 | 83 | end subroutine get_ncdim1 84 | 85 | 86 | 87 | 88 | subroutine get_var1_double( ncid, var1_name, im, var1, var_exist ) 89 | integer, intent(in):: ncid 90 | character(len=*), intent(in):: var1_name 91 | integer, intent(in):: im 92 | logical, intent(out), optional:: var_exist 93 | real(kind=8), intent(out):: var1(im) 94 | integer:: status, var1id 95 | 96 | status = nf_inq_varid (ncid, var1_name, var1id) 97 | if (status .ne. NF_NOERR) then 98 | ! call handle_err(status) 99 | if(present(var_exist) ) var_exist = .false. 100 | else 101 | status = nf_get_var_double (ncid, var1id, var1) 102 | if (status .ne. NF_NOERR) call handle_err(status) 103 | if(present(var_exist) ) var_exist = .true. 104 | endif 105 | 106 | 107 | end subroutine get_var1_double 108 | 109 | 110 | ! 4-byte data: 111 | subroutine get_var1_real( ncid, var1_name, im, var1, var_exist ) 112 | integer, intent(in):: ncid 113 | character(len=*), intent(in):: var1_name 114 | integer, intent(in):: im 115 | logical, intent(out), optional:: var_exist 116 | real(kind=4), intent(out):: var1(im) 117 | integer:: status, var1id 118 | 119 | status = nf_inq_varid (ncid, var1_name, var1id) 120 | if (status .ne. NF_NOERR) then 121 | ! call handle_err(status) 122 | if(present(var_exist) ) var_exist = .false. 123 | else 124 | status = nf_get_var_real (ncid, var1id, var1) 125 | if (status .ne. NF_NOERR) call handle_err(status) 126 | if(present(var_exist) ) var_exist = .true. 127 | endif 128 | 129 | 130 | end subroutine get_var1_real 131 | 132 | subroutine get_var2_real( ncid, var_name, im, jm, var2 ) 133 | integer, intent(in):: ncid 134 | character(len=*), intent(in):: var_name 135 | integer, intent(in):: im, jm 136 | real(kind=4), intent(out):: var2(im) 137 | 138 | integer:: status, var1id 139 | 140 | status = nf_inq_varid (ncid, var_name, var1id) 141 | if (status .ne. NF_NOERR) call handle_err(status) 142 | 143 | status = nf_get_var_real (ncid, var1id, var2) 144 | if (status .ne. NF_NOERR) call handle_err(status) 145 | 146 | end subroutine get_var2_real 147 | 148 | subroutine get_var2_r4( ncid, var2_name, is,ie, js,je, var2, time_slice ) 149 | integer, intent(in):: ncid 150 | character(len=*), intent(in):: var2_name 151 | integer, intent(in):: is, ie, js, je 152 | real(kind=4), intent(out):: var2(is:ie,js:je) 153 | integer, intent(in), optional :: time_slice 154 | ! 155 | real(kind=4), dimension(1) :: time 156 | integer, dimension(3):: start, nreco 157 | integer:: status, var2id 158 | 159 | status = nf_inq_varid (ncid, var2_name, var2id) 160 | if (status .ne. NF_NOERR) call handle_err(status) 161 | 162 | start(1) = is; start(2) = js; start(3) = 1 163 | if ( present(time_slice) ) then 164 | start(3) = time_slice 165 | end if 166 | 167 | nreco(1) = ie - is + 1 168 | nreco(2) = je - js + 1 169 | nreco(3) = 1 170 | 171 | status = nf_get_vara_real(ncid, var2id, start, nreco, var2) 172 | if (status .ne. NF_NOERR) call handle_err(status) 173 | 174 | end subroutine get_var2_r4 175 | 176 | subroutine get_var2_double( ncid, var2_name, im, jm, var2 ) 177 | integer, intent(in):: ncid 178 | character(len=*), intent(in):: var2_name 179 | integer, intent(in):: im, jm 180 | real(kind=8), intent(out):: var2(im,jm) 181 | 182 | integer:: status, var2id 183 | 184 | status = nf_inq_varid (ncid, var2_name, var2id) 185 | if (status .ne. NF_NOERR) call handle_err(status) 186 | 187 | status = nf_get_var_double (ncid, var2id, var2) 188 | if (status .ne. NF_NOERR) call handle_err(status) 189 | 190 | 191 | end subroutine get_var2_double 192 | 193 | 194 | subroutine get_var3_double( ncid, var3_name, im, jm, km, var3 ) 195 | integer, intent(in):: ncid 196 | character(len=*), intent(in):: var3_name 197 | integer, intent(in):: im, jm, km 198 | real(kind=8), intent(out):: var3(im,jm,km) 199 | 200 | integer:: status, var3id 201 | 202 | status = nf_inq_varid (ncid, var3_name, var3id) 203 | 204 | if (status .ne. NF_NOERR) call handle_err(status) 205 | 206 | status = nf_get_var_double (ncid, var3id, var3) 207 | if (status .ne. NF_NOERR) call handle_err(status) 208 | 209 | end subroutine get_var3_double 210 | 211 | subroutine get_var3_real( ncid, var3_name, im, jm, km, var3 ) 212 | integer, intent(in):: ncid 213 | character(len=*), intent(in):: var3_name 214 | integer, intent(in):: im, jm, km 215 | real(kind=4), intent(out):: var3(im,jm,km) 216 | 217 | integer:: status, var3id 218 | 219 | status = nf_inq_varid (ncid, var3_name, var3id) 220 | 221 | if (status .ne. NF_NOERR) call handle_err(status) 222 | status = nf_get_var_real (ncid, var3id, var3) 223 | 224 | if (status .ne. NF_NOERR) call handle_err(status) 225 | 226 | end subroutine get_var3_real 227 | 228 | 229 | subroutine get_var3_r4( ncid, var3_name, is,ie, js,je, ks,ke, var3, time_slice ) 230 | integer, intent(in):: ncid 231 | character(len=*), intent(in):: var3_name 232 | integer, intent(in):: is, ie, js, je, ks,ke 233 | real(kind=4), intent(out):: var3(is:ie,js:je,ks:ke) 234 | integer, intent(in), optional :: time_slice 235 | ! 236 | real(kind=4), dimension(1) :: time 237 | integer, dimension(4):: start, nreco 238 | integer:: status, var3id 239 | 240 | status = nf_inq_varid (ncid, var3_name, var3id) 241 | if (status .ne. NF_NOERR) call handle_err(status) 242 | 243 | start(1) = is; start(2) = js; start(3) = ks; start(4) = 1 244 | if ( present(time_slice) ) then 245 | start(4) = time_slice 246 | end if 247 | 248 | nreco(1) = ie - is + 1 249 | nreco(2) = je - js + 1 250 | nreco(3) = ke - ks + 1 251 | nreco(4) = 1 252 | 253 | status = nf_get_vara_real(ncid, var3id, start, nreco, var3) 254 | if (status .ne. NF_NOERR) call handle_err(status) 255 | 256 | end subroutine get_var3_r4 257 | subroutine get_var4_real( ncid, var4_name, im, jm, km, nt, var4 ) 258 | implicit none 259 | #include 260 | integer, intent(in):: ncid 261 | character*(*), intent(in):: var4_name 262 | integer, intent(in):: im, jm, km, nt 263 | real*4:: wk4(im,jm,km,4) 264 | real*4, intent(out):: var4(im,jm) 265 | integer:: status, var4id 266 | integer:: start(4), icount(4) 267 | integer:: i,j 268 | 269 | start(1) = 1 270 | start(2) = 1 271 | start(3) = 1 272 | start(4) = nt 273 | 274 | icount(1) = im ! all range 275 | icount(2) = jm ! all range 276 | icount(3) = km ! all range 277 | icount(4) = 1 ! one time level at a time 278 | 279 | ! write(*,*) nt, 'Within get_var4_double: ', var4_name 280 | 281 | status = nf_inq_varid (ncid, var4_name, var4id) 282 | ! write(*,*) '#1', status, ncid, var4id 283 | 284 | status = nf_get_vara_real(ncid, var4id, start, icount, var4) 285 | ! status = nf_get_vara_real(ncid, var4id, start, icount, wk4) 286 | ! write(*,*) '#2', status, ncid, var4id 287 | 288 | do j=1,jm 289 | do i=1,im 290 | ! var4(i,j) = wk4(i,j,1,nt) 291 | enddo 292 | enddo 293 | 294 | if (status .ne. NF_NOERR) call handle_err(status) 295 | 296 | end subroutine get_var4_real 297 | 298 | 299 | subroutine get_var4_double( ncid, var4_name, im, jm, km, nt, var4 ) 300 | integer, intent(in):: ncid 301 | character(len=*), intent(in):: var4_name 302 | integer, intent(in):: im, jm, km, nt 303 | real(kind=8), intent(out):: var4(im,jm,km,1) 304 | integer:: status, var4id 305 | ! 306 | integer:: start(4), icount(4) 307 | 308 | start(1) = 1 309 | start(2) = 1 310 | start(3) = 1 311 | start(4) = nt 312 | 313 | icount(1) = im ! all range 314 | icount(2) = jm ! all range 315 | icount(3) = km ! all range 316 | icount(4) = 1 ! one time level at a time 317 | 318 | status = nf_inq_varid (ncid, var4_name, var4id) 319 | status = nf_get_vara_double(ncid, var4id, start, icount, var4) 320 | 321 | if (status .ne. NF_NOERR) call handle_err(status) 322 | 323 | end subroutine get_var4_double 324 | !------------------------------------------------------------------------ 325 | 326 | subroutine get_real3( ncid, var4_name, im, jm, nt, var4 ) 327 | ! This is for multi-time-level 2D var 328 | integer, intent(in):: ncid 329 | character(len=*), intent(in):: var4_name 330 | integer, intent(in):: im, jm, nt 331 | real(kind=4), intent(out):: var4(im,jm) 332 | integer:: status, var4id 333 | integer:: start(3), icount(3) 334 | integer:: i,j 335 | 336 | start(1) = 1 337 | start(2) = 1 338 | start(3) = nt 339 | 340 | icount(1) = im 341 | icount(2) = jm 342 | icount(3) = 1 343 | 344 | status = nf_inq_varid (ncid, var4_name, var4id) 345 | status = nf_get_vara_real(ncid, var4id, start, icount, var4) 346 | 347 | if (status .ne. NF_NOERR) call handle_err(status) 348 | 349 | end subroutine get_real3 350 | !------------------------------------------------------------------------ 351 | 352 | logical function check_var( ncid, var3_name) 353 | integer, intent(in):: ncid 354 | character(len=*), intent(in):: var3_name 355 | 356 | integer:: status, var3id 357 | 358 | status = nf_inq_varid (ncid, var3_name, var3id) 359 | check_var = (status == NF_NOERR) 360 | 361 | end function check_var 362 | 363 | subroutine check_var_exists(ncid, var_name, status) 364 | integer, intent(in):: ncid 365 | integer, intent(inout) :: status 366 | character(len=*), intent(in):: var_name 367 | integer:: varid 368 | status = nf_inq_varid (ncid, var_name, varid) 369 | end subroutine check_var_exists 370 | 371 | subroutine get_var_att_str(ncid, var_name, att_name, att) 372 | implicit none 373 | #include 374 | integer, intent(in):: ncid 375 | character*(*), intent(in):: var_name, att_name 376 | character*(*), intent(out):: att 377 | 378 | integer:: status, varid 379 | 380 | status = nf_inq_varid (ncid, var_name, varid) 381 | status = nf_get_att_text(ncid, varid, att_name, att) 382 | 383 | if (status .ne. NF_NOERR) call handle_err(status) 384 | 385 | end subroutine get_var_att_str 386 | 387 | subroutine get_var_att_double(ncid, var_name, att_name, value) 388 | implicit none 389 | #include 390 | integer, intent(in):: ncid 391 | character*(*), intent(in):: var_name, att_name 392 | real(kind=8), intent(out):: value 393 | 394 | integer:: status, varid 395 | 396 | status = nf_inq_varid (ncid, var_name, varid) 397 | status = nf_get_att(ncid, varid, att_name, value) 398 | 399 | if (status .ne. NF_NOERR) call handle_err(status) 400 | 401 | end subroutine get_var_att_double 402 | 403 | 404 | subroutine handle_err(status) 405 | integer status 406 | character(len=120) :: errstr 407 | 408 | if (status .ne. nf_noerr) then 409 | write(errstr,*) 'Error in handle_err: ', NF_STRERROR(STATUS) 410 | call mpp_error(FATAL,errstr) 411 | endif 412 | 413 | end subroutine handle_err 414 | 415 | subroutine calendar(year, month, day, hour) 416 | integer, intent(inout) :: year ! year 417 | integer, intent(inout) :: month ! month 418 | integer, intent(inout) :: day ! day 419 | integer, intent(inout) :: hour 420 | ! 421 | ! Local variables 422 | ! 423 | integer irem4,irem100 424 | integer mdays(12) ! number day of month 425 | data mdays /31,28,31,30,31,30,31,31,30,31,30,31/ 426 | ! 427 | !*********************************************************************** 428 | !****** compute current GMT ****** 429 | !*********************************************************************** 430 | ! 431 | !**** consider leap year 432 | ! 433 | irem4 = mod( year, 4 ) 434 | irem100 = mod( year, 100 ) 435 | if( irem4 == 0 .and. irem100 /= 0) mdays(2) = 29 436 | ! 437 | if( hour >= 24 ) then 438 | day = day + 1 439 | hour = hour - 24 440 | end if 441 | 442 | if( day > mdays(month) ) then 443 | day = day - mdays(month) 444 | month = month + 1 445 | end if 446 | if( month > 12 ) then 447 | year = year + 1 448 | month = 1 449 | end if 450 | 451 | end subroutine calendar 452 | 453 | end module sim_nc_mod 454 | -------------------------------------------------------------------------------- /model/a2b_edge.F90: -------------------------------------------------------------------------------- 1 | !*********************************************************************** 2 | !* GNU Lesser General Public License 3 | !* 4 | !* This file is part of the FV3 dynamical core. 5 | !* 6 | !* The FV3 dynamical core is free software: you can redistribute it 7 | !* and/or modify it under the terms of the 8 | !* GNU Lesser General Public License as published by the 9 | !* Free Software Foundation, either version 3 of the License, or 10 | !* (at your option) any later version. 11 | !* 12 | !* The FV3 dynamical core is distributed in the hope that it will be 13 | !* useful, but WITHOUT ANY WARRANTY; without even the implied warranty 14 | !* of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. 15 | !* See the GNU General Public License for more details. 16 | !* 17 | !* You should have received a copy of the GNU Lesser General Public 18 | !* License along with the FV3 dynamical core. 19 | !* If not, see . 20 | !*********************************************************************** 21 | 22 | module a2b_edge_mod 23 | 24 | use fv_grid_utils_mod, only: great_circle_dist 25 | 26 | use fv_arrays_mod, only: fv_grid_type, R_GRID 27 | 28 | implicit none 29 | 30 | real, parameter:: r3 = 1./3. 31 | !---------------------------- 32 | ! 4-pt Lagrange interpolation 33 | !---------------------------- 34 | real, parameter:: a1 = 0.5625 ! 9/16 35 | real, parameter:: a2 = -0.0625 ! -1/16 36 | !---------------------- 37 | ! PPM volume mean form: 38 | !---------------------- 39 | real, parameter:: b1 = 7./12. ! 0.58333333 40 | real, parameter:: b2 = -1./12. 41 | 42 | private 43 | public :: a2b_ord2, a2b_ord4 44 | 45 | contains 46 | 47 | subroutine a2b_ord4(qin, qout, gridstruct, npx, npy, is, ie, js, je, ng, replace) 48 | integer, intent(IN):: npx, npy, is, ie, js, je, ng 49 | real, intent(INOUT):: qin(is-ng:ie+ng,js-ng:je+ng) ! A-grid field 50 | real, intent(INOUT):: qout(is-ng:ie+ng,js-ng:je+ng) ! Output B-grid field 51 | type(fv_grid_type), intent(IN), target :: gridstruct 52 | logical, optional, intent(IN):: replace 53 | ! local: compact 4-pt cubic 54 | real, parameter:: c1 = 2./3. 55 | real, parameter:: c2 = -1./6. 56 | ! Parabolic spline 57 | ! real, parameter:: c1 = 0.75 58 | ! real, parameter:: c2 = -0.25 59 | 60 | real qx(is:ie+1,js-ng:je+ng) 61 | real qy(is-ng:ie+ng,js:je+1) 62 | real qxx(is-ng:ie+ng,js-ng:je+ng) 63 | real qyy(is-ng:ie+ng,js-ng:je+ng) 64 | real g_in, g_ou 65 | real:: p0(2) 66 | real:: q1(is-1:ie+1), q2(js-1:je+1) 67 | integer:: i, j, is1, js1, is2, js2, ie1, je1 68 | 69 | real, pointer, dimension(:,:,:) :: grid, agrid 70 | real, pointer, dimension(:,:) :: dxa, dya 71 | real(kind=R_GRID), pointer, dimension(:) :: edge_w, edge_e, edge_s, edge_n 72 | 73 | edge_w => gridstruct%edge_w 74 | edge_e => gridstruct%edge_e 75 | edge_s => gridstruct%edge_s 76 | edge_n => gridstruct%edge_n 77 | 78 | grid => gridstruct%grid 79 | agrid => gridstruct%agrid 80 | dxa => gridstruct%dxa 81 | dya => gridstruct%dya 82 | 83 | if (gridstruct%grid_type < 3) then 84 | 85 | is1 = max(1,is-1) 86 | js1 = max(1,js-1) 87 | is2 = max(2,is) 88 | js2 = max(2,js) 89 | 90 | ie1 = min(npx-1,ie+1) 91 | je1 = min(npy-1,je+1) 92 | 93 | ! Corners: 94 | ! 3-way extrapolation 95 | if (gridstruct%bounded_domain) then 96 | 97 | do j=js-2,je+2 98 | do i=is,ie+1 99 | qx(i,j) = b2*(qin(i-2,j)+qin(i+1,j)) + b1*(qin(i-1,j)+qin(i,j)) 100 | enddo 101 | enddo 102 | 103 | 104 | else 105 | 106 | if ( gridstruct%sw_corner ) then 107 | p0(1:2) = grid(1,1,1:2) 108 | qout(1,1) = (extrap_corner(p0, agrid(1,1,1:2), agrid( 2, 2,1:2), qin(1,1), qin( 2, 2)) + & 109 | extrap_corner(p0, agrid(0,1,1:2), agrid(-1, 2,1:2), qin(0,1), qin(-1, 2)) + & 110 | extrap_corner(p0, agrid(1,0,1:2), agrid( 2,-1,1:2), qin(1,0), qin( 2,-1)))*r3 111 | 112 | endif 113 | if ( gridstruct%se_corner ) then 114 | p0(1:2) = grid(npx,1,1:2) 115 | qout(npx,1) = (extrap_corner(p0, agrid(npx-1,1,1:2), agrid(npx-2, 2,1:2), qin(npx-1,1), qin(npx-2, 2)) + & 116 | extrap_corner(p0, agrid(npx-1,0,1:2), agrid(npx-2,-1,1:2), qin(npx-1,0), qin(npx-2,-1)) + & 117 | extrap_corner(p0, agrid(npx ,1,1:2), agrid(npx+1, 2,1:2), qin(npx ,1), qin(npx+1, 2)))*r3 118 | endif 119 | if ( gridstruct%ne_corner ) then 120 | p0(1:2) = grid(npx,npy,1:2) 121 | qout(npx,npy) = (extrap_corner(p0, agrid(npx-1,npy-1,1:2), agrid(npx-2,npy-2,1:2), qin(npx-1,npy-1), qin(npx-2,npy-2)) + & 122 | extrap_corner(p0, agrid(npx ,npy-1,1:2), agrid(npx+1,npy-2,1:2), qin(npx ,npy-1), qin(npx+1,npy-2)) + & 123 | extrap_corner(p0, agrid(npx-1,npy ,1:2), agrid(npx-2,npy+1,1:2), qin(npx-1,npy ), qin(npx-2,npy+1)))*r3 124 | endif 125 | if ( gridstruct%nw_corner ) then 126 | p0(1:2) = grid(1,npy,1:2) 127 | qout(1,npy) = (extrap_corner(p0, agrid(1,npy-1,1:2), agrid( 2,npy-2,1:2), qin(1,npy-1), qin( 2,npy-2)) + & 128 | extrap_corner(p0, agrid(0,npy-1,1:2), agrid(-1,npy-2,1:2), qin(0,npy-1), qin(-1,npy-2)) + & 129 | extrap_corner(p0, agrid(1,npy, 1:2), agrid( 2,npy+1,1:2), qin(1,npy ), qin( 2,npy+1)))*r3 130 | endif 131 | 132 | !------------ 133 | ! X-Interior: 134 | !------------ 135 | do j=max(1,js-2),min(npy-1,je+2) 136 | do i=max(3,is), min(npx-2,ie+1) 137 | qx(i,j) = b2*(qin(i-2,j)+qin(i+1,j)) + b1*(qin(i-1,j)+qin(i,j)) 138 | enddo 139 | enddo 140 | 141 | ! *** West Edges: 142 | if ( is==1 ) then 143 | do j=js1, je1 144 | q2(j) = (qin(0,j)*dxa(1,j) + qin(1,j)*dxa(0,j))/(dxa(0,j) + dxa(1,j)) 145 | enddo 146 | do j=js2, je1 147 | qout(1,j) = edge_w(j)*q2(j-1) + (1.-edge_w(j))*q2(j) 148 | enddo 149 | ! 150 | do j=max(1,js-2),min(npy-1,je+2) 151 | g_in = dxa(2,j) / dxa(1,j) 152 | g_ou = dxa(-1,j) / dxa(0,j) 153 | qx(1,j) = 0.5*( ((2.+g_in)*qin(1,j)-qin( 2,j))/(1.+g_in) + & 154 | ((2.+g_ou)*qin(0,j)-qin(-1,j))/(1.+g_ou) ) 155 | qx(2,j) = ( 3.*(g_in*qin(1,j)+qin(2,j))-(g_in*qx(1,j)+qx(3,j)) ) / (2.+2.*g_in) 156 | enddo 157 | endif 158 | 159 | ! East Edges: 160 | if ( (ie+1)==npx ) then 161 | do j=js1, je1 162 | q2(j) = (qin(npx-1,j)*dxa(npx,j) + qin(npx,j)*dxa(npx-1,j))/(dxa(npx-1,j) + dxa(npx,j)) 163 | enddo 164 | do j=js2, je1 165 | qout(npx,j) = edge_e(j)*q2(j-1) + (1.-edge_e(j))*q2(j) 166 | enddo 167 | ! 168 | do j=max(1,js-2),min(npy-1,je+2) 169 | g_in = dxa(npx-2,j) / dxa(npx-1,j) 170 | g_ou = dxa(npx+1,j) / dxa(npx,j) 171 | qx(npx,j) = 0.5*( ((2.+g_in)*qin(npx-1,j)-qin(npx-2,j))/(1.+g_in) + & 172 | ((2.+g_ou)*qin(npx, j)-qin(npx+1,j))/(1.+g_ou) ) 173 | qx(npx-1,j) = (3.*(qin(npx-2,j)+g_in*qin(npx-1,j)) - (g_in*qx(npx,j)+qx(npx-2,j)))/(2.+2.*g_in) 174 | enddo 175 | endif 176 | 177 | end if 178 | !------------ 179 | ! Y-Interior: 180 | !------------ 181 | 182 | if (gridstruct%bounded_domain) then 183 | 184 | 185 | do j=js,je+1 186 | do i=is-2,ie+2 187 | qy(i,j) = b2*(qin(i,j-2)+qin(i,j+1)) + b1*(qin(i,j-1) + qin(i,j)) 188 | enddo 189 | enddo 190 | 191 | else 192 | 193 | do j=max(3,js),min(npy-2,je+1) 194 | do i=max(1,is-2), min(npx-1,ie+2) 195 | qy(i,j) = b2*(qin(i,j-2)+qin(i,j+1)) + b1*(qin(i,j-1) + qin(i,j)) 196 | enddo 197 | enddo 198 | 199 | ! South Edges: 200 | if ( js==1 ) then 201 | do i=is1, ie1 202 | q1(i) = (qin(i,0)*dya(i,1) + qin(i,1)*dya(i,0))/(dya(i,0) + dya(i,1)) 203 | enddo 204 | do i=is2, ie1 205 | qout(i,1) = edge_s(i)*q1(i-1) + (1.-edge_s(i))*q1(i) 206 | enddo 207 | ! 208 | do i=max(1,is-2),min(npx-1,ie+2) 209 | g_in = dya(i,2) / dya(i,1) 210 | g_ou = dya(i,-1) / dya(i,0) 211 | qy(i,1) = 0.5*( ((2.+g_in)*qin(i,1)-qin(i,2))/(1.+g_in) + & 212 | ((2.+g_ou)*qin(i,0)-qin(i,-1))/(1.+g_ou) ) 213 | qy(i,2) = (3.*(g_in*qin(i,1)+qin(i,2)) - (g_in*qy(i,1)+qy(i,3)))/(2.+2.*g_in) 214 | enddo 215 | endif 216 | 217 | ! North Edges: 218 | if ( (je+1)==npy ) then 219 | do i=is1, ie1 220 | q1(i) = (qin(i,npy-1)*dya(i,npy) + qin(i,npy)*dya(i,npy-1))/(dya(i,npy-1)+dya(i,npy)) 221 | enddo 222 | do i=is2, ie1 223 | qout(i,npy) = edge_n(i)*q1(i-1) + (1.-edge_n(i))*q1(i) 224 | enddo 225 | ! 226 | do i=max(1,is-2),min(npx-1,ie+2) 227 | g_in = dya(i,npy-2) / dya(i,npy-1) 228 | g_ou = dya(i,npy+1) / dya(i,npy) 229 | qy(i,npy) = 0.5*( ((2.+g_in)*qin(i,npy-1)-qin(i,npy-2))/(1.+g_in) + & 230 | ((2.+g_ou)*qin(i,npy )-qin(i,npy+1))/(1.+g_ou) ) 231 | qy(i,npy-1) = (3.*(qin(i,npy-2)+g_in*qin(i,npy-1)) - (g_in*qy(i,npy)+qy(i,npy-2)))/(2.+2.*g_in) 232 | enddo 233 | endif 234 | 235 | end if 236 | !-------------------------------------- 237 | 238 | if (gridstruct%bounded_domain) then 239 | 240 | do j=js, je+1 241 | do i=is,ie+1 242 | qxx(i,j) = a2*(qx(i,j-2)+qx(i,j+1)) + a1*(qx(i,j-1)+qx(i,j)) 243 | enddo 244 | enddo 245 | 246 | do j=js,je+1 247 | do i=is,ie+1 248 | qyy(i,j) = a2*(qy(i-2,j)+qy(i+1,j)) + a1*(qy(i-1,j)+qy(i,j)) 249 | enddo 250 | 251 | do i=is,ie+1 252 | qout(i,j) = 0.5*(qxx(i,j) + qyy(i,j)) ! averaging 253 | enddo 254 | enddo 255 | 256 | 257 | 258 | else 259 | 260 | do j=max(3,js),min(npy-2,je+1) 261 | do i=max(2,is),min(npx-1,ie+1) 262 | qxx(i,j) = a2*(qx(i,j-2)+qx(i,j+1)) + a1*(qx(i,j-1)+qx(i,j)) 263 | enddo 264 | enddo 265 | 266 | if ( js==1 ) then 267 | do i=max(2,is),min(npx-1,ie+1) 268 | qxx(i,2) = c1*(qx(i,1)+qx(i,2))+c2*(qout(i,1)+qxx(i,3)) 269 | enddo 270 | endif 271 | if ( (je+1)==npy ) then 272 | do i=max(2,is),min(npx-1,ie+1) 273 | qxx(i,npy-1) = c1*(qx(i,npy-2)+qx(i,npy-1))+c2*(qout(i,npy)+qxx(i,npy-2)) 274 | enddo 275 | endif 276 | 277 | 278 | do j=max(2,js),min(npy-1,je+1) 279 | do i=max(3,is),min(npx-2,ie+1) 280 | qyy(i,j) = a2*(qy(i-2,j)+qy(i+1,j)) + a1*(qy(i-1,j)+qy(i,j)) 281 | enddo 282 | if ( is==1 ) qyy(2,j) = c1*(qy(1,j)+qy(2,j))+c2*(qout(1,j)+qyy(3,j)) 283 | if((ie+1)==npx) qyy(npx-1,j) = c1*(qy(npx-2,j)+qy(npx-1,j))+c2*(qout(npx,j)+qyy(npx-2,j)) 284 | 285 | do i=max(2,is),min(npx-1,ie+1) 286 | qout(i,j) = 0.5*(qxx(i,j) + qyy(i,j)) ! averaging 287 | enddo 288 | enddo 289 | 290 | end if 291 | 292 | else ! grid_type>=3 293 | !------------------------ 294 | ! Doubly periodic domain: 295 | !------------------------ 296 | ! X-sweep: PPM 297 | do j=js-2,je+2 298 | do i=is,ie+1 299 | qx(i,j) = b1*(qin(i-1,j)+qin(i,j)) + b2*(qin(i-2,j)+qin(i+1,j)) 300 | enddo 301 | enddo 302 | ! Y-sweep: PPM 303 | do j=js,je+1 304 | do i=is-2,ie+2 305 | qy(i,j) = b1*(qin(i,j-1)+qin(i,j)) + b2*(qin(i,j-2)+qin(i,j+1)) 306 | enddo 307 | enddo 308 | 309 | do j=js,je+1 310 | do i=is,ie+1 311 | qout(i,j) = 0.5*( a1*(qx(i,j-1)+qx(i,j ) + qy(i-1,j)+qy(i, j)) + & 312 | a2*(qx(i,j-2)+qx(i,j+1) + qy(i-2,j)+qy(i+1,j)) ) 313 | enddo 314 | enddo 315 | endif 316 | 317 | if ( present(replace) ) then 318 | if ( replace ) then 319 | do j=js,je+1 320 | do i=is,ie+1 321 | qin(i,j) = qout(i,j) 322 | enddo 323 | enddo 324 | endif 325 | endif 326 | 327 | end subroutine a2b_ord4 328 | 329 | subroutine a2b_ord2(qin, qout, gridstruct, npx, npy, is, ie, js, je, ng, replace) 330 | integer, intent(IN ) :: npx, npy, is, ie, js, je, ng 331 | real , intent(INOUT) :: qin(is-ng:ie+ng,js-ng:je+ng) ! A-grid field 332 | real , intent( OUT) :: qout(is-ng:ie+ng,js-ng:je+ng) ! Output B-grid field 333 | type(fv_grid_type), intent(IN), target :: gridstruct 334 | logical, optional, intent(IN) :: replace 335 | ! local: 336 | real q1(npx), q2(npy) 337 | integer :: i,j 338 | integer :: is1, js1, is2, js2, ie1, je1 339 | 340 | real, pointer, dimension(:,:,:) :: grid, agrid 341 | real, pointer, dimension(:,:) :: dxa, dya 342 | 343 | real(kind=R_GRID), pointer, dimension(:) :: edge_w, edge_e, edge_s, edge_n 344 | 345 | edge_w => gridstruct%edge_w 346 | edge_e => gridstruct%edge_e 347 | edge_s => gridstruct%edge_s 348 | edge_n => gridstruct%edge_n 349 | 350 | grid => gridstruct%grid 351 | agrid => gridstruct%agrid 352 | dxa => gridstruct%dxa 353 | dya => gridstruct%dya 354 | 355 | if (gridstruct%grid_type < 3) then 356 | 357 | if (gridstruct%bounded_domain) then 358 | 359 | do j=js,je+1 360 | do i=is,ie+1 361 | qout(i,j) = 0.25*(qin(i-1,j-1)+qin(i,j-1)+qin(i-1,j)+qin(i,j)) 362 | enddo 363 | enddo 364 | 365 | else 366 | 367 | is1 = max(1,is-1) 368 | js1 = max(1,js-1) 369 | is2 = max(2,is) 370 | js2 = max(2,js) 371 | 372 | ie1 = min(npx-1,ie+1) 373 | je1 = min(npy-1,je+1) 374 | 375 | do j=js2,je1 376 | do i=is2,ie1 377 | qout(i,j) = 0.25*(qin(i-1,j-1)+qin(i,j-1)+qin(i-1,j)+qin(i,j)) 378 | enddo 379 | enddo 380 | 381 | ! Fix the 4 Corners: 382 | if ( gridstruct%sw_corner ) qout(1, 1) = r3*(qin(1, 1)+qin(1, 0)+qin(0, 1)) 383 | if ( gridstruct%se_corner ) qout(npx, 1) = r3*(qin(npx-1, 1)+qin(npx-1, 0)+qin(npx, 1)) 384 | if ( gridstruct%ne_corner ) qout(npx,npy) = r3*(qin(npx-1,npy-1)+qin(npx,npy-1)+qin(npx-1,npy)) 385 | if ( gridstruct%nw_corner ) qout(1, npy) = r3*(qin(1, npy-1)+qin(0, npy-1)+qin(1, npy)) 386 | 387 | ! *** West Edges: 388 | if ( is==1 ) then 389 | do j=js1, je1 390 | q2(j) = 0.5*(qin(0,j) + qin(1,j)) 391 | enddo 392 | do j=js2, je1 393 | qout(1,j) = edge_w(j)*q2(j-1) + (1.-edge_w(j))*q2(j) 394 | enddo 395 | endif 396 | 397 | ! East Edges: 398 | if ( (ie+1)==npx ) then 399 | do j=js1, je1 400 | q2(j) = 0.5*(qin(npx-1,j) + qin(npx,j)) 401 | enddo 402 | do j=js2, je1 403 | qout(npx,j) = edge_e(j)*q2(j-1) + (1.-edge_e(j))*q2(j) 404 | enddo 405 | endif 406 | 407 | ! South Edges: 408 | if ( js==1 ) then 409 | do i=is1, ie1 410 | q1(i) = 0.5*(qin(i,0) + qin(i,1)) 411 | enddo 412 | do i=is2, ie1 413 | qout(i,1) = edge_s(i)*q1(i-1) + (1.-edge_s(i))*q1(i) 414 | enddo 415 | endif 416 | 417 | ! North Edges: 418 | if ( (je+1)==npy ) then 419 | do i=is1, ie1 420 | q1(i) = 0.5*(qin(i,npy-1) + qin(i,npy)) 421 | enddo 422 | do i=is2, ie1 423 | qout(i,npy) = edge_n(i)*q1(i-1) + (1.-edge_n(i))*q1(i) 424 | enddo 425 | endif 426 | 427 | end if 428 | 429 | else 430 | 431 | do j=js,je+1 432 | do i=is,ie+1 433 | qout(i,j) = 0.25*(qin(i-1,j-1)+qin(i,j-1)+qin(i-1,j)+qin(i,j)) 434 | enddo 435 | enddo 436 | 437 | endif 438 | 439 | 440 | if ( present(replace) ) then 441 | if ( replace ) then 442 | do j=js,je+1 443 | do i=is,ie+1 444 | qin(i,j) = qout(i,j) 445 | enddo 446 | enddo 447 | endif 448 | endif 449 | 450 | end subroutine a2b_ord2 451 | 452 | real function extrap_corner ( p0, p1, p2, q1, q2 ) 453 | real, intent(in ), dimension(2):: p0, p1, p2 454 | real, intent(in ):: q1, q2 455 | real:: x1, x2 456 | 457 | x1 = great_circle_dist( real(p1,kind=R_GRID), real(p0,kind=R_GRID) ) 458 | x2 = great_circle_dist( real(p2,kind=R_GRID), real(p0,kind=R_GRID) ) 459 | 460 | extrap_corner = q1 + x1/(x2-x1) * (q1-q2) 461 | 462 | end function extrap_corner 463 | 464 | end module a2b_edge_mod 465 | -------------------------------------------------------------------------------- /model/fv_thermodynamics.F90: -------------------------------------------------------------------------------- 1 | !*********************************************************************** 2 | !* GNU Lesser General Public License 3 | !* 4 | !* This file is part of the FV3 dynamical core. 5 | !* 6 | !* The FV3 dynamical core is free software: you can redistribute it 7 | !* and/or modify it under the terms of the 8 | !* GNU Lesser General Public License as published by the 9 | !* Free Software Foundation, either version 3 of the License, or 10 | !* (at your option) any later version. 11 | !* 12 | !* The FV3 dynamical core is distributed in the hope that it will be 13 | !* useful, but WITHOUT ANY WARRANTY; without even the implied warranty 14 | !* of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. 15 | !* See the GNU General Public License for more details. 16 | !* 17 | !* You should have received a copy of the GNU Lesser General Public 18 | !* License along with the FV3 dynamical core. 19 | !* If not, see . 20 | !*********************************************************************** 21 | 22 | ! Linjiong Zhou: Nov 19, 2019 23 | ! Revise the OpenMP code to avoid crash 24 | module fv_thermodynamics_mod 25 | 26 | #ifdef OVERLOAD_R4 27 | use constantsR4_mod, only: grav, cp_air, cp_vapor, rvgas, rdgas 28 | #else 29 | use constants_mod, only: grav, cp_air, cp_vapor, rvgas, rdgas 30 | #endif 31 | use gfdl_mp_mod, only: c_liq, c_ice 32 | use field_manager_mod, only: MODEL_ATMOS 33 | use tracer_manager_mod, only: get_tracer_name 34 | use fv_arrays_mod, only: fv_grid_bounds_type, fv_thermo_type, fv_flags_type 35 | use mpp_mod, only: mpp_error, FATAL, input_nml_file 36 | use fms_mod, only: check_nml_error 37 | 38 | implicit none 39 | real, parameter:: cv_vap = 3.*rvgas ! 1384.5 40 | real, parameter:: cv_air = cp_air - rdgas ! = rdgas * (7/2-1) = 2.5*rdgas=717.68 41 | real, parameter:: tice = 273.16 42 | 43 | public fv_thermo_init, compute_total_energy, moist_cv, moist_cp, compute_q_con 44 | 45 | contains 46 | 47 | 48 | subroutine fv_thermo_init(thermostruct,flagstruct) 49 | 50 | type(fv_thermo_type), intent(INOUT), target :: thermostruct 51 | type(fv_flags_type), intent(INOUT) :: flagstruct 52 | 53 | integer :: f_unit, ios, ierr, dum 54 | logical, pointer :: use_cond, moist_kappa 55 | namelist /fv_thermo_nml/ use_cond, moist_kappa 56 | 57 | use_cond => thermostruct%use_cond 58 | moist_kappa => thermostruct%moist_kappa 59 | 60 | !For hydrostatic dynamics, set default to .false. for both 61 | ! to maintain compatibility with the usual hydrostatic configuration 62 | if (flagstruct%hydrostatic) then 63 | use_cond = .false. 64 | moist_kappa = .false. 65 | endif 66 | 67 | 68 | !read namelist 69 | read (input_nml_file,fv_thermo_nml,iostat=ios) 70 | ierr = check_nml_error(ios,'fv_thermo_nml') 71 | 72 | if (moist_kappa .and. .not. use_cond) then 73 | call mpp_error(FATAL, " moist_kappa = .true. and use_cond = .false. not supported.") 74 | endif 75 | 76 | if (flagstruct%hydrostatic .and. moist_kappa) then 77 | call mpp_error(FATAL, " moist_kappa not yet supported for hydrostatic simulation.") 78 | endif 79 | 80 | if (flagstruct%hydrostatic .and. use_cond) then 81 | call mpp_error(FATAL, " use_cond not yet supported for hydrostatic simulation.") 82 | endif 83 | 84 | thermostruct%is_initialized = .true. 85 | 86 | end subroutine fv_thermo_init 87 | 88 | 89 | 90 | subroutine compute_total_energy(is, ie, js, je, isd, ied, jsd, jed, km, & 91 | u, v, w, delz, pt, delp, q, qc, q_con, pe, peln, hs, & 92 | rsin2_l, cosa_s_l, & 93 | r_vir, cp, rg, hlv, te_2d, ua, va, teq, & 94 | moist_phys, nwat, sphum, liq_wat, rainwat, & 95 | ice_wat, snowwat, graupel, hydrostatic, & 96 | moist_kappa, id_te) 97 | !------------------------------------------------------ 98 | ! Compute vertically integrated total energy per column 99 | !------------------------------------------------------ 100 | ! !INPUT PARAMETERS: 101 | integer, intent(in):: km, is, ie, js, je, isd, ied, jsd, jed, id_te 102 | integer, intent(in):: sphum, liq_wat, ice_wat, rainwat, snowwat, graupel, nwat 103 | real, intent(inout), dimension(isd:ied,jsd:jed,km):: ua, va 104 | real, intent(in), dimension(isd:ied,jsd:jed,km):: pt, delp 105 | real, intent(in), dimension(isd:ied,jsd:jed,km,*):: q 106 | real, intent(in), dimension(isd:ied,jsd:jed,km):: qc, q_con !virtual adjustment zvir*qv 107 | real, intent(inout):: u(isd:ied, jsd:jed+1,km) 108 | real, intent(inout):: v(isd:ied+1,jsd:jed, km) 109 | real, intent(in):: w(isd:,jsd:,1:) ! vertical velocity (m/s) 110 | real, intent(in):: delz(is:,js:,1:) 111 | real, intent(in):: hs(isd:ied,jsd:jed) ! surface geopotential 112 | real, intent(in):: pe(is-1:ie+1,km+1,js-1:je+1) ! pressure at layer edges 113 | real, intent(in):: peln(is:ie,km+1,js:je) ! log(pe) 114 | real, intent(in):: cp, rg, r_vir, hlv 115 | real, intent(in) :: rsin2_l(isd:ied, jsd:jed) 116 | real, intent(in) :: cosa_s_l(isd:ied, jsd:jed) 117 | logical, intent(in):: moist_phys, hydrostatic, moist_kappa 118 | ! Output: 119 | real, intent(out):: te_2d(is:ie,js:je) ! vertically integrated TE 120 | real, intent(out):: teq(is:ie,js:je) ! Moist TE 121 | ! Local 122 | real, dimension(is:ie,km):: tv 123 | real phiz(is:ie,km+1) 124 | real cvm(is:ie), qd(is:ie) 125 | integer i, j, k 126 | 127 | !$OMP parallel do default(none) shared(is,ie,js,je,isd,ied,jsd,jed,km,hydrostatic,hs,pt,qc,q_con,rg,peln,te_2d, & 128 | !$OMP pe,delp,cp,rsin2_l,u,v,cosa_s_l,delz,moist_phys,w, & 129 | !$OMP q,nwat,liq_wat,rainwat,ice_wat,snowwat,graupel,sphum,moist_kappa) & 130 | !$OMP private(phiz, tv, cvm, qd) 131 | do j=js,je 132 | 133 | if ( hydrostatic ) then 134 | 135 | do i=is,ie 136 | phiz(i,km+1) = hs(i,j) 137 | enddo 138 | do k=km,1,-1 139 | do i=is,ie 140 | #ifdef USE_COND 141 | tv(i,k) = pt(i,j,k)*(1.+qc(i,j,k))*(1-q_con(i,j,k)) 142 | #else 143 | tv(i,k) = pt(i,j,k)*(1.+qc(i,j,k)) 144 | #endif 145 | phiz(i,k) = phiz(i,k+1) + rg*tv(i,k)*(peln(i,k+1,j)-peln(i,k,j)) 146 | enddo 147 | enddo 148 | 149 | do i=is,ie 150 | te_2d(i,j) = pe(i,km+1,j)*phiz(i,km+1) - pe(i,1,j)*phiz(i,1) 151 | enddo 152 | 153 | do k=1,km 154 | do i=is,ie 155 | te_2d(i,j) = te_2d(i,j) + delp(i,j,k)*(cp*tv(i,k) + & 156 | 0.25*rsin2_l(i,j)*(u(i,j,k)**2+u(i,j+1,k)**2 + & 157 | v(i,j,k)**2+v(i+1,j,k)**2 - & 158 | (u(i,j,k)+u(i,j+1,k))*(v(i,j,k)+v(i+1,j,k))*cosa_s_l(i,j))) 159 | enddo 160 | enddo 161 | 162 | else 163 | !----------------- 164 | ! Non-hydrostatic: 165 | !----------------- 166 | do i=is,ie 167 | phiz(i,km+1) = hs(i,j) 168 | do k=km,1,-1 169 | phiz(i,k) = phiz(i,k+1) - grav*delz(i,j,k) 170 | enddo 171 | enddo 172 | do i=is,ie 173 | te_2d(i,j) = 0. 174 | enddo 175 | !TODO moist_phys doesn't seem to make a difference --- lmh 13may21 176 | if ( moist_phys ) then 177 | do k=1,km 178 | if (moist_kappa) then 179 | call moist_cv(is,ie,isd,ied,jsd,jed, km, j, k, nwat, sphum, liq_wat, rainwat, & 180 | ice_wat, snowwat, graupel, q, qd, cvm) 181 | do i=is,ie 182 | te_2d(i,j) = te_2d(i,j) + delp(i,j,k)*( cvm(i)*pt(i,j,k) + & 183 | 0.5*(phiz(i,k)+phiz(i,k+1)+w(i,j,k)**2+0.5*rsin2_l(i,j)*(u(i,j,k)**2+u(i,j+1,k)**2 + & 184 | v(i,j,k)**2+v(i+1,j,k)**2-(u(i,j,k)+u(i,j+1,k))*(v(i,j,k)+v(i+1,j,k))*cosa_s_l(i,j)))) 185 | enddo 186 | else 187 | do i=is,ie 188 | te_2d(i,j) = te_2d(i,j) + delp(i,j,k)*( cv_air*pt(i,j,k) + & 189 | 0.5*(phiz(i,k)+phiz(i,k+1)+w(i,j,k)**2+0.5*rsin2_l(i,j)*(u(i,j,k)**2+u(i,j+1,k)**2 + & 190 | v(i,j,k)**2+v(i+1,j,k)**2-(u(i,j,k)+u(i,j+1,k))*(v(i,j,k)+v(i+1,j,k))*cosa_s_l(i,j)))) 191 | enddo 192 | endif 193 | enddo 194 | else 195 | do k=1,km 196 | do i=is,ie 197 | te_2d(i,j) = te_2d(i,j) + delp(i,j,k)*( cv_air*pt(i,j,k) + & 198 | 0.5*(phiz(i,k)+phiz(i,k+1)+w(i,j,k)**2+0.5*rsin2_l(i,j)*(u(i,j,k)**2+u(i,j+1,k)**2 + & 199 | v(i,j,k)**2+v(i+1,j,k)**2-(u(i,j,k)+u(i,j+1,k))*(v(i,j,k)+v(i+1,j,k))*cosa_s_l(i,j)))) 200 | enddo 201 | enddo 202 | endif 203 | endif 204 | enddo 205 | 206 | !------------------------------------- 207 | ! Diganostics computation for moist TE 208 | !------------------------------------- 209 | if( id_te>0 ) then 210 | !$OMP parallel do default(none) shared(is,ie,js,je,teq,te_2d,moist_phys,km,hlv,sphum,q,delp) 211 | do j=js,je 212 | do i=is,ie 213 | teq(i,j) = te_2d(i,j) 214 | enddo 215 | if ( moist_phys ) then 216 | do k=1,km 217 | do i=is,ie 218 | teq(i,j) = teq(i,j) + hlv*q(i,j,k,sphum)*delp(i,j,k) 219 | enddo 220 | enddo 221 | endif 222 | enddo 223 | endif 224 | 225 | end subroutine compute_total_energy 226 | 227 | #ifdef THERMO_PROTOTYPE 228 | subroutine fv_thermodynamics_init 229 | 230 | !set up heat capacities for each tracer 231 | 232 | do n=1,min(ncnst,nwat) 233 | tracer_name = ... 234 | if ( 'sphum' == trim(tracer_name)) then 235 | dcv(n) = cv_vap - cv_air 236 | dcp(n) = cp_vap - cp_air 237 | else if ( ANY( (/'liq_wat','rainwat'/) == trim(tracer_name)) ) then 238 | dcv(n) = c_liq - cv_air 239 | dcp(n) = c_liq - cp_air 240 | else if ( ANY( (/'ice_wat', 'snowwat', 'graupel', 'hailwat'/) == trim(tracer_name)) ) then 241 | dcv(n) = c_ice - cv_air 242 | dcp(n) = c_ice - cp_air 243 | endif 244 | enddo 245 | 246 | end subroutine fv_thermodynamics_init 247 | #endif 248 | 249 | 250 | subroutine moist_cv(is,ie, isd,ied, jsd,jed, km, j, k, nwat, sphum, liq_wat, rainwat, & 251 | ice_wat, snowwat, graupel, q, q_con, cvm, t1) 252 | integer, intent(in):: is, ie, isd,ied, jsd,jed, km, nwat, j, k 253 | integer, intent(in):: sphum, liq_wat, rainwat, ice_wat, snowwat, graupel 254 | real, intent(in), dimension(isd:ied,jsd:jed,km,nwat):: q 255 | real, intent(out), dimension(is:ie):: cvm, q_con 256 | real, intent(in), optional:: t1(is:ie) 257 | ! 258 | real, parameter:: t_i0 = 15. 259 | real, dimension(is:ie):: qv, ql, qs 260 | integer:: i 261 | 262 | select case (nwat) 263 | 264 | case(2) 265 | if ( present(t1) ) then ! Special case for GFS physics 266 | do i=is,ie 267 | q_con(i) = max(0., q(i,j,k,liq_wat)) 268 | if ( t1(i) > tice ) then 269 | qs(i) = 0. 270 | elseif ( t1(i) < tice-t_i0 ) then 271 | qs(i) = q_con(i) 272 | else 273 | qs(i) = q_con(i)*(tice-t1(i))/t_i0 274 | endif 275 | ql(i) = q_con(i) - qs(i) 276 | qv(i) = max(0.,q(i,j,k,sphum)) 277 | cvm(i) = (1.-(qv(i)+q_con(i)))*cv_air + qv(i)*cv_vap + ql(i)*c_liq + qs(i)*c_ice 278 | enddo 279 | else 280 | do i=is,ie 281 | qv(i) = max(0.,q(i,j,k,sphum)) 282 | qs(i) = max(0.,q(i,j,k,liq_wat)) 283 | q_con(i) = qs(i) 284 | cvm(i) = (1.-qv(i))*cv_air + qv(i)*cv_vap 285 | enddo 286 | endif 287 | case (3) 288 | do i=is,ie 289 | qv(i) = q(i,j,k,sphum) 290 | ql(i) = q(i,j,k,liq_wat) 291 | qs(i) = q(i,j,k,ice_wat) 292 | q_con(i) = ql(i) + qs(i) 293 | cvm(i) = (1.-(qv(i)+q_con(i)))*cv_air + qv(i)*cv_vap + ql(i)*c_liq + qs(i)*c_ice 294 | enddo 295 | case(4) ! K_warm_rain with fake ice 296 | do i=is,ie 297 | qv(i) = q(i,j,k,sphum) 298 | q_con(i) = q(i,j,k,liq_wat) + q(i,j,k,rainwat) 299 | cvm(i) = (1.-(qv(i)+q_con(i)))*cv_air + qv(i)*cv_vap + q_con(i)*c_liq 300 | enddo 301 | case(5) 302 | do i=is,ie 303 | qv(i) = q(i,j,k,sphum) 304 | ql(i) = q(i,j,k,liq_wat) + q(i,j,k,rainwat) 305 | qs(i) = q(i,j,k,ice_wat) + q(i,j,k,snowwat) 306 | q_con(i) = ql(i) + qs(i) 307 | cvm(i) = (1.-(qv(i)+q_con(i)))*cv_air + qv(i)*cv_vap + ql(i)*c_liq + qs(i)*c_ice 308 | enddo 309 | case(6) 310 | do i=is,ie 311 | qv(i) = q(i,j,k,sphum) 312 | ql(i) = q(i,j,k,liq_wat) + q(i,j,k,rainwat) 313 | qs(i) = q(i,j,k,ice_wat) + q(i,j,k,snowwat) + q(i,j,k,graupel) 314 | q_con(i) = ql(i) + qs(i) 315 | cvm(i) = (1.-(qv(i)+q_con(i)))*cv_air + qv(i)*cv_vap + ql(i)*c_liq + qs(i)*c_ice 316 | enddo 317 | case default 318 | !call mpp_error (NOTE, 'fv_mapz::moist_cv - using default cv_air') 319 | do i=is,ie 320 | q_con(i) = 0. 321 | cvm(i) = cv_air 322 | enddo 323 | end select 324 | 325 | end subroutine moist_cv 326 | 327 | subroutine moist_cp(is,ie, isd,ied, jsd,jed, km, j, k, nwat, sphum, liq_wat, rainwat, & 328 | ice_wat, snowwat, graupel, q, q_con, cpm, t1) 329 | 330 | integer, intent(in):: is, ie, isd,ied, jsd,jed, km, nwat, j, k 331 | integer, intent(in):: sphum, liq_wat, rainwat, ice_wat, snowwat, graupel 332 | real, intent(in), dimension(isd:ied,jsd:jed,km,nwat):: q 333 | real, intent(out), dimension(is:ie):: cpm, q_con 334 | real, intent(in), optional:: t1(is:ie) 335 | ! 336 | real, parameter:: t_i0 = 15. 337 | real, dimension(is:ie):: qv, ql, qs 338 | integer:: i 339 | 340 | select case (nwat) 341 | 342 | case(2) 343 | if ( present(t1) ) then ! Special case for GFS physics 344 | do i=is,ie 345 | q_con(i) = max(0., q(i,j,k,liq_wat)) 346 | if ( t1(i) > tice ) then 347 | qs(i) = 0. 348 | elseif ( t1(i) < tice-t_i0 ) then 349 | qs(i) = q_con(i) 350 | else 351 | qs(i) = q_con(i)*(tice-t1(i))/t_i0 352 | endif 353 | ql(i) = q_con(i) - qs(i) 354 | qv(i) = max(0.,q(i,j,k,sphum)) 355 | cpm(i) = (1.-(qv(i)+q_con(i)))*cp_air + qv(i)*cp_vapor + ql(i)*c_liq + qs(i)*c_ice 356 | enddo 357 | else 358 | do i=is,ie 359 | qv(i) = max(0.,q(i,j,k,sphum)) 360 | qs(i) = max(0.,q(i,j,k,liq_wat)) 361 | q_con(i) = qs(i) 362 | cpm(i) = (1.-qv(i))*cp_air + qv(i)*cp_vapor 363 | enddo 364 | endif 365 | 366 | case(3) 367 | do i=is,ie 368 | qv(i) = q(i,j,k,sphum) 369 | ql(i) = q(i,j,k,liq_wat) 370 | qs(i) = q(i,j,k,ice_wat) 371 | q_con(i) = ql(i) + qs(i) 372 | cpm(i) = (1.-(qv(i)+q_con(i)))*cp_air + qv(i)*cp_vapor + ql(i)*c_liq + qs(i)*c_ice 373 | enddo 374 | case(4) ! K_warm_rain scheme with fake ice 375 | do i=is,ie 376 | qv(i) = q(i,j,k,sphum) 377 | q_con(i) = q(i,j,k,liq_wat) + q(i,j,k,rainwat) 378 | cpm(i) = (1.-(qv(i)+q_con(i)))*cp_air + qv(i)*cp_vapor + q_con(i)*c_liq 379 | enddo 380 | case(5) 381 | do i=is,ie 382 | qv(i) = q(i,j,k,sphum) 383 | ql(i) = q(i,j,k,liq_wat) + q(i,j,k,rainwat) 384 | qs(i) = q(i,j,k,ice_wat) + q(i,j,k,snowwat) 385 | q_con(i) = ql(i) + qs(i) 386 | cpm(i) = (1.-(qv(i)+q_con(i)))*cp_air + qv(i)*cp_vapor + ql(i)*c_liq + qs(i)*c_ice 387 | enddo 388 | case(6) 389 | do i=is,ie 390 | qv(i) = q(i,j,k,sphum) 391 | ql(i) = q(i,j,k,liq_wat) + q(i,j,k,rainwat) 392 | qs(i) = q(i,j,k,ice_wat) + q(i,j,k,snowwat) + q(i,j,k,graupel) 393 | q_con(i) = ql(i) + qs(i) 394 | cpm(i) = (1.-(qv(i)+q_con(i)))*cp_air + qv(i)*cp_vapor + ql(i)*c_liq + qs(i)*c_ice 395 | enddo 396 | case default 397 | !call mpp_error (NOTE, 'fv_mapz::moist_cp - using default cp_air') 398 | do i=is,ie 399 | q_con(i) = 0. 400 | cpm(i) = cp_air 401 | enddo 402 | end select 403 | 404 | end subroutine moist_cp 405 | 406 | subroutine compute_q_con(bd, npz, nwat, nq, q, q_con) 407 | type(fv_grid_bounds_type), intent(IN) :: bd 408 | integer, intent(in):: npz, nwat, nq 409 | real, intent(in), dimension(bd%isd:bd%ied,bd%jsd:bd%jed,npz,nq):: q 410 | real, intent(out), dimension(bd%is:bd%ie,bd%js:bd%je,npz):: q_con 411 | 412 | integer:: n, dum 413 | character(len=32) :: tracer_name 414 | integer :: is, ie, js, je 415 | integer :: isd, ied, jsd, jed 416 | 417 | is = bd%is 418 | ie = bd%ie 419 | js = bd%js 420 | je = bd%je 421 | isd = bd%isd 422 | ied = bd%ied 423 | jsd = bd%jsd 424 | jed = bd%jed 425 | 426 | !Not optimized for OpenMP yet 427 | 428 | q_con = 0. 429 | do n=1,nwat 430 | dum = get_tracer_name(MODEL_ATMOS, n, tracer_name) 431 | select case (trim(tracer_name)) 432 | case('liq_wat','rainwat') 433 | q_con = q_con + q(is:ie,js:je,:,n) 434 | case('ice_wat','snowwat','graupel','hailwat') 435 | q_con = q_con + q(is:ie,js:je,:,n) 436 | end select 437 | enddo 438 | 439 | end subroutine compute_q_con 440 | 441 | ! subroutine compute_moist_kappa(!! 442 | ! 443 | ! end subroutine compute_moist_kappa 444 | 445 | 446 | end module fv_thermodynamics_mod 447 | --------------------------------------------------------------------------------