diff --git a/Makefile b/Makefile index 4d5f20edfb..10e5d30beb 100644 --- a/Makefile +++ b/Makefile @@ -20,7 +20,7 @@ gnu: # BUILDTARGET GNU Fortran, C, and C++ compilers "CFLAGS_OPT = -O3" \ "CXXFLAGS_OPT = -O3" \ "LDFLAGS_OPT = -O3" \ - "FFLAGS_DEBUG = -g -ffree-line-length-none -fconvert=big-endian -ffree-form -fcheck=all -fbacktrace -ffpe-trap=invalid,zero,overflow" \ + "FFLAGS_DEBUG = -std=f2008 -g -ffree-line-length-none -fconvert=big-endian -ffree-form -fcheck=all -fbacktrace -ffpe-trap=invalid,zero,overflow" \ "CFLAGS_DEBUG = -g" \ "CXXFLAGS_DEBUG = -g" \ "LDFLAGS_DEBUG = -g" \ @@ -654,6 +654,33 @@ cray: # BUILDTARGET Cray Programming Environment "OPENMP = $(OPENMP)" \ "CPPFLAGS = $(MODEL_FORMULATION) -D_MPI" ) +intel: # BUILDTARGET Intel oneAPI Fortran, C, and C++ compiler suite + ( $(MAKE) all \ + "FC_PARALLEL = mpifort" \ + "CC_PARALLEL = mpicc" \ + "CXX_PARALLEL = mpic++" \ + "FC_SERIAL = ifx" \ + "CC_SERIAL = icx" \ + "CXX_SERIAL = icpx" \ + "FFLAGS_PROMOTION = -real-size 64" \ + "FFLAGS_OPT = -O3 -convert big_endian -free -align array64byte" \ + "CFLAGS_OPT = -O3" \ + "CXXFLAGS_OPT = -O3" \ + "LDFLAGS_OPT = -O3" \ + "FFLAGS_DEBUG = -g -convert big_endian -free -check all -fpe0 -traceback" \ + "CFLAGS_DEBUG = -g -traceback" \ + "CXXFLAGS_DEBUG = -g -traceback" \ + "LDFLAGS_DEBUG = -g -fpe0 -traceback" \ + "FFLAGS_OMP = -qopenmp" \ + "CFLAGS_OMP = -qopenmp" \ + "PICFLAG = -fpic" \ + "BUILD_TARGET = $(@)" \ + "CORE = $(CORE)" \ + "DEBUG = $(DEBUG)" \ + "USE_PAPI = $(USE_PAPI)" \ + "OPENMP = $(OPENMP)" \ + "CPPFLAGS = $(MODEL_FORMULATION) -D_MPI" ) + CPPINCLUDES = FCINCLUDES = LIBS = @@ -831,14 +858,18 @@ ifeq "$(OPENMP_OFFLOAD)" "true" LDFLAGS += $(LDFLAGS_GPU) endif #OPENMP_OFFLOAD IF -ifeq "$(PRECISION)" "single" +ifneq (,$(filter-out double single,$(PRECISION))) +$(error PRECISION should be "", "single", or "double"; received value "$(PRECISION)") +endif +ifeq "$(PRECISION)" "double" + FFLAGS += $(FFLAGS_PROMOTION) + PRECISION_MESSAGE="MPAS was built with default double-precision reals." +else +$(if $(PRECISION),$(info NOTE: PRECISION=single is unnecessary, single is the default)) CFLAGS += "-DSINGLE_PRECISION" CXXFLAGS += "-DSINGLE_PRECISION" override CPPFLAGS += "-DSINGLE_PRECISION" PRECISION_MESSAGE="MPAS was built with default single-precision reals." -else - FFLAGS += $(FFLAGS_PROMOTION) - PRECISION_MESSAGE="MPAS was built with default double-precision reals." endif #PRECISION IF ifeq "$(USE_PAPI)" "true" @@ -996,6 +1027,7 @@ override CPPFLAGS += -DMPAS_BUILD_TARGET=$(BUILD_TARGET) ifeq ($(wildcard src/core_$(CORE)), ) # CHECK FOR EXISTENCE OF CORE DIRECTORY all: core_error +clean: core_error else @@ -1074,70 +1106,70 @@ ifeq "$(OPENACC)" "true" @# See whether the test programs can be compiled @# @echo "Checking [$(BUILD_TARGET)] compilers for OpenACC support..." - @( $(SCC) openacc.c $(CPPINCLUDES) $(CFLAGS) $(LDFLAGS) $(LIBS) -o openacc_c.out > openacc_c.log 2>&1; \ + @( $(SCC) openacc.c $(CPPINCLUDES) $(CFLAGS) $(LDFLAGS) -o openacc_c.out > openacc_c.log 2>&1; \ if [ $$? -eq 0 ]; then \ echo "=> $(SCC) can compile test OpenACC program"; \ else \ echo "*********************************************************"; \ echo "ERROR: Test OpenACC C program could not be compiled by $(SCC)."; \ echo "Following compilation command failed with errors:" ; \ - echo "$(SCC) openacc.c $(CPPINCLUDES) $(CFLAGS) $(LDFLAGS) $(LIBS) -o openacc_c.out"; \ + echo "$(SCC) openacc.c $(CPPINCLUDES) $(CFLAGS) $(LDFLAGS) -o openacc_c.out"; \ echo ""; \ echo "Test program openacc.c and output openacc_c.log have been left"; \ echo "in the top-level MPAS directory for further debugging"; \ echo "*********************************************************"; \ rm -f openacc.f90 openacc_[cf].out openacc_f.log; exit 1; \ fi ) - @( $(CC) openacc.c $(CPPINCLUDES) $(CFLAGS) $(LDFLAGS) $(LIBS) -o openacc_c.out > openacc_c.log 2>&1; \ + @( $(CC) openacc.c $(CPPINCLUDES) $(CFLAGS) $(LDFLAGS) -o openacc_c.out > openacc_c.log 2>&1; \ if [ $$? -eq 0 ] ; then \ echo "=> $(CC) can compile test OpenACC program"; \ else \ echo "*********************************************************"; \ echo "ERROR: Test OpenACC C program could not be compiled by $(CC)."; \ echo "Following compilation command failed with errors:" ; \ - echo "$(CC) openacc.c $(CPPINCLUDES) $(CFLAGS) $(LDFLAGS) $(LIBS) -o openacc_c.out"; \ + echo "$(CC) openacc.c $(CPPINCLUDES) $(CFLAGS) $(LDFLAGS) -o openacc_c.out"; \ echo ""; \ echo "Test program openacc.c and output openacc_c.log have been left"; \ echo "in the top-level MPAS directory for further debugging"; \ echo "*********************************************************"; \ rm -f openacc.f90 openacc_[cf].out openacc_f.log; exit 1; \ fi ) - @( $(CXX) openacc.c $(CPPINCLUDES) $(CFLAGS) $(LDFLAGS) $(LIBS) -o openacc_c.out > openacc_c.log 2>&1; \ + @( $(CXX) openacc.c $(CPPINCLUDES) $(CFLAGS) $(LDFLAGS) -o openacc_c.out > openacc_c.log 2>&1; \ if [ $$? -eq 0 ] ; then \ echo "=> $(CXX) can compile test OpenACC program"; \ else \ echo "*********************************************************"; \ echo "ERROR: Test OpenACC C program could not be compiled by $(CXX)."; \ echo "Following compilation command failed with errors:" ; \ - echo "$(CXX) openacc.c $(CPPINCLUDES) $(CFLAGS) $(LDFLAGS) $(LIBS) -o openacc_c.out"; \ + echo "$(CXX) openacc.c $(CPPINCLUDES) $(CFLAGS) $(LDFLAGS) -o openacc_c.out"; \ echo ""; \ echo "Test program openacc.c and output openacc_c.log have been left"; \ echo "in the top-level MPAS directory for further debugging"; \ echo "*********************************************************"; \ rm -f openacc.f90 openacc_[cf].out openacc_f.log; exit 1; \ fi ) - @( $(SFC) openacc.f90 $(FCINCLUDES) $(FFLAGS) $(LDFLAGS) $(LIBS) -o openacc_f.out > openacc_f.log 2>&1; \ + @( $(SFC) openacc.f90 $(FCINCLUDES) $(FFLAGS) $(LDFLAGS) -o openacc_f.out > openacc_f.log 2>&1; \ if [ $$? -eq 0 ] ; then \ echo "=> $(SFC) can compile test OpenACC program"; \ else \ echo "*********************************************************"; \ echo "ERROR: Test OpenACC Fortran program could not be compiled by $(SFC)."; \ echo "Following compilation command failed with errors:" ; \ - echo "$(SFC) openacc.f90 $(FCINCLUDES) $(FFLAGS) $(LDFLAGS) $(LIBS) -o openacc_f.out"; \ + echo "$(SFC) openacc.f90 $(FCINCLUDES) $(FFLAGS) $(LDFLAGS) -o openacc_f.out"; \ echo ""; \ echo "Test program openacc.f90 and output openacc_f.log have been left"; \ echo "in the top-level MPAS directory for further debugging"; \ echo "*********************************************************"; \ rm -f openacc.c openacc_[cf].out openacc_c.log; exit 1; \ fi ) - @( $(FC) openacc.f90 $(FCINCLUDES) $(FFLAGS) $(LDFLAGS) $(LIBS) -o openacc_f.out > openacc_f.log 2>&1; \ + @( $(FC) openacc.f90 $(FCINCLUDES) $(FFLAGS) $(LDFLAGS) -o openacc_f.out > openacc_f.log 2>&1; \ if [ $$? -eq 0 ] ; then \ echo "=> $(FC) can compile test OpenACC program"; \ else \ echo "*********************************************************"; \ echo "ERROR: Test OpenACC Fortran program could not be compiled by $(FC)."; \ echo "Following compilation command failed with errors:" ; \ - echo "$(FC) openacc.f90 $(FCINCLUDES) $(FFLAGS) $(LDFLAGS) $(LIBS) -o openacc_f.out"; \ + echo "$(FC) openacc.f90 $(FCINCLUDES) $(FFLAGS) $(LDFLAGS) -o openacc_f.out"; \ echo ""; \ echo "Test program openacc.f90 and output openacc_f.log have been left"; \ echo "in the top-level MPAS directory for further debugging"; \ @@ -1225,11 +1257,42 @@ endif exit 1; \ fi + +mpi_f08_test: + @# + @# MPAS_MPI_F08 will be set to: + @# 0 if no mpi_f08 module support was detected + @# 1 if the MPI library provides an mpi_f08 module + @# + $(info Checking for mpi_f08 support...) + $(eval MPAS_MPI_F08 := $(shell $\ + printf "program main\n$\ + & use mpi_f08, only : MPI_Init, MPI_Comm\n$\ + & integer :: ierr\n$\ + & type (MPI_Comm) :: comm\n$\ + & call MPI_Init(ierr)\n$\ + end program main\n" | sed 's/&/ /' > mpi_f08.f90; $\ + $\ + $(FC) mpi_f08.f90 -o mpi_f08.x $(FFLAGS) $(LDFLAGS) > /dev/null 2>&1; $\ + mpi_f08_status=$$?; $\ + rm -f mpi_f08.f90 mpi_f08.x; $\ + if [ $$mpi_f08_status -eq 0 ]; then $\ + printf "1"; $\ + else $\ + printf "0"; $\ + fi $\ + )) + $(if $(findstring 0,$(MPAS_MPI_F08)), $(eval MPI_F08_MESSAGE = "Using the mpi module."), ) + $(if $(findstring 0,$(MPAS_MPI_F08)), $(info No working mpi_f08 module detected; using mpi module.)) + $(if $(findstring 1,$(MPAS_MPI_F08)), $(eval override CPPFLAGS += -DMPAS_USE_MPI_F08), ) + $(if $(findstring 1,$(MPAS_MPI_F08)), $(eval MPI_F08_MESSAGE = "Using the mpi_f08 module."), ) + $(if $(findstring 1,$(MPAS_MPI_F08)), $(info mpi_f08 module detected.)) + ifneq "$(PIO)" "" -MAIN_DEPS = openmp_test openacc_test pio_test +MAIN_DEPS = openmp_test openacc_test pio_test mpi_f08_test override CPPFLAGS += "-DMPAS_PIO_SUPPORT" else -MAIN_DEPS = openmp_test openacc_test +MAIN_DEPS = openmp_test openacc_test mpi_f08_test IO_MESSAGE = "Using the SMIOL library." override CPPFLAGS += "-DMPAS_SMIOL_SUPPORT" endif @@ -1268,6 +1331,7 @@ endif @echo $(PRECISION_MESSAGE) @echo $(DEBUG_MESSAGE) @echo $(PARALLEL_MESSAGE) + @echo $(MPI_F08_MESSAGE) @echo $(PAPI_MESSAGE) @echo $(TAU_MESSAGE) @echo $(OPENMP_MESSAGE) @@ -1320,8 +1384,7 @@ clean_core: else # CORE IF all: error -clean: errmsg - exit 1 +clean: error error: errmsg @echo "************ ERROR ************" @echo "No CORE specified. Quitting." @@ -1353,7 +1416,7 @@ errmsg: @echo " TIMER_LIB=tau - Uses TAU for the timer interface instead of the native interface" @echo " OPENMP=true - builds and links with OpenMP flags. Default is to not use OpenMP." @echo " OPENACC=true - builds and links with OpenACC flags. Default is to not use OpenACC." - @echo " PRECISION=single - builds with default single-precision real kind. Default is to use double-precision." + @echo " PRECISION=double - builds with default double-precision real kind. Default is to use single-precision." @echo " SHAREDLIB=true - generate position-independent code suitable for use in a shared library. Default is false." @echo "" @echo "Ensure that NETCDF, PNETCDF, PIO, and PAPI (if USE_PAPI=true) are environment variables" diff --git a/README.md b/README.md index 148dcf2a76..9823010d8b 100644 --- a/README.md +++ b/README.md @@ -1,4 +1,4 @@ -MPAS-v8.0.2 +MPAS-v8.1.0 ==== The Model for Prediction Across Scales (MPAS) is a collaborative project for diff --git a/azure-pipelines.yml b/azure-pipelines.yml deleted file mode 100644 index c586773f9e..0000000000 --- a/azure-pipelines.yml +++ /dev/null @@ -1,141 +0,0 @@ -trigger: - branches: - include: - - master - - develop - - ocean/develop - - lanice/develop - - ocean/coastal - tags: - include: - - '*' -pr: - branches: - include: - - master - - develop - - ocean/develop - - lanice/develop - - ocean/coastal - -jobs: -- job: - displayName: docs - pool: - vmImage: 'ubuntu-16.04' - strategy: - matrix: - Python38: - python.version: '3.8' - - steps: - - bash: echo "##vso[task.prependpath]$CONDA/bin" - displayName: Add conda to PATH - - - bash: | - set -e - eval "$(conda shell.bash hook)" - conda config --add channels conda-forge - conda config --set channel_priority strict - displayName: Configure conda - - - bash: | - set -e - eval "$(conda shell.bash hook)" - conda create -y -n docs python=$PYTHON_VERSION sphinx mock sphinx_rtd_theme m2r - displayName: Create docs environment - - - bash: | - set -e - eval "$(conda shell.bash hook)" - conda activate docs - - echo "source branch: $(Build.SourceBranch)" - echo "repository: $(Build.Repository.Name)" - - tag=$(git describe --tags $(git rev-list --tags --max-count=1)) - echo "tag: $tag" - - REPO_PATH=$PWD - - if [[ "$(Build.SourceBranch)" == refs/tags/* ]]; then - echo "this is a tag build" - export DOCS_VERSION="$tag" - deploy=True - run=True - elif [[ "$(Build.SourceBranch)" == refs/heads/* ]]; then - branch="$(Build.SourceBranchName)" - echo "this is a merge build of $branch" - deploy=True - elif [[ "$(Build.SourceBranch)" == refs/pull/*/merge ]]; then - branch="$(System.PullRequest.TargetBranch)" - echo "this is a pull request into $branch" - deploy=False - fi - - if [ -n ${branch} ]; then - echo "This build is for branch $branch" - if [[ ${branch} == "master" ]]; then - export DOCS_VERSION="stable" - run=True - elif [[ ${branch} == "develop" ]]; then - export DOCS_VERSION="latest" - run=True - elif [[ ${branch} == "ocean/develop" ]]; then - export DOCS_VERSION="latest ocean" - run=True - elif [[ ${branch} == "ocean/coastal" ]]; then - export DOCS_VERSION="latest coastal" - run=True - elif [[ ${branch} == "landice/develop" ]]; then - export DOCS_VERSION="latest landice" - run=True - else - echo "We don't build docs for $branch" - deploy=False - run=False - fi - fi - - if [[ "${run}" == "False" ]]; then - echo "Not building docs for branch ${branch}" - exit 0 - fi - - echo "Docs version: $DOCS_VERSION" - echo "Deploy to gh-pages? $deploy" - cd docs || exit 1 - make html - - cd "$REPO_PATH" || exit 1 - - if [[ "$deploy" == "False" ]]; then - exit 0 - fi - - PUBLICATION_BRANCH=gh-pages - DOCS_PATH="${DOCS_VERSION// /_}" - # Checkout the branch - pushd $HOME || exit 1 - git clone --branch=$PUBLICATION_BRANCH https://$(GitHubToken)@github.com/$(Build.Repository.Name) publish - cd publish || exit 1 - - # Update pages - if [[ -d "$DOCS_PATH" ]]; then - git rm -rf "$DOCS_PATH" > /dev/null - fi - mkdir "$DOCS_PATH" - cp -r "$REPO_PATH"/docs/_build/html/* "$DOCS_PATH" - # Commit and push latest version - git add . - if git diff-index --quiet HEAD; then - echo "No changes in the docs." - else - git config --local user.name "Azure Pipelines" - git config --local user.email "azuredevops@microsoft.com" - git commit -m "[skip ci] Update $DOCS_VERSION" - git push -fq origin $PUBLICATION_BRANCH - fi - popd || exit 1 - displayName: build and deploy docs - diff --git a/src/CMakeLists.txt b/src/CMakeLists.txt deleted file mode 100644 index 41375a53d2..0000000000 --- a/src/CMakeLists.txt +++ /dev/null @@ -1,97 +0,0 @@ -# -# This is the interface between E3SM's new CMake-based build system and MPAS. -# -# The following CMake variables are expected to be defined: -# * CORES : A list of CORES to build, comma-separated (e.g. "ocean,seaice,landice") -# * Whatever CIME settings are setting to correctly resolve the ${CASEROOT}/Macros.cmake file -# - COMPILER, DEBUG, MPILIB, MACH, OS -# - -# Source CIME-generated Macros -include(${CASEROOT}/Macros.cmake) -# Load machine/compiler specific settings -set(COMPILER_SPECIFIC_DEPENDS ${CASEROOT}/Depends.${COMPILER}.cmake) -set(MACHINE_SPECIFIC_DEPENDS ${CASEROOT}/Depends.${MACH}.cmake) -set(PLATFORM_SPECIFIC_DEPENDS ${CASEROOT}/Depends.${MACH}.${COMPILER}.cmake) -set(TRY_TO_LOAD ${COMPILER_SPECIFIC_DEPENDS} ${MACHINE_SPECIFIC_DEPENDS} ${PLATFORM_SPECIFIC_DEPENDS}) -foreach(ITEM IN LISTS TRY_TO_LOAD) - if (EXISTS ${ITEM}) - include(${ITEM}) - endif() -endforeach() - -# -# General setup -# - -if (USE_ESMF_LIB) - set(ESMFDIR "esmf") -else() - set(ESMFDIR "noesmf") -endif() - -set(CMAKE_C_COMPILER ${MPICC}) -set(CMAKE_CXX_COMPILER ${MPICXX}) -set(CMAKE_Fortran_COMPILER ${MPIFC}) -set(CMAKE_EXE_LINKER_FLAGS "${LDFLAGS}") -set(CMAKE_VERBOSE_MAKEFILE TRUE) - -# Set up CPPDEFS -set(FILE_OFFSET "-DOFFSET64BIT") -if (CPPDEFS) - separate_arguments(CPPDEFS UNIX_COMMAND "${CPPDEFS}") -endif() -list(APPEND CPPDEFS "-DMPAS_NO_LOG_REDIRECT" "-DUSE_PIO2" "-DMPAS_NO_ESMF_INIT" "-DMPAS_ESM_SHR_CONST" "-DMPAS_PERF_MOD_TIMERS" "${MODEL_FORMULATION}" "${FILE_OFFSET}" "${ZOLTAN_DEFINE}" "-D_MPI" "-DMPAS_NAMELIST_SUFFIX=${NAMELIST_SUFFIX}" "-DMPAS_EXE_NAME=${EXE_NAME}") -if (DEBUG) - list(APPEND CPPDEFS "-DMPAS_DEBUG") -endif() -if (compile_threaded) - list(APPEND CPPDEFS "-DMPAS_OPENMP") -endif() - -set(INCLUDES "${INSTALL_SHAREDPATH}/include" "${INSTALL_SHAREDPATH}/${COMP_INTERFACE}/${ESMFDIR}/${NINST_VALUE}/csm_share" "${INSTALL_SHAREDPATH}/pio" "${PNETCDF_PATH}/include" "${CMAKE_CURRENT_SOURCE_DIR}/external/ezxml" "${CMAKE_BINARY_DIR}/framework" "${CMAKE_BINARY_DIR}/operators") -if (NETCDF_PATH) - list(APPEND INCLUDES ${NETCDF_PATH}/include) -else() - if (NETCDF_C_PATH) - list(APPEND INCLUDES ${NETCDF_C_PATH}/include) - endif() - if (NETCDF_FORTRAN_PATH) - list(APPEND INCLUDES ${NETCDF_FORTRAN_PATH}/include) - endif() -endif() - -if (USE_KOKKOS) - include(${INSTALL_SHAREDPATH}/kokkos_generated_settings.cmake) - string (REPLACE ";" " " KOKKOS_CXXFLAGS_STR "${KOKKOS_CXXFLAGS}") - set(CXXFLAGS "${CXXFLAGS} ${KOKKOS_CXXFLAGS_STR}") -endif() - -set(CMAKE_Fortran_FLAGS "${FFLAGS}") -set(CMAKE_C_FLAGS "${CFLAGS}") -set(CMAKE_CXX_FLAGS "${CXXFLAGS}") - -# Include custom cmake libraries used for mpas -include(${CMAKE_CURRENT_SOURCE_DIR}/cmake_utils.cmake) -include(${CMAKE_CURRENT_SOURCE_DIR}/build_core.cmake) - -# Add tools -add_subdirectory(tools) - -# Gather sources that are needed for all cores into "common" library - -set(COMMON_RAW_SOURCES external/ezxml/ezxml.c) -include(${CMAKE_CURRENT_SOURCE_DIR}/framework/framework.cmake) -include(${CMAKE_CURRENT_SOURCE_DIR}/operators/operators.cmake) - -add_library(common OBJECT) -target_compile_definitions(common PRIVATE ${CPPDEFS}) -target_include_directories(common PRIVATE ${INCLUDES}) - -genf90_targets("${COMMON_RAW_SOURCES}" "${INCLUDES}" "${CPPDEFS}" "" "") -target_sources(common PRIVATE ${SOURCES}) - -# Build cores! -foreach(CORE IN LISTS CORES) - build_core(${CORE}) -endforeach() diff --git a/src/build_core.cmake b/src/build_core.cmake deleted file mode 100644 index c2c36464cb..0000000000 --- a/src/build_core.cmake +++ /dev/null @@ -1,67 +0,0 @@ -function(build_core CORE) - set(EXE_NAME ${CORE}_model) - set(NAMELIST_SUFFIX ${CORE}) - - # Map the ESM component corresponding to each MPAS core - if (CORE STREQUAL "ocean") - set(COMPONENT "ocn") - elseif(CORE STREQUAL "landice") - set(COMPONENT "glc") - elseif(CORE STREQUAL "seaice") - set(COMPONENT "ice") - else() - message(FATAL_ERROR "Unrecognized core: ${CORE}") - endif() - - # Gather sources - set(CORE_BLDDIR ${CMAKE_BINARY_DIR}/core_${CORE}) - if (NOT EXISTS ${CORE_BLDDIR}) - file(MAKE_DIRECTORY ${CORE_BLDDIR}) - endif() - - set(CORE_INPUT_DIR ${CORE_BLDDIR}/default_inputs) - if (NOT EXISTS ${CORE_INPUT_DIR}) - file(MAKE_DIRECTORY ${CORE_INPUT_DIR}) - endif() - - # Provides us RAW_SOURCES, CPPDEFS, and INCLUDES - include(${CMAKE_CURRENT_SOURCE_DIR}/core_${CORE}/${CORE}.cmake) - - add_library(${COMPONENT}) - target_compile_definitions(${COMPONENT} PRIVATE ${CPPDEFS}) - target_include_directories(${COMPONENT} PRIVATE ${INCLUDES}) - - # Make .inc files - add_custom_command ( - OUTPUT ${CORE_BLDDIR}/Registry_processed.xml - COMMAND cpp -P -traditional ${CPPDEFS} -Uvector - ${CMAKE_CURRENT_SOURCE_DIR}/core_${CORE}/Registry.xml > Registry_processed.xml - DEPENDS ${CMAKE_CURRENT_SOURCE_DIR}/core_${CORE}/Registry.xml - WORKING_DIRECTORY ${CORE_BLDDIR} - ) - - set(INC_DIR ${CORE_BLDDIR}/inc) - if (NOT EXISTS ${INC_DIR}) - file(MAKE_DIRECTORY ${INC_DIR}) - endif() - - add_custom_command( - OUTPUT ${INC_DIR}/core_variables.inc - COMMAND ${CMAKE_BINARY_DIR}/mpas-source/src/tools/parse < ${CORE_BLDDIR}/Registry_processed.xml - DEPENDS parse ${CORE_BLDDIR}/Registry_processed.xml - WORKING_DIRECTORY ${INC_DIR} - ) - - # Disable qsmp for some files - if (FFLAGS MATCHES ".*-qsmp.*") - foreach(DISABLE_QSMP_FILE IN LISTS DISABLE_QSMP) - get_filename_component(SOURCE_EXT ${DISABLE_QSMP_FILE} EXT) - string(REPLACE "${SOURCE_EXT}" ".f90" SOURCE_F90 ${DISABLE_QSMP_FILE}) - set_property(SOURCE ${CMAKE_BINARY_DIR}/${SOURCE_F90} APPEND_STRING PROPERTY COMPILE_FLAGS " -qnosmp") - endforeach() - endif() - - genf90_targets("${RAW_SOURCES}" "${INCLUDES}" "${CPPDEFS}" "${NO_PREPROCESS}" "${INC_DIR}") - target_sources(${COMPONENT} PRIVATE ${SOURCES} $) - -endfunction(build_core) diff --git a/src/cmake_utils.cmake b/src/cmake_utils.cmake deleted file mode 100644 index c3a25f238d..0000000000 --- a/src/cmake_utils.cmake +++ /dev/null @@ -1,74 +0,0 @@ -# Function for handling nl and st gen -function(handle_st_nl_gen NL_GEN_ARGS ST_GEN_ARGS CORE_INPUT_DIR_ARG CORE_BLDDIR_ARG) - foreach(NL_GEN_ARG IN LISTS NL_GEN_ARGS) - separate_arguments(ITEMS UNIX_COMMAND "${NL_GEN_ARG}") - list(GET ITEMS 0 ITEM) - list(APPEND INPUTS ${ITEM}) - add_custom_command( - OUTPUT ${CORE_INPUT_DIR_ARG}/${ITEM} - COMMAND ${CMAKE_BINARY_DIR}/tools/namelist_gen ${CORE_BLDDIR_ARG}/Registry_processed.xml ${NL_GEN_ARG} - DEPENDS namelist_gen ${CORE_BLDDIR_ARG}/Registry_processed.xml - WORKING_DIRECTORY ${CORE_INPUT_DIR_ARG} - ) - endforeach() - - foreach(ST_GEN_ARG IN LISTS ST_GEN_ARGS) - separate_arguments(ITEMS UNIX_COMMAND "${ST_GEN_ARG}") - list(GET ITEMS 0 ITEM) - list(APPEND INPUTS ${ITEM}) - add_custom_command( - OUTPUT ${CORE_INPUT_DIR_ARG}/${ITEM} - COMMAND ${CMAKE_BINARY_DIR}/tools/streams_gen ${CORE_BLDDIR_ARG}/Registry_processed.xml ${ST_GEN_ARG} - DEPENDS streams_gen ${CORE_BLDDIR_ARG}/Registry_processed.xml - WORKING_DIRECTORY ${CORE_INPUT_DIR_ARG} - ) - endforeach() - - foreach(INPUT IN LISTS INPUTS) - add_custom_command( - OUTPUT ${CORE_BLDDIR_ARG}/${INPUT} - COMMAND ${CMAKE_COMMAND} -E copy ${CORE_INPUT_DIR_ARG}/${INPUT} ${CORE_BLDDIR_ARG}/${INPUT} - DEPENDS ${CORE_INPUT_DIR_ARG}/${INPUT} - WORKING_DIRECTORY ${CORE_BLDDIR_ARG} - ) - endforeach() -endfunction() - -# Function for generating f90 file targets, will add to parent's SOURCES var -function(genf90_targets RAW_SOURCES_ARG INCLUDES_ARG CPPDEFS_ARG NO_PREPROCESS_ARG CORE_INC_DIR_ARG) - # Add -I to includes so that they can used for cpp command - foreach(ITEM IN LISTS INCLUDES_ARG) - list(APPEND INCLUDES_I "-I${ITEM}") - endforeach() - - # Run all .F files through cpp to generate the f90 file - foreach(RAW_SOURCE_FILE IN LISTS RAW_SOURCES_ARG) - get_filename_component(SOURCE_EXT ${RAW_SOURCE_FILE} EXT) - if ( (SOURCE_EXT STREQUAL ".F" OR SOURCE_EXT STREQUAL ".F90") AND NOT RAW_SOURCE_FILE IN_LIST NO_PREPROCESS_ARG) - string(REPLACE "${SOURCE_EXT}" ".f90" SOURCE_F90 ${RAW_SOURCE_FILE}) - get_filename_component(DIR_RELATIVE ${SOURCE_F90} DIRECTORY) - set(DIR_ABSOLUTE ${CMAKE_BINARY_DIR}/${DIR_RELATIVE}) - if (NOT EXISTS ${DIR_ABSOLUTE}) - file(MAKE_DIRECTORY ${DIR_ABSOLUTE}) - endif() - if (CORE_INC_DIR_ARG) - add_custom_command ( - OUTPUT ${CMAKE_BINARY_DIR}/${SOURCE_F90} - COMMAND cpp -P -traditional ${CPPDEFS_ARG} ${INCLUDES_I} -Uvector - ${CMAKE_CURRENT_SOURCE_DIR}/${RAW_SOURCE_FILE} > ${CMAKE_BINARY_DIR}/${SOURCE_F90} - DEPENDS ${CMAKE_CURRENT_SOURCE_DIR}/${RAW_SOURCE_FILE} ${CORE_INC_DIR_ARG}/core_variables.inc) - else() - add_custom_command ( - OUTPUT ${CMAKE_BINARY_DIR}/${SOURCE_F90} - COMMAND cpp -P -traditional ${CPPDEFS_ARG} ${INCLUDES_I} -Uvector - ${CMAKE_CURRENT_SOURCE_DIR}/${RAW_SOURCE_FILE} > ${CMAKE_BINARY_DIR}/${SOURCE_F90}) - endif() - list(APPEND LOCAL_SOURCES ${CMAKE_BINARY_DIR}/${SOURCE_F90}) - else() - list(APPEND LOCAL_SOURCES ${RAW_SOURCE_FILE}) - endif() - endforeach() - - set(SOURCES ${LOCAL_SOURCES} PARENT_SCOPE) - -endfunction(genf90_targets) diff --git a/src/core_atmosphere/Makefile b/src/core_atmosphere/Makefile index 60ce1b2703..c06d2a74b8 100644 --- a/src/core_atmosphere/Makefile +++ b/src/core_atmosphere/Makefile @@ -15,7 +15,8 @@ endif OBJS = mpas_atm_core.o \ mpas_atm_core_interface.o \ mpas_atm_dimensions.o \ - mpas_atm_threading.o + mpas_atm_threading.o \ + mpas_atm_halos.o all: $(PHYSCORE) dycore diagcore atmcore utilities @@ -25,7 +26,7 @@ core_reg: core_input_gen: if [ ! -e default_inputs ]; then mkdir default_inputs; fi ( cd default_inputs; $(NL_GEN) ../Registry_processed.xml namelist.atmosphere in_defaults=true ) - ( cd default_inputs; $(ST_GEN) ../Registry_processed.xml streams.atmosphere stream_list.atmosphere. listed ) + ( cd default_inputs; $(ST_GEN) ../Registry_processed.xml streams.atmosphere stream_list.atmosphere. listed in_defaults=true) gen_includes: core_reg (if [ ! -d inc ]; then mkdir -p inc; fi) # To generate *.inc files @@ -56,7 +57,7 @@ atmcore: $(PHYSCORE) dycore diagcore $(OBJS) mpas_atm_core_interface.o: mpas_atm_core.o -mpas_atm_core.o: dycore diagcore mpas_atm_threading.o +mpas_atm_core.o: dycore diagcore mpas_atm_threading.o mpas_atm_halos.o mpas_atm_dimensions.o: diff --git a/src/core_atmosphere/Registry.xml b/src/core_atmosphere/Registry.xml index 42630440c5..4dbab8d9dc 100644 --- a/src/core_atmosphere/Registry.xml +++ b/src/core_atmosphere/Registry.xml @@ -1,5 +1,5 @@ - + @@ -400,13 +400,14 @@ - + + @@ -415,11 +416,12 @@ - + filename_template="invariant.nc" + input_interval="none" + immutable="true" + in_defaults="false"> @@ -480,10 +482,6 @@ - - - - @@ -492,9 +490,23 @@ #endif + + + + + + + + + + @@ -557,80 +569,19 @@ output_interval="1_00:00:00" immutable="true"> - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + - - - #ifdef MPAS_CAM_DYCORE #endif - + @@ -687,6 +638,7 @@ + @@ -696,6 +648,19 @@ + + + + + + + + + + + + + @@ -824,6 +789,7 @@ + @@ -922,6 +888,7 @@ + @@ -1006,6 +973,7 @@ + @@ -1478,6 +1446,9 @@ + + @@ -1502,7 +1473,7 @@ + packages="bl_mynn_in;bl_ysu_in;cu_ntiedtke_in;mp_kessler_in;mp_thompson_in;mp_wsm6_in"/> + packages="bl_mynn_in;bl_ysu_in;cu_ntiedtke_in;mp_thompson_in;mp_wsm6_in"/> + packages="bl_mynn_in;mp_thompson_in;mp_wsm6_in"/> + packages="bl_mynn_in;bl_ysu_in;cu_ntiedtke_in;mp_kessler_in;mp_thompson_in;mp_wsm6_in"/> + packages="bl_mynn_in;bl_ysu_in;cu_ntiedtke_in;mp_thompson_in;mp_wsm6_in"/> + packages="bl_mynn_in;mp_thompson_in;mp_wsm6_in"/> - - + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + packages="cu_grell_freitas_in;cu_kain_fritsch_in;cu_ntiedtke_in"/> + packages="cu_grell_freitas_in;cu_kain_fritsch_in;cu_ntiedtke_in"/> + packages="cu_grell_freitas_in;cu_kain_fritsch_in;cu_ntiedtke_in"/> + packages="cu_grell_freitas_in;cu_kain_fritsch_in;cu_ntiedtke_in"/> @@ -2338,14 +2393,6 @@ description="Planetary Boundary Layer (PBL) height" packages="bl_mynn_in;bl_ysu_in"/> - - - - @@ -2360,12 +2407,32 @@ + + + + + + + + + + @@ -2414,6 +2481,46 @@ description="TKE vertical distribution" packages="bl_mynn_in"/> + + + + + + + + + + + + + + + + + + + + @@ -2551,6 +2658,10 @@ description="stability function for heat" packages="bl_mynn_in"/> + + + packages="cu_grell_freitas_in;cu_kain_fritsch_in;cu_ntiedtke_in"/> + packages="cu_grell_freitas_in;cu_kain_fritsch_in;cu_ntiedtke_in"/> + packages="cu_grell_freitas_in;cu_kain_fritsch_in;cu_ntiedtke_in"/> + packages="cu_grell_freitas_in;cu_kain_fritsch_in;cu_ntiedtke_in"/> @@ -3008,15 +3119,15 @@ + packages="cu_grell_freitas_in;cu_ntiedtke_in"/> + packages="cu_grell_freitas_in;cu_ntiedtke_in"/> + packages="cu_grell_freitas_in;cu_ntiedtke_in"/> @@ -3050,6 +3161,10 @@ description="tendency of cloud ice mixing ratio due to pbl processes" packages="bl_mynn_in;bl_ysu_in"/> + + @@ -3227,13 +3342,13 @@ - - block % next + ! Set the units to be cf compliant 'seconds since ' + call mpas_pool_get_field(state, 'Time', Time_field) + call mpas_modify_att(Time_field % attLists(1) % attList, 'units', & + 'seconds since ' // mpas_string_replace(initial_time1, '_', ' ')) + + block => block % next end do call exchange_halo_group(domain, 'initialization:pv_edge,ru,rw') @@ -955,6 +968,7 @@ subroutine atm_do_timestep(domain, dt, itimestep) use mpas_atmphys_manager use mpas_atmphys_update #endif + use mpas_atm_halos, only: exchange_halo_group implicit none @@ -999,6 +1013,7 @@ function atm_core_finalize(domain) result(ierr) use mpas_atm_diagnostics_manager, only : mpas_atm_diag_cleanup use mpas_atm_threading, only : mpas_atm_threading_finalize use atm_time_integration, only : mpas_atm_dynamics_finalize + use mpas_atm_halos, only: atm_destroy_halo_groups #ifdef DO_PHYSICS use mpas_atmphys_finalize @@ -1477,411 +1492,5 @@ subroutine mpas_atm_run_compatibility(dminfo, blockList, streamManager, ierr) end subroutine mpas_atm_run_compatibility - - !----------------------------------------------------------------------- - ! routine atm_build_halo_groups - ! - !> \brief Builds halo exchange groups used throughout atmosphere core - !> \author Michael Duda - !> \date 5 June 2023 - !> \details - !> This routine builds the halo exchange groups that are used throughout - !> the atmosphere core, and it sets a function pointer, - !> exchange_halo_group, to the routine that may be used to exchange the - !> halos for all fields in a named group. - !> - !> A value of 0 is returned if halo exchange groups have been - !> successfully set up and a non-zero value is returned otherwise. - ! - !----------------------------------------------------------------------- - subroutine atm_build_halo_groups(domain, ierr) - - use mpas_halo, only : mpas_halo_init, mpas_halo_exch_group_create, mpas_halo_exch_group_add_field, & - mpas_halo_exch_group_complete, mpas_halo_exch_group_full_halo_exch - - type (domain_type), intent(inout) :: domain - integer, intent(inout) :: ierr - - ! - ! Determine from the namelist option config_halo_exch_method which halo exchange method to employ - ! - call mpas_pool_get_config(domain % blocklist % configs, 'config_halo_exch_method', config_halo_exch_method) - - if (trim(config_halo_exch_method) == 'mpas_dmpar') then - call mpas_log_write('') - call mpas_log_write('*** Using ''mpas_dmpar'' routines for exchanging halos') - call mpas_log_write('') - - ! - ! Set up halo exchange groups used during atmosphere core initialization - ! - call mpas_dmpar_exch_group_create(domain, 'initialization:u') - call mpas_dmpar_exch_group_add_field(domain, 'initialization:u', 'u', timeLevel=1, haloLayers=(/1,2,3/)) - - call mpas_dmpar_exch_group_create(domain, 'initialization:pv_edge,ru,rw') - call mpas_dmpar_exch_group_add_field(domain, 'initialization:pv_edge,ru,rw', 'pv_edge', timeLevel=1, haloLayers=(/1,2,3/)) - call mpas_dmpar_exch_group_add_field(domain, 'initialization:pv_edge,ru,rw', 'ru', timeLevel=1, haloLayers=(/1,2,3/)) - call mpas_dmpar_exch_group_add_field(domain, 'initialization:pv_edge,ru,rw', 'rw', timeLevel=1, haloLayers=(/1,2/)) - - ! - ! Set up halo exchange groups used by dynamics - ! - call mpas_dmpar_exch_group_create(domain, 'dynamics:theta_m,scalars,pressure_p,rtheta_p') - call mpas_dmpar_exch_group_add_field(domain, 'dynamics:theta_m,scalars,pressure_p,rtheta_p', 'theta_m', & - timeLevel=1, haloLayers=(/1,2/)) - call mpas_dmpar_exch_group_add_field(domain, 'dynamics:theta_m,scalars,pressure_p,rtheta_p', 'scalars', & - timeLevel=1, haloLayers=(/1,2/)) - call mpas_dmpar_exch_group_add_field(domain, 'dynamics:theta_m,scalars,pressure_p,rtheta_p', 'pressure_p', & - timeLevel=1, haloLayers=(/1,2/)) - call mpas_dmpar_exch_group_add_field(domain, 'dynamics:theta_m,scalars,pressure_p,rtheta_p', 'rtheta_p', & - timeLevel=1, haloLayers=(/1,2/)) - - !CR: SMALLER STENCIL?: call mpas_dmpar_exch_halo_field(block % diag % rw_p, (/ 1 /)) - !CR: SMALLER STENCIL?: call mpas_dmpar_exch_halo_field(block % diag % ru_p, (/ 2 /)) - call mpas_dmpar_exch_group_create(domain, 'dynamics:rw_p,ru_p,rho_pp,rtheta_pp') - call mpas_dmpar_exch_group_add_field(domain, 'dynamics:rw_p,ru_p,rho_pp,rtheta_pp', 'rw_p', & - timeLevel=1, haloLayers=(/1/)) - call mpas_dmpar_exch_group_add_field(domain, 'dynamics:rw_p,ru_p,rho_pp,rtheta_pp', 'ru_p', & - timeLevel=1, haloLayers=(/2/)) - call mpas_dmpar_exch_group_add_field(domain, 'dynamics:rw_p,ru_p,rho_pp,rtheta_pp', 'rho_pp', & - timeLevel=1, haloLayers=(/1,2/)) - call mpas_dmpar_exch_group_add_field(domain, 'dynamics:rw_p,ru_p,rho_pp,rtheta_pp', 'rtheta_pp', & - timeLevel=1, haloLayers=(/2/)) - - call mpas_dmpar_exch_group_create(domain, 'dynamics:w,pv_edge,rho_edge') - call mpas_dmpar_exch_group_add_field(domain, 'dynamics:w,pv_edge,rho_edge', 'w', & - timeLevel=2, haloLayers=(/1,2/)) - call mpas_dmpar_exch_group_add_field(domain, 'dynamics:w,pv_edge,rho_edge', 'pv_edge', & - timeLevel=1, haloLayers=(/1,2/)) - call mpas_dmpar_exch_group_add_field(domain, 'dynamics:w,pv_edge,rho_edge', 'rho_edge', & - timeLevel=1, haloLayers=(/1,2/)) - - call mpas_dmpar_exch_group_create(domain, 'dynamics:w,pv_edge,rho_edge,scalars') - call mpas_dmpar_exch_group_add_field(domain, 'dynamics:w,pv_edge,rho_edge,scalars', 'w', & - timeLevel=2, haloLayers=(/1,2/)) - call mpas_dmpar_exch_group_add_field(domain, 'dynamics:w,pv_edge,rho_edge,scalars', 'pv_edge', & - timeLevel=1, haloLayers=(/1,2/)) - call mpas_dmpar_exch_group_add_field(domain, 'dynamics:w,pv_edge,rho_edge,scalars', 'rho_edge', & - timeLevel=1, haloLayers=(/1,2/)) - call mpas_dmpar_exch_group_add_field(domain, 'dynamics:w,pv_edge,rho_edge,scalars', 'scalars', & - timeLevel=2, haloLayers=(/1,2/)) - - call mpas_dmpar_exch_group_create(domain, 'dynamics:theta_m,pressure_p,rtheta_p') - call mpas_dmpar_exch_group_add_field(domain, 'dynamics:theta_m,pressure_p,rtheta_p', 'theta_m', & - timeLevel=2, haloLayers=(/1,2/)) - call mpas_dmpar_exch_group_add_field(domain, 'dynamics:theta_m,pressure_p,rtheta_p', 'pressure_p', & - timeLevel=1, haloLayers=(/1,2/)) - call mpas_dmpar_exch_group_add_field(domain, 'dynamics:theta_m,pressure_p,rtheta_p', 'rtheta_p', & - timeLevel=1, haloLayers=(/1,2/)) - - - call mpas_dmpar_exch_group_create(domain, 'dynamics:exner') - call mpas_dmpar_exch_group_add_field(domain, 'dynamics:exner', 'exner', timeLevel=1, haloLayers=(/1,2/)) - - call mpas_dmpar_exch_group_create(domain, 'dynamics:tend_u') - call mpas_dmpar_exch_group_add_field(domain, 'dynamics:tend_u', 'tend_u', timeLevel=1, haloLayers=(/1/)) - - call mpas_dmpar_exch_group_create(domain, 'dynamics:rho_pp') - call mpas_dmpar_exch_group_add_field(domain, 'dynamics:rho_pp', 'rho_pp', timeLevel=1, haloLayers=(/1/)) - - call mpas_dmpar_exch_group_create(domain, 'dynamics:rtheta_pp') - call mpas_dmpar_exch_group_add_field(domain, 'dynamics:rtheta_pp', 'rtheta_pp', timeLevel=1, haloLayers=(/1/)) - - call mpas_dmpar_exch_group_create(domain, 'dynamics:u_123') - call mpas_dmpar_exch_group_add_field(domain, 'dynamics:u_123', 'u', timeLevel=2, haloLayers=(/1,2,3/)) - - call mpas_dmpar_exch_group_create(domain, 'dynamics:u_3') - call mpas_dmpar_exch_group_add_field(domain, 'dynamics:u_3', 'u', timeLevel=2, haloLayers=(/3/)) - - call mpas_dmpar_exch_group_create(domain, 'dynamics:scalars') - call mpas_dmpar_exch_group_add_field(domain, 'dynamics:scalars', 'scalars', timeLevel=2, haloLayers=(/1,2/)) - - call mpas_dmpar_exch_group_create(domain, 'dynamics:scalars_old') - call mpas_dmpar_exch_group_add_field(domain, 'dynamics:scalars_old', 'scalars', timeLevel=1, haloLayers=(/1,2/)) - - call mpas_dmpar_exch_group_create(domain, 'dynamics:w') - call mpas_dmpar_exch_group_add_field(domain, 'dynamics:w', 'w', timeLevel=2, haloLayers=(/1,2/)) - - call mpas_dmpar_exch_group_create(domain, 'dynamics:scale') - call mpas_dmpar_exch_group_add_field(domain, 'dynamics:scale', 'scale', timeLevel=1, haloLayers=(/1,2/)) - -#ifdef DO_PHYSICS - ! - ! Set up halo exchange groups used by physics - ! - call mpas_dmpar_exch_group_create(domain, 'physics:blten') - call mpas_dmpar_exch_group_add_field(domain, 'physics:blten', 'rublten', timeLevel=1, haloLayers=(/1,2/)) - call mpas_dmpar_exch_group_add_field(domain, 'physics:blten', 'rvblten', timeLevel=1, haloLayers=(/1,2/)) - - call mpas_dmpar_exch_group_create(domain, 'physics:cuten') - call mpas_dmpar_exch_group_add_field(domain, 'physics:cuten', 'rucuten', timeLevel=1, haloLayers=(/1,2/)) - call mpas_dmpar_exch_group_add_field(domain, 'physics:cuten', 'rvcuten', timeLevel=1, haloLayers=(/1,2/)) -#endif - - ! - ! Set routine to exchange a halo group - ! - exchange_halo_group => mpas_dmpar_exch_group_full_halo_exch - - else if (trim(config_halo_exch_method) == 'mpas_halo') then - - call mpas_log_write('') - call mpas_log_write('*** Using ''mpas_halo'' routines for exchanging halos') - call mpas_log_write('') - - call mpas_halo_init(domain) - - ! - ! Set up halo exchange groups used during atmosphere core initialization - ! - call mpas_halo_exch_group_create(domain, 'initialization:u') - call mpas_halo_exch_group_add_field(domain, 'initialization:u', 'u', timeLevel=1, haloLayers=(/1,2,3/)) - call mpas_halo_exch_group_complete(domain, 'initialization:u') - - call mpas_halo_exch_group_create(domain, 'initialization:pv_edge,ru,rw') - call mpas_halo_exch_group_add_field(domain, 'initialization:pv_edge,ru,rw', 'pv_edge', timeLevel=1, haloLayers=(/1,2,3/)) - call mpas_halo_exch_group_add_field(domain, 'initialization:pv_edge,ru,rw', 'ru', timeLevel=1, haloLayers=(/1,2,3/)) - call mpas_halo_exch_group_add_field(domain, 'initialization:pv_edge,ru,rw', 'rw', timeLevel=1, haloLayers=(/1,2/)) - call mpas_halo_exch_group_complete(domain, 'initialization:pv_edge,ru,rw') - - ! - ! Set up halo exchange groups used by dynamics - ! - call mpas_halo_exch_group_create(domain, 'dynamics:theta_m,scalars,pressure_p,rtheta_p') - call mpas_halo_exch_group_add_field(domain, 'dynamics:theta_m,scalars,pressure_p,rtheta_p', 'theta_m', & - timeLevel=1, haloLayers=(/1,2/)) - call mpas_halo_exch_group_add_field(domain, 'dynamics:theta_m,scalars,pressure_p,rtheta_p', 'scalars', & - timeLevel=1, haloLayers=(/1,2/)) - call mpas_halo_exch_group_add_field(domain, 'dynamics:theta_m,scalars,pressure_p,rtheta_p', 'pressure_p', & - timeLevel=1, haloLayers=(/1,2/)) - call mpas_halo_exch_group_add_field(domain, 'dynamics:theta_m,scalars,pressure_p,rtheta_p', 'rtheta_p', & - timeLevel=1, haloLayers=(/1,2/)) - call mpas_halo_exch_group_complete(domain, 'dynamics:theta_m,scalars,pressure_p,rtheta_p') - - call mpas_halo_exch_group_create(domain, 'dynamics:rw_p,ru_p,rho_pp,rtheta_pp') - call mpas_halo_exch_group_add_field(domain, 'dynamics:rw_p,ru_p,rho_pp,rtheta_pp', 'rw_p', & - timeLevel=1, haloLayers=(/1/)) - call mpas_halo_exch_group_add_field(domain, 'dynamics:rw_p,ru_p,rho_pp,rtheta_pp', 'ru_p', & - timeLevel=1, haloLayers=(/2/)) - call mpas_halo_exch_group_add_field(domain, 'dynamics:rw_p,ru_p,rho_pp,rtheta_pp', 'rho_pp', & - timeLevel=1, haloLayers=(/1,2/)) - call mpas_halo_exch_group_add_field(domain, 'dynamics:rw_p,ru_p,rho_pp,rtheta_pp', 'rtheta_pp', & - timeLevel=1, haloLayers=(/2/)) - call mpas_halo_exch_group_complete(domain, 'dynamics:rw_p,ru_p,rho_pp,rtheta_pp') - - call mpas_halo_exch_group_create(domain, 'dynamics:w,pv_edge,rho_edge') - call mpas_halo_exch_group_add_field(domain, 'dynamics:w,pv_edge,rho_edge', 'w', timeLevel=2, haloLayers=(/1,2/)) - call mpas_halo_exch_group_add_field(domain, 'dynamics:w,pv_edge,rho_edge', 'pv_edge', timeLevel=1, haloLayers=(/1,2/)) - call mpas_halo_exch_group_add_field(domain, 'dynamics:w,pv_edge,rho_edge', 'rho_edge', timeLevel=1, haloLayers=(/1,2/)) - call mpas_halo_exch_group_complete(domain, 'dynamics:w,pv_edge,rho_edge') - - call mpas_halo_exch_group_create(domain, 'dynamics:w,pv_edge,rho_edge,scalars') - call mpas_halo_exch_group_add_field(domain, 'dynamics:w,pv_edge,rho_edge,scalars', 'w', & - timeLevel=2, haloLayers=(/1,2/)) - call mpas_halo_exch_group_add_field(domain, 'dynamics:w,pv_edge,rho_edge,scalars', 'pv_edge', & - timeLevel=1, haloLayers=(/1,2/)) - call mpas_halo_exch_group_add_field(domain, 'dynamics:w,pv_edge,rho_edge,scalars', 'rho_edge', & - timeLevel=1, haloLayers=(/1,2/)) - call mpas_halo_exch_group_add_field(domain, 'dynamics:w,pv_edge,rho_edge,scalars', 'scalars', & - timeLevel=2, haloLayers=(/1,2/)) - call mpas_halo_exch_group_complete(domain, 'dynamics:w,pv_edge,rho_edge,scalars') - - call mpas_halo_exch_group_create(domain, 'dynamics:theta_m,pressure_p,rtheta_p') - call mpas_halo_exch_group_add_field(domain, 'dynamics:theta_m,pressure_p,rtheta_p', 'theta_m', & - timeLevel=2, haloLayers=(/1,2/)) - call mpas_halo_exch_group_add_field(domain, 'dynamics:theta_m,pressure_p,rtheta_p', 'pressure_p', & - timeLevel=1, haloLayers=(/1,2/)) - call mpas_halo_exch_group_add_field(domain, 'dynamics:theta_m,pressure_p,rtheta_p', 'rtheta_p', & - timeLevel=1, haloLayers=(/1,2/)) - call mpas_halo_exch_group_complete(domain, 'dynamics:theta_m,pressure_p,rtheta_p') - - - call mpas_halo_exch_group_create(domain, 'dynamics:exner') - call mpas_halo_exch_group_add_field(domain, 'dynamics:exner', 'exner', timeLevel=1, haloLayers=(/1,2/)) - call mpas_halo_exch_group_complete(domain, 'dynamics:exner') - - call mpas_halo_exch_group_create(domain, 'dynamics:tend_u') - call mpas_halo_exch_group_add_field(domain, 'dynamics:tend_u', 'tend_u', timeLevel=1, haloLayers=(/1/)) - call mpas_halo_exch_group_complete(domain, 'dynamics:tend_u') - - call mpas_halo_exch_group_create(domain, 'dynamics:rho_pp') - call mpas_halo_exch_group_add_field(domain, 'dynamics:rho_pp', 'rho_pp', timeLevel=1, haloLayers=(/1/)) - call mpas_halo_exch_group_complete(domain, 'dynamics:rho_pp') - - call mpas_halo_exch_group_create(domain, 'dynamics:rtheta_pp') - call mpas_halo_exch_group_add_field(domain, 'dynamics:rtheta_pp', 'rtheta_pp', timeLevel=1, haloLayers=(/1/)) - call mpas_halo_exch_group_complete(domain, 'dynamics:rtheta_pp') - - call mpas_halo_exch_group_create(domain, 'dynamics:u_123') - call mpas_halo_exch_group_add_field(domain, 'dynamics:u_123', 'u', timeLevel=2, haloLayers=(/1,2,3/)) - call mpas_halo_exch_group_complete(domain, 'dynamics:u_123') - - call mpas_halo_exch_group_create(domain, 'dynamics:u_3') - call mpas_halo_exch_group_add_field(domain, 'dynamics:u_3', 'u', timeLevel=2, haloLayers=(/3/)) - call mpas_halo_exch_group_complete(domain, 'dynamics:u_3') - - call mpas_halo_exch_group_create(domain, 'dynamics:scalars') - call mpas_halo_exch_group_add_field(domain, 'dynamics:scalars', 'scalars', timeLevel=2, haloLayers=(/1,2/)) - call mpas_halo_exch_group_complete(domain, 'dynamics:scalars') - - call mpas_halo_exch_group_create(domain, 'dynamics:scalars_old') - call mpas_halo_exch_group_add_field(domain, 'dynamics:scalars_old', 'scalars', timeLevel=1, haloLayers=(/1,2/)) - call mpas_halo_exch_group_complete(domain, 'dynamics:scalars_old') - - call mpas_halo_exch_group_create(domain, 'dynamics:w') - call mpas_halo_exch_group_add_field(domain, 'dynamics:w', 'w', timeLevel=2, haloLayers=(/1,2/)) - call mpas_halo_exch_group_complete(domain, 'dynamics:w') - - call mpas_halo_exch_group_create(domain, 'dynamics:scale') - call mpas_halo_exch_group_add_field(domain, 'dynamics:scale', 'scale', timeLevel=1, haloLayers=(/1,2/)) - call mpas_halo_exch_group_complete(domain, 'dynamics:scale') - -#ifdef DO_PHYSICS - ! - ! Set up halo exchange groups used by physics - ! - call mpas_halo_exch_group_create(domain, 'physics:blten') - call mpas_halo_exch_group_add_field(domain, 'physics:blten', 'rublten', timeLevel=1, haloLayers=(/1,2/)) - call mpas_halo_exch_group_add_field(domain, 'physics:blten', 'rvblten', timeLevel=1, haloLayers=(/1,2/)) - call mpas_halo_exch_group_complete(domain, 'physics:blten') - - call mpas_halo_exch_group_create(domain, 'physics:cuten') - call mpas_halo_exch_group_add_field(domain, 'physics:cuten', 'rucuten', timeLevel=1, haloLayers=(/1,2/)) - call mpas_halo_exch_group_add_field(domain, 'physics:cuten', 'rvcuten', timeLevel=1, haloLayers=(/1,2/)) - call mpas_halo_exch_group_complete(domain, 'physics:cuten') -#endif - - ! - ! Set routine to exchange a halo group - ! - exchange_halo_group => mpas_halo_exch_group_full_halo_exch - - else - - ! - ! Invalid method for exchanging halos - ! - ierr = 1 - call mpas_log_write('Invalid method for exchanging halos specified by ''config_halo_exch_method'': ' // & - trim(config_halo_exch_method), messageType=MPAS_LOG_ERR) - return - - end if - - ierr = 0 - - end subroutine atm_build_halo_groups - - - !----------------------------------------------------------------------- - ! routine atm_destroy_halo_groups - ! - !> \brief Destroys halo exchange groups used throughout atmosphere core - !> \author Michael Duda - !> \date 5 June 2023 - !> \details - !> This routine destroys the halo exchange groups that are used throughout - !> the atmosphere core, freeing up any resources that were used by these - !> halo exchange groups. - !> - !> A value of 0 is returned if halo exchange groups have been - !> successfully destroyed and a non-zero value is returned otherwise. - ! - !----------------------------------------------------------------------- - subroutine atm_destroy_halo_groups(domain, ierr) - - use mpas_halo, only : mpas_halo_exch_group_destroy, mpas_halo_finalize - - type (domain_type), intent(inout) :: domain - integer, intent(inout) :: ierr - - - if (trim(config_halo_exch_method) == 'mpas_dmpar') then - ! - ! Destroy halo exchange groups used only during initialization - ! - call mpas_dmpar_exch_group_destroy(domain, 'initialization:u') - call mpas_dmpar_exch_group_destroy(domain, 'initialization:pv_edge,ru,rw') - - ! - ! Destroy halo exchange groups used by dynamics - ! - call mpas_dmpar_exch_group_destroy(domain, 'dynamics:theta_m,scalars,pressure_p,rtheta_p') - call mpas_dmpar_exch_group_destroy(domain, 'dynamics:rw_p,ru_p,rho_pp,rtheta_pp') - call mpas_dmpar_exch_group_destroy(domain, 'dynamics:w,pv_edge,rho_edge') - call mpas_dmpar_exch_group_destroy(domain, 'dynamics:w,pv_edge,rho_edge,scalars') - call mpas_dmpar_exch_group_destroy(domain, 'dynamics:theta_m,pressure_p,rtheta_p') - - call mpas_dmpar_exch_group_destroy(domain, 'dynamics:exner') - call mpas_dmpar_exch_group_destroy(domain, 'dynamics:tend_u') - call mpas_dmpar_exch_group_destroy(domain, 'dynamics:rho_pp') - call mpas_dmpar_exch_group_destroy(domain, 'dynamics:rtheta_pp') - call mpas_dmpar_exch_group_destroy(domain, 'dynamics:u_123') - call mpas_dmpar_exch_group_destroy(domain, 'dynamics:u_3') - call mpas_dmpar_exch_group_destroy(domain, 'dynamics:scalars') - call mpas_dmpar_exch_group_destroy(domain, 'dynamics:scalars_old') - call mpas_dmpar_exch_group_destroy(domain, 'dynamics:w') - call mpas_dmpar_exch_group_destroy(domain, 'dynamics:scale') - -#ifdef DO_PHYSICS - ! - ! Destroy halo exchange groups used by physics - ! - call mpas_dmpar_exch_group_destroy(domain, 'physics:blten') - call mpas_dmpar_exch_group_destroy(domain, 'physics:cuten') -#endif - - else if (trim(config_halo_exch_method) == 'mpas_halo') then - - ! - ! Destroy halo exchange groups used only during initialization - ! - call mpas_halo_exch_group_destroy(domain, 'initialization:u') - call mpas_halo_exch_group_destroy(domain, 'initialization:pv_edge,ru,rw') - - ! - ! Destroy halo exchange groups used by dynamics - ! - call mpas_halo_exch_group_destroy(domain, 'dynamics:theta_m,scalars,pressure_p,rtheta_p') - call mpas_halo_exch_group_destroy(domain, 'dynamics:rw_p,ru_p,rho_pp,rtheta_pp') - call mpas_halo_exch_group_destroy(domain, 'dynamics:w,pv_edge,rho_edge') - call mpas_halo_exch_group_destroy(domain, 'dynamics:w,pv_edge,rho_edge,scalars') - call mpas_halo_exch_group_destroy(domain, 'dynamics:theta_m,pressure_p,rtheta_p') - - call mpas_halo_exch_group_destroy(domain, 'dynamics:exner') - call mpas_halo_exch_group_destroy(domain, 'dynamics:tend_u') - call mpas_halo_exch_group_destroy(domain, 'dynamics:rho_pp') - call mpas_halo_exch_group_destroy(domain, 'dynamics:rtheta_pp') - call mpas_halo_exch_group_destroy(domain, 'dynamics:u_123') - call mpas_halo_exch_group_destroy(domain, 'dynamics:u_3') - call mpas_halo_exch_group_destroy(domain, 'dynamics:scalars') - call mpas_halo_exch_group_destroy(domain, 'dynamics:scalars_old') - call mpas_halo_exch_group_destroy(domain, 'dynamics:w') - call mpas_halo_exch_group_destroy(domain, 'dynamics:scale') - -#ifdef DO_PHYSICS - ! - ! Destroy halo exchange groups used by physics - ! - call mpas_halo_exch_group_destroy(domain, 'physics:blten') - call mpas_halo_exch_group_destroy(domain, 'physics:cuten') -#endif - - call mpas_halo_finalize(domain) - - else - - ! - ! Invalid method for exchanging halos - an error should have already occurred in atm_build_halo_groups() - ! - ierr = 1 - return - - end if - - ierr = 0 - - end subroutine atm_destroy_halo_groups - end module atm_core diff --git a/src/core_atmosphere/mpas_atm_core_interface.F b/src/core_atmosphere/mpas_atm_core_interface.F index 5e319ef26b..af7a9d7ee3 100644 --- a/src/core_atmosphere/mpas_atm_core_interface.F +++ b/src/core_atmosphere/mpas_atm_core_interface.F @@ -99,10 +99,10 @@ end subroutine atm_setup_domain !> not allocated until after this routine has been called. ! !----------------------------------------------------------------------- - function atm_setup_packages(configs, packages, iocontext) result(ierr) + function atm_setup_packages(configs, streamInfo, packages, iocontext) result(ierr) use mpas_dmpar - use mpas_derived_types, only : mpas_pool_type, mpas_io_context_type + use mpas_derived_types, only : mpas_pool_type, mpas_io_context_type, MPAS_streamInfo_type use mpas_pool_routines, only : mpas_pool_get_config, mpas_pool_get_package #ifdef DO_PHYSICS @@ -113,6 +113,7 @@ function atm_setup_packages(configs, packages, iocontext) result(ierr) implicit none type (mpas_pool_type), intent(inout) :: configs + type (MPAS_streamInfo_type), intent(inout) :: streamInfo type (mpas_pool_type), intent(inout) :: packages type (mpas_io_context_type), intent(inout) :: iocontext integer :: ierr @@ -122,6 +123,8 @@ function atm_setup_packages(configs, packages, iocontext) result(ierr) logical, pointer :: limited_areaActive logical, pointer :: config_apply_lbcs logical, pointer :: config_jedi_da, jedi_daActive + logical, pointer :: no_invariant_streamActive + character(len=StrKIND) :: attvalue integer :: local_ierr ierr = 0 @@ -174,6 +177,25 @@ function atm_setup_packages(configs, packages, iocontext) result(ierr) messageType=MPAS_LOG_ERR) end if + ! + ! Separate time-invariant stream + ! + nullify(no_invariant_streamActive) + call mpas_pool_get_package(packages, 'no_invariant_streamActive', no_invariant_streamActive) + + if (associated(no_invariant_streamActive)) then + no_invariant_streamActive = .true. + if (streamInfo % query('invariant', attname='input_interval', attvalue=attvalue)) then + if (trim(attvalue) == 'initial_only') then + no_invariant_streamActive = .false. + end if + end if + else + ierr = ierr + 1 + call mpas_log_write("Package setup failed for 'no_invariant_stream'. 'no_invariant_stream' is not a package.", & + messageType=MPAS_LOG_ERR) + end if + #ifdef DO_PHYSICS !check that all the physics options are correctly defined and that at !least one physics parameterization is called (using the logical moist_physics): @@ -336,22 +358,36 @@ end function atm_setup_log!}}} !> are available. ! !----------------------------------------------------------------------- - function atm_get_mesh_stream(configs, stream) result(ierr) + function atm_get_mesh_stream(configs, streamInfo, stream) result(ierr) use mpas_kind_types, only : StrKIND - use mpas_derived_types, only : mpas_pool_type + use mpas_derived_types, only : mpas_pool_type, MPAS_streamInfo_type use mpas_pool_routines, only : mpas_pool_get_config implicit none type (mpas_pool_type), intent(inout) :: configs + type (MPAS_streamInfo_type), intent(inout) :: streamInfo character(len=StrKIND), intent(out) :: stream integer :: ierr logical, pointer :: config_do_restart + character(len=StrKIND) :: attvalue ierr = 0 + ! + ! If the 'invariant' stream is defined in the streams XML file with an + ! input_interval of 'initial_only', then use the 'invariant' stream to + ! get mesh information + ! + if (streamInfo % query('invariant', attname='input_interval', attvalue=attvalue)) then + if (trim(attvalue) == 'initial_only') then + write(stream,'(a)') 'invariant' + return + end if + end if + call mpas_pool_get_config(configs, 'config_do_restart', config_do_restart) if (.not. associated(config_do_restart)) then diff --git a/src/core_atmosphere/mpas_atm_halos.F b/src/core_atmosphere/mpas_atm_halos.F new file mode 100644 index 0000000000..633b5582a7 --- /dev/null +++ b/src/core_atmosphere/mpas_atm_halos.F @@ -0,0 +1,445 @@ +! Copyright (c) 2023, The University Corporation for Atmospheric Research (UCAR). +! +! Unless noted otherwise source code is licensed under the BSD license. +! Additional copyright and license information can be found in the LICENSE file +! distributed with this code, or at http://mpas-dev.github.com/license.html +! +module mpas_atm_halos + + use mpas_derived_types + use mpas_pool_routines + use mpas_log, only : mpas_log_write, mpas_log_info + + ! + ! Abstract interface for routine used to communicate halos of fields + ! in a named group + ! + abstract interface + subroutine halo_exchange_routine(domain, halo_group, ierr) + + use mpas_derived_types, only : domain_type + + type (domain_type), intent(inout) :: domain + character(len=*), intent(in) :: halo_group + integer, intent(out), optional :: ierr + + end subroutine halo_exchange_routine + end interface + + character(len=StrKIND), pointer, private :: config_halo_exch_method + procedure (halo_exchange_routine), pointer :: exchange_halo_group + + + contains + + + !----------------------------------------------------------------------- + ! routine atm_build_halo_groups + ! + !> \brief Builds halo exchange groups used throughout atmosphere core + !> \author Michael Duda + !> \date 5 June 2023 + !> \details + !> This routine builds the halo exchange groups that are used throughout + !> the atmosphere core, and it sets a function pointer, + !> exchange_halo_group, to the routine that may be used to exchange the + !> halos for all fields in a named group. + !> + !> A value of 0 is returned if halo exchange groups have been + !> successfully set up and a non-zero value is returned otherwise. + ! + !----------------------------------------------------------------------- + subroutine atm_build_halo_groups(domain, ierr) + + use mpas_dmpar, only : mpas_dmpar_exch_group_create, mpas_dmpar_exch_group_add_field, & + mpas_dmpar_exch_group_full_halo_exch + use mpas_halo, only : mpas_halo_init, mpas_halo_exch_group_create, mpas_halo_exch_group_add_field, & + mpas_halo_exch_group_complete, mpas_halo_exch_group_full_halo_exch + + type (domain_type), intent(inout) :: domain + integer, intent(inout) :: ierr + + ! + ! Determine from the namelist option config_halo_exch_method which halo exchange method to employ + ! + call mpas_pool_get_config(domain % blocklist % configs, 'config_halo_exch_method', config_halo_exch_method) + + if (trim(config_halo_exch_method) == 'mpas_dmpar') then + call mpas_log_write('') + call mpas_log_write('*** Using ''mpas_dmpar'' routines for exchanging halos') + call mpas_log_write('') + + ! + ! Set up halo exchange groups used during atmosphere core initialization + ! + call mpas_dmpar_exch_group_create(domain, 'initialization:u') + call mpas_dmpar_exch_group_add_field(domain, 'initialization:u', 'u', timeLevel=1, haloLayers=(/1,2,3/)) + + call mpas_dmpar_exch_group_create(domain, 'initialization:pv_edge,ru,rw') + call mpas_dmpar_exch_group_add_field(domain, 'initialization:pv_edge,ru,rw', 'pv_edge', timeLevel=1, haloLayers=(/1,2,3/)) + call mpas_dmpar_exch_group_add_field(domain, 'initialization:pv_edge,ru,rw', 'ru', timeLevel=1, haloLayers=(/1,2,3/)) + call mpas_dmpar_exch_group_add_field(domain, 'initialization:pv_edge,ru,rw', 'rw', timeLevel=1, haloLayers=(/1,2/)) + + ! + ! Set up halo exchange groups used by dynamics + ! + call mpas_dmpar_exch_group_create(domain, 'dynamics:theta_m,scalars,pressure_p,rtheta_p') + call mpas_dmpar_exch_group_add_field(domain, 'dynamics:theta_m,scalars,pressure_p,rtheta_p', 'theta_m', & + timeLevel=1, haloLayers=(/1,2/)) + call mpas_dmpar_exch_group_add_field(domain, 'dynamics:theta_m,scalars,pressure_p,rtheta_p', 'scalars', & + timeLevel=1, haloLayers=(/1,2/)) + call mpas_dmpar_exch_group_add_field(domain, 'dynamics:theta_m,scalars,pressure_p,rtheta_p', 'pressure_p', & + timeLevel=1, haloLayers=(/1,2/)) + call mpas_dmpar_exch_group_add_field(domain, 'dynamics:theta_m,scalars,pressure_p,rtheta_p', 'rtheta_p', & + timeLevel=1, haloLayers=(/1,2/)) + + !CR: SMALLER STENCIL?: call mpas_dmpar_exch_halo_field(block % diag % rw_p, (/ 1 /)) + !CR: SMALLER STENCIL?: call mpas_dmpar_exch_halo_field(block % diag % ru_p, (/ 2 /)) + call mpas_dmpar_exch_group_create(domain, 'dynamics:rw_p,ru_p,rho_pp,rtheta_pp') + call mpas_dmpar_exch_group_add_field(domain, 'dynamics:rw_p,ru_p,rho_pp,rtheta_pp', 'rw_p', & + timeLevel=1, haloLayers=(/1/)) + call mpas_dmpar_exch_group_add_field(domain, 'dynamics:rw_p,ru_p,rho_pp,rtheta_pp', 'ru_p', & + timeLevel=1, haloLayers=(/2/)) + call mpas_dmpar_exch_group_add_field(domain, 'dynamics:rw_p,ru_p,rho_pp,rtheta_pp', 'rho_pp', & + timeLevel=1, haloLayers=(/1,2/)) + call mpas_dmpar_exch_group_add_field(domain, 'dynamics:rw_p,ru_p,rho_pp,rtheta_pp', 'rtheta_pp', & + timeLevel=1, haloLayers=(/2/)) + + call mpas_dmpar_exch_group_create(domain, 'dynamics:w,pv_edge,rho_edge') + call mpas_dmpar_exch_group_add_field(domain, 'dynamics:w,pv_edge,rho_edge', 'w', & + timeLevel=2, haloLayers=(/1,2/)) + call mpas_dmpar_exch_group_add_field(domain, 'dynamics:w,pv_edge,rho_edge', 'pv_edge', & + timeLevel=1, haloLayers=(/1,2/)) + call mpas_dmpar_exch_group_add_field(domain, 'dynamics:w,pv_edge,rho_edge', 'rho_edge', & + timeLevel=1, haloLayers=(/1,2/)) + + call mpas_dmpar_exch_group_create(domain, 'dynamics:w,pv_edge,rho_edge,scalars') + call mpas_dmpar_exch_group_add_field(domain, 'dynamics:w,pv_edge,rho_edge,scalars', 'w', & + timeLevel=2, haloLayers=(/1,2/)) + call mpas_dmpar_exch_group_add_field(domain, 'dynamics:w,pv_edge,rho_edge,scalars', 'pv_edge', & + timeLevel=1, haloLayers=(/1,2/)) + call mpas_dmpar_exch_group_add_field(domain, 'dynamics:w,pv_edge,rho_edge,scalars', 'rho_edge', & + timeLevel=1, haloLayers=(/1,2/)) + call mpas_dmpar_exch_group_add_field(domain, 'dynamics:w,pv_edge,rho_edge,scalars', 'scalars', & + timeLevel=2, haloLayers=(/1,2/)) + + call mpas_dmpar_exch_group_create(domain, 'dynamics:theta_m,pressure_p,rtheta_p') + call mpas_dmpar_exch_group_add_field(domain, 'dynamics:theta_m,pressure_p,rtheta_p', 'theta_m', & + timeLevel=2, haloLayers=(/1,2/)) + call mpas_dmpar_exch_group_add_field(domain, 'dynamics:theta_m,pressure_p,rtheta_p', 'pressure_p', & + timeLevel=1, haloLayers=(/1,2/)) + call mpas_dmpar_exch_group_add_field(domain, 'dynamics:theta_m,pressure_p,rtheta_p', 'rtheta_p', & + timeLevel=1, haloLayers=(/1,2/)) + + + call mpas_dmpar_exch_group_create(domain, 'dynamics:exner') + call mpas_dmpar_exch_group_add_field(domain, 'dynamics:exner', 'exner', timeLevel=1, haloLayers=(/1,2/)) + + call mpas_dmpar_exch_group_create(domain, 'dynamics:tend_u') + call mpas_dmpar_exch_group_add_field(domain, 'dynamics:tend_u', 'tend_u', timeLevel=1, haloLayers=(/1/)) + + call mpas_dmpar_exch_group_create(domain, 'dynamics:rho_pp') + call mpas_dmpar_exch_group_add_field(domain, 'dynamics:rho_pp', 'rho_pp', timeLevel=1, haloLayers=(/1/)) + + call mpas_dmpar_exch_group_create(domain, 'dynamics:rtheta_pp') + call mpas_dmpar_exch_group_add_field(domain, 'dynamics:rtheta_pp', 'rtheta_pp', timeLevel=1, haloLayers=(/1/)) + + call mpas_dmpar_exch_group_create(domain, 'dynamics:u_123') + call mpas_dmpar_exch_group_add_field(domain, 'dynamics:u_123', 'u', timeLevel=2, haloLayers=(/1,2,3/)) + + call mpas_dmpar_exch_group_create(domain, 'dynamics:u_3') + call mpas_dmpar_exch_group_add_field(domain, 'dynamics:u_3', 'u', timeLevel=2, haloLayers=(/3/)) + + call mpas_dmpar_exch_group_create(domain, 'dynamics:scalars') + call mpas_dmpar_exch_group_add_field(domain, 'dynamics:scalars', 'scalars', timeLevel=2, haloLayers=(/1,2/)) + + call mpas_dmpar_exch_group_create(domain, 'dynamics:scalars_old') + call mpas_dmpar_exch_group_add_field(domain, 'dynamics:scalars_old', 'scalars', timeLevel=1, haloLayers=(/1,2/)) + + call mpas_dmpar_exch_group_create(domain, 'dynamics:w') + call mpas_dmpar_exch_group_add_field(domain, 'dynamics:w', 'w', timeLevel=2, haloLayers=(/1,2/)) + + call mpas_dmpar_exch_group_create(domain, 'dynamics:scale') + call mpas_dmpar_exch_group_add_field(domain, 'dynamics:scale', 'scale', timeLevel=1, haloLayers=(/1,2/)) + +#ifdef DO_PHYSICS + ! + ! Set up halo exchange groups used by physics + ! + call mpas_dmpar_exch_group_create(domain, 'physics:blten') + call mpas_dmpar_exch_group_add_field(domain, 'physics:blten', 'rublten', timeLevel=1, haloLayers=(/1,2/)) + call mpas_dmpar_exch_group_add_field(domain, 'physics:blten', 'rvblten', timeLevel=1, haloLayers=(/1,2/)) + + call mpas_dmpar_exch_group_create(domain, 'physics:cuten') + call mpas_dmpar_exch_group_add_field(domain, 'physics:cuten', 'rucuten', timeLevel=1, haloLayers=(/1,2/)) + call mpas_dmpar_exch_group_add_field(domain, 'physics:cuten', 'rvcuten', timeLevel=1, haloLayers=(/1,2/)) +#endif + + ! + ! Set routine to exchange a halo group + ! + exchange_halo_group => mpas_dmpar_exch_group_full_halo_exch + + else if (trim(config_halo_exch_method) == 'mpas_halo') then + + call mpas_log_write('') + call mpas_log_write('*** Using ''mpas_halo'' routines for exchanging halos') + call mpas_log_write('') + + call mpas_halo_init(domain) + + ! + ! Set up halo exchange groups used during atmosphere core initialization + ! + call mpas_halo_exch_group_create(domain, 'initialization:u') + call mpas_halo_exch_group_add_field(domain, 'initialization:u', 'u', timeLevel=1, haloLayers=(/1,2,3/)) + call mpas_halo_exch_group_complete(domain, 'initialization:u') + + call mpas_halo_exch_group_create(domain, 'initialization:pv_edge,ru,rw') + call mpas_halo_exch_group_add_field(domain, 'initialization:pv_edge,ru,rw', 'pv_edge', timeLevel=1, haloLayers=(/1,2,3/)) + call mpas_halo_exch_group_add_field(domain, 'initialization:pv_edge,ru,rw', 'ru', timeLevel=1, haloLayers=(/1,2,3/)) + call mpas_halo_exch_group_add_field(domain, 'initialization:pv_edge,ru,rw', 'rw', timeLevel=1, haloLayers=(/1,2/)) + call mpas_halo_exch_group_complete(domain, 'initialization:pv_edge,ru,rw') + + ! + ! Set up halo exchange groups used by dynamics + ! + call mpas_halo_exch_group_create(domain, 'dynamics:theta_m,scalars,pressure_p,rtheta_p') + call mpas_halo_exch_group_add_field(domain, 'dynamics:theta_m,scalars,pressure_p,rtheta_p', 'theta_m', & + timeLevel=1, haloLayers=(/1,2/)) + call mpas_halo_exch_group_add_field(domain, 'dynamics:theta_m,scalars,pressure_p,rtheta_p', 'scalars', & + timeLevel=1, haloLayers=(/1,2/)) + call mpas_halo_exch_group_add_field(domain, 'dynamics:theta_m,scalars,pressure_p,rtheta_p', 'pressure_p', & + timeLevel=1, haloLayers=(/1,2/)) + call mpas_halo_exch_group_add_field(domain, 'dynamics:theta_m,scalars,pressure_p,rtheta_p', 'rtheta_p', & + timeLevel=1, haloLayers=(/1,2/)) + call mpas_halo_exch_group_complete(domain, 'dynamics:theta_m,scalars,pressure_p,rtheta_p') + + call mpas_halo_exch_group_create(domain, 'dynamics:rw_p,ru_p,rho_pp,rtheta_pp') + call mpas_halo_exch_group_add_field(domain, 'dynamics:rw_p,ru_p,rho_pp,rtheta_pp', 'rw_p', & + timeLevel=1, haloLayers=(/1/)) + call mpas_halo_exch_group_add_field(domain, 'dynamics:rw_p,ru_p,rho_pp,rtheta_pp', 'ru_p', & + timeLevel=1, haloLayers=(/2/)) + call mpas_halo_exch_group_add_field(domain, 'dynamics:rw_p,ru_p,rho_pp,rtheta_pp', 'rho_pp', & + timeLevel=1, haloLayers=(/1,2/)) + call mpas_halo_exch_group_add_field(domain, 'dynamics:rw_p,ru_p,rho_pp,rtheta_pp', 'rtheta_pp', & + timeLevel=1, haloLayers=(/2/)) + call mpas_halo_exch_group_complete(domain, 'dynamics:rw_p,ru_p,rho_pp,rtheta_pp') + + call mpas_halo_exch_group_create(domain, 'dynamics:w,pv_edge,rho_edge') + call mpas_halo_exch_group_add_field(domain, 'dynamics:w,pv_edge,rho_edge', 'w', timeLevel=2, haloLayers=(/1,2/)) + call mpas_halo_exch_group_add_field(domain, 'dynamics:w,pv_edge,rho_edge', 'pv_edge', timeLevel=1, haloLayers=(/1,2/)) + call mpas_halo_exch_group_add_field(domain, 'dynamics:w,pv_edge,rho_edge', 'rho_edge', timeLevel=1, haloLayers=(/1,2/)) + call mpas_halo_exch_group_complete(domain, 'dynamics:w,pv_edge,rho_edge') + + call mpas_halo_exch_group_create(domain, 'dynamics:w,pv_edge,rho_edge,scalars') + call mpas_halo_exch_group_add_field(domain, 'dynamics:w,pv_edge,rho_edge,scalars', 'w', & + timeLevel=2, haloLayers=(/1,2/)) + call mpas_halo_exch_group_add_field(domain, 'dynamics:w,pv_edge,rho_edge,scalars', 'pv_edge', & + timeLevel=1, haloLayers=(/1,2/)) + call mpas_halo_exch_group_add_field(domain, 'dynamics:w,pv_edge,rho_edge,scalars', 'rho_edge', & + timeLevel=1, haloLayers=(/1,2/)) + call mpas_halo_exch_group_add_field(domain, 'dynamics:w,pv_edge,rho_edge,scalars', 'scalars', & + timeLevel=2, haloLayers=(/1,2/)) + call mpas_halo_exch_group_complete(domain, 'dynamics:w,pv_edge,rho_edge,scalars') + + call mpas_halo_exch_group_create(domain, 'dynamics:theta_m,pressure_p,rtheta_p') + call mpas_halo_exch_group_add_field(domain, 'dynamics:theta_m,pressure_p,rtheta_p', 'theta_m', & + timeLevel=2, haloLayers=(/1,2/)) + call mpas_halo_exch_group_add_field(domain, 'dynamics:theta_m,pressure_p,rtheta_p', 'pressure_p', & + timeLevel=1, haloLayers=(/1,2/)) + call mpas_halo_exch_group_add_field(domain, 'dynamics:theta_m,pressure_p,rtheta_p', 'rtheta_p', & + timeLevel=1, haloLayers=(/1,2/)) + call mpas_halo_exch_group_complete(domain, 'dynamics:theta_m,pressure_p,rtheta_p') + + + call mpas_halo_exch_group_create(domain, 'dynamics:exner') + call mpas_halo_exch_group_add_field(domain, 'dynamics:exner', 'exner', timeLevel=1, haloLayers=(/1,2/)) + call mpas_halo_exch_group_complete(domain, 'dynamics:exner') + + call mpas_halo_exch_group_create(domain, 'dynamics:tend_u') + call mpas_halo_exch_group_add_field(domain, 'dynamics:tend_u', 'tend_u', timeLevel=1, haloLayers=(/1/)) + call mpas_halo_exch_group_complete(domain, 'dynamics:tend_u') + + call mpas_halo_exch_group_create(domain, 'dynamics:rho_pp') + call mpas_halo_exch_group_add_field(domain, 'dynamics:rho_pp', 'rho_pp', timeLevel=1, haloLayers=(/1/)) + call mpas_halo_exch_group_complete(domain, 'dynamics:rho_pp') + + call mpas_halo_exch_group_create(domain, 'dynamics:rtheta_pp') + call mpas_halo_exch_group_add_field(domain, 'dynamics:rtheta_pp', 'rtheta_pp', timeLevel=1, haloLayers=(/1/)) + call mpas_halo_exch_group_complete(domain, 'dynamics:rtheta_pp') + + call mpas_halo_exch_group_create(domain, 'dynamics:u_123') + call mpas_halo_exch_group_add_field(domain, 'dynamics:u_123', 'u', timeLevel=2, haloLayers=(/1,2,3/)) + call mpas_halo_exch_group_complete(domain, 'dynamics:u_123') + + call mpas_halo_exch_group_create(domain, 'dynamics:u_3') + call mpas_halo_exch_group_add_field(domain, 'dynamics:u_3', 'u', timeLevel=2, haloLayers=(/3/)) + call mpas_halo_exch_group_complete(domain, 'dynamics:u_3') + + call mpas_halo_exch_group_create(domain, 'dynamics:scalars') + call mpas_halo_exch_group_add_field(domain, 'dynamics:scalars', 'scalars', timeLevel=2, haloLayers=(/1,2/)) + call mpas_halo_exch_group_complete(domain, 'dynamics:scalars') + + call mpas_halo_exch_group_create(domain, 'dynamics:scalars_old') + call mpas_halo_exch_group_add_field(domain, 'dynamics:scalars_old', 'scalars', timeLevel=1, haloLayers=(/1,2/)) + call mpas_halo_exch_group_complete(domain, 'dynamics:scalars_old') + + call mpas_halo_exch_group_create(domain, 'dynamics:w') + call mpas_halo_exch_group_add_field(domain, 'dynamics:w', 'w', timeLevel=2, haloLayers=(/1,2/)) + call mpas_halo_exch_group_complete(domain, 'dynamics:w') + + call mpas_halo_exch_group_create(domain, 'dynamics:scale') + call mpas_halo_exch_group_add_field(domain, 'dynamics:scale', 'scale', timeLevel=1, haloLayers=(/1,2/)) + call mpas_halo_exch_group_complete(domain, 'dynamics:scale') + +#ifdef DO_PHYSICS + ! + ! Set up halo exchange groups used by physics + ! + call mpas_halo_exch_group_create(domain, 'physics:blten') + call mpas_halo_exch_group_add_field(domain, 'physics:blten', 'rublten', timeLevel=1, haloLayers=(/1,2/)) + call mpas_halo_exch_group_add_field(domain, 'physics:blten', 'rvblten', timeLevel=1, haloLayers=(/1,2/)) + call mpas_halo_exch_group_complete(domain, 'physics:blten') + + call mpas_halo_exch_group_create(domain, 'physics:cuten') + call mpas_halo_exch_group_add_field(domain, 'physics:cuten', 'rucuten', timeLevel=1, haloLayers=(/1,2/)) + call mpas_halo_exch_group_add_field(domain, 'physics:cuten', 'rvcuten', timeLevel=1, haloLayers=(/1,2/)) + call mpas_halo_exch_group_complete(domain, 'physics:cuten') +#endif + + ! + ! Set routine to exchange a halo group + ! + exchange_halo_group => mpas_halo_exch_group_full_halo_exch + + else + + ! + ! Invalid method for exchanging halos + ! + ierr = 1 + call mpas_log_write('Invalid method for exchanging halos specified by ''config_halo_exch_method'': ' // & + trim(config_halo_exch_method), messageType=MPAS_LOG_ERR) + return + + end if + + ierr = 0 + + end subroutine atm_build_halo_groups + + + !----------------------------------------------------------------------- + ! routine atm_destroy_halo_groups + ! + !> \brief Destroys halo exchange groups used throughout atmosphere core + !> \author Michael Duda + !> \date 5 June 2023 + !> \details + !> This routine destroys the halo exchange groups that are used throughout + !> the atmosphere core, freeing up any resources that were used by these + !> halo exchange groups. + !> + !> A value of 0 is returned if halo exchange groups have been + !> successfully destroyed and a non-zero value is returned otherwise. + ! + !----------------------------------------------------------------------- + subroutine atm_destroy_halo_groups(domain, ierr) + + use mpas_dmpar, only : mpas_dmpar_exch_group_destroy + use mpas_halo, only : mpas_halo_exch_group_destroy, mpas_halo_finalize + + type (domain_type), intent(inout) :: domain + integer, intent(inout) :: ierr + + + if (trim(config_halo_exch_method) == 'mpas_dmpar') then + ! + ! Destroy halo exchange groups used only during initialization + ! + call mpas_dmpar_exch_group_destroy(domain, 'initialization:u') + call mpas_dmpar_exch_group_destroy(domain, 'initialization:pv_edge,ru,rw') + + ! + ! Destroy halo exchange groups used by dynamics + ! + call mpas_dmpar_exch_group_destroy(domain, 'dynamics:theta_m,scalars,pressure_p,rtheta_p') + call mpas_dmpar_exch_group_destroy(domain, 'dynamics:rw_p,ru_p,rho_pp,rtheta_pp') + call mpas_dmpar_exch_group_destroy(domain, 'dynamics:w,pv_edge,rho_edge') + call mpas_dmpar_exch_group_destroy(domain, 'dynamics:w,pv_edge,rho_edge,scalars') + call mpas_dmpar_exch_group_destroy(domain, 'dynamics:theta_m,pressure_p,rtheta_p') + + call mpas_dmpar_exch_group_destroy(domain, 'dynamics:exner') + call mpas_dmpar_exch_group_destroy(domain, 'dynamics:tend_u') + call mpas_dmpar_exch_group_destroy(domain, 'dynamics:rho_pp') + call mpas_dmpar_exch_group_destroy(domain, 'dynamics:rtheta_pp') + call mpas_dmpar_exch_group_destroy(domain, 'dynamics:u_123') + call mpas_dmpar_exch_group_destroy(domain, 'dynamics:u_3') + call mpas_dmpar_exch_group_destroy(domain, 'dynamics:scalars') + call mpas_dmpar_exch_group_destroy(domain, 'dynamics:scalars_old') + call mpas_dmpar_exch_group_destroy(domain, 'dynamics:w') + call mpas_dmpar_exch_group_destroy(domain, 'dynamics:scale') + +#ifdef DO_PHYSICS + ! + ! Destroy halo exchange groups used by physics + ! + call mpas_dmpar_exch_group_destroy(domain, 'physics:blten') + call mpas_dmpar_exch_group_destroy(domain, 'physics:cuten') +#endif + + else if (trim(config_halo_exch_method) == 'mpas_halo') then + + ! + ! Destroy halo exchange groups used only during initialization + ! + call mpas_halo_exch_group_destroy(domain, 'initialization:u') + call mpas_halo_exch_group_destroy(domain, 'initialization:pv_edge,ru,rw') + + ! + ! Destroy halo exchange groups used by dynamics + ! + call mpas_halo_exch_group_destroy(domain, 'dynamics:theta_m,scalars,pressure_p,rtheta_p') + call mpas_halo_exch_group_destroy(domain, 'dynamics:rw_p,ru_p,rho_pp,rtheta_pp') + call mpas_halo_exch_group_destroy(domain, 'dynamics:w,pv_edge,rho_edge') + call mpas_halo_exch_group_destroy(domain, 'dynamics:w,pv_edge,rho_edge,scalars') + call mpas_halo_exch_group_destroy(domain, 'dynamics:theta_m,pressure_p,rtheta_p') + + call mpas_halo_exch_group_destroy(domain, 'dynamics:exner') + call mpas_halo_exch_group_destroy(domain, 'dynamics:tend_u') + call mpas_halo_exch_group_destroy(domain, 'dynamics:rho_pp') + call mpas_halo_exch_group_destroy(domain, 'dynamics:rtheta_pp') + call mpas_halo_exch_group_destroy(domain, 'dynamics:u_123') + call mpas_halo_exch_group_destroy(domain, 'dynamics:u_3') + call mpas_halo_exch_group_destroy(domain, 'dynamics:scalars') + call mpas_halo_exch_group_destroy(domain, 'dynamics:scalars_old') + call mpas_halo_exch_group_destroy(domain, 'dynamics:w') + call mpas_halo_exch_group_destroy(domain, 'dynamics:scale') + +#ifdef DO_PHYSICS + ! + ! Destroy halo exchange groups used by physics + ! + call mpas_halo_exch_group_destroy(domain, 'physics:blten') + call mpas_halo_exch_group_destroy(domain, 'physics:cuten') +#endif + + call mpas_halo_finalize(domain) + + else + + ! + ! Invalid method for exchanging halos - an error should have already occurred in atm_build_halo_groups() + ! + ierr = 1 + return + + end if + + ierr = 0 + + end subroutine atm_destroy_halo_groups + +end module mpas_atm_halos + diff --git a/src/core_atmosphere/physics/Makefile b/src/core_atmosphere/physics/Makefile index 22e7e22b1e..39f7230f4b 100644 --- a/src/core_atmosphere/physics/Makefile +++ b/src/core_atmosphere/physics/Makefile @@ -29,6 +29,7 @@ OBJS = \ mpas_atmphys_driver_pbl.o \ mpas_atmphys_driver_radiation_lw.o \ mpas_atmphys_driver_radiation_sw.o \ + mpas_atmphys_driver_seaice.o \ mpas_atmphys_driver_sfclayer.o \ mpas_atmphys_finalize.o \ mpas_atmphys_init.o \ @@ -36,6 +37,7 @@ OBJS = \ mpas_atmphys_interface.o \ mpas_atmphys_landuse.o \ mpas_atmphys_lsm_noahinit.o \ + mpas_atmphys_lsm_shared.o \ mpas_atmphys_manager.o \ mpas_atmphys_o3climatology.o \ mpas_atmphys_packages.o \ @@ -81,6 +83,7 @@ mpas_atmphys_driver.o: \ mpas_atmphys_driver_pbl.o \ mpas_atmphys_driver_radiation_lw.o \ mpas_atmphys_driver_radiation_sw.o \ + mpas_atmphys_driver_seaice.o \ mpas_atmphys_driver_sfclayer.o \ mpas_atmphys_driver_oml.o \ mpas_atmphys_constants.o \ @@ -144,11 +147,13 @@ mpas_atmphys_init.o: \ mpas_atmphys_driver_convection.o \ mpas_atmphys_driver_lsm.o \ mpas_atmphys_driver_microphysics.o \ + mpas_atmphys_driver_pbl.o \ mpas_atmphys_driver_radiation_lw.o \ mpas_atmphys_driver_radiation_sw.o \ mpas_atmphys_driver_sfclayer.o \ mpas_atmphys_landuse.o \ - mpas_atmphys_o3climatology.o + mpas_atmphys_o3climatology.o \ + mpas_atmphys_vars.o mpas_atmphys_interface.o: \ mpas_atmphys_constants.o \ @@ -182,6 +187,11 @@ mpas_atmphys_rrtmg_swinit.o: \ mpas_atmphys_constants.o \ mpas_atmphys_utilities.o +mpas_atmphys_driver_seaice.o: \ + mpas_atmphys_constants.o \ + mpas_atmphys_lsm_shared.o \ + mpas_atmphys_vars.o + mpas_atmphys_todynamics.o: \ mpas_atmphys_constants.o \ mpas_atmphys_vars.o diff --git a/src/core_atmosphere/physics/mpas_atmphys_driver.F b/src/core_atmosphere/physics/mpas_atmphys_driver.F index b120d0ccc4..64a50efca4 100644 --- a/src/core_atmosphere/physics/mpas_atmphys_driver.F +++ b/src/core_atmosphere/physics/mpas_atmphys_driver.F @@ -17,6 +17,7 @@ module mpas_atmphys_driver use mpas_atmphys_driver_pbl use mpas_atmphys_driver_radiation_lw use mpas_atmphys_driver_radiation_sw + use mpas_atmphys_driver_seaice,only: allocate_seaice,deallocate_seaice,driver_seaice use mpas_atmphys_driver_sfclayer use mpas_atmphys_driver_oml use mpas_atmphys_constants @@ -270,14 +271,23 @@ subroutine physics_driver(domain,itimestep,xtime_s) !call to land-surface scheme: if(config_lsm_scheme .ne. 'off') then - call allocate_lsm(config_frac_seaice) + call allocate_lsm !$OMP PARALLEL DO do thread=1,nThreads call driver_lsm(itimestep,block%configs,mesh,diag_physics,sfc_input, & cellSolveThreadStart(thread), cellSolveThreadEnd(thread)) end do !$OMP END PARALLEL DO - call deallocate_lsm(config_frac_seaice) + call deallocate_lsm + + call allocate_seaice +!$OMP PARALLEL DO + do thread=1,nThreads + call driver_seaice(block%configs,diag_physics,sfc_input, & + cellSolveThreadStart(thread),cellSolveThreadEnd(thread)) + enddo +!$OMP END PARALLEL DO + call deallocate_seaice endif !call to pbl schemes: diff --git a/src/core_atmosphere/physics/mpas_atmphys_driver_convection.F b/src/core_atmosphere/physics/mpas_atmphys_driver_convection.F index 3310f1c801..763776bf7f 100644 --- a/src/core_atmosphere/physics/mpas_atmphys_driver_convection.F +++ b/src/core_atmosphere/physics/mpas_atmphys_driver_convection.F @@ -90,7 +90,10 @@ module mpas_atmphys_driver_convection ! Laura D. Fowler (laura@ucar.edu) / 2016-10-18. ! * since we removed the local variable convection_scheme from mpas_atmphys_vars.F, now defines convection_scheme ! as a pointer to config_convection_scheme. -! Laura D. Fowler (laura@ucar.edu) / 2917-02-16. +! Laura D. Fowler (laura@ucar.edu) / 2017-02-16. +! * removed f_qv,f_qr,and f_qs in the calls to cu_tiedtke and cu_ntiedtke. removed f_qv and f_qc in the call to +! kf_eta_cps. +! Laura D. Fowler (laura@ucar.edu) / 2024-02-13. contains @@ -518,7 +521,7 @@ subroutine driver_convection(itimestep,configs,mesh,sfc_input,diag_physics,tend_ endif call mpas_timer_start('Kain-Fritsch') - call kf_eta_cps ( & + call kf_eta_cps ( & pcps = pres_hyd_p , t = t_p , & dt = dt_dyn , ktau = ktau , & dxCell = dx_p , areaCell = area_p , & @@ -538,8 +541,7 @@ subroutine driver_convection(itimestep,configs,mesh,sfc_input,diag_physics,tend_ svpt0 = svpt0 , stepcu = n_cu , & cu_act_flag = cu_act_flag , warm_rain = warm_rain , & cutop = cutop_p , cubot = cubot_p , & - qv = qv_p , f_qv = f_qv , & - f_qc = f_qc , f_qr = f_qr , & + qv = qv_p , f_qr = f_qr , & f_qi = f_qi , f_qs = f_qs , & rthcuten = rthcuten_p , rqvcuten = rqvcuten_p , & rqccuten = rqccuten_p , rqrcuten = rqrcuten_p , & @@ -553,23 +555,22 @@ subroutine driver_convection(itimestep,configs,mesh,sfc_input,diag_physics,tend_ case("cu_tiedtke") call mpas_timer_start('Tiedtke') call cu_tiedtke( & - pcps = pres_hyd_p , p8w = pres2_hyd_p , & - znu = znu_hyd_p , t3d = t_p , & - dt = dt_dyn , itimestep = initflag , & - stepcu = n_cu , raincv = raincv_p , & - pratec = pratec_p , qfx = qfx_p , & - u3d = u_p , v3d = v_p , & - w = w_p , qv3d = qv_p , & - qc3d = qc_p , qi3d = qi_p , & - pi3d = pi_p , rho3d = rho_p , & - qvften = rqvdynten_p , qvpblten = rqvdynblten_p , & - dz8w = dz_p , xland = xland_p , & - cu_act_flag = cu_act_flag , f_qv = f_qv , & - f_qc = f_qc , f_qr = f_qr , & - f_qi = f_qi , f_qs = f_qs , & - rthcuten = rthcuten_p , rqvcuten = rqvcuten_p , & - rqccuten = rqccuten_p , rqicuten = rqicuten_p , & - rucuten = rucuten_p , rvcuten = rvcuten_p , & + pcps = pres_hyd_p , p8w = pres2_hyd_p , & + znu = znu_hyd_p , t3d = t_p , & + dt = dt_dyn , itimestep = initflag , & + stepcu = n_cu , raincv = raincv_p , & + pratec = pratec_p , qfx = qfx_p , & + u3d = u_p , v3d = v_p , & + w = w_p , qv3d = qv_p , & + qc3d = qc_p , qi3d = qi_p , & + pi3d = pi_p , rho3d = rho_p , & + qvften = rqvdynten_p , qvpblten = rqvdynblten_p , & + dz8w = dz_p , xland = xland_p , & + cu_act_flag = cu_act_flag , f_qc = f_qc , & + f_qi = f_qi , rthcuten = rthcuten_p , & + rqvcuten = rqvcuten_p , rqccuten = rqccuten_p , & + rqicuten = rqicuten_p , rucuten = rucuten_p , & + rvcuten = rvcuten_p , & ids = ids , ide = ide , jds = jds , jde = jde , kds = kds , kde = kde , & ims = ims , ime = ime , jms = jms , jme = jme , kms = kds , kme = kme , & its = its , ite = ite , jts = jts , jte = jte , kts = kts , kte = kte & @@ -579,28 +580,27 @@ subroutine driver_convection(itimestep,configs,mesh,sfc_input,diag_physics,tend_ case("cu_ntiedtke") call mpas_timer_start('cu_ntiedtke') call cu_ntiedtke_driver( & - pcps = pres_hyd_p , p8w = pres2_hyd_p , & - t3d = t_p , dz8w = dz_p , & - dt = dt_dyn , itimestep = initflag , & - stepcu = n_cu , raincv = raincv_p , & - pratec = pratec_p , qfx = qfx_p , & - hfx = hfx_p , xland = xland_p , & - dx = dx_p , u3d = u_p , & - v3d = v_p , w = w_p , & - qv3d = qv_p , qc3d = qc_p , & - qi3d = qi_p , pi3d = pi_p , & - rho3d = rho_p , qvften = rqvften_p , & - thften = rthften_p , cu_act_flag = cu_act_flag , & - f_qv = f_qv , f_qc = f_qc , & - f_qr = f_qr , f_qi = f_qi , & - f_qs = f_qs , rthcuten = rthcuten_p , & - rqvcuten = rqvcuten_p , rqccuten = rqccuten_p , & - rqicuten = rqicuten_p , rucuten = rucuten_p , & - rvcuten = rvcuten_p , grav = gravity , & - xlf = xlf , xls = xls , & - xlv = xlv , rd = R_d , & - rv = R_v , cp = cp , & - errmsg = errmsg , errflg = errflg , & + pcps = pres_hyd_p , p8w = pres2_hyd_p , & + t3d = t_p , dz8w = dz_p , & + dt = dt_dyn , itimestep = initflag , & + stepcu = n_cu , raincv = raincv_p , & + pratec = pratec_p , qfx = qfx_p , & + hfx = hfx_p , xland = xland_p , & + dx = dx_p , u3d = u_p , & + v3d = v_p , w = w_p , & + qv3d = qv_p , qc3d = qc_p , & + qi3d = qi_p , pi3d = pi_p , & + rho3d = rho_p , qvften = rqvften_p , & + thften = rthften_p , cu_act_flag = cu_act_flag , & + f_qc = f_qc , f_qi = f_qi , & + rthcuten = rthcuten_p , rqvcuten = rqvcuten_p , & + rqccuten = rqccuten_p , rqicuten = rqicuten_p , & + rucuten = rucuten_p , rvcuten = rvcuten_p , & + grav = gravity , xlf = xlf , & + xls = xls , xlv = xlv , & + rd = R_d , rv = R_v , & + cp = cp , & + errmsg = errmsg , errflg = errflg , & ids = ids , ide = ide , jds = jds , jde = jde , kds = kds , kde = kde , & ims = ims , ime = ime , jms = jms , jme = jme , kms = kds , kme = kme , & its = its , ite = ite , jts = jts , jte = jte , kts = kts , kte = kte & diff --git a/src/core_atmosphere/physics/mpas_atmphys_driver_gwdo.F b/src/core_atmosphere/physics/mpas_atmphys_driver_gwdo.F index d783cc831b..06bf5ef0ea 100644 --- a/src/core_atmosphere/physics/mpas_atmphys_driver_gwdo.F +++ b/src/core_atmosphere/physics/mpas_atmphys_driver_gwdo.F @@ -307,7 +307,7 @@ subroutine driver_gwdo(itimestep,configs,mesh,sfc_input,diag_physics,tend_physic gwdo_select: select case (trim(gwdo_scheme)) case("bl_ysu_gwdo") - call mpas_timer_start('bl_ysu_gwdo') + call mpas_timer_start('bl_gwdo') call gwdo ( & p3d = pres_hydd_p , p3di = pres2_hydd_p , pi3d = pi_p , & u3d = u_p , v3d = v_p , t3d = t_p , & @@ -326,7 +326,7 @@ subroutine driver_gwdo(itimestep,configs,mesh,sfc_input,diag_physics,tend_physic ims = ims , ime = ime , jms = jms , jme = jme , kms = kms , kme = kme , & its = its , ite = ite , jts = jts , jte = jte , kts = kts , kte = kte & ) - call mpas_timer_stop('bl_ysu_gwdo') + call mpas_timer_stop('bl_gwdo') case default diff --git a/src/core_atmosphere/physics/mpas_atmphys_driver_lsm.F b/src/core_atmosphere/physics/mpas_atmphys_driver_lsm.F index 5231645a29..0116dcf561 100644 --- a/src/core_atmosphere/physics/mpas_atmphys_driver_lsm.F +++ b/src/core_atmosphere/physics/mpas_atmphys_driver_lsm.F @@ -98,6 +98,11 @@ module mpas_atmphys_driver_lsm ! Laura D. Fowler (laura@ucar.edu) / 2020-05-10. ! * replaced the option "noah" with "sf_noah" to run the NOAH land surface scheme. ! Laura D. Fowler (laura@ucar.edu) / 2022-02-18. +! * moved the call to sfcdiags from subroutine driver_lsm to subroutine lsm_to_MPAS. this allows t2m, th2m, +! and q2 to be correctly computed over seaice points. +! Laura D. Fowler (laura@ucar.edu) / 2024-03-12. +! * moved all sourcecode related to surface processes over seaice points to mpas_atmphys_driver_seaice.F. +! Laura D. Fowler (laura@ucar.edu) / 2024-03-13. ! @@ -114,12 +119,9 @@ module mpas_atmphys_driver_lsm !================================================================================================================= - subroutine allocate_lsm(config_frac_seaice) + subroutine allocate_lsm !================================================================================================================= - logical,intent(in):: config_frac_seaice -!----------------------------------------------------------------------------------------------------------------- - !arrays for soil layer properties: if(.not.allocated(dzs_p) ) allocate(dzs_p(1:num_soils) ) if(.not.allocated(smcrel_p)) allocate(smcrel_p(ims:ime,1:num_soils,jms:jme)) @@ -179,9 +181,6 @@ subroutine allocate_lsm(config_frac_seaice) if(.not.allocated(xland_p) ) allocate(xland_p(ims:ime,jms:jme) ) if(.not.allocated(z0_p) ) allocate(z0_p(ims:ime,jms:jme) ) if(.not.allocated(znt_p) ) allocate(znt_p(ims:ime,jms:jme) ) - if(.not.allocated(t2m_p) ) allocate(t2m_p(ims:ime,jms:jme) ) - if(.not.allocated(th2m_p) ) allocate(th2m_p(ims:ime,jms:jme) ) - if(.not.allocated(q2_p) ) allocate(q2_p(ims:ime,jms:jme) ) if(.not.allocated(flxsnow_p) ) allocate(flxsnow_p(ims:ime,jms:jme) ) if(.not.allocated(fvbsnow_p) ) allocate(fvbsnow_p(ims:ime,jms:jme) ) if(.not.allocated(fbursnow_p) ) allocate(fbursnow_p(ims:ime,jms:jme) ) @@ -190,23 +189,12 @@ subroutine allocate_lsm(config_frac_seaice) if(.not.allocated(ust_urb_p) ) allocate(ust_urb_p(ims:ime,jms:jme) ) if(.not.allocated(utype_urb_p) ) allocate(utype_urb_p(ims:ime,jms:jme) ) - if(config_frac_seaice) then - if(.not.allocated(tsk_sea) ) allocate(tsk_sea(ims:ime,jms:jme) ) - if(.not.allocated(tsk_ice) ) allocate(tsk_ice(ims:ime,jms:jme) ) - if(.not.allocated(albsi_p) ) allocate(albsi_p(ims:ime,jms:jme) ) - if(.not.allocated(icedepth_p)) allocate(icedepth_p(ims:ime,jms:jme)) - if(.not.allocated(snowsi_p) ) allocate(snowsi_p(ims:ime,jms:jme) ) - endif - end subroutine allocate_lsm !================================================================================================================= - subroutine deallocate_lsm(config_frac_seaice) + subroutine deallocate_lsm !================================================================================================================= - logical,intent(in):: config_frac_seaice -!----------------------------------------------------------------------------------------------------------------- - !arrays for soil layer properties: if(allocated(dzs_p) ) deallocate(dzs_p ) if(allocated(smcrel_p)) deallocate(smcrel_p) @@ -266,9 +254,6 @@ subroutine deallocate_lsm(config_frac_seaice) if(allocated(xland_p) ) deallocate(xland_p ) if(allocated(z0_p) ) deallocate(z0_p ) if(allocated(znt_p) ) deallocate(znt_p ) - if(allocated(t2m_p) ) deallocate(t2m_p ) - if(allocated(th2m_p) ) deallocate(th2m_p ) - if(allocated(q2_p) ) deallocate(q2_p ) if(allocated(flxsnow_p) ) deallocate(flxsnow_p ) if(allocated(fvbsnow_p) ) deallocate(fvbsnow_p ) if(allocated(fbursnow_p) ) deallocate(fbursnow_p ) @@ -277,23 +262,6 @@ subroutine deallocate_lsm(config_frac_seaice) if(allocated(ust_urb_p) ) deallocate(ust_urb_p ) if(allocated(utype_urb_p) ) deallocate(utype_urb_p ) - if(config_frac_seaice) then - if(allocated(chs_sea) ) deallocate(chs_sea ) - if(allocated(chs2_sea) ) deallocate(chs2_sea ) - if(allocated(cqs2_sea) ) deallocate(cqs2_sea ) - if(allocated(cpm_sea) ) deallocate(cpm_sea ) - if(allocated(hfx_sea) ) deallocate(hfx_sea ) - if(allocated(qfx_sea) ) deallocate(qfx_sea ) - if(allocated(qgh_sea) ) deallocate(qgh_sea ) - if(allocated(qsfc_sea) ) deallocate(qsfc_sea ) - if(allocated(lh_sea) ) deallocate(lh_sea ) - if(allocated(tsk_sea) ) deallocate(tsk_sea ) - if(allocated(tsk_ice) ) deallocate(tsk_ice ) - if(allocated(albsi_p) ) deallocate(albsi_p ) - if(allocated(icedepth_p)) deallocate(icedepth_p) - if(allocated(snowsi_p) ) deallocate(snowsi_p ) - endif - end subroutine deallocate_lsm !================================================================================================================= @@ -308,8 +276,6 @@ subroutine lsm_from_MPAS(configs,mesh,diag_physics,sfc_input,its,ite) integer,intent(in):: its,ite !local pointers: - logical,pointer:: config_frac_seaice - character(len=StrKIND),pointer:: config_microp_scheme, & config_convection_scheme @@ -322,7 +288,6 @@ subroutine lsm_from_MPAS(configs,mesh,diag_physics,sfc_input,its,ite) z0,znt real(kind=RKIND),dimension(:),pointer :: shdmin,shdmax,snoalb,sfc_albbck,snow,snowc,snowh,tmn, & skintemp,vegfra,xice,xland - real(kind=RKIND),dimension(:),pointer :: t2m,th2m,q2 real(kind=RKIND),dimension(:),pointer :: raincv,rainncv real(kind=RKIND),dimension(:,:),pointer:: sh2o,smcrel,smois,tslb,dzs @@ -333,46 +298,42 @@ subroutine lsm_from_MPAS(configs,mesh,diag_physics,sfc_input,its,ite) !----------------------------------------------------------------------------------------------------------------- - call mpas_pool_get_config(configs,'config_frac_seaice' ,config_frac_seaice ) call mpas_pool_get_config(configs,'config_convection_scheme',config_convection_scheme) call mpas_pool_get_config(configs,'config_microp_scheme' ,config_microp_scheme ) - call mpas_pool_get_array(diag_physics,'acsnom' ,acsnom ) - call mpas_pool_get_array(diag_physics,'acsnow' ,acsnow ) - call mpas_pool_get_array(diag_physics,'canwat' ,canwat ) - call mpas_pool_get_array(diag_physics,'chs' ,chs ) - call mpas_pool_get_array(diag_physics,'chs2' ,chs2 ) - call mpas_pool_get_array(diag_physics,'chklowq' ,chklowq ) - call mpas_pool_get_array(diag_physics,'cpm' ,cpm ) - call mpas_pool_get_array(diag_physics,'cqs2' ,cqs2 ) - call mpas_pool_get_array(diag_physics,'glw' ,glw ) - call mpas_pool_get_array(diag_physics,'grdflx' ,grdflx ) - call mpas_pool_get_array(diag_physics,'gsw' ,gsw ) - call mpas_pool_get_array(diag_physics,'hfx' ,hfx ) - call mpas_pool_get_array(diag_physics,'lai' ,lai ) - call mpas_pool_get_array(diag_physics,'lh' ,lh ) - call mpas_pool_get_array(diag_physics,'noahres' ,noahres ) - call mpas_pool_get_array(diag_physics,'potevp' ,potevp ) - call mpas_pool_get_array(diag_physics,'qfx' ,qfx ) - call mpas_pool_get_array(diag_physics,'qgh' ,qgh ) - call mpas_pool_get_array(diag_physics,'qsfc' ,qsfc ) - call mpas_pool_get_array(diag_physics,'br' ,br ) - call mpas_pool_get_array(diag_physics,'sfc_albedo' ,sfc_albedo ) - call mpas_pool_get_array(diag_physics,'sfc_emibck' ,sfc_emibck ) - call mpas_pool_get_array(diag_physics,'sfc_emiss' ,sfc_emiss ) - call mpas_pool_get_array(diag_physics,'sfcrunoff' ,sfcrunoff ) - call mpas_pool_get_array(diag_physics,'smstav' ,smstav ) - call mpas_pool_get_array(diag_physics,'smstot' ,smstot ) - call mpas_pool_get_array(diag_physics,'snotime' ,snotime ) - call mpas_pool_get_array(diag_physics,'snopcx' ,snopcx ) - call mpas_pool_get_array(diag_physics,'swddif' ,swddif ) - call mpas_pool_get_array(diag_physics,'swddir' ,swddir ) - call mpas_pool_get_array(diag_physics,'udrunoff' ,udrunoff ) - call mpas_pool_get_array(diag_physics,'z0' ,z0 ) - call mpas_pool_get_array(diag_physics,'znt' ,znt ) - call mpas_pool_get_array(diag_physics,'t2m' ,t2m ) - call mpas_pool_get_array(diag_physics,'th2m' ,th2m ) - call mpas_pool_get_array(diag_physics,'q2' ,q2 ) + call mpas_pool_get_array(diag_physics,'acsnom' ,acsnom ) + call mpas_pool_get_array(diag_physics,'acsnow' ,acsnow ) + call mpas_pool_get_array(diag_physics,'canwat' ,canwat ) + call mpas_pool_get_array(diag_physics,'chs' ,chs ) + call mpas_pool_get_array(diag_physics,'chs2' ,chs2 ) + call mpas_pool_get_array(diag_physics,'chklowq' ,chklowq ) + call mpas_pool_get_array(diag_physics,'cpm' ,cpm ) + call mpas_pool_get_array(diag_physics,'cqs2' ,cqs2 ) + call mpas_pool_get_array(diag_physics,'glw' ,glw ) + call mpas_pool_get_array(diag_physics,'grdflx' ,grdflx ) + call mpas_pool_get_array(diag_physics,'gsw' ,gsw ) + call mpas_pool_get_array(diag_physics,'hfx' ,hfx ) + call mpas_pool_get_array(diag_physics,'lai' ,lai ) + call mpas_pool_get_array(diag_physics,'lh' ,lh ) + call mpas_pool_get_array(diag_physics,'noahres' ,noahres ) + call mpas_pool_get_array(diag_physics,'potevp' ,potevp ) + call mpas_pool_get_array(diag_physics,'qfx' ,qfx ) + call mpas_pool_get_array(diag_physics,'qgh' ,qgh ) + call mpas_pool_get_array(diag_physics,'qsfc' ,qsfc ) + call mpas_pool_get_array(diag_physics,'br' ,br ) + call mpas_pool_get_array(diag_physics,'sfc_albedo',sfc_albedo) + call mpas_pool_get_array(diag_physics,'sfc_emibck',sfc_emibck) + call mpas_pool_get_array(diag_physics,'sfc_emiss' ,sfc_emiss ) + call mpas_pool_get_array(diag_physics,'sfcrunoff' ,sfcrunoff ) + call mpas_pool_get_array(diag_physics,'smstav' ,smstav ) + call mpas_pool_get_array(diag_physics,'smstot' ,smstot ) + call mpas_pool_get_array(diag_physics,'snotime' ,snotime ) + call mpas_pool_get_array(diag_physics,'snopcx' ,snopcx ) + call mpas_pool_get_array(diag_physics,'swddif' ,swddif ) + call mpas_pool_get_array(diag_physics,'swddir' ,swddir ) + call mpas_pool_get_array(diag_physics,'udrunoff' ,udrunoff ) + call mpas_pool_get_array(diag_physics,'z0' ,z0 ) + call mpas_pool_get_array(diag_physics,'znt' ,znt ) call mpas_pool_get_array(sfc_input,'isltyp' ,isltyp ) call mpas_pool_get_array(sfc_input,'ivgtyp' ,ivgtyp ) @@ -446,9 +407,6 @@ subroutine lsm_from_MPAS(configs,mesh,diag_physics,sfc_input,its,ite) udrunoff_p(i,j) = udrunoff(i) z0_p(i,j) = z0(i) znt_p(i,j) = znt(i) - t2m_p(i,j) = t2m(i) - th2m_p(i,j) = th2m(i) - q2_p(i,j) = q2(i) isltyp_p(i,j) = isltyp(i) ivgtyp_p(i,j) = ivgtyp(i) @@ -481,41 +439,6 @@ subroutine lsm_from_MPAS(configs,mesh,diag_physics,sfc_input,its,ite) enddo enddo - if(config_frac_seaice) then - do j = jts,jte - do i = its,ite - !modify the surface albedo and surface emissivity, and surface temperatures over sea-ice points: - if(xice(i).ge.xice_threshold .and. xice(i).le.1._RKIND) then - sfc_albedo_p(i,j) = (sfc_albedo(i) - 0.08_RKIND*(1._RKIND-xice(i))) / xice(i) - sfc_emiss_p(i,j) = (sfc_emiss(i) - 0.98_RKIND*(1._RKIND-xice(i))) / xice(i) - else - sfc_albedo_p(i,j) = sfc_albedo(i) - sfc_emiss_p(i,j) = sfc_emiss(i) - endif - enddo - enddo - - !calculate sea-surface and sea-ice temperatures over sea-ice grid cells: - call correct_tsk_over_seaice(ims,ime,jms,jme,its,ite,jts,jte,xice_threshold,xice_p, & - tsk_p,tsk_sea,tsk_ice) - - do j = jts,jte - do i = its,ite - tsk_p(i,j) = tsk_ice(i,j) - enddo - enddo - - !initialize the surface albedo, the surface albedo over snow-covered seaice, and the - !seaice thickness. - do j = jts,jte - do i = its,ite - albsi_p(i,j) = seaice_albedo_default - icedepth_p(i,j) = seaice_thickness_default - snowsi_p(i,j) = seaice_snowdepth_min - enddo - enddo - endif - do j = jts,jte do i = its,ite sr_p(i,j) = 0._RKIND @@ -565,8 +488,6 @@ subroutine lsm_to_MPAS(configs,mesh,diag_physics,sfc_input,its,ite) integer,intent(in):: its,ite !local pointers: - logical,pointer:: config_frac_seaice - character(len=StrKIND),pointer:: config_microp_scheme integer,dimension(:),pointer:: isltyp,ivgtyp @@ -577,7 +498,6 @@ subroutine lsm_to_MPAS(configs,mesh,diag_physics,sfc_input,its,ite) smstav,smstot,snotime,snopcx,sr,udrunoff,z0,znt real(kind=RKIND),dimension(:),pointer :: shdmin,shdmax,snoalb,sfc_albbck,snow,snowc,snowh,tmn, & skintemp,vegfra,xice,xland - real(kind=RKIND),dimension(:),pointer :: t2m,th2m,q2 real(kind=RKIND),dimension(:),pointer :: raincv,rainncv real(kind=RKIND),dimension(:,:),pointer:: sh2o,smcrel,smois,tslb @@ -587,7 +507,6 @@ subroutine lsm_to_MPAS(configs,mesh,diag_physics,sfc_input,its,ite) !----------------------------------------------------------------------------------------------------------------- - call mpas_pool_get_config(configs,'config_frac_seaice' ,config_frac_seaice ) call mpas_pool_get_config(configs,'config_microp_scheme',config_microp_scheme) call mpas_pool_get_array(diag_physics,'acsnom' ,acsnom ) @@ -623,28 +542,25 @@ subroutine lsm_to_MPAS(configs,mesh,diag_physics,sfc_input,its,ite) call mpas_pool_get_array(diag_physics,'udrunoff' ,udrunoff ) call mpas_pool_get_array(diag_physics,'z0' ,z0 ) call mpas_pool_get_array(diag_physics,'znt' ,znt ) - call mpas_pool_get_array(diag_physics,'t2m' ,t2m ) - call mpas_pool_get_array(diag_physics,'th2m' ,th2m ) - call mpas_pool_get_array(diag_physics,'q2' ,q2 ) - - call mpas_pool_get_array(sfc_input,'isltyp' ,isltyp ) - call mpas_pool_get_array(sfc_input,'ivgtyp' ,ivgtyp ) - call mpas_pool_get_array(sfc_input,'shdmin' ,shdmin ) - call mpas_pool_get_array(sfc_input,'shdmax' ,shdmax ) - call mpas_pool_get_array(sfc_input,'snoalb' ,snoalb ) - call mpas_pool_get_array(sfc_input,'sfc_albbck' ,sfc_albbck) - call mpas_pool_get_array(sfc_input,'snow' ,snow ) - call mpas_pool_get_array(sfc_input,'snowc' ,snowc ) - call mpas_pool_get_array(sfc_input,'snowh' ,snowh ) - call mpas_pool_get_array(sfc_input,'tmn' ,tmn ) - call mpas_pool_get_array(sfc_input,'skintemp' ,skintemp ) - call mpas_pool_get_array(sfc_input,'vegfra' ,vegfra ) - call mpas_pool_get_array(sfc_input,'xice' ,xice ) - call mpas_pool_get_array(sfc_input,'xland' ,xland ) - call mpas_pool_get_array(sfc_input,'sh2o' ,sh2o ) - call mpas_pool_get_array(sfc_input,'smcrel' ,smcrel ) - call mpas_pool_get_array(sfc_input,'smois' ,smois ) - call mpas_pool_get_array(sfc_input,'tslb' ,tslb ) + + call mpas_pool_get_array(sfc_input,'isltyp' ,isltyp ) + call mpas_pool_get_array(sfc_input,'ivgtyp' ,ivgtyp ) + call mpas_pool_get_array(sfc_input,'shdmin' ,shdmin ) + call mpas_pool_get_array(sfc_input,'shdmax' ,shdmax ) + call mpas_pool_get_array(sfc_input,'snoalb' ,snoalb ) + call mpas_pool_get_array(sfc_input,'sfc_albbck',sfc_albbck) + call mpas_pool_get_array(sfc_input,'snow' ,snow ) + call mpas_pool_get_array(sfc_input,'snowc' ,snowc ) + call mpas_pool_get_array(sfc_input,'snowh' ,snowh ) + call mpas_pool_get_array(sfc_input,'tmn' ,tmn ) + call mpas_pool_get_array(sfc_input,'skintemp' ,skintemp ) + call mpas_pool_get_array(sfc_input,'vegfra' ,vegfra ) + call mpas_pool_get_array(sfc_input,'xice' ,xice ) + call mpas_pool_get_array(sfc_input,'xland' ,xland ) + call mpas_pool_get_array(sfc_input,'sh2o' ,sh2o ) + call mpas_pool_get_array(sfc_input,'smcrel' ,smcrel ) + call mpas_pool_get_array(sfc_input,'smois' ,smois ) + call mpas_pool_get_array(sfc_input,'tslb' ,tslb ) do j = jts,jte do n = 1,num_soils @@ -690,9 +606,6 @@ subroutine lsm_to_MPAS(configs,mesh,diag_physics,sfc_input,its,ite) udrunoff(i) = udrunoff_p(i,j) z0(i) = z0_p(i,j) znt(i) = znt_p(i,j) - t2m(i) = t2m_p(i,j) - th2m(i) = th2m_p(i,j) - q2(i) = q2_p(i,j) snoalb(i) = snoalb_p(i,j) sfc_albbck(i) = sfc_albbck_p(i,j) @@ -707,27 +620,6 @@ subroutine lsm_to_MPAS(configs,mesh,diag_physics,sfc_input,its,ite) enddo enddo - if(config_frac_seaice) then - do j = jts,jte - do i = its,ite - if(xice_p(i,j).ge.xice_threshold .and. xice_p(i,j).le.1._RKIND) then - chs(i) = xice_p(i,j)*chs_p(i,j) + (1._RKIND-xice_p(i,j))*chs_sea(i,j) - chs2(i) = xice_p(i,j)*chs2_p(i,j) + (1._RKIND-xice_p(i,j))*chs2_sea(i,j) - cqs2(i) = xice_p(i,j)*cqs2_p(i,j) + (1._RKIND-xice_p(i,j))*cqs2_sea(i,j) - cpm(i) = xice_p(i,j)*cpm_p(i,j) + (1._RKIND-xice_p(i,j))*cpm_sea(i,j) - hfx(i) = xice_p(i,j)*hfx_p(i,j) + (1._RKIND-xice_p(i,j))*hfx_sea(i,j) - lh(i) = xice_p(i,j)*lh_p(i,j) + (1._RKIND-xice_p(i,j))*lh_sea(i,j) - qfx(i) = xice_p(i,j)*qfx_p(i,j) + (1._RKIND-xice_p(i,j))*qfx_sea(i,j) - qgh(i) = xice_p(i,j)*qgh_p(i,j) + (1._RKIND-xice_p(i,j))*qgh_sea(i,j) - qsfc(i) = xice_p(i,j)*qsfc_p(i,j) + (1._RKIND-xice_p(i,j))*qsfc_sea(i,j) - skintemp(i) = xice_p(i,j)*tsk_p(i,j) + (1._RKIND-xice_p(i,j))*tsk_sea(i,j) - sfc_albedo(i) = xice_p(i,j)*sfc_albedo_p(i,j) + (1._RKIND-xice_p(i,j))*0.08_RKIND - sfc_emiss(i) = xice_p(i,j)*sfc_emiss_p(i,j) + (1._RKIND-xice_p(i,j))*0.98_RKIND - endif - enddo - enddo - endif - if(config_microp_scheme .ne. 'off') then call mpas_pool_get_array(diag_physics,'sr',sr) @@ -787,7 +679,7 @@ subroutine driver_lsm(itimestep,configs,mesh,diag_physics,sfc_input,its,ite) type(mpas_pool_type),intent(inout):: sfc_input !local pointers: - logical,pointer:: config_sfc_albedo,config_frac_seaice + logical,pointer:: config_sfc_albedo character(len=StrKIND),pointer:: lsm_scheme character(len=StrKIND),pointer:: mminlu integer,pointer:: isice @@ -797,7 +689,6 @@ subroutine driver_lsm(itimestep,configs,mesh,diag_physics,sfc_input,its,ite) !call mpas_log_write('--- enter subroutine driver_lsm:') call mpas_pool_get_config(configs,'config_sfc_albedo' ,config_sfc_albedo ) - call mpas_pool_get_config(configs,'config_frac_seaice',config_frac_seaice) call mpas_pool_get_config(configs,'config_lsm_scheme',lsm_scheme) call mpas_pool_get_array(sfc_input,'mminlu',mminlu) call mpas_pool_get_array(sfc_input,'isice' ,isice ) @@ -856,50 +747,7 @@ subroutine driver_lsm(itimestep,configs,mesh,diag_physics,sfc_input,its,ite) ims = ims , ime = ime , jms = jms , jme = jme , kms = kms , kme = kme , & its = its , ite = ite , jts = jts , jte = jte , kts = kts , kte = kte & ) - - if(config_frac_seaice) then - call seaice_noah( & - dz8w = dz_p , p8w3d = pres2_hyd_p , t3d = t_p , & - qv3d = qv_p , xice = xice_p , snoalb2d = snoalb_p , & - glw = glw_p , swdown = swdown_p , rainbl = rainbl_p , & - sr = sr_p , qgh = qgh_p , tsk = tsk_p , & - hfx = hfx_p , qfx = qfx_p , lh = lh_p , & - grdflx = grdflx_p , potevp = potevp_p , qsfc = qsfc_p , & - emiss = sfc_emiss_p , albedo = sfc_albedo_p , rib = br_p , & - cqs2 = cqs2_p , chs = chs_p , chs2 = chs2_p , & - z02d = z0_p , znt = znt_p , tslb = tslb_p , & - snow = snow_p , snowc = snowc_p , snowh2d = snowh_p , & - snopcx = snopcx_p , acsnow = acsnow_p , acsnom = acsnom_p , & - sfcrunoff = sfcrunoff_p , albsi = albsi_p , snowsi = snowsi_p , & - icedepth = icedepth_p , noahres = noahres_p , dt = dt_pbl , & - frpcpn = frpcpn , & - seaice_albedo_opt = seaice_albedo_opt , & - seaice_albedo_default = seaice_albedo_default , & - seaice_thickness_opt = seaice_thickness_opt , & - seaice_thickness_default = seaice_thickness_default , & - seaice_snowdepth_opt = seaice_snowdepth_opt , & - seaice_snowdepth_max = seaice_snowdepth_max , & - seaice_snowdepth_min = seaice_snowdepth_min , & - xice_threshold = xice_threshold , & - num_soil_layers = num_soils , & - sf_urban_physics = sf_urban_physics , & - ids = ids , ide = ide , jds = jds , jde = jde , kds = kds , kde = kde , & - ims = ims , ime = ime , jms = jms , jme = jme , kms = kms , kme = kme , & - its = its , ite = ite , jts = jts , jte = jte , kts = kts , kte = kte & - ) - endif - - call sfcdiags( & - hfx = hfx_p , qfx = qfx_p , tsk = tsk_p , qsfc = qsfc_p , chs = chs_p , & - chs2 = chs2_p , cqs2 = cqs2_p , t2 = t2m_p , th2 = th2m_p , q2 = q2_p , & - psfc = psfc_p , t3d = t_p , qv3d = qv_p , cp = cp , R_d = R_d , & - rovcp = rcp , ua_phys = ua_phys , & - ids = ids , ide = ide , jds = jds , jde = jde , kds = kds , kde = kde , & - ims = ims , ime = ime , jms = jms , jme = jme , kms = kms , kme = kme , & - its = its , ite = ite , jts = jts , jte = jte , kts = kts , kte = kte & - ) call mpas_timer_stop('sf_noah') - case default @@ -912,44 +760,6 @@ subroutine driver_lsm(itimestep,configs,mesh,diag_physics,sfc_input,its,ite) end subroutine driver_lsm -!================================================================================================================= - subroutine correct_tsk_over_seaice(ims,ime,jms,jme,its,ite,jts,jte,xice_thresh,xice,tsk,tsk_sea,tsk_ice) -!================================================================================================================= - -!input arguments: - integer,intent(in):: ims,ime,its,ite,jms,jme,jts,jte - real(kind=RKIND),intent(in):: xice_thresh - real(kind=RKIND),intent(in),dimension(ims:ime,jms:jme):: tsk,xice - -!inout arguments: - real(kind=RKIND),intent(inout),dimension(ims:ime,jms:jme):: tsk_sea,tsk_ice - -!local variables: - integer:: i,j - -!----------------------------------------------------------------------------------------------------------------- - -!initialize the local sea-surface temperature and local sea-ice temperature to the local surface -!temperature: - do j = jts,jte - do i = its,ite - tsk_sea(i,j) = tsk(i,j) - tsk_ice(i,j) = tsk(i,j) - - if(xice(i,j).ge.xice_thresh .and. xice(i,j).le.1._RKIND) then - !over sea-ice grid cells, limit sea-surface temperatures to temperatures warmer than 271.4: - tsk_sea(i,j) = max(tsk_sea(i,j),271.4_RKIND) - - !over sea-ice grid cells, avoids unphysically too cold sea-ice temperatures for grid cells - !with small sea-ice fractions: - if(xice(i,j).lt.0.2_RKIND .and. tsk_ice(i,j).lt.253.15_RKIND) tsk_ice(i,j) = 253.15_RKIND - if(xice(i,j).lt.0.1_RKIND .and. tsk_ice(i,j).lt.263.15_RKIND) tsk_ice(i,j) = 263.15_RKIND - endif - enddo - enddo - - end subroutine correct_tsk_over_seaice - !================================================================================================================= end module mpas_atmphys_driver_lsm !================================================================================================================= diff --git a/src/core_atmosphere/physics/mpas_atmphys_driver_pbl.F b/src/core_atmosphere/physics/mpas_atmphys_driver_pbl.F index c5ee085954..6969ff6e5b 100644 --- a/src/core_atmosphere/physics/mpas_atmphys_driver_pbl.F +++ b/src/core_atmosphere/physics/mpas_atmphys_driver_pbl.F @@ -9,19 +9,20 @@ module mpas_atmphys_driver_pbl use mpas_kind_types use mpas_pool_routines - use mpas_timer, only : mpas_timer_start, mpas_timer_stop + use mpas_timer,only: mpas_timer_start,mpas_timer_stop use mpas_atmphys_constants use mpas_atmphys_vars -!wrf physics: - use module_bl_mynn + use bl_mynn,only: bl_mynn_init + use module_bl_mynn,only: mynn_bl_driver use module_bl_ysu implicit none private public:: allocate_pbl, & deallocate_pbl, & + init_pbl, & driver_pbl !MPAS driver for parameterization of Planetary Boundary Layer (PBL) processes. @@ -73,6 +74,10 @@ module mpas_atmphys_driver_pbl ! errmsg and errflg in the call to subroutine ysu for compliance with the CCPP framework. also removed local ! variable regime_p which is no longer needed in the call to subroutine ysu. ! Laura D. Fowler (laura@ucar.edu) / 2023-05-15. +! * in the call to subroutine mynn_bl_driver,renamed f_qnc to f_nc, and f_qni to f_ni. +! Laura D. Fowler (laura@ucar.edu) / 2024-02-14. +! * updated the MYNN PBL scheme to the sourcecode from WRF version 4.6. +! Laura D. Fowler (laura@ucar.edu) / 2024-02.15. contains @@ -100,12 +105,9 @@ subroutine allocate_pbl(configs) if(.not.allocated(hpbl_p) ) allocate(hpbl_p(ims:ime,jms:jme) ) if(.not.allocated(kpbl_p) ) allocate(kpbl_p(ims:ime,jms:jme) ) if(.not.allocated(znt_p) ) allocate(znt_p(ims:ime,jms:jme) ) - if(.not.allocated(delta_p)) allocate(delta_p(ims:ime,jms:jme)) - if(.not.allocated(wstar_p)) allocate(wstar_p(ims:ime,jms:jme)) if(.not.allocated(uoce_p) ) allocate(uoce_p(ims:ime,jms:jme) ) if(.not.allocated(voce_p) ) allocate(voce_p(ims:ime,jms:jme) ) - !tendencies: if(.not.allocated(rublten_p) ) allocate(rublten_p(ims:ime,kms:kme,jms:jme) ) if(.not.allocated(rvblten_p) ) allocate(rvblten_p(ims:ime,kms:kme,jms:jme) ) @@ -114,6 +116,8 @@ subroutine allocate_pbl(configs) if(.not.allocated(rqcblten_p)) allocate(rqcblten_p(ims:ime,kms:kme,jms:jme)) if(.not.allocated(rqiblten_p)) allocate(rqiblten_p(ims:ime,kms:kme,jms:jme)) + if(.not.allocated(rthraten_p)) allocate(rthraten_p(ims:ime,kms:kme,jms:jme)) + !exchange coefficients: if(.not.allocated(kzh_p)) allocate(kzh_p(ims:ime,kms:kme,jms:jme)) if(.not.allocated(kzm_p)) allocate(kzm_p(ims:ime,kms:kme,jms:jme)) @@ -123,42 +127,63 @@ subroutine allocate_pbl(configs) case("bl_ysu") !from surface-layer model: - if(.not.allocated(br_p) ) allocate(br_p(ims:ime,jms:jme) ) - if(.not.allocated(ctopo_p) ) allocate(ctopo_p(ims:ime,jms:jme) ) - if(.not.allocated(ctopo2_p)) allocate(ctopo2_p(ims:ime,jms:jme) ) - if(.not.allocated(psih_p) ) allocate(psih_p(ims:ime,jms:jme) ) - if(.not.allocated(psim_p) ) allocate(psim_p(ims:ime,jms:jme) ) - if(.not.allocated(u10_p) ) allocate(u10_p(ims:ime,jms:jme) ) - if(.not.allocated(v10_p) ) allocate(v10_p(ims:ime,jms:jme) ) - if(.not.allocated(exch_p) ) allocate(exch_p(ims:ime,kms:kme,jms:jme)) - !from radiation schemes: - if(.not.allocated(rthraten_p)) allocate(rthraten_p(ims:ime,kms:kme,jms:jme)) + if(.not.allocated(br_p) ) allocate(br_p(ims:ime,jms:jme) ) + if(.not.allocated(ctopo_p) ) allocate(ctopo_p(ims:ime,jms:jme) ) + if(.not.allocated(ctopo2_p) ) allocate(ctopo2_p(ims:ime,jms:jme) ) + if(.not.allocated(delta_p) ) allocate(delta_p(ims:ime,jms:jme) ) + if(.not.allocated(psih_p) ) allocate(psih_p(ims:ime,jms:jme) ) + if(.not.allocated(psim_p) ) allocate(psim_p(ims:ime,jms:jme) ) + if(.not.allocated(u10_p) ) allocate(u10_p(ims:ime,jms:jme) ) + if(.not.allocated(v10_p) ) allocate(v10_p(ims:ime,jms:jme) ) + if(.not.allocated(exch_p) ) allocate(exch_p(ims:ime,kms:kme,jms:jme) ) + if(.not.allocated(wstar_p) ) allocate(wstar_p(ims:ime,jms:jme) ) case("bl_mynn") - if(.not.allocated(dx_p) ) allocate(dx_p(ims:ime,jms:jme) ) - if(.not.allocated(ch_p) ) allocate(ch_p(ims:ime,jms:jme) ) - if(.not.allocated(qcg_p) ) allocate(qcg_p(ims:ime,jms:jme) ) - if(.not.allocated(qsfc_p) ) allocate(qsfc_p(ims:ime,jms:jme) ) - if(.not.allocated(rmol_p) ) allocate(rmol_p(ims:ime,jms:jme) ) - if(.not.allocated(tsk_p) ) allocate(tsk_p(ims:ime,jms:jme) ) - if(.not.allocated(vdfg_p) ) allocate(vdfg_p(ims:ime,jms:jme) ) - - if(.not.allocated(cov_p) ) allocate(cov_p(ims:ime,kms:kme,jms:jme) ) - if(.not.allocated(qke_p) ) allocate(qke_p(ims:ime,kms:kme,jms:jme) ) - if(.not.allocated(qsq_p) ) allocate(qsq_p(ims:ime,kms:kme,jms:jme) ) - if(.not.allocated(tsq_p) ) allocate(tsq_p(ims:ime,kms:kme,jms:jme) ) - if(.not.allocated(qkeadv_p)) allocate(qkeadv_p(ims:ime,kms:kme,jms:jme)) - if(.not.allocated(elpbl_p) ) allocate(elpbl_p(ims:ime,kms:kme,jms:jme) ) - if(.not.allocated(tkepbl_p)) allocate(tkepbl_p(ims:ime,kms:kme,jms:jme)) - if(.not.allocated(sh3d_p) ) allocate(sh3d_p(ims:ime,kms:kme,jms:jme) ) - - if(.not.allocated(dqke_p) ) allocate(dqke_p(ims:ime,kms:kme,jms:jme) ) - if(.not.allocated(qbuoy_p) ) allocate(qbuoy_p(ims:ime,kms:kme,jms:jme) ) - if(.not.allocated(qdiss_p) ) allocate(qdiss_p(ims:ime,kms:kme,jms:jme) ) - if(.not.allocated(qshear_p)) allocate(qshear_p(ims:ime,kms:kme,jms:jme)) - if(.not.allocated(qwt_p) ) allocate(qwt_p(ims:ime,kms:kme,jms:jme) ) - - if(.not.allocated(rniblten_p)) allocate(rniblten_p(ims:ime,kms:kme,jms:jme)) + if(.not.allocated(kbl_plume_p) ) allocate(kbl_plume_p(ims:ime,jms:jme) ) + + if(.not.allocated(dx_p) ) allocate(dx_p(ims:ime,jms:jme) ) + if(.not.allocated(ch_p) ) allocate(ch_p(ims:ime,jms:jme) ) + if(.not.allocated(qsfc_p) ) allocate(qsfc_p(ims:ime,jms:jme) ) + if(.not.allocated(rmol_p) ) allocate(rmol_p(ims:ime,jms:jme) ) + if(.not.allocated(tsk_p) ) allocate(tsk_p(ims:ime,jms:jme) ) + if(.not.allocated(maxwidthbl_p) ) allocate(maxwidthbl_p(ims:ime,jms:jme) ) + if(.not.allocated(maxmfbl_p) ) allocate(maxmfbl_p(ims:ime,jms:jme) ) + if(.not.allocated(zbl_plume_p) ) allocate(zbl_plume_p(ims:ime,jms:jme) ) + + if(.not.allocated(cov_p) ) allocate(cov_p(ims:ime,kms:kme,jms:jme) ) + if(.not.allocated(qke_p) ) allocate(qke_p(ims:ime,kms:kme,jms:jme) ) + if(.not.allocated(qsq_p) ) allocate(qsq_p(ims:ime,kms:kme,jms:jme) ) + if(.not.allocated(tsq_p) ) allocate(tsq_p(ims:ime,kms:kme,jms:jme) ) + if(.not.allocated(qkeadv_p) ) allocate(qkeadv_p(ims:ime,kms:kme,jms:jme) ) + if(.not.allocated(elpbl_p) ) allocate(elpbl_p(ims:ime,kms:kme,jms:jme) ) + if(.not.allocated(tkepbl_p) ) allocate(tkepbl_p(ims:ime,kms:kme,jms:jme) ) + if(.not.allocated(sh3d_p) ) allocate(sh3d_p(ims:ime,kms:kme,jms:jme) ) + if(.not.allocated(sm3d_p) ) allocate(sm3d_p(ims:ime,kms:kme,jms:jme) ) + if(.not.allocated(dqke_p) ) allocate(dqke_p(ims:ime,kms:kme,jms:jme) ) + if(.not.allocated(qbuoy_p) ) allocate(qbuoy_p(ims:ime,kms:kme,jms:jme) ) + if(.not.allocated(qdiss_p) ) allocate(qdiss_p(ims:ime,kms:kme,jms:jme) ) + if(.not.allocated(qshear_p) ) allocate(qshear_p(ims:ime,kms:kme,jms:jme) ) + if(.not.allocated(qwt_p) ) allocate(qwt_p(ims:ime,kms:kme,jms:jme) ) + if(.not.allocated(qcbl_p) ) allocate(qcbl_p(ims:ime,kms:kme,jms:jme) ) + if(.not.allocated(qibl_p) ) allocate(qibl_p(ims:ime,kms:kme,jms:jme) ) + if(.not.allocated(cldfrabl_p) ) allocate(cldfrabl_p(ims:ime,kms:kme,jms:jme) ) + if(.not.allocated(edmfa_p) ) allocate(edmfa_p(ims:ime,kms:kme,jms:jme) ) + if(.not.allocated(edmfw_p) ) allocate(edmfw_p(ims:ime,kms:kme,jms:jme) ) + if(.not.allocated(edmfqt_p) ) allocate(edmfqt_p(ims:ime,kms:kme,jms:jme) ) + if(.not.allocated(edmfthl_p) ) allocate(edmfthl_p(ims:ime,kms:kme,jms:jme) ) + if(.not.allocated(edmfent_p) ) allocate(edmfent_p(ims:ime,kms:kme,jms:jme) ) + if(.not.allocated(edmfqc_p) ) allocate(edmfqc_p(ims:ime,kms:kme,jms:jme) ) + if(.not.allocated(subthl_p) ) allocate(subthl_p(ims:ime,kms:kme,jms:jme) ) + if(.not.allocated(subqv_p) ) allocate(subqv_p(ims:ime,kms:kme,jms:jme) ) + if(.not.allocated(detthl_p) ) allocate(detthl_p(ims:ime,kms:kme,jms:jme) ) + if(.not.allocated(detqv_p) ) allocate(detqv_p(ims:ime,kms:kme,jms:jme) ) + + !additional tendencies: + if(.not.allocated(rqsblten_p) ) allocate(rqsblten_p(ims:ime,kms:kme,jms:jme) ) + if(.not.allocated(rniblten_p) ) allocate(rniblten_p(ims:ime,kms:kme,jms:jme) ) + + !allocation of additional arrays: + if(.not.allocated(pattern_spp_pbl)) allocate(pattern_spp_pbl(ims:ime,kms:kme,jms:jme)) case default @@ -188,8 +213,6 @@ subroutine deallocate_pbl(configs) if(allocated(hpbl_p) ) deallocate(hpbl_p ) if(allocated(kpbl_p) ) deallocate(kpbl_p ) if(allocated(znt_p) ) deallocate(znt_p ) - if(allocated(delta_p)) deallocate(delta_p) - if(allocated(wstar_p)) deallocate(wstar_p) if(allocated(uoce_p) ) deallocate(uoce_p ) if(allocated(voce_p) ) deallocate(voce_p ) @@ -201,6 +224,8 @@ subroutine deallocate_pbl(configs) if(allocated(rqcblten_p)) deallocate(rqcblten_p) if(allocated(rqiblten_p)) deallocate(rqiblten_p) + if(allocated(rthraten_p)) deallocate(rthraten_p) + !exchange coefficients: if(allocated(kzh_p)) deallocate(kzh_p) if(allocated(kzm_p)) deallocate(kzm_p) @@ -210,41 +235,63 @@ subroutine deallocate_pbl(configs) case("bl_ysu") !from surface-layer model: - if(allocated(br_p) ) deallocate(br_p ) - if(allocated(ctopo_p) ) deallocate(ctopo_p ) - if(allocated(ctopo2_p)) deallocate(ctopo2_p) - if(allocated(psih_p) ) deallocate(psih_p ) - if(allocated(psim_p) ) deallocate(psim_p ) - if(allocated(u10_p) ) deallocate(u10_p ) - if(allocated(v10_p) ) deallocate(v10_p ) - if(allocated(exch_p) ) deallocate(exch_p ) - !from radiation schemes: - if(allocated(rthraten_p)) deallocate(rthraten_p) + if(allocated(br_p) ) deallocate(br_p ) + if(allocated(ctopo_p) ) deallocate(ctopo_p ) + if(allocated(ctopo2_p) ) deallocate(ctopo2_p ) + if(allocated(delta_p) ) deallocate(delta_p ) + if(allocated(psih_p) ) deallocate(psih_p ) + if(allocated(psim_p) ) deallocate(psim_p ) + if(allocated(u10_p) ) deallocate(u10_p ) + if(allocated(v10_p) ) deallocate(v10_p ) + if(allocated(exch_p) ) deallocate(exch_p ) + if(allocated(wstar_p) ) deallocate(wstar_p ) case("bl_mynn") - if(allocated(dx_p) ) deallocate(dx_p ) - if(allocated(ch_p) ) deallocate(ch_p ) - if(allocated(qcg_p) ) deallocate(qcg_p ) - if(allocated(qsfc_p) ) deallocate(qsfc_p ) - if(allocated(rmol_p) ) deallocate(rmol_p ) - if(allocated(tsk_p) ) deallocate(tsk_p ) - if(allocated(vdfg_p) ) deallocate(vdfg_p ) - - if(allocated(cov_p) ) deallocate(cov_p ) - if(allocated(qke_p) ) deallocate(qke_p ) - if(allocated(qsq_p) ) deallocate(qsq_p ) - if(allocated(tsq_p) ) deallocate(tsq_p ) - if(allocated(qkeadv_p)) deallocate(qkeadv_p) - if(allocated(elpbl_p) ) deallocate(elpbl_p ) - if(allocated(tkepbl_p)) deallocate(tkepbl_p) - if(allocated(sh3d_p) ) deallocate(sh3d_p ) - if(allocated(dqke_p) ) deallocate(dqke_p ) - if(allocated(qbuoy_p) ) deallocate(qbuoy_p ) - if(allocated(qdiss_p) ) deallocate(qdiss_p ) - if(allocated(qshear_p)) deallocate(qshear_p) - if(allocated(qwt_p) ) deallocate(qwt_p ) - - if(allocated(rniblten_p)) deallocate(rniblten_p) + if(allocated(kbl_plume_p) ) deallocate(kbl_plume_p ) + + if(allocated(dx_p) ) deallocate(dx_p ) + if(allocated(ch_p) ) deallocate(ch_p ) + if(allocated(qsfc_p) ) deallocate(qsfc_p ) + if(allocated(rmol_p) ) deallocate(rmol_p ) + if(allocated(tsk_p) ) deallocate(tsk_p ) + if(allocated(maxwidthbl_p) ) deallocate(maxwidthbl_p ) + if(allocated(maxmfbl_p) ) deallocate(maxmfbl_p ) + if(allocated(zbl_plume_p) ) deallocate(zbl_plume_p ) + + if(allocated(cov_p) ) deallocate(cov_p ) + if(allocated(qke_p) ) deallocate(qke_p ) + if(allocated(qsq_p) ) deallocate(qsq_p ) + if(allocated(tsq_p) ) deallocate(tsq_p ) + if(allocated(qkeadv_p) ) deallocate(qkeadv_p ) + if(allocated(elpbl_p) ) deallocate(elpbl_p ) + if(allocated(tkepbl_p) ) deallocate(tkepbl_p ) + if(allocated(sh3d_p) ) deallocate(sh3d_p ) + if(allocated(sm3d_p) ) deallocate(sm3d_p ) + if(allocated(dqke_p) ) deallocate(dqke_p ) + if(allocated(qbuoy_p) ) deallocate(qbuoy_p ) + if(allocated(qdiss_p) ) deallocate(qdiss_p ) + if(allocated(qshear_p) ) deallocate(qshear_p ) + if(allocated(qwt_p) ) deallocate(qwt_p ) + if(allocated(qcbl_p) ) deallocate(qcbl_p ) + if(allocated(qibl_p) ) deallocate(qibl_p ) + if(allocated(cldfrabl_p) ) deallocate(cldfrabl_p ) + if(allocated(edmfa_p) ) deallocate(edmfa_p ) + if(allocated(edmfw_p) ) deallocate(edmfw_p ) + if(allocated(edmfqt_p) ) deallocate(edmfqt_p ) + if(allocated(edmfthl_p) ) deallocate(edmfthl_p ) + if(allocated(edmfent_p) ) deallocate(edmfent_p ) + if(allocated(edmfqc_p) ) deallocate(edmfqc_p ) + if(allocated(subthl_p) ) deallocate(subthl_p ) + if(allocated(subqv_p) ) deallocate(subqv_p ) + if(allocated(detthl_p) ) deallocate(detthl_p ) + if(allocated(detqv_p) ) deallocate(detqv_p ) + + !additional tendencies: + if(allocated(rqsblten_p) ) deallocate(rqsblten_p ) + if(allocated(rniblten_p) ) deallocate(rniblten_p ) + + !deallocation of additional arrays: + if(allocated(pattern_spp_pbl)) deallocate(pattern_spp_pbl) case default @@ -282,41 +329,48 @@ subroutine pbl_from_MPAS(configs,mesh,sfc_input,diag_physics,tend_physics,its,it !local pointers for MYNN scheme: real(kind=RKIND),pointer:: len_disp real(kind=RKIND),dimension(:),pointer :: meshDensity - real(kind=RKIND),dimension(:),pointer :: ch,qsfc,qcg,rmol,skintemp - real(kind=RKIND),dimension(:,:),pointer:: cov,qke,qsq,tsq,sh3d,tke_pbl,qke_adv,el_pbl + real(kind=RKIND),dimension(:),pointer :: ch,qsfc,rmol,skintemp + real(kind=RKIND),dimension(:,:),pointer:: cov,qke,qsq,tsq,sh3d,sm3d,tke_pbl,qke_adv,el_pbl + real(kind=RKIND),dimension(:,:),pointer:: cldfrac_bl,qc_bl,qi_bl + real(kind=RKIND),dimension(:,:),pointer:: edmf_a,edmf_ent,edmf_qc,edmf_qt,edmf_thl,edmf_w + real(kind=RKIND),dimension(:,:),pointer:: sub_thl,sub_qv,det_thl,det_qv !----------------------------------------------------------------------------------------------------------------- call mpas_pool_get_config(configs,'config_pbl_scheme',pbl_scheme) - call mpas_pool_get_array(diag_physics,'hfx' ,hfx ) - call mpas_pool_get_array(diag_physics,'hpbl' ,hpbl ) - call mpas_pool_get_array(diag_physics,'qfx' ,qfx ) - call mpas_pool_get_array(diag_physics,'ust' ,ust ) - call mpas_pool_get_array(diag_physics,'wspd' ,wspd ) - call mpas_pool_get_array(diag_physics,'znt' ,znt ) - call mpas_pool_get_array(diag_physics,'delta' ,delta ) - call mpas_pool_get_array(diag_physics,'wstar' ,wstar ) + call mpas_pool_get_array(diag_physics,'hfx' ,hfx ) + call mpas_pool_get_array(diag_physics,'hpbl',hpbl) + call mpas_pool_get_array(diag_physics,'qfx' ,qfx ) + call mpas_pool_get_array(diag_physics,'ust' ,ust ) + call mpas_pool_get_array(diag_physics,'wspd',wspd) + call mpas_pool_get_array(diag_physics,'znt' ,znt ) - call mpas_pool_get_array(sfc_input ,'xland' ,xland ) + call mpas_pool_get_array(tend_physics,'rthratenlw',rthratenlw) + call mpas_pool_get_array(tend_physics,'rthratensw',rthratensw) + + call mpas_pool_get_array(sfc_input,'xland',xland) do j = jts,jte do i = its,ite !from surface-layer model: - hfx_p(i,j) = hfx(i) - hpbl_p(i,j) = hpbl(i) - qfx_p(i,j) = qfx(i) - ust_p(i,j) = ust(i) - wspd_p(i,j) = wspd(i) - xland_p(i,j) = xland(i) - kpbl_p(i,j) = 1 - znt_p(i,j) = znt(i) - delta_p(i,j) = delta(i) - wstar_p(i,j) = wstar(i) + hfx_p(i,j) = hfx(i) + hpbl_p(i,j) = hpbl(i) + qfx_p(i,j) = qfx(i) + ust_p(i,j) = ust(i) + wspd_p(i,j) = wspd(i) + xland_p(i,j) = xland(i) + kpbl_p(i,j) = 1 + znt_p(i,j) = znt(i) !... ocean currents are set to zero: uoce_p(i,j) = 0._RKIND voce_p(i,j) = 0._RKIND enddo + do k = kts,kte + do i = its,ite + rthraten_p(i,k,j) = rthratenlw(k,i) + rthratensw(k,i) + enddo + enddo enddo pbl_select: select case (trim(pbl_scheme)) @@ -324,14 +378,13 @@ subroutine pbl_from_MPAS(configs,mesh,sfc_input,diag_physics,tend_physics,its,it case("bl_ysu") call mpas_pool_get_config(configs,'config_ysu_pblmix',config_ysu_pblmix) - call mpas_pool_get_array(diag_physics,'br' ,br ) - call mpas_pool_get_array(diag_physics,'fm' ,fm ) - call mpas_pool_get_array(diag_physics,'fh' ,fh ) - call mpas_pool_get_array(diag_physics,'u10' ,u10 ) - call mpas_pool_get_array(diag_physics,'v10' ,v10 ) - - call mpas_pool_get_array(tend_physics,'rthratenlw',rthratenlw) - call mpas_pool_get_array(tend_physics,'rthratensw',rthratensw) + call mpas_pool_get_array(diag_physics,'br' ,br ) + call mpas_pool_get_array(diag_physics,'delta',delta) + call mpas_pool_get_array(diag_physics,'fm' ,fm ) + call mpas_pool_get_array(diag_physics,'fh' ,fh ) + call mpas_pool_get_array(diag_physics,'u10' ,u10 ) + call mpas_pool_get_array(diag_physics,'v10' ,v10 ) + call mpas_pool_get_array(diag_physics,'wstar',wstar) ysu_pblmix = 0 if(config_ysu_pblmix) ysu_pblmix = 1 @@ -344,6 +397,8 @@ subroutine pbl_from_MPAS(configs,mesh,sfc_input,diag_physics,tend_physics,its,it psih_p(i,j) = fh(i) u10_p(i,j) = u10(i) v10_p(i,j) = v10(i) + delta_p(i,j) = delta(i) + wstar_p(i,j) = wstar(i) !initialization for YSU PBL scheme: ctopo_p(i,j) = 1._RKIND ctopo2_p(i,j) = 1._RKIND @@ -353,8 +408,7 @@ subroutine pbl_from_MPAS(configs,mesh,sfc_input,diag_physics,tend_physics,its,it do j = jts,jte do k = kts,kte do i = its,ite - exch_p(i,k,j) = 0._RKIND - rthraten_p(i,k,j) = rthratenlw(k,i) + rthratensw(k,i) + exch_p(i,k,j) = 0._RKIND enddo enddo enddo @@ -363,31 +417,40 @@ subroutine pbl_from_MPAS(configs,mesh,sfc_input,diag_physics,tend_physics,its,it call mpas_pool_get_config(configs,'config_len_disp',len_disp) call mpas_pool_get_array(mesh,'meshDensity',meshDensity) - call mpas_pool_get_array(sfc_input ,'skintemp',skintemp) - call mpas_pool_get_array(diag_physics,'ch' ,ch ) - call mpas_pool_get_array(diag_physics,'qcg' ,qcg ) - call mpas_pool_get_array(diag_physics,'qsfc' ,qsfc ) - call mpas_pool_get_array(diag_physics,'rmol' ,rmol ) - - call mpas_pool_get_array(diag_physics,'el_pbl' ,el_pbl ) - call mpas_pool_get_array(diag_physics,'cov' ,cov ) - call mpas_pool_get_array(diag_physics,'qke' ,qke ) - call mpas_pool_get_array(diag_physics,'qke_adv',qke_adv ) - call mpas_pool_get_array(diag_physics,'qsq' ,qsq ) - call mpas_pool_get_array(diag_physics,'tsq' ,tsq ) - call mpas_pool_get_array(diag_physics,'tke_pbl',tke_pbl ) - call mpas_pool_get_array(diag_physics,'sh3d' ,sh3d ) + call mpas_pool_get_array(sfc_input,'skintemp',skintemp) + call mpas_pool_get_array(diag_physics,'ch' ,ch ) + call mpas_pool_get_array(diag_physics,'qsfc' ,qsfc ) + call mpas_pool_get_array(diag_physics,'rmol' ,rmol ) + call mpas_pool_get_array(diag_physics,'el_pbl' ,el_pbl ) + call mpas_pool_get_array(diag_physics,'cov' ,cov ) + call mpas_pool_get_array(diag_physics,'qke' ,qke ) + call mpas_pool_get_array(diag_physics,'qke_adv' ,qke_adv ) + call mpas_pool_get_array(diag_physics,'qsq' ,qsq ) + call mpas_pool_get_array(diag_physics,'tsq' ,tsq ) + call mpas_pool_get_array(diag_physics,'tke_pbl' ,tke_pbl ) + call mpas_pool_get_array(diag_physics,'sh3d' ,sh3d ) + call mpas_pool_get_array(diag_physics,'sm3d' ,sm3d ) + call mpas_pool_get_array(diag_physics,'cldfrac_bl',cldfrac_bl) + call mpas_pool_get_array(diag_physics,'qc_bl' ,qc_bl ) + call mpas_pool_get_array(diag_physics,'qi_bl' ,qi_bl ) + call mpas_pool_get_array(diag_physics,'edmf_a' ,edmf_a ) + call mpas_pool_get_array(diag_physics,'edmf_ent' ,edmf_ent ) + call mpas_pool_get_array(diag_physics,'edmf_qc' ,edmf_qc ) + call mpas_pool_get_array(diag_physics,'edmf_qt' ,edmf_qt ) + call mpas_pool_get_array(diag_physics,'edmf_thl' ,edmf_thl ) + call mpas_pool_get_array(diag_physics,'edmf_w' ,edmf_w ) + call mpas_pool_get_array(diag_physics,'sub_thl' ,sub_thl ) + call mpas_pool_get_array(diag_physics,'sub_qv' ,sub_qv ) + call mpas_pool_get_array(diag_physics,'det_thl' ,det_thl ) + call mpas_pool_get_array(diag_physics,'det_qv' ,det_qv ) do j = jts,jte do i = its,ite - dx_p(i,j) = len_disp / meshDensity(i)**0.25 - ch_p(i,j) = ch(i) - qcg_p(i,j) = qcg(i) - qsfc_p(i,j) = qsfc(i) - rmol_p(i,j) = rmol(i) - tsk_p(i,j) = skintemp(i) - !... no gravitational settling of fog/cloud droplets (grav_settling = 0): - vdfg_p(i,j) = 0._RKIND + dx_p(i,j) = len_disp / meshDensity(i)**0.25 + ch_p(i,j) = ch(i) + qsfc_p(i,j) = qsfc(i) + rmol_p(i,j) = rmol(i) + tsk_p(i,j) = skintemp(i) enddo enddo @@ -402,16 +465,38 @@ subroutine pbl_from_MPAS(configs,mesh,sfc_input,diag_physics,tend_physics,its,it tkepbl_p(i,k,j) = tke_pbl(k,i) qkeadv_p(i,k,j) = qke_adv(k,i) sh3d_p(i,k,j) = sh3d(k,i) + sm3d_p(i,k,j) = sm3d(k,i) + cldfrabl_p(i,k,j) = cldfrac_bl(k,i) + qcbl_p(i,k,j) = qc_bl(k,i) + qibl_p(i,k,j) = qi_bl(k,i) + edmfa_p(i,k,j) = edmf_a(k,i) + edmfent_p(i,k,j) = edmf_ent(k,i) + edmfqc_p(i,k,j) = edmf_qc(k,i) + edmfqt_p(i,k,j) = edmf_qt(k,i) + edmfthl_p(i,k,j) = edmf_thl(k,i) + edmfw_p(i,k,j) = edmf_w(k,i) + subthl_p(i,k,j) = sub_thl(k,i) + subqv_p(i,k,j) = sub_qv(k,i) + detthl_p(i,k,j) = det_thl(k,i) + detqv_p(i,k,j) = det_qv(k,i) + dqke_p(i,k,j) = 0._RKIND + qbuoy_p(i,k,j) = 0._RKIND + qdiss_p(i,k,j) = 0._RKIND + qshear_p(i,k,j) = 0._RKIND + qwt_p(i,k,j) = 0._RKIND + + rqsblten_p(i,k,j) = 0._RKIND rniblten_p(i,k,j) = 0._RKIND - !... outputs: - dqke_p(i,k,j) = 0._RKIND - qbuoy_p(i,k,j) = 0._RKIND - qdiss_p(i,k,j) = 0._RKIND - qshear_p(i,k,j) = 0._RKIND - qwt_p(i,k,j) = 0._RKIND + pattern_spp_pbl(i,k,j) = 0._RKIND enddo enddo + do i = its,ite + kbl_plume_p(i,j) = 0 + maxwidthbl_p(i,j) = 0._RKIND + maxmfbl_p(i,j) = 0._RKIND + zbl_plume_p(i,j) = 0 + enddo enddo case default @@ -428,9 +513,9 @@ subroutine pbl_from_MPAS(configs,mesh,sfc_input,diag_physics,tend_physics,its,it rqcblten_p(i,k,j) = 0._RKIND rqiblten_p(i,k,j) = 0._RKIND - kzh_p(i,k,j) = 0._RKIND - kzm_p(i,k,j) = 0._RKIND - kzq_p(i,k,j) = 0._RKIND + kzh_p(i,k,j) = 0._RKIND + kzm_p(i,k,j) = 0._RKIND + kzq_p(i,k,j) = 0._RKIND enddo enddo enddo @@ -460,16 +545,19 @@ subroutine pbl_to_MPAS(configs,diag_physics,tend_physics,its,ite) real(kind=RKIND),dimension(:),pointer :: hpbl real(kind=RKIND),dimension(:,:),pointer:: kzh,kzm,kzq - real(kind=RKIND),dimension(:,:),pointer:: rublten,rvblten,rthblten,rqvblten,rqcblten,rqiblten, & - rniblten + real(kind=RKIND),dimension(:,:),pointer:: rublten,rvblten,rthblten,rqvblten,rqcblten,rqiblten,rqsblten + real(kind=RKIND),dimension(:,:),pointer:: rniblten !local pointers for YSU scheme: real(kind=RKIND),dimension(:,:),pointer:: exch_h !local pointers for MYNN scheme: real(kind=RKIND),dimension(:),pointer :: delta,wstar - real(kind=RKIND),dimension(:,:),pointer:: cov,qke,qsq,tsq,sh3d,tke_pbl,qke_adv,el_pbl,dqke,qbuoy, & + real(kind=RKIND),dimension(:,:),pointer:: cov,qke,qsq,tsq,sh3d,sm3d,tke_pbl,qke_adv,el_pbl,dqke,qbuoy, & qdiss,qshear,qwt + real(kind=RKIND),dimension(:,:),pointer:: cldfrac_bl,qc_bl,qi_bl + real(kind=RKIND),dimension(:,:),pointer:: edmf_a,edmf_ent,edmf_qc,edmf_qt,edmf_thl,edmf_w + real(kind=RKIND),dimension(:,:),pointer:: sub_thl,sub_qv,det_thl,det_qv !----------------------------------------------------------------------------------------------------------------- @@ -480,8 +568,6 @@ subroutine pbl_to_MPAS(configs,diag_physics,tend_physics,its,ite) call mpas_pool_get_array(diag_physics,'kzh' ,kzh ) call mpas_pool_get_array(diag_physics,'kzm' ,kzm ) call mpas_pool_get_array(diag_physics,'kzq' ,kzq ) - call mpas_pool_get_array(diag_physics,'delta',delta) - call mpas_pool_get_array(diag_physics,'wstar',wstar) call mpas_pool_get_array(tend_physics,'rublten' ,rublten ) call mpas_pool_get_array(tend_physics,'rvblten' ,rvblten ) @@ -492,10 +578,8 @@ subroutine pbl_to_MPAS(configs,diag_physics,tend_physics,its,ite) do j = jts,jte do i = its,ite - hpbl(i) = hpbl_p(i,j) - kpbl(i) = kpbl_p(i,j) - delta(i) = delta_p(i,j) - wstar(i) = wstar_p(i,j) + hpbl(i) = hpbl_p(i,j) + kpbl(i) = kpbl_p(i,j) enddo enddo @@ -519,9 +603,15 @@ subroutine pbl_to_MPAS(configs,diag_physics,tend_physics,its,ite) pbl_select: select case (trim(pbl_scheme)) case("bl_ysu") + call mpas_pool_get_array(diag_physics,'delta',delta ) + call mpas_pool_get_array(diag_physics,'wstar' ,wstar ) call mpas_pool_get_array(diag_physics,'exch_h',exch_h) do j = jts,jte + do i = its,ite + delta(i) = delta_p(i,j) + wstar(i) = wstar_p(i,j) + enddo do k = kts,kte do i = its,ite exch_h(k,i) = exch_p(i,k,j) @@ -530,40 +620,70 @@ subroutine pbl_to_MPAS(configs,diag_physics,tend_physics,its,ite) enddo case("bl_mynn") - call mpas_pool_get_array(diag_physics,'el_pbl' ,el_pbl ) - call mpas_pool_get_array(diag_physics,'cov' ,cov ) - call mpas_pool_get_array(diag_physics,'qke' ,qke ) - call mpas_pool_get_array(diag_physics,'qke_adv' ,qke_adv ) - call mpas_pool_get_array(diag_physics,'qsq' ,qsq ) - call mpas_pool_get_array(diag_physics,'tsq' ,tsq ) - call mpas_pool_get_array(diag_physics,'tke_pbl' ,tke_pbl ) - call mpas_pool_get_array(diag_physics,'sh3d' ,sh3d ) - call mpas_pool_get_array(diag_physics,'dqke' ,dqke ) - call mpas_pool_get_array(diag_physics,'qbuoy' ,qbuoy ) - call mpas_pool_get_array(diag_physics,'qdiss' ,qdiss ) - call mpas_pool_get_array(diag_physics,'qshear' ,qshear ) - call mpas_pool_get_array(diag_physics,'qwt' ,qwt ) - call mpas_pool_get_array(tend_physics,'rniblten',rniblten) + call mpas_pool_get_array(diag_physics,'el_pbl' ,el_pbl ) + call mpas_pool_get_array(diag_physics,'cov' ,cov ) + call mpas_pool_get_array(diag_physics,'qke' ,qke ) + call mpas_pool_get_array(diag_physics,'qke_adv' ,qke_adv ) + call mpas_pool_get_array(diag_physics,'qsq' ,qsq ) + call mpas_pool_get_array(diag_physics,'tsq' ,tsq ) + call mpas_pool_get_array(diag_physics,'tke_pbl' ,tke_pbl ) + call mpas_pool_get_array(diag_physics,'sh3d' ,sh3d ) + call mpas_pool_get_array(diag_physics,'sm3d' ,sm3d ) + call mpas_pool_get_array(diag_physics,'dqke' ,dqke ) + call mpas_pool_get_array(diag_physics,'qbuoy' ,qbuoy ) + call mpas_pool_get_array(diag_physics,'qdiss' ,qdiss ) + call mpas_pool_get_array(diag_physics,'qshear' ,qshear ) + call mpas_pool_get_array(diag_physics,'qwt' ,qwt ) + call mpas_pool_get_array(diag_physics,'cldfrac_bl',cldfrac_bl) + call mpas_pool_get_array(diag_physics,'qc_bl' ,qc_bl ) + call mpas_pool_get_array(diag_physics,'qi_bl' ,qi_bl ) + call mpas_pool_get_array(diag_physics,'edmf_a' ,edmf_a ) + call mpas_pool_get_array(diag_physics,'edmf_ent' ,edmf_ent ) + call mpas_pool_get_array(diag_physics,'edmf_qc' ,edmf_qc ) + call mpas_pool_get_array(diag_physics,'edmf_qt' ,edmf_qt ) + call mpas_pool_get_array(diag_physics,'edmf_thl' ,edmf_thl ) + call mpas_pool_get_array(diag_physics,'edmf_w' ,edmf_w ) + call mpas_pool_get_array(diag_physics,'sub_thl' ,sub_thl ) + call mpas_pool_get_array(diag_physics,'sub_qv' ,sub_qv ) + call mpas_pool_get_array(diag_physics,'det_thl' ,det_thl ) + call mpas_pool_get_array(diag_physics,'det_qv' ,det_qv ) + + call mpas_pool_get_array(tend_physics,'rqsblten' ,rqsblten ) + call mpas_pool_get_array(tend_physics,'rniblten' ,rniblten ) do j = jts,jte do k = kts,kte do i = its,ite - el_pbl(k,i) = elpbl_p(i,k,j) - cov(k,i) = cov_p(i,k,j) - qke(k,i) = qke_p(i,k,j) - qsq(k,i) = qsq_p(i,k,j) - tsq(k,i) = tsq_p(i,k,j) - sh3d(k,i) = sh3d_p(i,k,j) - tke_pbl(k,i) = tkepbl_p(i,k,j) - qke_adv(k,i) = qkeadv_p(i,k,j) - !... outputs: - dqke(k,i) = dqke_p(i,k,j) - qbuoy(k,i) = qbuoy_p(i,k,j) - qdiss(k,i) = qdiss_p(i,k,j) - qshear(k,i) = qshear_p(i,k,j) - qwt(k,i) = qwt_p(i,k,j) - - rniblten(k,i) = rniblten_p(i,k,j) + el_pbl(k,i) = elpbl_p(i,k,j) + cov(k,i) = cov_p(i,k,j) + qke(k,i) = qke_p(i,k,j) + qsq(k,i) = qsq_p(i,k,j) + tsq(k,i) = tsq_p(i,k,j) + sh3d(k,i) = sh3d_p(i,k,j) + sm3d(k,i) = sm3d_p(i,k,j) + tke_pbl(k,i) = tkepbl_p(i,k,j) + qke_adv(k,i) = qkeadv_p(i,k,j) + cldfrac_bl(k,i) = cldfrabl_p(i,k,j) + qc_bl(k,i) = qcbl_p(i,k,j) + qi_bl(k,i) = qibl_p(i,k,j) + edmf_a(k,i) = edmfa_p(i,k,j) + edmf_ent(k,i) = edmfent_p(i,k,j) + edmf_qc(k,i) = edmfqc_p(i,k,j) + edmf_qt(k,i) = edmfqt_p(i,k,j) + edmf_thl(k,i) = edmfthl_p(i,k,j) + edmf_w(k,i) = edmfw_p(i,k,j) + sub_thl(k,i) = subthl_p(i,k,j) + sub_qv(k,i) = subqv_p(i,k,j) + det_thl(k,i) = detthl_p(i,k,j) + det_qv(k,i) = detqv_p(i,k,j) + dqke(k,i) = dqke_p(i,k,j) + qbuoy(k,i) = qbuoy_p(i,k,j) + qdiss(k,i) = qdiss_p(i,k,j) + qshear(k,i) = qshear_p(i,k,j) + qwt(k,i) = qwt_p(i,k,j) + + rqsblten(k,i) = rqsblten_p(i,k,j) + rniblten(k,i) = rniblten_p(i,k,j) enddo enddo enddo @@ -574,6 +694,36 @@ subroutine pbl_to_MPAS(configs,diag_physics,tend_physics,its,ite) end subroutine pbl_to_MPAS +!================================================================================================================= + subroutine init_pbl(configs) +!================================================================================================================= + +!input arguments: + type(mpas_pool_type),intent(in):: configs + +!local variables and pointers: + character(len=StrKIND),pointer:: pbl_scheme + character(len=StrKIND):: errmsg + integer:: errflg + +!----------------------------------------------------------------------------------------------------------------- + + call mpas_pool_get_config(configs,'config_pbl_scheme',pbl_scheme) + + pbl_select: select case (trim(pbl_scheme)) + + case("bl_mynn") + call mpas_log_write('--- enter subroutine bl_mynn_init:') + call bl_mynn_init(cp,cpv,cice,cliq,ep_1,ep_2,gravity,karman,P0,R_d,R_v,svp1,svp2,svp3,svpt0, & + xlf,xls,xlv,errmsg,errflg) + call mpas_log_write('--- end subroutine bl_mynn_mpas_init:') + + case default + + end select pbl_select + + end subroutine init_pbl + !================================================================================================================= subroutine driver_pbl(itimestep,configs,mesh,sfc_input,diag_physics,tend_physics,its,ite) !================================================================================================================= @@ -591,9 +741,30 @@ subroutine driver_pbl(itimestep,configs,mesh,sfc_input,diag_physics,tend_physics type(mpas_pool_type),intent(inout):: tend_physics !local pointers: - logical,pointer:: config_do_restart + logical,pointer:: config_do_DAcycling, & + config_do_restart, & + bl_mynn_tkeadvect + character(len=StrKIND),pointer:: pbl_scheme + integer,pointer:: bl_mynn_cloudpdf, & + bl_mynn_mixlength, & + bl_mynn_stfunc, & + bl_mynn_topdown, & + bl_mynn_scaleaware, & + bl_mynn_dheat_opt, & + bl_mynn_edmf, & + bl_mynn_edmf_dd, & + bl_mynn_edmf_mom, & + bl_mynn_edmf_tke, & + bl_mynn_edmf_output, & + bl_mynn_mixscalars, & + bl_mynn_cloudmix, & + bl_mynn_mixqt, & + bl_mynn_tkebudget + + real(kind=RKIND),pointer:: bl_mynn_closure + !local variables: integer:: initflag integer:: i,k,j @@ -610,8 +781,9 @@ subroutine driver_pbl(itimestep,configs,mesh,sfc_input,diag_physics,tend_physics errmsg = ' ' errflg = 0 - call mpas_pool_get_config(configs,'config_do_restart',config_do_restart) - call mpas_pool_get_config(configs,'config_pbl_scheme',pbl_scheme ) + call mpas_pool_get_config(configs,'config_do_DAcycling',config_do_DAcycling) + call mpas_pool_get_config(configs,'config_do_restart' ,config_do_restart ) + call mpas_pool_get_config(configs,'config_pbl_scheme' ,pbl_scheme ) !copy MPAS arrays to local arrays: call pbl_from_MPAS(configs,mesh,sfc_input,diag_physics,tend_physics,its,ite) @@ -651,37 +823,112 @@ subroutine driver_pbl(itimestep,configs,mesh,sfc_input,diag_physics,tend_physics call mpas_timer_stop('bl_ysu') case("bl_mynn") - call mpas_timer_start('MYNN_pbl') - call mynn_bl_driver ( & - p = pres_hyd_p , exner = pi_p , ps = psfc_p , & - th = th_p , dz = dz_p , u = u_p , & - v = v_p , qv = qv_p , qc = qc_p , & - qi = qi_p , qni = ni_p , rho = rho_p , & - du = rublten_p , dv = rvblten_p , dth = rthblten_p , & - dqv = rqvblten_p , dqc = rqcblten_p , dqi = rqiblten_p , & - dqni = rniblten_p , flag_qc = f_qc , flag_qnc = f_qnc , & - flag_qi = f_qi , flag_qni = f_qni , kpbl = kpbl_p , & - pblh = hpbl_p , xland = xland_p , ts = tsk_p , & - hfx = hfx_p , qfx = qfx_p , ch = ch_p , & - sh3d = sh3d_p , tsq = tsq_p , qsq = qsq_p , & - cov = cov_p , el_pbl = elpbl_p , qsfc = qsfc_p , & - qcg = qcg_p , ust = ust_p , rmol = rmol_p , & - wspd = wspd_p , wstar = wstar_p , delta = delta_p , & - delt = dt_pbl , k_h = kzh_p , k_m = kzm_p , & - k_q = kzq_p , uoce = uoce_p , voce = voce_p , & - qke = qke_p , qke_adv = qkeadv_p , vdfg = vdfg_p , & - tke_pbl = tkepbl_p , dqke = dqke_p , qwt = qwt_p , & - qshear = qshear_p , qbuoy = qbuoy_p , qdiss = qdiss_p , & - initflag = initflag , & - grav_settling = grav_settling , & - bl_mynn_cloudpdf = bl_mynn_cloudpdf , & - bl_mynn_tkeadvect = bl_mynn_tkeadvect , & - bl_mynn_tkebudget = bl_mynn_tkebudget , & - ids = ids , ide = ide , jds = jds , jde = jde , kds = kds , kde = kde , & - ims = ims , ime = ime , jms = jms , jme = jme , kms = kms , kme = kme , & - its = its , ite = ite , jts = jts , jte = jte , kts = kts , kte = kte & - ) - call mpas_timer_stop('MYNN_pbl') + call mpas_pool_get_config(configs,'config_mynn_cloudpdf' ,bl_mynn_cloudpdf ) + call mpas_pool_get_config(configs,'config_mynn_mixlength' ,bl_mynn_mixlength ) + call mpas_pool_get_config(configs,'config_mynn_stfunc' ,bl_mynn_stfunc ) + call mpas_pool_get_config(configs,'config_mynn_topdown' ,bl_mynn_topdown ) + call mpas_pool_get_config(configs,'config_mynn_scaleaware' ,bl_mynn_scaleaware ) + call mpas_pool_get_config(configs,'config_mynn_dheat_opt' ,bl_mynn_dheat_opt ) + call mpas_pool_get_config(configs,'config_mynn_edmf' ,bl_mynn_edmf ) + call mpas_pool_get_config(configs,'config_mynn_edmf_dd' ,bl_mynn_edmf_dd ) + call mpas_pool_get_config(configs,'config_mynn_edmf_mom' ,bl_mynn_edmf_mom ) + call mpas_pool_get_config(configs,'config_mynn_edmf_tke' ,bl_mynn_edmf_tke ) + call mpas_pool_get_config(configs,'config_mynn_edmf_output',bl_mynn_edmf_output) + call mpas_pool_get_config(configs,'config_mynn_closure' ,bl_mynn_closure ) + call mpas_pool_get_config(configs,'config_mynn_mixscalars' ,bl_mynn_mixscalars ) + call mpas_pool_get_config(configs,'config_mynn_mixclouds' ,bl_mynn_cloudmix ) + call mpas_pool_get_config(configs,'config_mynn_mixqt' ,bl_mynn_mixqt ) + call mpas_pool_get_config(configs,'config_mynn_tkeadvect' ,bl_mynn_tkeadvect ) + call mpas_pool_get_config(configs,'config_mynn_tkebudget' ,bl_mynn_tkebudget ) + +! call mpas_log_write(' ') +! call mpas_log_write('--- enter subroutine mynn_bl_driver:') +! call mpas_log_write('--- config_mynn_cloudpdf = $i',intArgs=(/bl_mynn_cloudpdf/)) +! call mpas_log_write('--- config_mynn_mixlength = $i',intArgs=(/bl_mynn_mixlength/)) +! call mpas_log_write('--- config_mynn_stfunc = $i',intArgs=(/bl_mynn_stfunc/)) +! call mpas_log_write('--- config_mynn_topdown = $i',intArgs=(/bl_mynn_topdown/)) +! call mpas_log_write('--- config_mynn_scaleaware = $i',intArgs=(/bl_mynn_scaleaware/)) +! call mpas_log_write('--- config_mynn_dheat_opt = $i',intArgs=(/bl_mynn_dheat_opt/)) +! call mpas_log_write('--- config_mynn_edmf = $i',intArgs=(/bl_mynn_edmf/)) +! call mpas_log_write('--- config_mynn_edmf_dd = $i',intArgs=(/bl_mynn_edmf_dd/)) +! call mpas_log_write('--- config_mynn_edmf_mom = $i',intArgs=(/bl_mynn_edmf_mom/)) +! call mpas_log_write('--- config_mynn_edmf_tke = $i',intArgs=(/bl_mynn_edmf_tke/)) +! call mpas_log_write('--- config_mynn_edmf_output = $i',intArgs=(/bl_mynn_edmf_output/)) +! call mpas_log_write('--- config_mynn_mixscalars = $i',intArgs=(/bl_mynn_mixscalars/)) +! call mpas_log_write('--- config_mynn_mixclouds = $i',intArgs=(/bl_mynn_cloudmix/)) +! call mpas_log_write('--- config_mynn_mixqt = $i',intArgs=(/bl_mynn_mixqt/)) +! call mpas_log_write('--- config_mynn_tkeadvect = $l',logicArgs=(/bl_mynn_tkeadvect/)) +! call mpas_log_write('--- config_mynn_tkebudget = $i',intArgs=(/bl_mynn_tkebudget/)) +! call mpas_log_write('--- config_mynn_closure = $r',realArgs=(/bl_mynn_closure/)) +! call mpas_log_write(' ') +! call mpas_log_write('--- f_qc = $l',logicArgs=(/f_qc/) ) +! call mpas_log_write('--- f_qi = $l',logicArgs=(/f_qi/) ) +! call mpas_log_write('--- f_qs = $l',logicArgs=(/f_qs/) ) +! call mpas_log_write('--- f_qoz = $l',logicArgs=(/f_qoz/) ) +! call mpas_log_write('--- f_nc = $l',logicArgs=(/f_nc/) ) +! call mpas_log_write('--- f_ni = $l',logicArgs=(/f_ni/) ) +! call mpas_log_write('--- f_nifa = $l',logicArgs=(/f_nifa/)) +! call mpas_log_write('--- f_nwfa = $l',logicArgs=(/f_nwfa/)) +! call mpas_log_write('--- f_nbca = $l',logicArgs=(/f_nbca/)) + + call mpas_timer_start('bl_mynn') + call mynn_bl_driver( & + f_qc = f_qc , f_qi = f_qi , f_qs = f_qs , & + f_qoz = f_qoz , f_nc = f_nc , f_ni = f_ni , & + f_nifa = f_nifa , f_nwfa = f_nwfa , f_nbca = f_nbca , & + icloud_bl = icloud_bl , delt = dt_pbl , dx = dx_p , & + xland = xland_p , ps = psfc_p , ts = tsk_p , & + qsfc = qsfc_p , ust = ust_p , ch = ch_p , & + hfx = hfx_p , qfx = qfx_p , rmol = rmol_p , & + wspd = wspd_p , znt = znt_p , uoce = uoce_p , & + voce = voce_p , dz = dz_p , u = u_p , & + v = v_p , w = w_p , th = th_p , & + tt = t_p , p = pres_hyd_p , exner = pi_p , & + rho = rho_p , qv = qv_p , qc = qc_p , & + qi = qi_p , qs = qs_p , ni = ni_p , & + rthraten = rthraten_p , pblh = hpbl_p , kpbl = kpbl_p , & + cldfra_bl = cldfrabl_p , qc_bl = qcbl_p , qi_bl = qibl_p , & + maxwidth = maxwidthbl_p , maxmf = maxmfbl_p , ktop_plume = kbl_plume_p , & + ztop_plume = zbl_plume_p , dqke = dqke_p , qke_adv = qkeadv_p , & + tsq = tsq_p , qsq = qsq_p , cov = cov_p , & + el_pbl = elpbl_p , rublten = rublten_p , rvblten = rvblten_p , & + rthblten = rthblten_p , rqvblten = rqvblten_p , rqcblten = rqcblten_p , & + rqiblten = rqiblten_p , rqsblten = rqsblten_p , rniblten = rniblten_p , & + edmf_a = edmfa_p , edmf_w = edmfw_p , edmf_qt = edmfqt_p , & + edmf_thl = edmfthl_p , edmf_ent = edmfent_p , edmf_qc = edmfqc_p , & + sub_thl = subthl_p , sub_sqv = subqv_p , det_thl = detthl_p , & + det_sqv = detqv_p , exch_h = kzh_p , exch_m = kzm_p , & + qke = qke_p , qwt = qwt_p , qshear = qshear_p , & + qbuoy = qbuoy_p , qdiss = qdiss_p , sh3d = sh3d_p , & + sm3d = sm3d_p , spp_pbl = spp_pbl , pattern_spp = pattern_spp_pbl , & + do_restart = config_do_restart , & + do_DAcycling = config_do_DAcycling , & + initflag = initflag , & + bl_mynn_tkeadvect = bl_mynn_tkeadvect , & + bl_mynn_tkebudget = bl_mynn_tkebudget , & + bl_mynn_cloudpdf = bl_mynn_cloudpdf , & + bl_mynn_mixlength = bl_mynn_mixlength , & + bl_mynn_closure = bl_mynn_closure , & + bl_mynn_stfunc = bl_mynn_stfunc , & + bl_mynn_topdown = bl_mynn_topdown , & + bl_mynn_scaleaware = bl_mynn_scaleaware , & + bl_mynn_dheat_opt = bl_mynn_dheat_opt , & + bl_mynn_edmf = bl_mynn_edmf , & + bl_mynn_edmf_dd = bl_mynn_edmf_dd , & + bl_mynn_edmf_mom = bl_mynn_edmf_mom , & + bl_mynn_edmf_tke = bl_mynn_edmf_tke , & + bl_mynn_output = bl_mynn_edmf_output , & + bl_mynn_mixscalars = bl_mynn_mixscalars , & + bl_mynn_cloudmix = bl_mynn_cloudmix , & + bl_mynn_mixqt = bl_mynn_mixqt , & + ids = ids , ide = ide , jds = jds , jde = jde , kds = kds , kde = kde , & + ims = ims , ime = ime , jms = jms , jme = jme , kms = kms , kme = kme , & + its = its , ite = ite , jts = jts , jte = jte , kts = kts , kte = kte , & + errmsg = errmsg , errflg = errflg & + ) + call mpas_timer_stop('bl_mynn') +! call mpas_log_write('--- exit subroutine mynn_bl_driver:') +! call mpas_log_write(' ') case default diff --git a/src/core_atmosphere/physics/mpas_atmphys_driver_radiation_lw.F b/src/core_atmosphere/physics/mpas_atmphys_driver_radiation_lw.F index 7365b3dcf6..60dbebb3e5 100644 --- a/src/core_atmosphere/physics/mpas_atmphys_driver_radiation_lw.F +++ b/src/core_atmosphere/physics/mpas_atmphys_driver_radiation_lw.F @@ -91,7 +91,9 @@ module mpas_atmphys_driver_radiation_lw ! Laura D. Fowler (laura@ucar.edu) / 2017-02-10. ! * since we removed the local variable radt_lw_scheme from mpas_atmphys_vars.F, now defines radt_lw_scheme ! as a pointer to config_radt_lw_scheme. -! Laura D. Fowler (laura@ucar.edu) / 2917-02-16. +! Laura D. Fowler (laura@ucar.edu) / 2017-02-16. +! * removed the variables f_qv and f_qg in the call to subroutine camrad. +! Laura D. Fowler (laura@ucar.edu) / 2024-02-13. contains @@ -912,10 +914,9 @@ subroutine driver_radiation_lw(xtime_s,configs,mesh,state,time_lev,diag_physics, rho_phy = rho_p , qv3d = qv_p , & qc3d = qc_p , qr3d = qr_p , & qi3d = qi_p , qs3d = qs_p , & - qg3d = qg_p , f_qv = f_qv , & - f_qc = f_qc , f_qr = f_qr , & - f_qi = f_qi , f_qs = f_qs , & - f_qg = f_qg , f_ice_phy = f_ice , & + qg3d = qg_p , f_qc = f_qc , & + f_qr = f_qr , f_qi = f_qi , & + f_qs = f_qs , f_ice_phy = f_ice , & f_rain_phy = f_rain , cldfra = cldfrac_p , & xland = xland_p , xice = xice_p , & num_months = num_months , levsiz = num_oznlevels , & diff --git a/src/core_atmosphere/physics/mpas_atmphys_driver_radiation_sw.F b/src/core_atmosphere/physics/mpas_atmphys_driver_radiation_sw.F index fc3b712966..f4b76d8fe8 100644 --- a/src/core_atmosphere/physics/mpas_atmphys_driver_radiation_sw.F +++ b/src/core_atmosphere/physics/mpas_atmphys_driver_radiation_sw.F @@ -85,6 +85,8 @@ module mpas_atmphys_driver_radiation_sw ! Laura D. Fowler (laura@ucar.edu) / 2017-02-16. ! * added the variables swddir,swddni,swddif for use in the updated version of the Noah LSM. ! Laura D. Fowler (laura@ucar.edu) / 2023-04-21. +! * removed the variables f_qv and f_qg in the call to subroutine camrad. +! Laura D. Fowler (laura@ucar.edu) / 2024-02-13. contains @@ -821,10 +823,9 @@ subroutine driver_radiation_sw(itimestep,configs,mesh,state,time_lev,diag_physic rho_phy = rho_p , qv3d = qv_p , & qc3d = qc_p , qr3d = qr_p , & qi3d = qi_p , qs3d = qs_p , & - qg3d = qg_p , f_qv = f_qv , & - f_qc = f_qc , f_qr = f_qr , & - f_qi = f_qi , f_qs = f_qs , & - f_qg = f_qg , f_ice_phy = f_ice , & + qg3d = qg_p , f_qc = f_qc , & + f_qr = f_qr , f_qi = f_qi , & + f_qs = f_qs , f_ice_phy = f_ice , & f_rain_phy = f_rain , cldfra = cldfrac_p , & xland = xland_p , xice = xice_p , & num_months = num_months , levsiz = num_oznlevels , & diff --git a/src/core_atmosphere/physics/mpas_atmphys_driver_seaice.F b/src/core_atmosphere/physics/mpas_atmphys_driver_seaice.F new file mode 100644 index 0000000000..7894a81429 --- /dev/null +++ b/src/core_atmosphere/physics/mpas_atmphys_driver_seaice.F @@ -0,0 +1,492 @@ +! Copyright (c) 2024 The University Corporation for Atmospheric Research (UCAR). +! +! Unless noted otherwise source code is licensed under the BSD license. +! Additional copyright and license information can be found in the LICENSE file +! distributed with this code, or at http://mpas-dev.github.com/license.html +! +!================================================================================================================= + module mpas_atmphys_driver_seaice + use mpas_kind_types + use mpas_pool_routines,only: mpas_pool_get_array,mpas_pool_get_config,mpas_pool_type + use mpas_log + + use mpas_atmphys_constants,only: rcp + use mpas_atmphys_lsm_shared,only: correct_tsk_over_seaice + use mpas_atmphys_vars + use module_sf_noah_seaice_drv + use module_sf_sfcdiags + + implicit none + private + public:: allocate_seaice, & + deallocate_seaice, & + driver_seaice + + logical,parameter:: frpcpn = .false. + +!urban physics: MPAS does not plan to run the urban physics option. + integer,parameter:: sf_urban_physics = 0 !activate urban canopy model (=0: no urban canopy) + + +!MPAS driver for parameterization of surface processes over seaice points. +!Laura D. Fowler (laura@ucar.edu) / 2024-03-13. + + + contains + + +!================================================================================================================= + subroutine allocate_seaice +!================================================================================================================= + + if(.not.allocated(acsnom_p) ) allocate(acsnom_p(ims:ime,jms:jme) ) + if(.not.allocated(acsnow_p) ) allocate(acsnow_p(ims:ime,jms:jme) ) + if(.not.allocated(albsi_p) ) allocate(albsi_p(ims:ime,jms:jme) ) + if(.not.allocated(br_p) ) allocate(br_p(ims:ime,jms:jme) ) + if(.not.allocated(chs_p) ) allocate(chs_p(ims:ime,jms:jme) ) + if(.not.allocated(chs2_p) ) allocate(chs2_p(ims:ime,jms:jme) ) + if(.not.allocated(cpm_p) ) allocate(cpm_p(ims:ime,jms:jme) ) + if(.not.allocated(cqs2_p) ) allocate(cqs2_p(ims:ime,jms:jme) ) + if(.not.allocated(qgh_p) ) allocate(qgh_p(ims:ime,jms:jme) ) + if(.not.allocated(qsfc_p) ) allocate(qsfc_p(ims:ime,jms:jme) ) + if(.not.allocated(glw_p) ) allocate(glw_p(ims:ime,jms:jme) ) + if(.not.allocated(grdflx_p) ) allocate(grdflx_p(ims:ime,jms:jme) ) + if(.not.allocated(icedepth_p) ) allocate(icedepth_p(ims:ime,jms:jme) ) + if(.not.allocated(hfx_p) ) allocate(hfx_p(ims:ime,jms:jme) ) + if(.not.allocated(qfx_p) ) allocate(qfx_p(ims:ime,jms:jme) ) + if(.not.allocated(lh_p) ) allocate(lh_p(ims:ime,jms:jme) ) + if(.not.allocated(noahres_p) ) allocate(noahres_p(ims:ime,jms:jme) ) + if(.not.allocated(potevp_p) ) allocate(potevp_p(ims:ime,jms:jme) ) + if(.not.allocated(rainbl_p) ) allocate(rainbl_p(ims:ime,jms:jme) ) + if(.not.allocated(sfc_albedo_p)) allocate(sfc_albedo_p(ims:ime,jms:jme)) + if(.not.allocated(sfc_emiss_p) ) allocate(sfc_emiss_p(ims:ime,jms:jme) ) + if(.not.allocated(sfcrunoff_p) ) allocate(sfcrunoff_p(ims:ime,jms:jme) ) + if(.not.allocated(snoalb_p) ) allocate(snoalb_p(ims:ime,jms:jme) ) + if(.not.allocated(snow_p) ) allocate(snow_p(ims:ime,jms:jme) ) + if(.not.allocated(snowc_p) ) allocate(snowc_p(ims:ime,jms:jme) ) + if(.not.allocated(snowh_p) ) allocate(snowh_p(ims:ime,jms:jme) ) + if(.not.allocated(snopcx_p) ) allocate(snopcx_p(ims:ime,jms:jme) ) + if(.not.allocated(snowsi_p) ) allocate(snowsi_p(ims:ime,jms:jme) ) + if(.not.allocated(swdown_p) ) allocate(swdown_p(ims:ime,jms:jme) ) + if(.not.allocated(sr_p) ) allocate(sr_p(ims:ime,jms:jme) ) + if(.not.allocated(tsk_p) ) allocate(tsk_p(ims:ime,jms:jme) ) + if(.not.allocated(xice_p) ) allocate(xice_p(ims:ime,jms:jme) ) + if(.not.allocated(z0_p) ) allocate(z0_p(ims:ime,jms:jme) ) + if(.not.allocated(znt_p) ) allocate(znt_p(ims:ime,jms:jme) ) + if(.not.allocated(q2_p) ) allocate(q2_p(ims:ime,jms:jme) ) + if(.not.allocated(t2m_p) ) allocate(t2m_p(ims:ime,jms:jme) ) + if(.not.allocated(th2m_p) ) allocate(th2m_p(ims:ime,jms:jme) ) + + if(.not.allocated(tsk_sea) ) allocate(tsk_sea(ims:ime,jms:jme) ) + if(.not.allocated(tsk_ice) ) allocate(tsk_ice(ims:ime,jms:jme) ) + if(.not.allocated(albsi_p) ) allocate(albsi_p(ims:ime,jms:jme) ) + if(.not.allocated(icedepth_p) ) allocate(icedepth_p(ims:ime,jms:jme) ) + if(.not.allocated(snowsi_p) ) allocate(snowsi_p(ims:ime,jms:jme) ) + + if(.not.allocated(tslb_p)) allocate(tslb_p(ims:ime,1:num_soils,jms:jme)) + + end subroutine allocate_seaice + +!================================================================================================================= + subroutine deallocate_seaice +!================================================================================================================= + + if(allocated(acsnom_p) ) deallocate(acsnom_p ) + if(allocated(acsnow_p) ) deallocate(acsnow_p ) + if(allocated(albsi_p) ) deallocate(albsi_p ) + if(allocated(br_p) ) deallocate(br_p ) + if(allocated(chs_p) ) deallocate(chs_p ) + if(allocated(chs2_p) ) deallocate(chs2_p ) + if(allocated(cpm_p) ) deallocate(cpm_p ) + if(allocated(cqs2_p) ) deallocate(cqs2_p ) + if(allocated(qgh_p) ) deallocate(qgh_p ) + if(allocated(qsfc_p) ) deallocate(qsfc_p ) + if(allocated(glw_p) ) deallocate(glw_p ) + if(allocated(grdflx_p) ) deallocate(grdflx_p ) + if(allocated(icedepth_p) ) deallocate(icedepth_p ) + if(allocated(hfx_p) ) deallocate(hfx_p ) + if(allocated(qfx_p) ) deallocate(qfx_p ) + if(allocated(lh_p) ) deallocate(lh_p ) + if(allocated(noahres_p) ) deallocate(noahres_p ) + if(allocated(potevp_p) ) deallocate(potevp_p ) + if(allocated(rainbl_p) ) deallocate(rainbl_p ) + if(allocated(sfc_albedo_p)) deallocate(sfc_albedo_p) + if(allocated(sfc_emiss_p) ) deallocate(sfc_emiss_p ) + if(allocated(sfcrunoff_p) ) deallocate(sfcrunoff_p ) + if(allocated(snoalb_p) ) deallocate(snoalb_p ) + if(allocated(snow_p) ) deallocate(snow_p ) + if(allocated(snowc_p) ) deallocate(snowc_p ) + if(allocated(snowh_p) ) deallocate(snowh_p ) + if(allocated(snopcx_p) ) deallocate(snopcx_p ) + if(allocated(snowsi_p) ) deallocate(snowsi_p ) + if(allocated(swdown_p) ) deallocate(swdown_p ) + if(allocated(sr_p) ) deallocate(sr_p ) + if(allocated(tsk_p) ) deallocate(tsk_p ) + if(allocated(xice_p) ) deallocate(xice_p ) + if(allocated(z0_p) ) deallocate(z0_p ) + if(allocated(znt_p) ) deallocate(znt_p ) + if(allocated(q2_p) ) deallocate(q2_p ) + if(allocated(t2m_p) ) deallocate(t2m_p ) + if(allocated(th2m_p) ) deallocate(th2m_p ) + + if(allocated(chs_sea) ) deallocate(chs_sea ) + if(allocated(chs2_sea) ) deallocate(chs2_sea ) + if(allocated(cqs2_sea) ) deallocate(cqs2_sea ) + if(allocated(cpm_sea) ) deallocate(cpm_sea ) + if(allocated(hfx_sea) ) deallocate(hfx_sea ) + if(allocated(qfx_sea) ) deallocate(qfx_sea ) + if(allocated(qgh_sea) ) deallocate(qgh_sea ) + if(allocated(qsfc_sea) ) deallocate(qsfc_sea ) + if(allocated(lh_sea) ) deallocate(lh_sea ) + if(allocated(tsk_sea) ) deallocate(tsk_sea ) + if(allocated(tsk_ice) ) deallocate(tsk_ice ) + if(allocated(albsi_p) ) deallocate(albsi_p ) + if(allocated(icedepth_p) ) deallocate(icedepth_p ) + if(allocated(snowsi_p) ) deallocate(snowsi_p ) + + if(allocated(tslb_p)) deallocate(tslb_p) + + end subroutine deallocate_seaice + +!================================================================================================================= + subroutine seaice_from_MPAS(configs,diag_physics,sfc_input,its,ite) +!================================================================================================================= + +!input and inout arguments: + type(mpas_pool_type),intent(in):: configs + type(mpas_pool_type),intent(inout):: diag_physics + type(mpas_pool_type),intent(inout):: sfc_input + integer,intent(in):: its,ite + +!local pointers: + character(len=StrKIND),pointer:: convection_scheme, & + microp_scheme + + real(kind=RKIND),dimension(:),pointer:: acsnom,acsnow,br,chs,chs2,cpm,cqs2,qgh,qsfc,glw,gsw,grdflx,hfx, & + qfx,lh,noahres,potevp,sfc_albedo,sfc_emiss,sfcrunoff,snopcx,z0, & + znt,raincv,rainncv,sr + real(kind=RKIND),dimension(:),pointer:: snoalb,snow,snowc,snowh,skintemp,xice + real(kind=RKIND),dimension(:,:),pointer:: tslb + +!local variables and arrays: + integer:: i,j,n + +!----------------------------------------------------------------------------------------------------------------- +!call mpas_log_write('--- enter subroutine seaice_from_MPAS:') + + call mpas_pool_get_config(configs,'config_convection_scheme',convection_scheme) + call mpas_pool_get_config(configs,'config_microp_scheme' ,microp_scheme ) + + call mpas_pool_get_array(diag_physics,'acsnom' ,acsnom ) + call mpas_pool_get_array(diag_physics,'acsnow' ,acsnow ) + call mpas_pool_get_array(diag_physics,'br' ,br ) + call mpas_pool_get_array(diag_physics,'chs' ,chs ) + call mpas_pool_get_array(diag_physics,'chs2' ,chs2 ) + call mpas_pool_get_array(diag_physics,'cpm' ,cpm ) + call mpas_pool_get_array(diag_physics,'cqs2' ,cqs2 ) + call mpas_pool_get_array(diag_physics,'qgh' ,qgh ) + call mpas_pool_get_array(diag_physics,'qsfc' ,qsfc ) + call mpas_pool_get_array(diag_physics,'glw' ,glw ) + call mpas_pool_get_array(diag_physics,'gsw' ,gsw ) + call mpas_pool_get_array(diag_physics,'grdflx' ,grdflx ) + call mpas_pool_get_array(diag_physics,'hfx' ,hfx ) + call mpas_pool_get_array(diag_physics,'qfx' ,qfx ) + call mpas_pool_get_array(diag_physics,'lh' ,lh ) + call mpas_pool_get_array(diag_physics,'noahres' ,noahres ) + call mpas_pool_get_array(diag_physics,'potevp' ,potevp ) + call mpas_pool_get_array(diag_physics,'sfc_albedo',sfc_albedo) + call mpas_pool_get_array(diag_physics,'sfc_emiss' ,sfc_emiss ) + call mpas_pool_get_array(diag_physics,'sfcrunoff' ,sfcrunoff ) + call mpas_pool_get_array(diag_physics,'snopcx' ,snopcx ) + call mpas_pool_get_array(diag_physics,'z0' ,z0 ) + call mpas_pool_get_array(diag_physics,'znt' ,znt ) + + call mpas_pool_get_array(sfc_input,'snoalb' ,snoalb ) + call mpas_pool_get_array(sfc_input,'snow' ,snow ) + call mpas_pool_get_array(sfc_input,'snowc' ,snowc ) + call mpas_pool_get_array(sfc_input,'snowh' ,snowh ) + call mpas_pool_get_array(sfc_input,'skintemp',skintemp) + call mpas_pool_get_array(sfc_input,'tslb' ,tslb ) + call mpas_pool_get_array(sfc_input,'xice' ,xice ) + + do j = jts,jte + do i = its,ite + !--- in variables: + xice_p(i,j) = xice(i) + glw_p(i,j) = glw(i) + qgh_p(i,j) = qgh(i) + snoalb_p(i,j) = snoalb(i) + br_p(i,j) = br(i) + chs_p(i,j) = chs(i) + swdown_p(i,j) = gsw(i)/(1._RKIND-sfc_albedo(i)) + + !--- inout variables: + do n = 1,num_soils + tslb_p(i,n,j) = tslb(n,i) + enddo + z0_p(i,j) = z0(i) + snow_p(i,j) = snow(i) + snowc_p(i,j) = snowc(i) + snowh_p(i,j) = snowh(i) + tsk_p(i,j) = skintemp(i) + cqs2_p(i,j) = cqs2(i) + acsnom_p(i,j) = acsnom(i) + acsnow_p(i,j) = acsnow(i) + sfcrunoff_p(i,j) = sfcrunoff(i) + albsi_p(i,j) = seaice_albedo_default + snowsi_p(i,j) = seaice_snowdepth_min + icedepth_p(i,j) = seaice_thickness_default + !--- inout optional variables: + potevp_p(i,j) = potevp(i) + snopcx_p(i,j) = snopcx(i) + + !--- output variables: + hfx_p(i,j) = hfx(i) + lh_p(i,j) = lh(i) + qfx_p(i,j) = qfx(i) + znt_p(i,j) = znt(i) + grdflx_p(i,j) = grdflx(i) + qsfc_p(i,j) = qsfc(i) + chs2_p(i,j) = chs2(i) + !--- output optional variables: + noahres_p(i,j) = noahres(i) + + !modify the surface albedo and surface emissivity, and surface temperatures over sea-ice points: + if(xice(i).ge.xice_threshold .and. xice(i).le.1._RKIND) then + sfc_albedo_p(i,j) = (sfc_albedo(i) - 0.08_RKIND*(1._RKIND-xice(i))) / xice(i) + sfc_emiss_p(i,j) = (sfc_emiss(i) - 0.98_RKIND*(1._RKIND-xice(i))) / xice(i) + else + sfc_emiss_p(i,j) = sfc_emiss(i) + sfc_albedo_p(i,j) = sfc_albedo(i) + endif + enddo + + !calculate sea-surface and sea-ice temperatures over sea-ice grid cells: + call correct_tsk_over_seaice(ims,ime,jms,jme,its,ite,jts,jte,xice_threshold,xice_p, & + tsk_p,tsk_sea,tsk_ice) + do i = its,ite + tsk_p(i,j) = tsk_ice(i,j) + enddo + enddo + + do j = jts,jte + do i = its,ite + sr_p(i,j) = 0._RKIND + rainbl_p(i,j) = 0._RKIND + enddo + if(microp_scheme .ne. 'off') then + call mpas_pool_get_array(diag_physics,'sr',sr) + call mpas_pool_get_array(diag_physics,'rainncv',rainncv) + do i = its,ite + sr_p(i,j) = sr(i) + rainbl_p(i,j) = rainbl_p(i,j) + rainncv(i) + enddo + endif + if(convection_scheme .ne. 'off') then + call mpas_pool_get_array(diag_physics,'raincv',raincv) + do i = its,ite + rainbl_p(i,j) = rainbl_p(i,j) + raincv(i) + enddo + endif + enddo + +!call mpas_log_write('--- end subroutine seaice_from_MPAS:') + + end subroutine seaice_from_MPAS + +!================================================================================================================= + subroutine seaice_to_MPAS(configs,diag_physics,sfc_input,its,ite) +!================================================================================================================= + +!input and inout arguments: + type(mpas_pool_type),intent(in):: configs + type(mpas_pool_type),intent(inout):: diag_physics + type(mpas_pool_type),intent(inout):: sfc_input + integer,intent(in):: its,ite + +!local pointers: + character(len=StrKIND),pointer:: config_microp_scheme + + real(kind=RKIND),dimension(:),pointer:: acsnom,acsnow,chs,chs2,cpm,cqs2,qgh,qsfc,grdflx,hfx, qfx,lh,noahres, & + potevp,sfc_albedo,sfc_emiss,sfcrunoff,snopcx,z0,znt + real(kind=RKIND),dimension(:),pointer:: snow,snowc,snowh,skintemp,xice + real(kind=RKIND),dimension(:),pointer:: t2m,th2m,q2 + real(kind=RKIND),dimension(:,:),pointer:: tslb + +!local variables and arrays: + integer:: i,j,n + +!----------------------------------------------------------------------------------------------------------------- +!call mpas_log_write('--- enter subroutine seaice_to_MPAS:') + + call mpas_pool_get_array(diag_physics,'acsnom' ,acsnom ) + call mpas_pool_get_array(diag_physics,'acsnow' ,acsnow ) + call mpas_pool_get_array(diag_physics,'chs' ,chs ) + call mpas_pool_get_array(diag_physics,'chs2' ,chs2 ) + call mpas_pool_get_array(diag_physics,'cpm' ,cpm ) + call mpas_pool_get_array(diag_physics,'cqs2' ,cqs2 ) + call mpas_pool_get_array(diag_physics,'qgh' ,qgh ) + call mpas_pool_get_array(diag_physics,'qsfc' ,qsfc ) + call mpas_pool_get_array(diag_physics,'grdflx' ,grdflx ) + call mpas_pool_get_array(diag_physics,'hfx' ,hfx ) + call mpas_pool_get_array(diag_physics,'qfx' ,qfx ) + call mpas_pool_get_array(diag_physics,'lh' ,lh ) + call mpas_pool_get_array(diag_physics,'noahres' ,noahres ) + call mpas_pool_get_array(diag_physics,'potevp' ,potevp ) + call mpas_pool_get_array(diag_physics,'sfc_albedo',sfc_albedo) + call mpas_pool_get_array(diag_physics,'sfc_emiss' ,sfc_emiss ) + call mpas_pool_get_array(diag_physics,'sfcrunoff' ,sfcrunoff ) + call mpas_pool_get_array(diag_physics,'snopcx' ,snopcx ) + call mpas_pool_get_array(diag_physics,'z0' ,z0 ) + call mpas_pool_get_array(diag_physics,'znt' ,znt ) + call mpas_pool_get_array(diag_physics,'t2m' ,t2m ) + call mpas_pool_get_array(diag_physics,'th2m' ,th2m ) + call mpas_pool_get_array(diag_physics,'q2' ,q2 ) + + call mpas_pool_get_array(sfc_input,'snow' ,snow ) + call mpas_pool_get_array(sfc_input,'snowc' ,snowc ) + call mpas_pool_get_array(sfc_input,'snowh' ,snowh ) + call mpas_pool_get_array(sfc_input,'skintemp',skintemp) + call mpas_pool_get_array(sfc_input,'tslb' ,tslb ) + call mpas_pool_get_array(sfc_input,'xice' ,xice ) + +!--- weigh local variables needed in the calculation of t2m, th2m, and q2 over seaice points: + do j = jts,jte + do i = its,ite + if(xice_p(i,j).ge.xice_threshold .and. xice_p(i,j).le.1._RKIND) then + cpm(i) = xice_p(i,j)*cpm(i) + (1._RKIND-xice_p(i,j))*cpm_sea(i,j) + + chs_p(i,j) = xice_p(i,j)*chs_p(i,j) + (1._RKIND-xice_p(i,j))*chs_sea(i,j) + chs2_p(i,j) = xice_p(i,j)*chs2_p(i,j) + (1._RKIND-xice_p(i,j))*chs2_sea(i,j) + cqs2_p(i,j) = xice_p(i,j)*cqs2_p(i,j) + (1._RKIND-xice_p(i,j))*cqs2_sea(i,j) + hfx_p(i,j) = xice_p(i,j)*hfx_p(i,j) + (1._RKIND-xice_p(i,j))*hfx_sea(i,j) + lh_p(i,j) = xice_p(i,j)*lh_p(i,j) + (1._RKIND-xice_p(i,j))*lh_sea(i,j) + qfx_p(i,j) = xice_p(i,j)*qfx_p(i,j) + (1._RKIND-xice_p(i,j))*qfx_sea(i,j) + qgh_p(i,j) = xice_p(i,j)*qgh_p(i,j) + (1._RKIND-xice_p(i,j))*qgh_sea(i,j) + qsfc_p(i,j) = xice_p(i,j)*qsfc_p(i,j) + (1._RKIND-xice_p(i,j))*qsfc_sea(i,j) + tsk_p(i,j) = xice_p(i,j)*tsk_p(i,j) + (1._RKIND-xice_p(i,j))*tsk_sea(i,j) + sfc_albedo_p(i,j) = xice_p(i,j)*sfc_albedo_p(i,j) + (1._RKIND-xice_p(i,j))*0.08_RKIND + sfc_emiss_p(i,j) = xice_p(i,j)*sfc_emiss_p(i,j) + (1._RKIND-xice_p(i,j))*0.98_RKIND + endif + enddo + enddo + + call sfcdiags( & + hfx = hfx_p , qfx = qfx_p , tsk = tsk_p , qsfc = qsfc_p , chs = chs_p , & + chs2 = chs2_p , cqs2 = cqs2_p , t2 = t2m_p , th2 = th2m_p , q2 = q2_p , & + psfc = psfc_p , t3d = t_p , qv3d = qv_p , cp = cp , R_d = R_d , & + rovcp = rcp , ua_phys = ua_phys , & + ids = ids , ide = ide , jds = jds , jde = jde , kds = kds , kde = kde , & + ims = ims , ime = ime , jms = jms , jme = jme , kms = kms , kme = kme , & + its = its , ite = ite , jts = jts , jte = jte , kts = kts , kte = kte & + ) + +!--- update all variables: + do j = jts,jte + do i = its,ite + !--- inout variables: + do n = 1,num_soils + tslb(n,i) = tslb_p(i,n,j) + enddo + z0(i) = z0_p(i,j) + snow(i) = snow_p(i,j) + snowc(i) = snowc_p(i,j) + snowh(i) = snowh_p(i,j) + skintemp(i) = tsk_p(i,j) + acsnom(i) = acsnom_p(i,j) + acsnow(i) = acsnow_p(i,j) + sfcrunoff(i) = sfcrunoff_p(i,j) + !--- inout optional variables: + potevp(i) = potevp_p(i,j) + snopcx(i) = snopcx_p(i,j) + + !--- output variables: + znt(i) = znt_p(i,j) + grdflx(i) = grdflx_p(i,j) + !--- output optional variables: + noahres(i) = noahres_p(i,j) + + chs(i) = chs_p(i,j) + chs2(i) = chs2_p(i,j) + cqs2(i) = cqs2_p(i,j) + qsfc(i) = qsfc_p(i,j) + qgh(i) = qgh_p(i,j) + hfx(i) = hfx_p(i,j) + qfx(i) = qfx_p(i,j) + lh(i) = lh_p(i,j) + sfc_albedo(i) = sfc_albedo_p(i,j) + sfc_emiss(i) = sfc_emiss_p(i,j) + + !--- 2-meter diagnostics: + q2(i) = q2_p(i,j) + t2m(i) = t2m_p(i,j) + th2m(i) = th2m_p(i,j) + enddo + enddo + +!call mpas_log_write('--- end subroutine seaice_to_MPAS:') + + end subroutine seaice_to_MPAS + +!================================================================================================================= + subroutine driver_seaice(configs,diag_physics,sfc_input,its,ite) +!================================================================================================================= + +!input arguments: + type(mpas_pool_type),intent(in):: configs + integer,intent(in):: its,ite + +!inout arguments: + type(mpas_pool_type),intent(inout):: diag_physics + type(mpas_pool_type),intent(inout):: sfc_input + +!local pointers: + integer:: i,j + +!----------------------------------------------------------------------------------------------------------------- +!call mpas_log_write(' ') +!call mpas_log_write('--- enter subroutine driver_seaice: xice_threshold = $r',realArgs=(/xice_threshold/)) + +!copy MPAS arrays to local arrays: + call seaice_from_MPAS(configs,diag_physics,sfc_input,its,ite) + + call seaice_noah( & + dz8w = dz_p , p8w3d = pres2_hyd_p , t3d = t_p , & + qv3d = qv_p , xice = xice_p , snoalb2d = snoalb_p , & + glw = glw_p , swdown = swdown_p , rainbl = rainbl_p , & + sr = sr_p , qgh = qgh_p , tsk = tsk_p , & + hfx = hfx_p , qfx = qfx_p , lh = lh_p , & + grdflx = grdflx_p , potevp = potevp_p , qsfc = qsfc_p , & + emiss = sfc_emiss_p , albedo = sfc_albedo_p , rib = br_p , & + cqs2 = cqs2_p , chs = chs_p , chs2 = chs2_p , & + z02d = z0_p , znt = znt_p , tslb = tslb_p , & + snow = snow_p , snowc = snowc_p , snowh2d = snowh_p , & + snopcx = snopcx_p , acsnow = acsnow_p , acsnom = acsnom_p , & + sfcrunoff = sfcrunoff_p , albsi = albsi_p , snowsi = snowsi_p , & + icedepth = icedepth_p , noahres = noahres_p , dt = dt_pbl , & + frpcpn = frpcpn , & + seaice_albedo_opt = seaice_albedo_opt , & + seaice_albedo_default = seaice_albedo_default , & + seaice_thickness_opt = seaice_thickness_opt , & + seaice_thickness_default = seaice_thickness_default , & + seaice_snowdepth_opt = seaice_snowdepth_opt , & + seaice_snowdepth_max = seaice_snowdepth_max , & + seaice_snowdepth_min = seaice_snowdepth_min , & + xice_threshold = xice_threshold , & + num_soil_layers = num_soils , & + sf_urban_physics = sf_urban_physics , & + ids = ids , ide = ide , jds = jds , jde = jde , kds = kds , kde = kde , & + ims = ims , ime = ime , jms = jms , jme = jme , kms = kms , kme = kme , & + its = its , ite = ite , jts = jts , jte = jte , kts = kts , kte = kte & + ) + +!copy local arrays to MPAS grid: + call seaice_to_MPAS(configs,diag_physics,sfc_input,its,ite) + +!call mpas_log_write('--- end subroutine driver_seaice:') + + end subroutine driver_seaice + +!================================================================================================================= + end module mpas_atmphys_driver_seaice +!================================================================================================================= diff --git a/src/core_atmosphere/physics/mpas_atmphys_driver_sfclayer.F b/src/core_atmosphere/physics/mpas_atmphys_driver_sfclayer.F index ae3314c32f..eaac82d38f 100644 --- a/src/core_atmosphere/physics/mpas_atmphys_driver_sfclayer.F +++ b/src/core_atmosphere/physics/mpas_atmphys_driver_sfclayer.F @@ -14,10 +14,10 @@ module mpas_atmphys_driver_sfclayer use mpas_atmphys_constants use mpas_atmphys_vars -!wrf physics: - use module_sf_mynn + use module_sf_mynn,only: sfclay_mynn use module_sf_sfclay use module_sf_sfclayrev,only: sfclayrev + use sf_mynn,only: sf_mynn_init use sf_sfclayrev,only: sf_sfclayrev_init implicit none @@ -86,7 +86,8 @@ module mpas_atmphys_driver_sfclayer ! Laura D. Fowler (laura@ucar.edu) / 2023-05-15. ! * added the option sf_monin_obukhov_rev to run the revised surface layer scheme with the YSU PBL scheme. ! Laura D. Fowler (laura@ucar.edu) / 2023-05-15. - +! * updated the MYNN surface layer scheme to the sourcecode available from WRF version 4.6. +! Laura D. Fowler (laura@ucar.edu) / 2024-02-14. contains @@ -219,12 +220,6 @@ subroutine allocate_sfclayer(configs) if(.not.allocated(ch_sea)) allocate(ch_sea(ims:ime,jms:jme)) endif - if(.not.allocated(cov_p) ) allocate(cov_p(ims:ime,kms:kme,jms:jme) ) - if(.not.allocated(qsq_p) ) allocate(qsq_p(ims:ime,kms:kme,jms:jme) ) - if(.not.allocated(tsq_p) ) allocate(tsq_p(ims:ime,kms:kme,jms:jme) ) - if(.not.allocated(sh3d_p) ) allocate(sh3d_p(ims:ime,kms:kme,jms:jme) ) - if(.not.allocated(elpbl_p) ) allocate(elpbl_p(ims:ime,kms:kme,jms:jme) ) - case default end select sfclayer_select @@ -347,12 +342,6 @@ subroutine deallocate_sfclayer(configs) if(allocated(ch_sea)) deallocate(ch_sea) endif - if(allocated(cov_p) ) deallocate(cov_p ) - if(allocated(qsq_p) ) deallocate(qsq_p ) - if(allocated(tsq_p) ) deallocate(tsq_p ) - if(allocated(sh3d_p) ) deallocate(sh3d_p ) - if(allocated(elpbl_p) ) deallocate(elpbl_p ) - case default end select sfclayer_select @@ -391,7 +380,6 @@ subroutine sfclayer_from_MPAS(configs,mesh,diag_physics,sfc_input,its,ite) !local pointers specific to mynn: real(kind=RKIND),dimension(:),pointer:: ch,qcg,snowh - real(kind=RKIND),dimension(:,:),pointer:: cov,el_pbl,qsq,sh3d,tsq !----------------------------------------------------------------------------------------------------------------- @@ -579,15 +567,10 @@ subroutine sfclayer_from_MPAS(configs,mesh,diag_physics,sfc_input,its,ite) case("sf_mynn") !input variables: - call mpas_pool_get_array(diag_physics,'qcg' ,qcg ) - call mpas_pool_get_array(sfc_input ,'snowh' ,snowh ) - call mpas_pool_get_array(diag_physics,'cov' ,cov ) - call mpas_pool_get_array(diag_physics,'el_pbl',el_pbl) - call mpas_pool_get_array(diag_physics,'qsq' ,qsq ) - call mpas_pool_get_array(diag_physics,'sh3d' ,sh3d ) - call mpas_pool_get_array(diag_physics,'tsq' ,tsq ) + call mpas_pool_get_array(diag_physics,'qcg' ,qcg ) + call mpas_pool_get_array(sfc_input ,'snowh',snowh) !inout variables: - call mpas_pool_get_array(diag_physics,'ch',ch ) + call mpas_pool_get_array(diag_physics,'ch',ch) do j = jts,jte do i = its,ite @@ -602,19 +585,6 @@ subroutine sfclayer_from_MPAS(configs,mesh,diag_physics,sfc_input,its,ite) enddo enddo - do j = jts,jte - do k = kts,kte - do i = its,ite - !input variables: - cov_p(i,k,j) = cov(k,i) - qsq_p(i,k,j) = qsq(k,i) - tsq_p(i,k,j) = tsq(k,i) - sh3d_p(i,k,j) = sh3d(k,i) - elpbl_p(i,k,j) = el_pbl(k,i) - enddo - enddo - enddo - case default end select sfclayer_select @@ -652,7 +622,6 @@ subroutine sfclayer_to_MPAS(configs,sfc_input,diag_physics,its,ite) !local pointers specific to mynn: real(kind=RKIND),dimension(:),pointer:: ch,qcg - real(kind=RKIND),dimension(:,:),pointer:: cov,el_pbl,qsq,sh3d,tsq !----------------------------------------------------------------------------------------------------------------- @@ -858,7 +827,7 @@ subroutine init_sfclayer(configs) call sf_sfclayrev_init(errmsg,errflg) case("sf_mynn") - call mynn_sf_init_driver(allowed_to_read) + call sf_mynn_init(errmsg,errflg) case default @@ -1049,71 +1018,69 @@ subroutine driver_sfclayer(itimestep,configs,mesh,diag_physics,sfc_input,its,ite call mpas_timer_stop('sf_monin_obukhov_rev') case("sf_mynn") - call mpas_timer_start('MYNN_sfclay') + call mpas_timer_start('sf_mynn') call sfclay_mynn( & - p3d = pres_hyd_p , pi3d = pi_p , psfcpa = psfc_p , & - th3d = th_p , t3d = t_p , u3d = u_p , & - v3d = v_p , qv3d = qv_p , qc3d = qc_p , & - rho3d = rho_p , dz8w = dz_p , cp = cp , & - g = gravity , rovcp = rcp , R = R_d , & - xlv = xlv , chs = chs_p , chs2 = chs2_p , & - cqs2 = cqs2_p , cpm = cpm_p , znt = znt_p , & - ust = ust_p , pblh = hpbl_p , mavail = mavail_p , & - zol = zol_p , mol = mol_p , regime = regime_p , & - psim = psim_p , psih = psih_p , xland = xland_p , & - hfx = hfx_p , qfx = qfx_p , lh = lh_p , & - tsk = tsk_p , flhc = flhc_p , flqc = flqc_p , & - qgh = qgh_p , qsfc = qsfc_p , rmol = rmol_p , & - u10 = u10_p , v10 = v10_p , th2 = th2m_p , & - t2 = t2m_p , q2 = q2_p , snowh = snowh_p , & - gz1oz0 = gz1oz0_p , wspd = wspd_p , br = br_p , & - isfflx = isfflx , dx = dx , svp1 = svp1 , & - svp2 = svp2 , svp3 = svp3 , svpt0 = svpt0 , & - ep1 = ep_1 , ep2 = ep_2 , karman = karman , & - dxCell = dx_p , ustm = ustm_p , ck = ck_p , & - cka = cka_p , cd = cd_p , cda = cda_p , & - isftcflx = isftcflx , iz0tlnd = iz0tlnd , itimestep = initflag , & - ch = ch_p , cov = cov_p , tsq = tsq_p , & - qsq = qsq_p , sh3d = sh3d_p , el_pbl = elpbl_p , & - qcg = qcg_p , bl_mynn_cloudpdf = bl_mynn_cloudpdf , & - ids = ids , ide = ide , jds = jds , jde = jde , kds = kds , kde = kde , & - ims = ims , ime = ime , jms = jms , jme = jme , kms = kms , kme = kme , & - its = its , ite = ite , jts = jts , jte = jte , kts = kts , kte = kte & + p3d = pres_hyd_p , pi3d = pi_p , psfcpa = psfc_p , & + th3d = th_p , t3d = t_p , u3d = u_p , & + v3d = v_p , qv3d = qv_p , qc3d = qc_p , & + rho3d = rho_p , dz8w = dz_p , cp = cp , & + g = gravity , rovcp = rcp , R = R_d , & + xlv = xlv , chs = chs_p , chs2 = chs2_p , & + cqs2 = cqs2_p , cpm = cpm_p , znt = znt_p , & + ust = ust_p , pblh = hpbl_p , mavail = mavail_p , & + zol = zol_p , mol = mol_p , regime = regime_p , & + psim = psim_p , psih = psih_p , xland = xland_p , & + hfx = hfx_p , qfx = qfx_p , lh = lh_p , & + tsk = tsk_p , flhc = flhc_p , flqc = flqc_p , & + qgh = qgh_p , qsfc = qsfc_p , rmol = rmol_p , & + u10 = u10_p , v10 = v10_p , th2 = th2m_p , & + t2 = t2m_p , q2 = q2_p , snowh = snowh_p , & + gz1oz0 = gz1oz0_p , wspd = wspd_p , br = br_p , & + isfflx = isfflx , dx = dx_p , svp1 = svp1 , & + svp2 = svp2 , svp3 = svp3 , svpt0 = svpt0 , & + ep1 = ep_1 , ep2 = ep_2 , karman = karman , & + ustm = ustm_p , ck = ck_p , cka = cka_p , & + cd = cd_p , cda = cda_p , ch = ch_p , & + qcg = qcg_p , spp_pbl = spp_pbl , isftcflx = isftcflx , & + iz0tlnd = iz0tlnd , itimestep = initflag , & + errmsg = errmsg , errflg = errflg , & + ids = ids , ide = ide , jds = jds , jde = jde , kds = kds , kde = kde , & + ims = ims , ime = ime , jms = jms , jme = jme , kms = kms , kme = kme , & + its = its , ite = ite , jts = jts , jte = jte , kts = kts , kte = kte & ) if(config_frac_seaice) then call sfclay_mynn( & - p3d = pres_hyd_p , pi3d = pi_p , psfcpa = psfc_p , & - th3d = th_p , t3d = t_p , u3d = u_p , & - v3d = v_p , qv3d = qv_p , qc3d = qc_p , & - rho3d = rho_p , dz8w = dz_p , cp = cp , & - g = gravity , rovcp = rcp , R = R_d , & - xlv = xlv , chs = chs_sea , chs2 = chs2_sea , & - cqs2 = cqs2_sea , cpm = cpm_sea , znt = znt_sea , & - ust = ust_sea , pblh = hpbl_p , mavail = mavail_sea , & - zol = zol_sea , mol = mol_sea , regime = regime_sea , & - psim = psim_sea , psih = psih_sea , xland = xland_sea , & - hfx = hfx_sea , qfx = qfx_sea , lh = lh_sea , & - tsk = tsk_sea , flhc = flhc_sea , flqc = flqc_sea , & - qgh = qgh_sea , qsfc = qsfc_sea , rmol = rmol_sea , & - u10 = u10_sea , v10 = v10_sea , th2 = th2m_sea , & - t2 = t2m_sea , q2 = q2_sea , snowh = snowh_p , & - gz1oz0 = gz1oz0_sea , wspd = wspd_sea , br = br_sea , & - isfflx = isfflx , dx = dx , svp1 = svp1 , & - svp2 = svp2 , svp3 = svp3 , svpt0 = svpt0 , & - ep1 = ep_1 , ep2 = ep_2 , karman = karman , & - dxCell = dx_p , ustm = ustm_sea , ck = ck_sea , & - cka = cka_sea , cd = cd_sea , cda = cda_sea , & - isftcflx = isftcflx , iz0tlnd = iz0tlnd , itimestep = initflag , & - ch = ch_sea , cov = cov_p , tsq = tsq_p , & - qsq = qsq_p , sh3d = sh3d_p , el_pbl = elpbl_p , & - qcg = qcg_p , bl_mynn_cloudpdf = bl_mynn_cloudpdf , & - ids = ids , ide = ide , jds = jds , jde = jde , kds = kds , kde = kde , & - ims = ims , ime = ime , jms = jms , jme = jme , kms = kms , kme = kme , & - its = its , ite = ite , jts = jts , jte = jte , kts = kts , kte = kte & + p3d = pres_hyd_p , pi3d = pi_p , psfcpa = psfc_p , & + th3d = th_p , t3d = t_p , u3d = u_p , & + v3d = v_p , qv3d = qv_p , qc3d = qc_p , & + rho3d = rho_p , dz8w = dz_p , cp = cp , & + g = gravity , rovcp = rcp , R = R_d , & + xlv = xlv , chs = chs_sea , chs2 = chs2_sea , & + cqs2 = cqs2_sea , cpm = cpm_sea , znt = znt_sea , & + ust = ust_sea , pblh = hpbl_p , mavail = mavail_sea , & + zol = zol_sea , mol = mol_sea , regime = regime_sea , & + psim = psim_sea , psih = psih_sea , xland = xland_sea , & + hfx = hfx_sea , qfx = qfx_sea , lh = lh_sea , & + tsk = tsk_sea , flhc = flhc_sea , flqc = flqc_sea , & + qgh = qgh_sea , qsfc = qsfc_sea , rmol = rmol_sea , & + u10 = u10_sea , v10 = v10_sea , th2 = th2m_sea , & + t2 = t2m_sea , q2 = q2_sea , snowh = snowh_p , & + gz1oz0 = gz1oz0_sea , wspd = wspd_sea , br = br_sea , & + isfflx = isfflx , dx = dx_p , svp1 = svp1 , & + svp2 = svp2 , svp3 = svp3 , svpt0 = svpt0 , & + ep1 = ep_1 , ep2 = ep_2 , karman = karman , & + ustm = ustm_sea , ck = ck_sea , cka = cka_sea , & + cd = cd_sea , cda = cda_sea , ch = ch_sea , & + qcg = qcg_p , spp_pbl = spp_pbl , isftcflx = isftcflx , & + iz0tlnd = iz0tlnd , itimestep = initflag , & + errmsg = errmsg , errflg = errflg , & + ids = ids , ide = ide , jds = jds , jde = jde , kds = kds , kde = kde , & + ims = ims , ime = ime , jms = jms , jme = jme , kms = kms , kme = kme , & + its = its , ite = ite , jts = jts , jte = jte , kts = kts , kte = kte & ) endif - call mpas_timer_stop('MYNN_sfclay') + call mpas_timer_stop('sf_mynn') case default diff --git a/src/core_atmosphere/physics/mpas_atmphys_init.F b/src/core_atmosphere/physics/mpas_atmphys_init.F index b58ee369d4..8145cdb98f 100644 --- a/src/core_atmosphere/physics/mpas_atmphys_init.F +++ b/src/core_atmosphere/physics/mpas_atmphys_init.F @@ -14,9 +14,11 @@ module mpas_atmphys_init use mpas_atmphys_driver_convection, only: init_convection use mpas_atmphys_driver_lsm,only: init_lsm use mpas_atmphys_driver_microphysics + use mpas_atmphys_driver_pbl,only: init_pbl use mpas_atmphys_driver_radiation_lw, only: init_radiation_lw use mpas_atmphys_driver_radiation_sw, only: init_radiation_sw use mpas_atmphys_driver_sfclayer + use mpas_atmphys_vars,only: f_qc,f_qr,f_qi,f_qs,f_qg,f_qoz,f_nc,f_ni,f_nifa,f_nwfa,f_nbca use mpas_atmphys_landuse use mpas_atmphys_o3climatology @@ -64,6 +66,8 @@ module mpas_atmphys_init ! * removed the calculation of the variable dcEdge_m which is no longer needed in the different physics ! parameterizations. ! Laura D. Fowler (laura@ucar.edu) / 2016-10-18. +! * added the subroutine init_physics_flags to initialize f_qc,f_qr,f_qi,f_qs,f_qg,f_nc,and f_ni. +! Laura D. Fowler (laura@ucar.edu) / 2024-02-14. contains @@ -95,9 +99,10 @@ subroutine physics_init(dminfo,clock,configs,mesh,diag,tend,state,time_lev,diag_ config_o3climatology character(len=StrKIND),pointer:: & + config_convection_scheme, & config_lsm_scheme, & config_microp_scheme, & - config_convection_scheme, & + config_pbl_scheme, & config_sfclayer_scheme, & config_radt_lw_scheme, & config_radt_sw_scheme @@ -139,9 +144,10 @@ subroutine physics_init(dminfo,clock,configs,mesh,diag,tend,state,time_lev,diag_ call mpas_pool_get_config(configs,'config_do_restart' ,config_do_restart ) call mpas_pool_get_config(configs,'config_o3climatology' ,config_o3climatology ) + call mpas_pool_get_config(configs,'config_convection_scheme',config_convection_scheme) call mpas_pool_get_config(configs,'config_lsm_scheme' ,config_lsm_scheme ) call mpas_pool_get_config(configs,'config_microp_scheme' ,config_microp_scheme ) - call mpas_pool_get_config(configs,'config_convection_scheme',config_convection_scheme) + call mpas_pool_get_config(configs,'config_pbl_scheme' ,config_pbl_scheme ) call mpas_pool_get_config(configs,'config_sfclayer_scheme' ,config_sfclayer_scheme ) call mpas_pool_get_config(configs,'config_radt_lw_scheme' ,config_radt_lw_scheme ) call mpas_pool_get_config(configs,'config_radt_sw_scheme' ,config_radt_sw_scheme ) @@ -214,6 +220,10 @@ subroutine physics_init(dminfo,clock,configs,mesh,diag,tend,state,time_lev,diag_ !edges: call init_dirs_forphys(mesh) +!initialization of logical flags for cloud mixing ratios and number concentrations, and aerosols +!number concentrations from the Thompson cloud microphysics: + call init_physics_flags(state,f_qc,f_qr,f_qi,f_qs,f_qg,f_qoz,f_nc,f_ni,f_nifa,f_nwfa,f_nbca) + !initialization of counters i_rainc and i_rainnc. i_rainc and i_rainnc track the number of !times the accumulated convective (rainc) and grid-scale (rainnc) rain exceed the prescribed !threshold value: @@ -355,6 +365,9 @@ subroutine physics_init(dminfo,clock,configs,mesh,diag,tend,state,time_lev,diag_ if(config_microp_scheme .ne. 'off') & call microphysics_init(dminfo,configs,mesh,sfc_input,diag_physics) +!initialization of PBL processes: + if(config_pbl_scheme .ne. 'off') call init_pbl(configs) + !initialization of surface layer processes: if(config_sfclayer_scheme .ne. 'off') call init_sfclayer(configs) @@ -397,6 +410,55 @@ subroutine physics_init(dminfo,clock,configs,mesh,diag,tend,state,time_lev,diag_ end subroutine physics_init +!================================================================================================================= + subroutine init_physics_flags(state,f_qc,f_qr,f_qi,f_qs,f_qg,f_qoz,f_nc,f_ni,f_nifa,f_nwfa,f_nbca) +!================================================================================================================= + +!input arguments: + type(mpas_pool_type),intent(in):: state + +!output arguments: + logical,intent(out):: f_qc,f_qr,f_qi,f_qs,f_qg,f_qoz + logical,intent(out):: f_nc,f_ni,f_nifa,f_nwfa,f_nbca + +!local pointers: + integer,pointer:: index_qc,index_qr,index_qi,index_qs,index_qg + integer,pointer:: index_ni + +!----------------------------------------------------------------------------------------------------------------- + +!initializes the logicals assigned to mixing ratios: + f_qc = .false. + f_qr = .false. + f_qi = .false. + f_qs = .false. + f_qg = .false. + f_qoz = .false. !qoz is not defined in Registry.xml and f_qoz is initialized to false. + call mpas_pool_get_dimension(state,'index_qc',index_qc) + call mpas_pool_get_dimension(state,'index_qr',index_qr) + call mpas_pool_get_dimension(state,'index_qi',index_qi) + call mpas_pool_get_dimension(state,'index_qs',index_qs) + call mpas_pool_get_dimension(state,'index_qg',index_qg) + + if(index_qc .gt. -1) f_qc = .true. + if(index_qr .gt. -1) f_qr = .true. + if(index_qi .gt. -1) f_qi = .true. + if(index_qs .gt. -1) f_qs = .true. + if(index_qg .gt. -1) f_qg = .true. + +!initializes the logical assigned to number concentrations: + f_nc = .false. !nc is not defined in Registry.xml - therefore f_nc is initialized to false. + f_ni = .false. + f_nifa = .false. !nifa is not defined in Registry.xml - therefore f_nc is initialized to false. + f_nwfa = .false. !nwfa is not defined in Registry.xml - therefore f_nc is initialized to false. + f_nbca = .false. !nbca is not defined in Registry.xml - therefore f_nc is initialized to false. + + call mpas_pool_get_dimension(state,'index_ni',index_ni) + + if(index_ni .gt. -1) f_ni = .true. + + end subroutine init_physics_flags + !================================================================================================================= subroutine init_dirs_forphys(mesh) !================================================================================================================= diff --git a/src/core_atmosphere/physics/mpas_atmphys_driver_lsm_shared.F b/src/core_atmosphere/physics/mpas_atmphys_lsm_shared.F similarity index 96% rename from src/core_atmosphere/physics/mpas_atmphys_driver_lsm_shared.F rename to src/core_atmosphere/physics/mpas_atmphys_lsm_shared.F index fdac7ed20c..af5a1a436a 100644 --- a/src/core_atmosphere/physics/mpas_atmphys_driver_lsm_shared.F +++ b/src/core_atmosphere/physics/mpas_atmphys_lsm_shared.F @@ -6,7 +6,7 @@ ! distributed with this code, or at http://mpas-dev.github.com/license.html ! !================================================================================================================= - module mpas_atmphys_driver_lsm_shared + module mpas_atmphys_lsm_shared use mpas_kind_types @@ -57,7 +57,7 @@ subroutine correct_tsk_over_seaice(ims,ime,jms,jme,its,ite,jts,jte,xice_thresh,x end subroutine correct_tsk_over_seaice !================================================================================================================= - end module mpas_atmphys_driver_lsm_shared + end module mpas_atmphys_lsm_shared !================================================================================================================= diff --git a/src/core_atmosphere/physics/mpas_atmphys_packages.F b/src/core_atmosphere/physics/mpas_atmphys_packages.F index f85d955400..ebbaabda3d 100644 --- a/src/core_atmosphere/physics/mpas_atmphys_packages.F +++ b/src/core_atmosphere/physics/mpas_atmphys_packages.F @@ -37,7 +37,7 @@ function atmphys_setup_packages(configs,packages,iocontext) result(ierr) character(len=StrKIND),pointer:: config_convection_scheme character(len=StrKIND),pointer:: config_pbl_scheme logical,pointer:: mp_kessler_in,mp_thompson_in,mp_wsm6_in - logical,pointer:: cu_grell_freitas_in,cu_kain_fritsch_in,cu_tiedtke_in + logical,pointer:: cu_grell_freitas_in,cu_kain_fritsch_in,cu_ntiedtke_in logical,pointer:: bl_mynn_in,bl_ysu_in integer :: ierr @@ -100,12 +100,12 @@ function atmphys_setup_packages(configs,packages,iocontext) result(ierr) nullify(cu_kain_fritsch_in) call mpas_pool_get_package(packages,'cu_kain_fritsch_inActive',cu_kain_fritsch_in) - nullify(cu_tiedtke_in) - call mpas_pool_get_package(packages,'cu_tiedtke_inActive',cu_tiedtke_in) + nullify(cu_ntiedtke_in) + call mpas_pool_get_package(packages,'cu_ntiedtke_inActive',cu_ntiedtke_in) if(.not.associated(cu_grell_freitas_in) .or. & .not.associated(cu_kain_fritsch_in) .or. & - .not.associated(cu_tiedtke_in) ) then + .not.associated(cu_ntiedtke_in) ) then call mpas_log_write('====================================================================================',messageType=MPAS_LOG_ERR) call mpas_log_write('* Error while setting up packages for convection options in atmosphere core.', messageType=MPAS_LOG_ERR) call mpas_log_write('====================================================================================',messageType=MPAS_LOG_ERR) @@ -115,7 +115,7 @@ function atmphys_setup_packages(configs,packages,iocontext) result(ierr) cu_grell_freitas_in = .false. cu_kain_fritsch_in = .false. - cu_tiedtke_in = .false. + cu_ntiedtke_in = .false. if(config_convection_scheme=='cu_grell_freitas') then cu_grell_freitas_in = .true. @@ -123,12 +123,12 @@ function atmphys_setup_packages(configs,packages,iocontext) result(ierr) cu_kain_fritsch_in = .true. elseif(config_convection_scheme == 'cu_tiedtke' .or. & config_convection_scheme == 'cu_ntiedtke') then - cu_tiedtke_in = .true. + cu_ntiedtke_in = .true. endif call mpas_log_write(' cu_grell_freitas_in = $l', logicArgs=(/cu_grell_freitas_in/)) call mpas_log_write(' cu_kain_fritsch_in = $l', logicArgs=(/cu_kain_fritsch_in/)) - call mpas_log_write(' cu_tiedtke_in = $l', logicArgs=(/cu_tiedtke_in/)) + call mpas_log_write(' cu_ntiedtke_in = $l', logicArgs=(/cu_ntiedtke_in/)) !--- initialization of all packages for parameterizations of surface layer and planetary boundary layer: diff --git a/src/core_atmosphere/physics/mpas_atmphys_todynamics.F b/src/core_atmosphere/physics/mpas_atmphys_todynamics.F index 6d5b9bba13..f8a04066c4 100644 --- a/src/core_atmosphere/physics/mpas_atmphys_todynamics.F +++ b/src/core_atmosphere/physics/mpas_atmphys_todynamics.F @@ -41,7 +41,7 @@ module mpas_atmphys_todynamics ! Laura D. Fowler (laura@ucar.edu) / 2014-09-18. ! * renamed "tiedtke" with "cu_tiedtke". ! Laura D. Fowler (laura@ucar.edu) / 2016-03-22. -! * modified the sourcecode to accomodate the packages "cu_kain_fritsch_in" and "cu_tiedtke_in". +! * modified the sourcecode to accomodate the packages "cu_kain_fritsch_in" and "cu_ntiedtke_in". ! Laura D. Fowler (laura@ucar.edu) / 2016-03-24. ! * added the option bl_mynn for the calculation of the tendency for the cloud ice number concentration. ! Laura D. Fowler (laura@ucar.edu) / 2016-04-11. @@ -105,7 +105,7 @@ subroutine physics_get_tend( block, mesh, state, diag, tend, tend_physics, confi real(kind=RKIND),dimension(:,:),pointer:: theta_m ! time level 1 real(kind=RKIND),dimension(:,:,:),pointer:: scalars real(kind=RKIND),dimension(:,:),pointer:: rthblten,rqvblten,rqcblten, & - rqiblten,rublten,rvblten + rqiblten,rqsblten,rublten,rvblten real(kind=RKIND),dimension(:,:),pointer:: rniblten real(kind=RKIND),dimension(:,:),pointer:: rthcuten,rqvcuten,rqccuten, & rqrcuten,rqicuten,rqscuten, & @@ -156,6 +156,7 @@ subroutine physics_get_tend( block, mesh, state, diag, tend, tend_physics, confi call mpas_pool_get_array(tend_physics, 'rqvblten', rqvblten) call mpas_pool_get_array(tend_physics, 'rqcblten', rqcblten) call mpas_pool_get_array(tend_physics, 'rqiblten', rqiblten) + call mpas_pool_get_array(tend_physics, 'rqsblten', rqsblten) call mpas_pool_get_array(tend_physics, 'rniblten', rniblten) call mpas_pool_get_array(tend_physics, 'rucuten', rucuten) @@ -194,21 +195,22 @@ subroutine physics_get_tend( block, mesh, state, diag, tend, tend_physics, confi ! we need to make their pointers associated here to avoid triggering run-time ! checks when calling physics_get_tend_work ! - if (.not. associated(rucuten)) allocate(rucuten(0,0)) - if (.not. associated(rvcuten)) allocate(rvcuten(0,0)) - if (.not. associated(rqrcuten)) allocate(rqrcuten(0,0)) - if (.not. associated(rqscuten)) allocate(rqscuten(0,0)) - if (.not. associated(rniblten)) allocate(rniblten(0,0)) - if (.not. associated(rublten)) allocate(rublten(0,0)) - if (.not. associated(rvblten)) allocate(rvblten(0,0)) + if (.not. associated(rublten)) allocate(rublten(0,0) ) + if (.not. associated(rvblten)) allocate(rvblten(0,0) ) if (.not. associated(rthblten)) allocate(rthblten(0,0)) if (.not. associated(rqvblten)) allocate(rqvblten(0,0)) if (.not. associated(rqcblten)) allocate(rqcblten(0,0)) if (.not. associated(rqiblten)) allocate(rqiblten(0,0)) + if (.not. associated(rqsblten)) allocate(rqsblten(0,0)) + if (.not. associated(rniblten)) allocate(rniblten(0,0)) + if (.not. associated(rucuten)) allocate(rucuten(0,0) ) + if (.not. associated(rvcuten)) allocate(rvcuten(0,0) ) if (.not. associated(rthcuten)) allocate(rthcuten(0,0)) if (.not. associated(rqvcuten)) allocate(rqvcuten(0,0)) if (.not. associated(rqccuten)) allocate(rqccuten(0,0)) if (.not. associated(rqicuten)) allocate(rqicuten(0,0)) + if (.not. associated(rqrcuten)) allocate(rqrcuten(0,0)) + if (.not. associated(rqscuten)) allocate(rqscuten(0,0)) call physics_get_tend_work(block, mesh, nCells, nEdges, nCellsSolve, nEdgesSolve, & rk_step, dynamics_substep, & @@ -217,7 +219,7 @@ subroutine physics_get_tend( block, mesh, state, diag, tend, tend_physics, confi rublten, rvblten, mass_edge, rublten_Edge, & tend_ru_physics, & rucuten, rvcuten, rucuten_Edge, & - tend_th, tend_scalars, mass, rthblten, rqvblten, rqcblten, rqiblten, rniblten, & + tend_th, tend_scalars, mass, rthblten, rqvblten, rqcblten, rqiblten, rqsblten, rniblten, & rthcuten, rqvcuten, rqccuten, rqrcuten, rqicuten, rqscuten, & rthratenlw, rthratensw, & tend_u_phys, & @@ -231,21 +233,22 @@ subroutine physics_get_tend( block, mesh, state, diag, tend, tend_physics, confi ! Clean up any pointers that were allocated with zero size before the call to ! physics_get_tend_work ! - if (size(rucuten) == 0) deallocate(rucuten) - if (size(rvcuten) == 0) deallocate(rvcuten) - if (size(rqrcuten) == 0) deallocate(rqrcuten) - if (size(rqscuten) == 0) deallocate(rqscuten) - if (size(rniblten) == 0) deallocate(rniblten) - if (size(rublten) == 0) deallocate(rublten) - if (size(rvblten) == 0) deallocate(rvblten) + if (size(rublten) == 0) deallocate(rublten ) + if (size(rvblten) == 0) deallocate(rvblten ) if (size(rthblten) == 0) deallocate(rthblten) if (size(rqvblten) == 0) deallocate(rqvblten) if (size(rqcblten) == 0) deallocate(rqcblten) if (size(rqiblten) == 0) deallocate(rqiblten) + if (size(rqsblten) == 0) deallocate(rqsblten) + if (size(rniblten) == 0) deallocate(rniblten) + if (size(rucuten) == 0) deallocate(rucuten ) + if (size(rvcuten) == 0) deallocate(rvcuten ) if (size(rthcuten) == 0) deallocate(rthcuten) if (size(rqvcuten) == 0) deallocate(rqvcuten) if (size(rqccuten) == 0) deallocate(rqccuten) if (size(rqicuten) == 0) deallocate(rqicuten) + if (size(rqrcuten) == 0) deallocate(rqrcuten) + if (size(rqscuten) == 0) deallocate(rqscuten) ! deallocate(theta) deallocate(tend_th) @@ -274,7 +277,7 @@ subroutine physics_get_tend_work(block, mesh, nCells, nEdges, nCellsSolve, nEdge index_qv, index_qc, index_qr, index_qi, index_qs, index_ni, & rublten, rvblten, mass_edge, rublten_Edge, tend_u, & rucuten, rvcuten, rucuten_Edge, & - tend_th, tend_scalars, mass, rthblten, rqvblten, rqcblten, rqiblten, rniblten, & + tend_th, tend_scalars, mass, rthblten, rqvblten, rqcblten, rqiblten, rqsblten, rniblten, & rthcuten, rqvcuten, rqccuten, rqrcuten, rqicuten, rqscuten, & rthratenlw, rthratensw, & tend_u_phys, & @@ -311,6 +314,7 @@ subroutine physics_get_tend_work(block, mesh, nCells, nEdges, nCellsSolve, nEdge real (kind=RKIND), dimension(nVertLevels,nCells+1), intent(in) :: rqvblten real (kind=RKIND), dimension(nVertLevels,nCells+1), intent(in) :: rqcblten real (kind=RKIND), dimension(nVertLevels,nCells+1), intent(in) :: rqiblten + real (kind=RKIND), dimension(nVertLevels,nCells+1), intent(in) :: rqsblten real (kind=RKIND), dimension(nVertLevels,nCells+1), intent(in) :: rniblten real (kind=RKIND), dimension(nVertLevels,nCells+1), intent(in) :: rthcuten real (kind=RKIND), dimension(nVertLevels,nCells+1), intent(in) :: rqvcuten @@ -361,6 +365,7 @@ subroutine physics_get_tend_work(block, mesh, nCells, nEdges, nCellsSolve, nEdge do i = 1, nCellsSolve do k = 1, nVertLevels + tend_scalars(index_qs,k,i) = tend_scalars(index_qs,k,i) + rqsblten(k,i)*mass(k,i) tend_scalars(index_ni,k,i) = tend_scalars(index_ni,k,i) + rniblten(k,i)*mass(k,i) enddo enddo diff --git a/src/core_atmosphere/physics/mpas_atmphys_vars.F b/src/core_atmosphere/physics/mpas_atmphys_vars.F index 985d46111e..159bef2fca 100644 --- a/src/core_atmosphere/physics/mpas_atmphys_vars.F +++ b/src/core_atmosphere/physics/mpas_atmphys_vars.F @@ -108,7 +108,7 @@ module mpas_atmphys_vars ! Thompson cloud microphysics scheme. ! Laura D. Fowler (laura@ucar.edu) / 2017-04-19. ! * added the local variables cosa_p and sina_p needed in call to subroutine gwdo after updating module_bl_gwdo.F -! to that of WRF version 4.0.2 +! to that of WRF version 4.0.2. ! Laura D. Fowler (laura@ucar.edu) / 2019-01-30. ! * reverted the option seaice_albedo_opt = 2 to seaic_albedo_opt = 0 since MPAS does not currently support the ! input of "observed" 2D seaice albedos. In conjunction with this update, we also change the initialization of @@ -122,6 +122,16 @@ module mpas_atmphys_vars ! * added the local variables swddir,swddni,and swddif which are output to subroutine rrtmg_swrad and now input ! to the updated module_sf_noahdrv.F. ! Laura D. Fowler (laura@ucar.edu) / 2023-04-21. +! * removed the variable f_qv which is not used in any of the ./physics_wrf modules. +! Laura D. Fowler (laura@ucar.edu) / 2024-02-13. +! * removed the definition of f_qc,f_qr,f_qi,f_qs,f_qg,f_nc,and f_ni as parameters. these variables are now +! initialized in mpas_atmphys_init.F (see subroutine init_physics_flags). also renamed f_qnc to f_nc, and f_qni +! to f_ni. +! Laura D. Fowler (laura@ucar.edu) / 2024-02-14. +! * added the variable spp_pbl needed in the updated version of the MYNN surface layer scheme. +! Laura D. Fowler (laura@ucar.edu) / 2024-02-14. +! * added and modified variables needed to run the MYNN PBL scheme using the sourcecode from WRF version 4.6. +! Laura D. Fowler (laura@ucar.edu) / 2024-02-18. !================================================================================================================= @@ -194,9 +204,8 @@ module mpas_atmphys_vars qg_p !graupel mixing ratio [kg/kg] real(kind=RKIND),dimension(:,:,:),allocatable:: & - nc_p, &! - ni_p, &! - nr_p ! + ni_p, &!cloud ice crystal number concentration [#/kg] + nr_p !rain drop number concentration [#/kg] !... arrays located at w (vertical velocity) points, or at interface between layers: real(kind=RKIND),dimension(:,:,:),allocatable:: & @@ -229,26 +238,25 @@ module mpas_atmphys_vars ! that the ice phase is included (except for the Kessler scheme which includes water ! clouds only. -! f_qv,f_qc,f_qr,f_qi,f_qs,f_qg: These logicals were initially defined in WRF to determine -! which kind of hydrometeors are present. Here, we assume that all six water species -! are present, even if their mixing ratios and number concentrations are zero. - !================================================================================================================= logical,parameter:: & - warm_rain=.false. !warm-phase cloud microphysics only (used in WRF). + warm_rain = .false.!warm-phase cloud microphysics only (used in WRF). - logical,parameter:: & - f_qv = .true., &! - f_qc = .true., &! - f_qr = .true., &! - f_qi = .true., &! - f_qs = .true., &! - f_qg = .true. ! + logical:: & + f_qc, &!parameter set to true to include the cloud water mixing ratio. + f_qr, &!parameter set to true to include the rain mixing ratio. + f_qi, &!parameter set to true to include the cloud ice mixing ratio. + f_qs, &!parameter set to true to include the snow minxg ratio. + f_qg, &!parameter set to true to include the graupel mixing ratio. + f_qoz !parameter set to true to include the ozone mixing ratio. - logical,parameter:: & - f_qnc = .true., &! - f_qni = .true. ! + logical:: & + f_nc, &!parameter set to true to include the cloud water number concentration. + f_ni, &!parameter set to true to include the cloud ice number concentration. + f_nifa, &!parameter set to true to include the number concentration of hygroscopic aerosols. + f_nwfa, &!parameter set to true to include the number concentration of hydrophobic aerosols. + f_nbca !parameter set to true to include the number concentration of black carbon. real(kind=RKIND),dimension(:,:,:),allocatable:: & f_ice, &!fraction of cloud ice (used in WRF only). @@ -384,12 +392,12 @@ module mpas_atmphys_vars exch_p !exchange coefficient [-] real(kind=RKIND),dimension(:,:,:),allocatable:: & - rublten_p, &! - rvblten_p, &! - rthblten_p, &! - rqvblten_p, &! - rqcblten_p, &! - rqiblten_p ! + rublten_p, &!tendency of zonal wind due to PBL processes. + rvblten_p, &!tendency of meridional wind due to PBL processes. + rthblten_p, &!tendency of potential temperature due to PBL processes. + rqvblten_p, &!tendency of water vapor mixing ratio due to PBL processes. + rqcblten_p, &!tendency of cloud water mixing ratio due to PBL processes. + rqiblten_p !tendency of cloud ice mixing ratio due to PBL processes. real(kind=RKIND),dimension(:,:,:),allocatable:: & kzh_p, &! @@ -397,14 +405,16 @@ module mpas_atmphys_vars kzq_p ! !... MYNN PBL scheme (module_bl_mynn.F): - integer,parameter:: grav_settling = 0 + integer,parameter:: spp_pbl = 0 !generate array with random perturbations (0=off,1=on). + integer,parameter:: icloud_bl = 0 !no coupling of subgrid-scale clouds with radiation. - logical,parameter:: bl_mynn_tkeadvect = .false.! - integer,parameter:: bl_mynn_tkebudget = 0 ! - integer,parameter:: bl_mynn_cloudpdf = 0 ! + integer,dimension(:,:),allocatable:: & + kbl_plume_p !level of highest penetrating plume. real(kind=RKIND),dimension(:,:),allocatable:: & - vdfg_p ! + maxwidthbl_p, &!max plume width [m] + maxmfbl_p, &!maximum mass flux for PBL shallow convection. + zbl_plume_p !height of highest penetrating plume [m] real(kind=RKIND),dimension(:,:,:),allocatable:: & dqke_p, &! @@ -417,7 +427,26 @@ module mpas_atmphys_vars tkepbl_p ! real(kind=RKIND),dimension(:,:,:),allocatable:: & - rniblten_p ! + edmfa_p, &! + edmfw_p, &! + edmfqt_p, &! + edmfthl_p, &! + edmfent_p, &! + edmfqc_p, &! + subthl_p, &! + subqv_p, &! + detthl_p, &! + detqv_p, &! + qcbl_p, &! + qibl_p, &! + cldfrabl_p ! + + real(kind=RKIND),dimension(:,:,:),allocatable:: & + rqsblten_p, &!tendency of snow mixing ratio due to PBL processes. + rniblten_p !tendency of cloud ice number concentration due to PBL processes. + + real(kind=RKIND),dimension(:,:,:),allocatable:: & + pattern_spp_pbl !stochastic forcing for the MYMM PBL and surface layer schemes. !================================================================================================================= !... variables and arrays related to parameterization of gravity wave drag over orography: @@ -525,6 +554,7 @@ module mpas_atmphys_vars qsq_p, &!liquid water variance [(kg/kg)^2] tsq_p, &!liquid water potential temperature variance [K^2] sh3d_p, &!stability function for heat [-] + sm3d_p, &!stability function for moisture [-] elpbl_p !length scale from PBL [m] !================================================================================================================= diff --git a/src/core_atmosphere/physics/physics_mmm/Makefile b/src/core_atmosphere/physics/physics_mmm/Makefile index 0af279de6c..f02fb955a2 100644 --- a/src/core_atmosphere/physics/physics_mmm/Makefile +++ b/src/core_atmosphere/physics/physics_mmm/Makefile @@ -7,18 +7,28 @@ dummy: OBJS = \ bl_gwdo.o \ + bl_mynn.o \ + bl_mynn_subroutines.o \ bl_ysu.o \ cu_ntiedtke.o \ - sf_sfclayrev.o \ - module_libmassv.o \ mp_radar.o \ mp_wsm6_effectRad.o \ - mp_wsm6.o + mp_wsm6.o \ + mynn_shared.o \ + sf_mynn.o \ + sf_sfclayrev.o \ + module_libmassv.o physics_mmm: $(OBJS) ar -ru ./../libphys.a $(OBJS) # DEPENDENCIES: +bl_mynn.o: \ + bl_mynn_subroutines.o + +bl_mynn_subroutines.o: \ + mynn_shared.o + mp_wsm6_effectRad.o: \ mp_wsm6.o @@ -26,6 +36,9 @@ mp_wsm6.o: \ mp_radar.o \ module_libmassv.o +sf_mynn.o: \ + mynn_shared.o + clean: $(RM) *.f90 *.o *.mod @# Certain systems with intel compilers generate *.i files diff --git a/src/core_atmosphere/physics/physics_mmm/bl_mynn.F b/src/core_atmosphere/physics/physics_mmm/bl_mynn.F new file mode 100644 index 0000000000..b41b2c538b --- /dev/null +++ b/src/core_atmosphere/physics/physics_mmm/bl_mynn.F @@ -0,0 +1,1244 @@ +!================================================================================================================= + module bl_mynn + use mpas_kind_types,only: kind_phys => RKIND + + use bl_mynn_common,only: & + cp , cpv , cliq , cice , ep_1 , ep_2 , ep_3 , grav , karman , p1000mb , & + r_d , r_v , svp1 , svp2 , svp3 , svpt0 , xlf , xls , xlv , p608 , & + t0c , tref , tkmin , tv0 , gtr , xlvcp , xlscp , rvovrd , rcp , cphh_st , & + cphm_st , cphh_unst , cphm_unst , b1 , b2 , zero + use bl_mynn_subroutines + + + implicit none + private + public:: bl_mynn_init, & + bl_mynn_finalize, & + bl_mynn_run + + + contains + + +!================================================================================================================= + subroutine bl_mynn_init(con_cp,con_cpv,con_cice,con_cliq,con_ep1,con_ep2,con_grav,con_karman,con_p0, & + con_rd,con_rv,con_svp1,con_svp2,con_svp3,con_svpt0,con_xlf,con_xls,con_xlv, & + errmsg,errflg) +!================================================================================================================= + +!-- input arguments: + real(kind=kind_phys),intent(in):: & + con_cp, & + con_cpv, & + con_cice, & + con_cliq + + real(kind=kind_phys),intent(in):: & + con_ep1, & + con_ep2 + + real(kind=kind_phys),intent(in):: & + con_grav + + real(kind=kind_phys),intent(in):: & + con_karman + + real(kind=kind_phys),intent(in):: & + con_p0 + + real(kind=kind_phys),intent(in):: & + con_rd, & + con_rv + + real(kind=kind_phys),intent(in):: & + con_svp1, & + con_svp2, & + con_svp3, & + con_svpt0 + + real(kind=kind_phys),intent(in):: & + con_xlf, & + con_xls, & + con_xlv + + character(len=*),intent(out):: errmsg + integer,intent(out):: errflg + +!----------------------------------------------------------------------------------------------------------------- + +!--- initialization of physics constants needed in the MYNN PBL scheme and already available from MPAS: + cp = con_cp + cpv = con_cpv + cliq = con_cliq + cice = con_cice + ep_1 = con_ep1 + ep_2 = con_ep2 + grav = con_grav + karman = con_karman + p1000mb = con_p0 + r_d = con_rd + r_v = con_rv + rvovrd = r_v/r_d + svp1 = con_svp1 + svp2 = con_svp2 + svp3 = con_svp3 + svpt0 = con_svpt0 + xlf = con_xlf + xls = con_xls + xlv = con_xlv + +!--- initialization of derived physics constants needed in the MYNN PBL scheme: + ep_3 = 1.-ep_2 + gtr = grav/tref + p608 = ep_1 + rcp = r_d/cp + t0c = svpt0 + tv0 = p608*tref + xlscp = (xlv+xlf)/cp + xlvcp = xlv/cp + +!ev = xlv +!rk = cp/r_d +!svp11 = svp1*1.e3 +!tv1 = (1.+p608)*tref +!vk = karman + + errmsg = " " + errflg = 0 + + end subroutine bl_mynn_init + +!================================================================================================================= + subroutine bl_mynn_finalize(errmsg,errflg) +!================================================================================================================= + + character(len=*),intent(out):: errmsg + integer,intent(out):: errflg + +!----------------------------------------------------------------------------------------------------------------- +!note: this subroutine currently does nothing. + + errmsg = ' ' + errflg = 0 + + end subroutine bl_mynn_finalize + +!================================================================================================================= + subroutine bl_mynn_run & + (initflag , restart , cycling , & + delt , dz , dx , & + znt , u , v , & + w , th , sqv , & + sqc , sqi , sqs , & + qnc , qni , qnwfa , & + qnifa , qnbca , qozone , & + p , exner , rho , & + tt , xland , ts , & + qsfc , ps , ust , & + ch , hfx , qfx , & + rmol , wspd , uoce , & + voce , qke , qke_adv , & + tsq , qsq , cov , & + rublten , rvblten , rthblten , & + rqvblten , rqcblten , rqiblten , & + rqsblten , rqncblten , rqniblten , & + rqnwfablten , rqnifablten , rqnbcablten , & + rqozblten , exch_h , exch_m , & + pblh , kpbl , el_pbl , & + dqke , qwt , qshear , & + qbuoy , qdiss , sh , & + sm , qc_bl , qi_bl , & + cldfra_bl , icloud_bl , bl_mynn_tkeadvect , & + bl_mynn_tkebudget , bl_mynn_cloudpdf , bl_mynn_mixlength , & + bl_mynn_closure , bl_mynn_stfunc , bl_mynn_topdown , & + bl_mynn_edmf , bl_mynn_edmf_dd , bl_mynn_edmf_mom , & + bl_mynn_edmf_tke , bl_mynn_mixscalars , bl_mynn_output , & + bl_mynn_cloudmix , bl_mynn_mixqt , bl_mynn_scaleaware , & + bl_mynn_dheatopt , edmf_a , edmf_w , & + edmf_qt , edmf_thl , edmf_ent , & + edmf_qc , sub_thl , sub_sqv , & + det_thl , det_sqv , edmf_a_dd , & + edmf_w_dd , edmf_qt_dd , edmf_thl_dd , & + edmf_ent_dd , edmf_qc_dd , maxwidth , & + maxmf , ztop_plume , ktop_plume , & + spp_pbl , pattern_spp_pbl , rthraten , & + flag_qc , flag_qi , flag_qs , & + flag_qnc , flag_qni , flag_qnwfa , & + flag_qnifa , flag_qnbca , flag_qoz , & +#if(WRF_CHEM == 1) + mix_chem , nchem , kdvel , & + ndvel , chem , emis_ant_no , & + frp , vdep , & +#endif + its, ite , kts , kte , kme , errmsg , errflg & + ) + +!================================================================================================================= + +!input arguments: + logical,intent(in):: & + flag_qc,flag_qi,flag_qs,flag_qoz,flag_qnc,flag_qni,flag_qnifa,flag_qnwfa,flag_qnbca + + logical,intent(in):: bl_mynn_edmf,bl_mynn_edmf_dd,bl_mynn_edmf_mom,bl_mynn_edmf_tke + logical,intent(in):: bl_mynn_mixscalars,bl_mynn_cloudmix,bl_mynn_mixqt + logical,intent(in):: bl_mynn_tkeadvect,bl_mynn_tkebudget + logical,intent(in):: bl_mynn_output,bl_mynn_dheatopt,bl_mynn_scaleaware,bl_mynn_topdown + + logical,intent(in):: & + restart,cycling + + integer,intent(in):: its,ite,kts,kte,kme + + integer,intent(in):: & + initflag,icloud_bl,spp_pbl + + integer,intent(in):: & + bl_mynn_cloudpdf,bl_mynn_mixlength,bl_mynn_stfunc + + real(kind=kind_phys),intent(in):: & + bl_mynn_closure + + real(kind=kind_phys),intent(in):: & + delt + + real(kind=kind_phys),intent(in),dimension(its:ite):: & + dx, &! + xland, &! + ps, &! + ts, &! + qsfc, &! + ust, &! + ch, &! + hfx, &! + qfx, &! + rmol, &! + wspd, &! + uoce, &! + voce, &! + znt ! + + real(kind=kind_phys),intent(in),dimension(its:ite,kts:kte):: & + dz, &! + u, &! + v, &! + th, &! + tt, &! + p, &! + exner, &! + rho, &! + rthraten ! + + real(kind=kind_phys),intent(in),dimension(its:ite,kts:kte):: & + sqv, &! + sqc, &! + sqi, &! + sqs, &! + qnc, &! + qni, &! + qnifa, &! + qnwfa, &! + qnbca, &! + qozone ! + + real(kind=kind_phys),intent(in),dimension(its:ite,kts:kte):: & + pattern_spp_pbl + + real(kind=kind_phys),intent(in),dimension(its:ite,kts:kme):: & + w ! + +!inout arguments: + integer,intent(inout),dimension(its:ite):: & + kpbl, &! + ktop_plume ! + + real(kind=kind_phys),intent(inout),dimension(its:ite):: & + pblh + + real(kind=kind_phys),intent(inout),dimension(its:ite,kts:kte):: & + cldfra_bl, &! + qc_bl, &! + qi_bl ! + + real(kind=kind_phys),intent(inout),dimension(its:ite,kts:kte):: & + el_pbl, &! + qke, &! + qke_adv, &! + cov, &! + qsq, &! + tsq, &! + sh, &! + sm ! + + real(kind=kind_phys),intent(inout),dimension(its:ite,kts:kte):: & + rublten, &! + rvblten, &! + rthblten, &! + rqvblten, &! + rqcblten, &! + rqiblten, &! + rqsblten, &! + rqncblten, &! + rqniblten, &! + rqnifablten, &! + rqnwfablten, &! + rqnbcablten, &! + rqozblten ! + + real(kind=kind_phys),intent(inout),dimension(its:ite,kts:kte):: & + edmf_a, &! + edmf_w, &! + edmf_qt, &! + edmf_thl, &! + edmf_ent, &! + edmf_qc, &! + sub_thl, &! + sub_sqv, &! + det_thl, &! + det_sqv ! + + real(kind=kind_phys),intent(inout),dimension(its:ite,kts:kte),optional:: & + edmf_a_dd, &! + edmf_w_dd, &! + edmf_qt_dd, &! + edmf_thl_dd, &! + edmf_ent_dd, &! + edmf_qc_dd + + +!output arguments: + character(len=*),intent(out):: & + errmsg ! output error message (-). + + integer,intent(out):: & + errflg ! output error flag (-). + + real(kind=kind_phys),intent(out),dimension(its:ite):: & + maxwidth, &! + maxmf, &! + ztop_plume + + real(kind=kind_phys),intent(out),dimension(its:ite,kts:kte):: & + exch_h, &! + exch_m ! + + real(kind=kind_phys),intent(out),dimension(its:ite,kts:kte),optional:: & + dqke, &! + qwt, &! + qshear, &! + qbuoy, &! + qdiss ! + + +!local variable and arrays: + logical:: initialize_qke + + integer:: i,k + + real(kind=kind_phys):: qc_bl2,qi_bl2 + real(kind=kind_phys):: cpm,exnerg,flq,flqc,flqv,flt,fltv,phh,pmz,psig_bl,psig_shcu,sqcg,phi_m, & + th_sfc,zet,ts_decay + + real(kind=kind_phys),dimension(kts:kte):: cldfra_bl1_old,qc_bl1_old,qi_bl1_old + real(kind=kind_phys),dimension(kts:kte):: qv1,qc1,qi1,qs1 + real(kind=kind_phys),dimension(kts:kte):: det_sqc,det_u,det_v,sub_u,sub_v + + real(kind=kind_phys),dimension(kts:kte):: pdc,pdk,pdq,pdt,sgm,sqw,thetav,thl,vq,vt,kzero + + real(kind=kind_phys),dimension(kts:kte):: dfh,dfm,dfq,qcd,tcd,diss_heat + + real(kind=kind_phys),dimension(kts:kte):: rstoch_col + + real(kind=kind_phys),dimension(kts:kte+1):: zw + + real(kind=kind_phys),dimension(kts:kte+1):: & + s_aw1,s_awthl1,s_awqt1,s_awqv1,s_awqc1,s_awu1,s_awv1,s_awqke1,s_awqnc1,s_awqni1, & + s_awqnwfa1,s_awqnifa1,s_awqnbca1 + + real(kind=kind_phys),dimension(kts:kte+1):: & + sd_aw1,sd_awthl1,sd_awqt1,sd_awqv1,sd_awqc1,sd_awu1,sd_awv1,sd_awqke1 + +!JOE-top-down diffusion + logical :: cloudflg + integer :: kk,kminrad + + real(kind=kind_phys),parameter:: pfac =2.0, zfmin = 0.01, phifac=8.0 + real(kind=kind_phys):: maxkhtopdown + real(kind=kind_phys):: bfxpbl,dthvx,tmp1,temps,templ,zl1,wstar3_2 + real(kind=kind_phys):: ent_eff,radsum,radflux,we,rcldb,rvls,minrad,zminrad + real(kind=kind_phys),dimension(kts:kte):: khtopdown,zfac,wscalek2,zfacent,tkeprodtd +!JOE-end top down + + +!local 1D input arguments: + real(kind=kind_phys):: dx1,xland1,ps1,ts1,qsfc1,ust1,ch1,hfx1,qfx1,rmol1,wspd1, & + uoce1,voce1,znt1 + real(kind=kind_phys),dimension(kts:kte):: & + dz1,u1,v1,th1,tk1,p1,ex1,rho1,qnc1,qni1,qnifa1,qnwfa1,qnbca1,qozone1,rthraten1,sqv1,sqc1,sqi1,sqs1 + real(kind=kind_phys),dimension(kts:kme):: w1 + +!local 1D inout arguments: + integer:: kpbl1,ktop_plume1 + + real(kind=kind_phys):: pblh1 + real(kind=kind_phys),dimension(kts:kte):: cldfra_bl1,qc_bl1,qi_bl1 + real(kind=kind_phys),dimension(kts:kte):: el_pbl1,qke1,qke_adv1,cov1,qsq1,tsq1,sh1,sm1 + real(kind=kind_phys),dimension(kts:kte):: du1,dv1,dth1,dqv1,dqc1,dqi1,dqs1,dqnc1,dqni1,dqnifa1,dqnwfa1, & + dqnbca1,dqozone1 + real(kind=kind_phys),dimension(kts:kte):: edmf_a1,edmf_w1,edmf_qt1,edmf_thl1,edmf_ent1,edmf_qc1,sub_thl1, & + sub_sqv1,det_thl1,det_sqv1 + real(kind=kind_phys),dimension(kts:kte):: edmf_a_dd1,edmf_w_dd1,edmf_qt_dd1,edmf_thl_dd1,edmf_ent_dd1, & + edmf_qc_dd1 + +!local 1D output arguments: + real(kind=kind_phys):: maxwidth1,maxmf1,ztop_plume1 + real(kind=kind_phys),dimension(kts:kte):: exch_h1,exch_m1 + + real(kind=kind_phys),dimension(kts:kte):: dqke1,qwt1,qshear1,qbuoy1,qdiss1 + +!substepping TKE: + integer:: nsub + real(kind=kind_phys):: delt2 + + + +!VARIABLES NEEDED FOR MIXING OF CHEMICAL SPECIES: +#if(WRF_CHEM == 1) +!--- inputs: + logical,intent(in):: mix_chem + integer,intent(in):: nchem,kdvel,ndvel + real(kind=kind_phys),intent(in),dimension(its:ite),optional:: frp,emis_ant_no + real(kind=kind_phys),intent(in),dimension(its:ite,ndvel):: vdep + +!--- inouts: + real(kind=kind_phys),intent(inout),dimension(its:ite,kts:kte,nchem):: chem +#else + logical,parameter:: mix_chem = .false. + integer,parameter:: nchem = 1 + integer,parameter:: kdvel = 1 + integer,parameter:: ndvel = 1 +#endif +!--- local variables and arrays: + logical,parameter:: rrfs_sd = .false. + logical,parameter:: smoke_dbg = .false. + logical,parameter:: enh_mix = .false. + + integer:: ic + real(kind=kind_phys):: emis_ant_no1,frp1 + real(kind=kind_phys),dimension(ndvel):: vd1 + real(kind=kind_phys),dimension(kts:kte,nchem):: chem1 + real(kind=kind_phys),dimension(kts:kte+1,nchem):: s_awchem1 + !END VARIABLES NEEDED FOR MIXING OF CHEMICAL SPECIES. + +!----------------------------------------------------------------------------------------------------------------- + + errmsg = " " + errflg = 0 + + do i = its,ite + + if(present(dqke)) then + do k = kts,kte + dqke(i,k) = qke(i,k) + enddo + endif + +!--- initialization of 2D inout tendencies: + do k = kts,kte + rublten(i,k) = 0._kind_phys + rvblten(i,k) = 0._kind_phys + rthblten(i,k) = 0._kind_phys + rqvblten(i,k) = 0._kind_phys + rqcblten(i,k) = 0._kind_phys + rqiblten(i,k) = 0._kind_phys + rqsblten(i,k) = 0._kind_phys + rqncblten(i,k) = 0._kind_phys + rqniblten(i,k) = 0._kind_phys + rqnifablten(i,k) = 0._kind_phys + rqnwfablten(i,k) = 0._kind_phys + rqnbcablten(i,k) = 0._kind_phys + rqozblten(i,k) = 0._kind_phys + enddo + +!--- initialization of 2D output variables: + ktop_plume(i) = 0 + maxwidth(i) = 0._kind_phys + maxmf(i) = 0._kind_phys + ztop_plume(i) = 0._kind_phys + +!--- initialization of 1D input variables using 2D input variables: + dx1 = dx(i) + xland1 = xland(i) + ps1 = ps(i) + ts1 = ts(i) + qsfc1 = qsfc(i) + ust1 = ust(i) + ch1 = ch(i) + hfx1 = hfx(i) + qfx1 = qfx(i) + rmol1 = rmol(i) + wspd1 = wspd(i) + uoce1 = uoce(i) + voce1 = voce(i) + znt1 = znt(i) + + do k = kts,kte + dz1(k) = dz(i,k) + u1(k) = u(i,k) + v1(k) = v(i,k) + w1(k) = w(i,k) + th1(k) = th(i,k) + tk1(k) = tt(i,k) + p1(k) = p(i,k) + ex1(k) = exner(i,k) + rho1(k) = rho(i,k) + sh1(k) = sh(i,k) + sm1(k) = sm(i,k) + rthraten1(k) = rthraten(i,k) + sqv1(k) = sqv(i,k) + sqc1(k) = sqc(i,k) + sqi1(k) = sqi(i,k) + sqs1(k) = sqs(i,k) + qnc1(k) = qnc(i,k) + qni1(k) = qni(i,k) + qnifa1(k) = qnifa(i,k) + qnwfa1(k) = qnwfa(i,k) + qnbca1(k) = qnbca(i,k) + qozone1(k) = qozone(i,k) + kzero(k) = 0._kind_phys + enddo + do k = kte,kte+1 + w1(k) = w(i,k) + enddo + +!--- initialization of the PBL stochastic forcing: + if(spp_pbl .eq. 1) then + do k = kts,kte + rstoch_col(k) = pattern_spp_pbl(i,k) + enddo + else + do k = kts,kte + rstoch_col(k) = 0._kind_phys + enddo + endif + + +!--- initialization of 1D inout variables using 2D inout variables: + kpbl1 = kpbl(i) + pblh1 = pblh(i) + + do k = kts,kte + cldfra_bl1(k) = cldfra_bl(i,k) + qc_bl1(k) = qc_bl(i,k) + qi_bl1(k) = qi_bl(i,k) + enddo + + do k = kts,kte + el_pbl1(k) = el_pbl(i,k) + qke1(k) = qke(i,k) + qke_adv1(k) = qke_adv(i,k) + cov1(k) = cov(i,k) + qsq1(k) = qsq(i,k) + tsq1(k) = tsq(i,k) + sh1(k) = sh(i,k) + sm1(k) = sm(i,k) + enddo + +!--- initialization of 1D local variables: + ktop_plume1 = 0 + maxwidth1 = 0._kind_phys + maxmf1 = 0._kind_phys + ztop_plume1 = 0._kind_phys + maxkhtopdown = 0._kind_phys + + do k = kts,kte + du1(k) = 0._kind_phys + dv1(k) = 0._kind_phys + dth1(k) = 0._kind_phys + dqv1(k) = 0._kind_phys + dqc1(k) = 0._kind_phys + dqi1(k) = 0._kind_phys + dqs1(k) = 0._kind_phys + dqnc1(k) = 0._kind_phys + dqni1(k) = 0._kind_phys + dqnifa1(k) = 0._kind_phys + dqnwfa1(k) = 0._kind_phys + dqnbca1(k) = 0._kind_phys + dqozone1(k) = 0._kind_phys + enddo + do k = kts,kte + edmf_a1(k) = 0._kind_phys + edmf_w1(k) = 0._kind_phys + edmf_qc1(k) = 0._kind_phys + edmf_ent1(k) = 0._kind_phys + edmf_qt1(k) = 0._kind_phys + edmf_thl1(k) = 0._kind_phys + sub_thl1(k) = 0._kind_phys + sub_sqv1(k) = 0._kind_phys + det_thl1(k) = 0._kind_phys + det_sqv1(k) = 0._kind_phys + + edmf_a_dd1(k) = 0._kind_phys + edmf_w_dd1(k) = 0._kind_phys + edmf_qc_dd1(k) = 0._kind_phys + edmf_ent_dd1(k) = 0._kind_phys + edmf_qt_dd1(k) = 0._kind_phys + edmf_thl_dd1(k) = 0._kind_phys + enddo + do k = kts,kte + dqke1(k) = 0._kind_phys + qwt1(k) = 0._kind_phys + qshear1(k) = 0._kind_phys + qbuoy1(k) = 0._kind_phys + qdiss1(k) = 0._kind_phys + exch_h1(k) = 0._kind_phys + exch_m1(k) = 0._kind_phys + enddo + do k = kts,kte + sub_u(k) = 0._kind_phys + sub_v(k) = 0._kind_phys + det_sqc(k) = 0._kind_phys + det_u(k) = 0._kind_phys + det_v(k) = 0._kind_phys + enddo + do k = kts,kte+1 + s_aw1(k) = 0._kind_phys + s_awthl1(k) = 0._kind_phys + s_awqt1(k) = 0._kind_phys + s_awqv1(k) = 0._kind_phys + s_awqc1(k) = 0._kind_phys + s_awu1(k) = 0._kind_phys + s_awv1(k) = 0._kind_phys + s_awqke1(k) = 0._kind_phys + s_awqnc1(k) = 0._kind_phys + s_awqni1(k) = 0._kind_phys + s_awqnwfa1(k) = 0._kind_phys + s_awqnifa1(k) = 0._kind_phys + s_awqnbca1(k) = 0._kind_phys + enddo + do k = kts,kte+1 + sd_aw1(k) = 0._kind_phys + sd_awthl1(k) = 0._kind_phys + sd_awqt1(k) = 0._kind_phys + sd_awqv1(k) = 0._kind_phys + sd_awqc1(k) = 0._kind_phys + sd_awu1(k) = 0._kind_phys + sd_awv1(k) = 0._kind_phys + sd_awqke1(k) = 0._kind_phys + enddo + do k = kts,kte + cldfra_bl1_old(k) = 0._kind_phys + qc_bl1_old(k) = 0._kind_phys + qi_bl1_old(k) = 0._kind_phys + enddo + + do k = kts,kte + qv1(k) = sqv1(k)/(1.-sqv1(k)) + qc1(k) = sqc1(k)/(1.-sqv1(k)) + qi1(k) = sqi1(k)/(1.-sqv1(k)) + qs1(k) = sqs1(k)/(1.-sqv1(k)) + enddo + + k = kts + zw(k) = 0._kind_phys + do k = kts+1,kte+1 + zw(k) = zw(k-1) + dz1(k-1) + enddo + +!INITIALIZATION OF LOCAL CHEMICAL SPECIES: +#if(WRF_CHEM == 1) + do ic = 1,nchem + vd1(ic) = vdep(i,ic) + do k = kts,kte + chem1(k,ic) = chem(i,k,ic) + enddo + enddo + if(present(emis_ant_no) .and. present(frp)) then + emis_ant_no1 = emis_ant_no(i) + frp1 = frp(i) + else + emis_ant_no1 = 0._kind_phys + frp1 = 0._kind_phys + endif + !END INITIALIZATION OF LOCAL CHEMICAL SPECIES. +#else + do ic = 1,nchem + vd1(ic) = 0._kind_phys + do k = kts,kte + chem1(k,ic) = 0._kind_phys + enddo + enddo + emis_ant_no1 = 0._kind_phys + frp1 = 0._kind_phys +#endif + do ic = 1,nchem + do k = kts,kte+1 + s_awchem1(k,ic) = 0._kind_phys + enddo + enddo +!END INITIALIZATION OF LOCAL CHEMICAL SPECIES. + + + do k = kts,kte + !keep snow out for now - increase ceiling bias + sqw(k) = sqv1(k)+sqc1(k)+sqi1(k) !+sqs1(k) + thl(k) = th1(k) - xlvcp/ex1(k)*sqc1(k) - xlscp/ex1(k)*(sqi1(k))!+sqs1(k)) + thetav(k) = th1(k)*(1.+0.608*sqv1(k)) + + !Use form from Tripoli and Cotton (1981) with their + !suggested min temperature to improve accuracy. + !thl(k)=th(k)*(1.- xlvcp/MAX(tk1(k),TKmin)*sqc1(k) - xlscp/MAX(tk1(k),TKmin)*sqi1(k)) + !thetav(k) = th1(k)*(1.+p608)*sqv1(k) + enddo + +!----------------------------------------------------------------------------------------------------------------- +!initflag > 0: +!----------------------------------------------------------------------------------------------------------------- + if(initflag > 0 .and. .not.restart) then + + !test to see if we want to initialize qke1: + if((restart .or. cycling)) then + if(qke1(kts) < 0.0002) then + initialize_qke = .true. + else + initialize_qke = .false. + endif + else ! not cycling or restarting: + initialize_qke = .true. + endif + + if(.not.restart .or. .not.cycling) then + do k = kts,kte + sh1(k) = 0._kind_phys + sm1(k) = 0._kind_phys + el_pbl1(k) = 0._kind_phys + tsq1(k) = 0._kind_phys + qsq1(k) = 0._kind_phys + cov1(k) = 0._kind_phys + cldfra_bl1(k) = 0._kind_phys + qc_bl1(k) = 0._kind_phys + qi_bl1(k) = 0._kind_phys + qke1(k) = 0._kind_phys + enddo + endif + do k = kts,kte + cldfra_bl1_old(k) = 0._kind_phys + qc_bl1_old(k) = 0._kind_phys + qi_bl1_old(k) = 0._kind_phys + enddo + + if(initialize_qke) then + do k = kts,kte + qke1(k)=5.*ust1*max((ust1*700.-zw(k))/(max(ust1,0.01)*700.),0.01) + enddo + endif + + !--- computes the PBL height: + call get_pblh(kts,kte,pblh1,thetav,qke1,zw,dz1,xland1,kpbl1) + + !--- computes the similarity functions: + if(bl_mynn_scaleaware) then + call scale_aware(dx1,pblh1,psig_bl,psig_shcu) + else + psig_bl = 1._kind_phys + psig_shcu = 1._kind_phys + endif + + !--- calls mym_initialize: + call mym_initialize( & + kts,kte,xland1, & + dz1,dx1,zw, & + u1,v1,thl,sqv1, & + pblh1,th1,thetav,sh1,sm1, & + ust1, rmol1, & + el_pbl1,qke1,tsq1,qsq1,cov1, & + psig_bl,cldfra_bl1, & + bl_mynn_mixlength, & + edmf_w1,edmf_a1, & + initialize_qke, & + spp_pbl,rstoch_col) + + endif +!----------------------------------------------------------------------------------------------------------------- +!end initflag > 0: +!----------------------------------------------------------------------------------------------------------------- + + + if(bl_mynn_tkeadvect) then + do k = kts,kte + qke1(k) = qke_adv1(k) + enddo + endif + !Joe-TKE budget: + if(bl_mynn_tkebudget) then + do k = kts,kte + dqke1(k) = qke1(k) + enddo + endif + if(icloud_bl > 0) then + do k = kts,kte + cldfra_bl1_old(k) = cldfra_bl1(k) + qc_bl1_old(k) = qc_bl1(k) + qi_bl1_old(k) = qi_bl1(k) + enddo + endif + + !--- computes the PBL height: + call get_pblh(kts,kte,pblh1,thetav,qke1,zw,dz1,xland1,kpbl1) + + !--- computes the similarity functions: + if(bl_mynn_scaleaware) then + call scale_aware(dx1,pblh1,psig_bl,psig_shcu) + else + psig_bl = 1._kind_phys + psig_shcu = 1._kind_phys + endif + + sqcg = 0.0 !ill-defined variable; qcg has been removed + cpm = cp*(1.+0.84*qv1(kts)) + exnerg = (ps1/p1000mb)**rcp + + !----------------------------------------------------- + !ORIGINAL CODE + !flt = hfx(i)/( rho(i,kts)*cpm ) & + ! +xlvcp*ch(i)*(sqc(kts)/exner(i,kts) -sqcg/exnerg) + !flq = qfx(i)/ rho(i,kts) & + ! -ch(i)*(sqc(kts) -sqcg ) + !----------------------------------------------------- + flqv = qfx1/rho1(kts) + flqc = 0.0 !currently no sea-spray fluxes, fog settling hangled elsewhere + th_sfc = ts1/ex1(kts) + + !--- turbulent flux for the TKE voundary conditions: + flq = flqv + flqc ! Latent + flt = hfx1/(rho1(kts)*cpm ) - xlvcp*flqc/ex1(kts) ! Temperature flux + fltv = flt + flqv*p608*th_sfc ! Virtual temperature flux + + !--- update 1/L using updated sfc heat flux and friction velocity: + rmol1 = -karman*gtr*fltv/max(ust1**3,1.0e-6) + zet = 0.5*dz1(kts)*rmol1 + zet = max(zet, -20.) + zet = min(zet, 20.) + + !if(i.eq.idbg)print*,"updated z/L=",zet + if(bl_mynn_stfunc == 0) then + !original Kansas-type stability functions: + if(zet >= 0.0) then + pmz = 1.0 + (cphm_st-1.0) * zet + phh = 1.0 + cphh_st * zet + else + pmz = 1.0/ (1.0-cphm_unst*zet)**0.25 - zet + phh = 1.0/sqrt(1.0-cphh_unst*zet) + endif + phi_m = pmz + zet + else + !updated stability functions (Puhales, 2020): + phi_m = phim(zet) + pmz = phi_m - zet + phh = phih(zet) + endif + + !call mym_condensation() to calculate the nonconvective component of the subgrid-scale cloud fraction + !and mixing ratio as well as the functions used to calculate the buoyancy flux. Different cloud PDFs + !can be selected by use of the namelist parameter bl_mynn_cloudpdf: + do k = kts,kte + vt(k) = 0._kind_phys + vq(k) = 0._kind_phys + sgm(k) = 0._kind_phys + enddo + + call mym_condensation(kts,kte, & + dx1,dz1,zw,xland1, & + thl,sqw,sqv1,sqc1,sqi1,sqs1, & + p1,ex1,tsq1,qsq1,cov1, & + sh1,el_pbl1,bl_mynn_cloudpdf, & + qc_bl1,qi_bl1,cldfra_bl1, & + pblh1,hfx1, & + vt,vq,th1,sgm,rmol1, & + spp_pbl,rstoch_col) + + + !add TKE source driven by cloud top cooling. calculate the buoyancy production of tke from cloud-top + !cooling when bl_mynn_topdown = .true. + if(bl_mynn_topdown)then + call topdown_cloudrad(kts,kte,dz1,zw,fltv, & + xland1,kpbl1,pblh1, & + sqc1,sqi1,sqw,thl,th1,ex1,p1,rho1,thetav, & + cldfra_bl1,rthraten1, & + maxkhtopdown,khtopdown,tkeprodtd) + else + maxkhtopdown = 0._kind_phys + do k = kts,kte + khtopdown(k) = 0._kind_phys + tkeprodtd(k) = 0._kind_phys + enddo + endif + + + !--- calls subroutine dmp_mf(): + if(bl_mynn_edmf) then + call dmp_mf( i, & + kts,kte,delt,zw,dz1,p1,rho1, & + bl_mynn_edmf_mom, & + bl_mynn_edmf_tke, & + bl_mynn_mixscalars, & + u1,v1,w1,th1,thl,thetav,tk1, & + sqw,sqv1,sqc1,qke1, & + qnc1,qni1,qnwfa1,qnifa1,qnbca1, & + ex1,vt,vq,sgm, & + ust1,flt,fltv,flq,flqv, & + pblh1,kpbl1,dx1, & + xland1,th_sfc, & + !now outputs - tendencies + !dth1mf,dqv1mf,dqc1mf,du1mf,dv1mf, & + !outputs - updraft properties + edmf_a1,edmf_w1,edmf_qt1, & + edmf_thl1,edmf_ent1,edmf_qc1, & + !for the solver + s_aw1,s_awthl1,s_awqt1, & + s_awqv1,s_awqc1, & + s_awu1,s_awv1,s_awqke1, & + s_awqnc1,s_awqni1, & + s_awqnwfa1,s_awqnifa1,s_awqnbca1, & + sub_thl1,sub_sqv1, & + sub_u,sub_v, & + det_thl1,det_sqv1,det_sqc, & + det_u,det_v, & + !chem/smoke mixing + nchem,chem1,s_awchem1, & + mix_chem, & + qc_bl1,cldfra_bl1, & + qc_bl1_old,cldfra_bl1_old, & + flag_qc,flag_qi, & + flag_qnc,flag_qni, & + flag_qnwfa,flag_qnifa,flag_qnbca, & + psig_shcu, & + maxwidth1,ktop_plume1, & + maxmf1,ztop_plume1, & + spp_pbl,rstoch_col) + + if(bl_mynn_edmf_dd) then + call ddmf_jpl(kts,kte,delt,zw,dz1,p1, & + u1,v1,th1,thl,thetav,tk1, & + sqw,sqv1,sqc1,rho1,ex1, & + ust1,flt,flq, & + pblh1,kpbl1, & + edmf_a_dd1,edmf_w_dd1,edmf_qt_dd1, & + edmf_thl_dd1,edmf_ent_dd1, & + edmf_qc_dd1, & + sd_aw1,sd_awthl1,sd_awqt1, & + sd_awqv1,sd_awqc1,sd_awu1,sd_awv1, & + sd_awqke1, & + qc_bl1,cldfra_bl1, & + rthraten) + endif + endif + + + !--- capability to substep the eddy-diffusivity portion: + !do nsub = 1,2 + delt2 = delt !*0.5 !only works if topdown=0 + + call mym_turbulence & + (kts,kte,xland1,bl_mynn_closure, & + dz1,dx1,zw, & + u1,v1,thl,thetav,sqc1,sqw, & + qke1,tsq1,qsq1,cov1, & + vt,vq, & + rmol1,flt,fltv,flq, & + pblh1,th1, & + sh1,sm1,el_pbl1, & + dfm,dfh,dfq, & + tcd,qcd,pdk, & + pdt,pdq,pdc, & + qwt1,qshear1,qbuoy1,qdiss1, & + bl_mynn_tkebudget, & + psig_bl,psig_shcu, & + cldfra_bl1,bl_mynn_mixlength, & + edmf_w1,edmf_a1, & + tkeprodtd, & + spp_pbl,rstoch_col) + + + !--- calls subroutine mym_predict() to solve TKE: + call mym_predict & + (kts,kte,bl_mynn_closure, & + delt2,dz1, & + ust1,flt,flq,pmz,phh, & + el_pbl1,dfq,rho1,pdk,pdt,pdq,pdc, & + qke1,tsq1,qsq1,cov1, & + s_aw1,s_awqke1,bl_mynn_edmf_tke, & + qwt1,qdiss1,bl_mynn_tkebudget) ! TKE budget (Puhales 2020) + + if(bl_mynn_dheatopt) then + do k = kts,kte-1 + !set max dissipative heating rate to 7.2 K per hour + diss_heat(k) = min(max(1.0*(qke1(k)**1.5)/(b1*max(0.5*(el_pbl1(k)+el_pbl1(k+1)),1.))/cp,0.0),0.002) + + !limit heating above 100 mb: + diss_heat(k) = diss_heat(k) * exp(-10000./MAX(p1(k),1.)) + enddo + diss_heat(kte) = 0. + else + do k = kts,kte + diss_heat(k) = 0. + enddo + endif + + + !--- call to subroutine mynn_tendencies: + call mynn_tendencies(kts,kte, & + delt,dz1,rho1, & + u1,v1,th1,tk1,qv1, & + qc1,qi1,kzero,qnc1,qni1, & !kzero replaces qs1 - not mixing snow + ps1,p1,ex1,thl, & + sqv1,sqc1,sqi1,kzero,sqw, & !kzero replaces sqs - not mxing snow + qnwfa1,qnifa1,qnbca1,qozone1, & + ust1,flt,flq,flqv,flqc, & + wspd1,uoce1,voce1, & + tsq1,qsq1,cov1, & + tcd,qcd, & + dfm,dfh,dfq, & + du1,dv1,dth1,dqv1, & + dqc1,dqi1,dqs1,dqnc1,dqni1, & + dqnwfa1,dqnifa1,dqnbca1, & + dqozone1, & + diss_heat, & + !mass flux components + s_aw1,s_awthl1,s_awqt1, & + s_awqv1,s_awqc1,s_awu1,s_awv1, & + s_awqnc1,s_awqni1, & + s_awqnwfa1,s_awqnifa1,s_awqnbca1, & + sd_aw1,sd_awthl1,sd_awqt1, & + sd_awqv1,sd_awqc1, & + sd_awu1,sd_awv1, & + sub_thl1,sub_sqv1, & + sub_u,sub_v, & + det_thl1,det_sqv1,det_sqc, & + det_u,det_v, & + flag_qc,flag_qi,flag_qnc, & + flag_qni,flag_qs, & + flag_qnwfa,flag_qnifa, & + flag_qnbca,flag_qoz, & + cldfra_bl1, & + bl_mynn_cloudmix, & + bl_mynn_mixqt, & + bl_mynn_edmf_mom, & + bl_mynn_mixscalars) + + + !--- call to subroutine mynn_mix_chem for PBL and tropospheric mixing of + ! chemical species: + if(mix_chem) then + if(rrfs_sd) then + call mynn_mix_chem(kts,kte, & + delt,dz1,pblh1, & + nchem,kdvel,ndvel, & + chem1,vd1, & + rho1,flt, & + tcd,qcd, & + dfh, & + s_aw1,s_awchem1, & + emis_ant_no1, & + frp1,rrfs_sd, & + enh_mix,smoke_dbg) + else + call mynn_mix_chem(kts,kte, & + delt,dz1,pblh1, & + nchem,kdvel,ndvel, & + chem1,vd1, & + rho1,flt, & + tcd,qcd, & + dfh, & + s_aw1,s_awchem1, & + zero, & + zero,rrfs_sd, & + enh_mix,smoke_dbg) + endif + endif +#if(WRF == 1) + !directly updates chem3 instead of computing a tendency: + do ic = 1,nchem + do k = kts,kte + chem(i,k,ic) = max(1.e-12,chem1(k,ic)) + enddo + enddo +#endif + + + !--- computes the exchange coefficients: + call retrieve_exchange_coeffs(kts,kte,dfm,dfh,dz1,exch_m1,exch_h1) + + +!----------------------------------------------------------------------------------------------------------------- +!begin output of 2D variables: +!----------------------------------------------------------------------------------------------------------------- + !output tendencies: + do k = kts,kte + rublten(i,k) = du1(k) + rvblten(i,k) = dv1(k) + rthblten(i,k) = dth1(k) + rqvblten(i,k) = dqv1(k) + enddo + if(bl_mynn_cloudmix .and. flag_qc) then + do k = kts,kte + rqcblten(i,k) = dqc1(k) + enddo + endif + if(bl_mynn_cloudmix .and. flag_qi) then + do k = kts,kte + rqiblten(i,k) = dqi1(k) + enddo + endif + if(bl_mynn_cloudmix .and. flag_qs) then + do k = kts,kte + rqsblten(i,k) = dqs1(k) + enddo + endif + if(bl_mynn_cloudmix .and. bl_mynn_mixscalars .and. flag_qnc) then + do k = kts,kte + rqncblten(i,k) = dqnc1(k) + enddo + endif + if(bl_mynn_cloudmix .and. bl_mynn_mixscalars .and. flag_qni) then + do k = kts,kte + rqniblten(i,k) = dqni1(k) + enddo + endif + if(bl_mynn_cloudmix .and. bl_mynn_mixscalars .and. flag_qnifa) then + do k = kts,kte + rqnifablten(i,k) = dqnifa1(k) + enddo + endif + if(bl_mynn_cloudmix .and. bl_mynn_mixscalars .and. flag_qnwfa) then + do k = kts,kte + rqnwfablten(i,k) = dqnwfa1(k) + enddo + endif + if(bl_mynn_cloudmix .and. bl_mynn_mixscalars .and. flag_qnbca) then + do k = kts,kte + rqnbcablten(i,k) = dqnbca1(k) + enddo + endif + do k = kts,kte + rqozblten(i,k) = 0._kind_phys + enddo + + !inout arrays: + kpbl(i) = kpbl1 + ktop_plume(i) = ktop_plume1 + + pblh(i) = pblh1 + + do k = kts,kte + cldfra_bl(i,k) = cldfra_bl1(k) + qc_bl(i,k) = qc_bl1(k) + qi_bl(i,k) = qi_bl1(k) + enddo + + do k = kts,kte + el_pbl(i,k) = el_pbl1(k) + qke(i,k) = qke1(k) + qke_adv(i,k) = qke_adv1(k) + cov(i,k) = cov1(k) + qsq(i,k) = qsq1(k) + tsq(i,k) = tsq1(k) + sh(i,k) = sh1(k) + sm(i,k) = sm1(k) + enddo + + + !the TKE budget is now given in m**2/s**-3 (Puhales, 2020): + if(present(qwt) .and. present(qbuoy) .and. present(qshear) .and. & + present(qdiss) .and. present(dqke)) then + if(bl_mynn_tkebudget) then + !lower boundary condtions (using similarity relationships such as the prognostic equation for Qke) + k = kts + qshear1(k) = 4.*(ust1**3*phi_m/(karman*dz1(k)))-qshear1(k+1) ! staggered + qbuoy1(k) = 4.*(-ust1**3*zet/(karman*dz1(k)))-qbuoy1(k+1) ! staggered + + !unstaggering shear and buoy and trasnfering all TKE budget to 2D arrays: + do k = kts,kte-1 + qshear(i,k) = 0.5*(qshear1(k) + qshear1(k+1)) ! unstaggering in z + qbuoy(i,k) = 0.5*(qbuoy1(k) + qbuoy1(k+1)) ! unstaggering in z + qwt(i,k) = qwt1(k) + qdiss(i,k) = qdiss1(k) + dqke(i,k) = (qke1(k)-dqke(i,k))*0.5/delt + enddo + !upper boundary conditions + k = kte + qshear(i,k) = 0._kind_phys + qbuoy(i,k) = 0._kind_phys + qwt(i,k) = 0._kind_phys + qdiss(i,k) = 0._kind_phys + dqke(i,k) = 0._kind_phys + else + do k = kts,kte + qshear(i,k) = 0._kind_phys + qbuoy(i,k) = 0._kind_phys + qwt(i,k) = 0._kind_phys + qdiss(i,k) = 0._kind_phys + dqke(i,k) = 0._kind_phys + enddo + endif + endif + + + !optional inout arrays for updraft/downdraft properties: + if(bl_mynn_edmf .and. bl_mynn_output) then + do k = kts,kte + edmf_a(i,k) = edmf_a1(k) + edmf_w(i,k) = edmf_w1(k) + edmf_qt(i,k) = edmf_qt1(k) + edmf_thl(i,k) = edmf_thl1(k) + edmf_ent(i,k) = edmf_ent1(k) + edmf_qc(i,k) = edmf_qc1(k) + sub_thl(i,k) = sub_thl1(k) + sub_sqv(i,k) = sub_sqv1(k) + det_thl(i,k) = det_thl1(k) + det_sqv(i,k) = det_sqv1(k) + enddo + else + do k = kts,kte + edmf_a(i,k) = 0._kind_phys + edmf_w(i,k) = 0._kind_phys + edmf_qt(i,k) = 0._kind_phys + edmf_thl(i,k) = 0._kind_phys + edmf_ent(i,k) = 0._kind_phys + edmf_qc(i,k) = 0._kind_phys + sub_thl(i,k) = 0._kind_phys + sub_sqv(i,k) = 0._kind_phys + det_thl(i,k) = 0._kind_phys + det_sqv(i,k) = 0._kind_phys + enddo + endif + if(bl_mynn_edmf_dd .and. bl_mynn_output) then + if(present(edmf_a_dd) .and. present(edmf_w_dd) .and. present(edmf_qt_dd) .and. & + present(edmf_thl_dd) .and. present(edmf_ent_dd) .and. present(edmf_qc_dd)) then + do k = kts,kte + edmf_a_dd(i,k) = edmf_a_dd1(k) + edmf_w_dd(i,k) = edmf_w_dd1(k) + edmf_qt_dd(i,k) = edmf_qt_dd1(k) + edmf_thl_dd(i,k) = edmf_thl_dd1(k) + edmf_ent_dd(i,k) = edmf_ent_dd1(k) + edmf_qc_dd(i,k) = edmf_qc_dd1(k) + enddo + endif + endif + + !output arrays: + maxwidth(i) = maxwidth1 + maxmf(i) = maxmf1 + ztop_plume(i) = ztop_plume1 + + do k = kts,kte + exch_h(i,k) = exch_h1(k) + exch_m(i,k) = exch_m1(k) + enddo + + enddo + + end subroutine bl_mynn_run + +!================================================================================================================= + end module bl_mynn +!================================================================================================================= diff --git a/src/core_atmosphere/physics/physics_mmm/bl_mynn_subroutines.F b/src/core_atmosphere/physics/physics_mmm/bl_mynn_subroutines.F new file mode 100644 index 0000000000..324c368517 --- /dev/null +++ b/src/core_atmosphere/physics/physics_mmm/bl_mynn_subroutines.F @@ -0,0 +1,6565 @@ +!================================================================================================================= + module bl_mynn_common + use mpas_kind_types,only: kind_phys => RKIND + + implicit none + save + + +!--- physics constants that need to be initialized with physics constants from the host model: + real(kind=kind_phys):: cp ! defined in bl_mynn_init. + real(kind=kind_phys):: cpv ! defined in bl_mynn_init. + real(kind=kind_phys):: cice ! defined in bl_mynn_init. + real(kind=kind_phys):: cliq ! defined in bl_mynn_init. + + real(kind=kind_phys):: ep_1 ! defined in bl_mynn_init. + real(kind=kind_phys):: ep_2 ! defined in bl_mynn_init. + + real(kind=kind_phys):: grav ! defined in bl_mynn_init. + + real(kind=kind_phys):: karman ! defined in bl_mynn_init. + real(kind=kind_phys):: p1000mb ! defined in bl_mynn_init. + + real(kind=kind_phys):: rcp ! defined in bl_mynn_init. + real(kind=kind_phys):: r_d ! defined in bl_mynn_init. + real(kind=kind_phys):: r_v ! defined in bl_mynn_init. + real(kind=kind_phys):: rvovrd ! defined in bl_mynn_init. + + real(kind=kind_phys):: svp1 ! defined in bl_mynn_init. + real(kind=kind_phys):: svp2 ! defined in bl_mynn_init. + real(kind=kind_phys):: svp3 ! defined in bl_mynn_init. + real(kind=kind_phys):: svpt0 ! defined in bl_mynn_init. + + real(kind=kind_phys):: xlf ! defined in bl_mynn_init. + real(kind=kind_phys):: xlv ! defined in bl_mynn_init. + real(kind=kind_phys):: xls ! defined in bl_mynn_init. + + +!--- derived physics constants: + real(kind=kind_phys):: ep_3 + real(kind=kind_phys):: gtr + real(kind=kind_phys):: p608 + real(kind=kind_phys):: t0c + real(kind=kind_phys):: tv0 + real(kind=kind_phys):: xlscp + real(kind=kind_phys):: xlvcp + +!real(kind=kind_phys):: ev +!real(kind=kind_phys):: rk +!real(kind=kind_phys):: svp11 +!real(kind=kind_phys):: tv1 +!real(kind=kind_phys):: vk + + +!--- parameters: + real(kind=kind_phys),parameter:: tice = 240.0 !-33 (C), temp at saturation w.r.t. ice + real(kind=kind_phys),parameter:: tkmin = 253.0 + real(kind=kind_phys),parameter:: tref = 300.0 + real(kind=kind_phys),parameter:: onethird = 1./3. + real(kind=kind_phys),parameter:: twothirds = 2./3. + real(kind=kind_phys),parameter:: zero = 0._kind_phys + + +!--- physics constants also needed in subroutine bl_mynn_run: + real(kind=kind_phys),parameter:: b1 = 24.0 + real(kind=kind_phys),parameter:: b2 = 15.0 + + real(kind=kind_phys),parameter:: cphh_st = 5.0 + real(kind=kind_phys),parameter:: cphm_st = 5.0 + real(kind=kind_phys),parameter:: cphh_unst = 16.0 + real(kind=kind_phys),parameter:: cphm_unst = 16.0 + + end module bl_mynn_common + +!================================================================================================================= +!>\file module_bl_mynn.F90 +!! This file contains the entity of MYNN-EDMF PBL scheme. +! ********************************************************************** +! * An improved Mellor-Yamada turbulence closure model * +! * * +! * Original author: M. Nakanishi (N.D.A), naka@nda.ac.jp * +! * Translated into F90 and implemented in WRF-ARW by: * +! * Mariusz Pagowski (NOAA-GSL) * +! * Subsequently developed by: * +! * Joseph Olson, Jaymes Kenyon (NOAA/GSL), * +! * Wayne Angevine (NOAA/CSL), Kay Suselj (NASA/JPL), * +! * Franciano Puhales (UFSM), Laura Fowler (NCAR), * +! * Elynn Wu (UCSD), and Jordan Schnell (NOAA/GSL) * +! * * +! * Contents: * +! * * +! * mynn_bl_driver - main subroutine which calls all other routines * +! * -------------- * +! * 1. mym_initialize (to be called once initially) * +! * gives the closure constants and initializes the turbulent * +! * quantities. * +! * 2. get_pblh * +! * Calculates the boundary layer height * +! * 3. scale_aware * +! * Calculates scale-adaptive tapering functions * +! * 4. mym_condensation * +! * determines the liquid water content and the cloud fraction * +! * diagnostically. * +! * 5. dmp_mf * +! * Calls the (nonlocal) mass-flux component * +! * 6. ddmf_jpl * +! * Calls the downdraft mass-flux component * +! * (-) mym_level2 (called in the other subroutines) * +! * calculates the stability functions at Level 2. * +! * (-) mym_length (called in the other subroutines) * +! * calculates the master length scale. * +! * 7. mym_turbulence * +! * calculates the vertical diffusivity coefficients and the * +! * production terms for the turbulent quantities. * +! * 8. mym_predict * +! * predicts the turbulent quantities at the next step. * +! * * +! * call mym_initialize * +! * | * +! * |<----------------+ * +! * | | * +! * call get_pblh | * +! * call scale_aware | * +! * call mym_condensation | * +! * call dmp_mf | * +! * call ddmf_jpl | * +! * call mym_turbulence | * +! * call mym_predict | * +! * | | * +! * |-----------------+ * +! * | * +! * end * +! * * +! * Variables worthy of special mention: * +! * tref : Reference temperature * +! * thl : Liquid water potential temperature * +! * qw : Total water (water vapor+liquid water) content * +! * ql : Liquid water content * +! * vt, vq : Functions for computing the buoyancy flux * +! * qke : 2 * TKE * +! * el : mixing length * +! * * +! * If the water contents are unnecessary, e.g., in the case of * +! * ocean models, thl is the potential temperature and qw, ql, vt * +! * and vq are all zero. * +! * * +! * Grid arrangement: * +! * k+1 +---------+ * +! * | | i = 1 - nx * +! * (k) | * | k = 1 - nz * +! * | | * +! * k +---------+ * +! * i (i) i+1 * +! * * +! * All the predicted variables are defined at the center (*) of * +! * the grid boxes. The diffusivity coefficients and two of their * +! * components (el and stability functions sh & sm) are, however, * +! * defined on the walls of the grid boxes. * +! * # Upper boundary values are given at k=nz. * +! * * +! * References: * +! * 1. Nakanishi, M., 2001: * +! * Boundary-Layer Meteor., 99, 349-378. * +! * 2. Nakanishi, M. and H. Niino, 2004: * +! * Boundary-Layer Meteor., 112, 1-31. * +! * 3. Nakanishi, M. and H. Niino, 2006: * +! * Boundary-Layer Meteor., 119, 397-407. * +! * 4. Nakanishi, M. and H. Niino, 2009: * +! * Jour. Meteor. Soc. Japan, 87, 895-912. * +! * 5. Olson J. and coauthors, 2019: A description of the * +! * MYNN-EDMF scheme and coupling to other components in * +! * WRF-ARW. NOAA Tech. Memo. OAR GSD, 61, 37 pp., * +! * https://doi.org/10.25923/n9wm-be49. * +! * 6. Puhales, Franciano S. and coauthors, 2020: Turbulent * +! * Kinetic Energy Budget for MYNN-EDMF PBL Scheme in WRF model.* +! * Universidade Federal de Santa Maria Technical Note. 9 pp. * +! ********************************************************************** +! ================================================================== +! Notes on original implementation into WRF-ARW +! changes to original code: +! 1. code is 1D (in z) +! 2. option to advect TKE, but not the covariances and variances +! 3. Cranck-Nicholson replaced with the implicit scheme +! 4. removed terrain-dependent grid since input in WRF in actual +! distances in z[m] +! 5. cosmetic changes to adhere to WRF standard (remove common blocks, +! intent etc) +!------------------------------------------------------------------- +! Further modifications post-implementation +! +! 1. Addition of BouLac mixing length in the free atmosphere. +! 2. Changed the turbulent mixing length to be integrated from the +! surface to the top of the BL + a transition layer depth. +! v3.4.1: Option to use Kitamura/Canuto modification which removes +! the critical Richardson number and negative TKE (default). +! Hybrid PBL height diagnostic, which blends a theta-v-based +! definition in neutral/convective BL and a TKE-based definition +! in stable conditions. +! TKE budget output option +! v3.5.0: TKE advection option (bl_mynn_tkeadvect) +! v3.5.1: Fog deposition related changes. +! v3.6.0: Removed fog deposition from the calculation of tendencies +! Added mixing of qc, qi, qni +! Added output for wstar, delta, TKE_PBL, & KPBL for correct +! coupling to shcu schemes +! v3.8.0: Added subgrid scale cloud output for coupling to radiation +! schemes (activated by setting icloud_bl =1 in phys namelist). +! Added WRF_DEBUG prints (at level 3000) +! Added Tripoli and Cotton (1981) correction. +! Added namelist option bl_mynn_cloudmix to test effect of mixing +! cloud species (default = 1: on). +! Added mass-flux option (bl_mynn_edmf, = .true. for DMP mass-flux, .false.: off). +! Related options: +! bl_mynn_edmf_mom = .true. : activate momentum transport in MF scheme +! bl_mynn_edmf_tke = .true. : activate TKE transport in MF scheme +! Added mixing length option (bl_mynn_mixlength, see notes below) +! Added more sophisticated saturation checks, following Thompson scheme +! Added new cloud PDF option (bl_mynn_cloudpdf = 2) from Chaboureau +! and Bechtold (2002, JAS, with mods) +! Added capability to mix chemical species when env variable +! WRF_CHEM = 1, thanks to Wayne Angevine. +! Added scale-aware mixing length, following Junshi Ito's work +! Ito et al. (2015, BLM). +! v3.9.0 Improvement to the mass-flux scheme (dynamic number of plumes, +! better plume/cloud depth, significant speed up, better cloud +! fraction). +! Added Stochastic Parameter Perturbation (SPP) implementation. +! Many miscellaneous tweaks to the mixing lengths and stratus +! component of the subgrid clouds. +! v.4.0 Removed or added alternatives to WRF-specific functions/modules +! for the sake of portability to other models. +! the sake of portability to other models. +! Further refinement of mass-flux scheme from SCM experiments with +! Wayne Angevine: switch to linear entrainment and back to +! Simpson and Wiggert-type w-equation. +! Addition of TKE production due to radiation cooling at top of +! clouds (proto-version); not activated by default. +! Some code rewrites to move if-thens out of loops in an attempt to +! improve computational efficiency. +! New tridiagonal solver, which is supposedly 14% faster and more +! conservative. Impact seems very small. +! Many miscellaneous tweaks to the mixing lengths and stratus +! component of the subgrid-scale (SGS) clouds. +! v4.1 Big improvements in downward SW radiation due to revision of subgrid clouds +! - better cloud fraction and subgrid scale mixing ratios. +! - may experience a small cool bias during the daytime now that high +! SW-down bias is greatly reduced... +! Some tweaks to increase the turbulent mixing during the daytime for +! bl_mynn_mixlength option 2 to alleviate cool bias (very small impact). +! Improved ensemble spread from changes to SPP in MYNN +! - now perturbing eddy diffusivity and eddy viscosity directly +! - now perturbing background rh (in SGS cloud calc only) +! - now perturbing entrainment rates in mass-flux scheme +! Added IF checks (within IFDEFS) to protect mixchem code from being used +! when HRRR smoke is used (no impact on regular non-wrf chem use) +! Important bug fix for wrf chem when transporting chemical species in MF scheme +! Removed 2nd mass-flux scheme (no only bl_mynn_edmf = 1, no option 2) +! Removed unused stochastic code for mass-flux scheme +! Changed mass-flux scheme to be integrated on interface levels instead of +! mass levels - impact is small +! Added option to mix 2nd moments in MYNN as opposed to the scalar_pblmix option. +! - activated with bl_mynn_mixscalars = .true.; this sets scalar_pblmix = 0 +! - added tridagonal solver used in scalar_pblmix option to duplicate tendencies +! - this alone changes the interface call considerably from v4.0. +! Slight revision to TKE production due to radiation cooling at top of clouds +! Added the non-Guassian buoyancy flux function of Bechtold and Siebesma (1998, JAS). +! - improves TKE in SGS clouds +! Added heating due to dissipation of TKE (small impact, maybe + 0.1 C daytime PBL temp) +! Misc changes made for FV3/MPAS compatibility +! v4.2 A series of small tweaks to help reduce a cold bias in the PBL: +! - slight increase in diffusion in convective conditions +! - relaxed criteria for mass-flux activation/strength +! - added capability to cycle TKE for continuity in hourly updating HRRR +! - added effects of compensational environmental subsidence in mass-flux scheme, +! which resulted in tweaks to detrainment rates. +! Bug fix for diagnostic-decay of SGS clouds - noticed by Greg Thompson. This has +! a very small, but primarily positive, impact on SW-down biases. +! Tweak to calculation of KPBL - urged by Laura Fowler - to make more intuitive. +! Tweak to temperature range of blending for saturation check (water to ice). This +! slightly reduces excessive SGS clouds in polar region. No impact warm clouds. +! Added namelist option bl_mynn_output (.false. or .true.) to suppress or activate the +! allocation and output of 10 3D variables. Most people will want this +! set to 0 (default) to save memory and disk space. +! Added new array qi_bl as opposed to using qc_bl for both SGS qc and qi. This +! gives us more control of the magnitudes which can be confounded by using +! a single array. As a results, many subroutines needed to be modified, +! especially mym_condensation. +! Added the blending of the stratus component of the SGS clouds to the mass-flux +! clouds to account for situations where stratus and cumulus may exist in the +! grid cell. +! Misc small-impact bugfixes: +! 1) dz was incorrectly indexed in mym_condensation +! 2) configurations with icloud_bl = 0 were using uninitialized arrays +! v4.5 / CCPP +! This version includes many modifications that proved valuable in the global +! framework and removes some key lingering bugs in the mixing of chemical species. +! TKE Budget output fixed (Puhales, 2020-12) +! New option for stability function: (Puhales, 2020-12) +! bl_mynn_stfunc = 0 (original, Kansas-type function, Paulson, 1970 ) +! bl_mynn_stfunc = 1 (expanded range, same as used for Jimenez et al (MWR) +! see the Technical Note for this implementation (small impact). +! Improved conservation of momentum and higher-order moments. +! Important bug fixes for mixing of chemical species. +! Addition of pressure-gradient effects on updraft momentum transport. +! Addition of bl_mynn_closure option = 2.5, 2.6, or 3.0 +! Addition of higher-order moments for sigma when using +! bl_mynn_cloudpdf = 2 (Chab-Becht). +! Removed WRF_CHEM dependencies. +! Many miscellaneous tweaks. +! v4.6 / CCPP +! Some code optimization. Removed many conditions from loops. Redesigned the mass- +! flux scheme to use 8 plumes instead of a variable n plumes. This results in +! the removal of the output variable "nudprafts" and adds maxwidth and ztop_plume. +! Revision option bl_mynn_cloudpdf = 2, which now ensures cloud fractions for all +! optically relevant mixing ratios (tip from Greg Thompson). Also, added flexibility +! for tuning near-surface cloud fractions to remove excess fog/low ceilings. +! Now outputs all SGS cloud mixing ratios as grid-mean values, not in-cloud. This +! results in a change in the pre-radiation code to no longer multiply mixing ratios +! by cloud fractions. +! Bug fix for the momentum transport. +! Lots of code cleanup: removal of test code, comments, changing text case, etc. +! Many misc tuning/tweaks. +! +! Many of these changes are now documented in references listed above. +!==================================================================== +MODULE bl_mynn_subroutines + use mpas_kind_types,only: kind_phys => RKIND,kind_phys8 => R8KIND + use bl_mynn_common,only: & + b1 , b2 , cice , cliq , cp , & + cpv , ep_2 , ep_3 , grav , gtr , & + karman , onethird , p1000mb , p608 , r_d , & + r_v , rcp , rvovrd , svp1 , t0c , & + tice , tkmin , tv0 , twothirds , xls , & + xlscp , xlv , xlvcp , cphh_st , cphm_st , & + cphh_unst , cphm_unst + + use mynn_shared,only: esat_blend,qsat_blend,xl_blend + + implicit none + private + public:: dmp_mf, & + ddmf_jpl, & + topdown_cloudrad, & + get_pblh, & + mym_condensation, & + mym_initialize, & + mynn_mix_chem, & + mym_predict, & + mym_turbulence, & + mynn_tendencies, & + phih, & + phim, & + retrieve_exchange_coeffs, & + scale_aware + +!=================================================================== +! From here on, these are MYNN-specific parameters: +! The parameters below depend on stability functions of module_sf_mynn. + +! Closure constants + real(kind_phys), parameter :: & + &pr = 0.74, & + &g1 = 0.235, & ! NN2009 = 0.235 +! &b1 = 24.0, & +! &b2 = 15.0, & ! CKmod NN2009 + &c2 = 0.729, & ! 0.729, & !0.75, & + &c3 = 0.340, & ! 0.340, & !0.352, & + &c4 = 0.0, & + &c5 = 0.2, & + &a1 = b1*( 1.0-3.0*g1 )/6.0, & +! &c1 = g1 -1.0/( 3.0*a1*b1**(1.0/3.0) ), & + &c1 = g1 -1.0/( 3.0*a1*2.88449914061481660), & + &a2 = a1*( g1-c1 )/( g1*pr ), & + &g2 = b2/b1*( 1.0-c3 ) +2.0*a1/b1*( 3.0-2.0*c2 ) + + real(kind_phys), parameter :: & + &cc2 = 1.0-c2, & + &cc3 = 1.0-c3, & + &e1c = 3.0*a2*b2*cc3, & + &e2c = 9.0*a1*a2*cc2, & + &e3c = 9.0*a2*a2*cc2*( 1.0-c5 ), & + &e4c = 12.0*a1*a2*cc2, & + &e5c = 6.0*a1*a1 + +! Constants for min tke in elt integration (qmin), max z/L in els (zmax), +! and factor for eddy viscosity for TKE (Kq = Sqfac*Km): + real(kind_phys), parameter :: qmin=0.0, zmax=1.0, Sqfac=3.0 +! Note that the following mixing-length constants are now specified in mym_length +! &cns=3.5, alp1=0.23, alp2=0.3, alp3=3.0, alp4=10.0, alp5=0.2 + + real(kind_phys), parameter :: gpw=5./3., qcgmin=1.e-8, qkemin=1.e-12 + real(kind_phys), parameter :: tliq = 269. !all hydrometeors are liquid when T > tliq + +! Constants for cloud PDF (mym_condensation) + real(kind_phys), parameter :: rr2=0.7071068, rrp=0.3989423 + + !>Use Canuto/Kitamura mod (remove Ric and negative TKE) (1:yes, 0:no) + !!For more info, see Canuto et al. (2008 JAS) and Kitamura (Journal of the + !!Meteorological Society of Japan, Vol. 88, No. 5, pp. 857-864, 2010). + !!Note that this change required further modification of other parameters + !!above (c2, c3). If you want to remove this option, set c2 and c3 constants + !!(above) back to NN2009 values (see commented out lines next to the + !!parameters above). This only removes the negative TKE problem + !!but does not necessarily improve performance - neutral impact. + real(kind_phys), parameter :: CKmod=1. + + !Option to activate environmental subsidence in mass-flux scheme + logical, parameter :: env_subs = .false. + + !option to print out more stuff for debugging purposes + logical, parameter :: debug_code = .false. + integer, parameter :: idbg = 23 !specific i-point to write out + +CONTAINS + +!======================================================================= +! SUBROUTINE mym_initialize: +! +! Input variables: +! iniflag : <>0; turbulent quantities will be initialized +! = 0; turbulent quantities have been already +! given, i.e., they will not be initialized +! nx, nz : Dimension sizes of the +! x and z directions, respectively +! tref : Reference temperature (K) +! dz(nz) : Vertical grid spacings (m) +! # dz(nz)=dz(nz-1) +! zw(nz+1) : Heights of the walls of the grid boxes (m) +! # zw(1)=0.0 and zw(k)=zw(k-1)+dz(k-1) +! exner(nx,nz) : Exner function at zw*h+zg (J/kg K) +! defined by c_p*( p_basic/1000hPa )^kappa +! This is usually computed by integrating +! d(pi0)/dz = -h*g/tref. +! rmo(nx) : Inverse of the Obukhov length (m^(-1)) +! flt, flq(nx) : Turbulent fluxes of potential temperature and +! total water, respectively: +! flt=-u_*Theta_* (K m/s) +! flq=-u_*qw_* (kg/kg m/s) +! ust(nx) : Friction velocity (m/s) +! pmz(nx) : phi_m-zeta at z1*h+z0, where z1 (=0.5*dz(1)) +! is the first grid point above the surafce, z0 +! the roughness length and zeta=(z1*h+z0)*rmo +! phh(nx) : phi_h at z1*h+z0 +! u, v(nx,nz) : Components of the horizontal wind (m/s) +! thl(nx,nz) : Liquid water potential temperature +! (K) +! qw(nx,nz) : Total water content Q_w (kg/kg) +! +! Output variables: +! ql(nx,nz) : Liquid water content (kg/kg) +! vt, vq(nx,nz) : Functions for computing the buoyancy flux +! qke(nx,nz) : Twice the turbulent kinetic energy q^2 +! (m^2/s^2) +! tsq(nx,nz) : Variance of Theta_l (K^2) +! qsq(nx,nz) : Variance of Q_w +! cov(nx,nz) : Covariance of Theta_l and Q_w (K) +! el(nx,nz) : Master length scale L (m) +! defined on the walls of the grid boxes +! +! Work arrays: see subroutine mym_level2 +! pd?(nx,nz,ny) : Half of the production terms at Level 2 +! defined on the walls of the grid boxes +! qkw(nx,nz,ny) : q on the walls of the grid boxes (m/s) +! +! # As to dtl, ...gh, see subroutine mym_turbulence. +! +!------------------------------------------------------------------- + +!>\ingroup gsd_mynn_edmf +!! This subroutine initializes the mixing length, TKE, \f$\theta^{'2}\f$, +!! \f$q^{'2}\f$, and \f$\theta^{'}q^{'}\f$. +!!\section gen_mym_ini GSD MYNN-EDMF mym_initialize General Algorithm +!> @{ + SUBROUTINE mym_initialize ( & + & kts,kte,xland, & + & dz, dx, zw, & + & u, v, thl, qw, & +! & ust, rmo, pmz, phh, flt, flq, & + & zi, theta, thetav, sh, sm, & + & ust, rmo, el, & + & Qke, Tsq, Qsq, Cov, Psig_bl, cldfra_bl1D, & + & bl_mynn_mixlength, & + & edmf_w1,edmf_a1, & + & INITIALIZE_QKE, & + & spp_pbl,rstoch_col) +! +!------------------------------------------------------------------- + + integer, intent(in) :: kts,kte + integer, intent(in) :: bl_mynn_mixlength + logical, intent(in) :: INITIALIZE_QKE +! real(kind_phys), intent(in) :: ust, rmo, pmz, phh, flt, flq + real(kind_phys), intent(in) :: rmo, Psig_bl, xland + real(kind_phys), intent(in) :: dx, ust, zi + real(kind_phys), dimension(kts:kte), intent(in) :: dz + real(kind_phys), dimension(kts:kte+1), intent(in) :: zw + real(kind_phys), dimension(kts:kte), intent(in) :: u,v,thl,& + &qw,cldfra_bl1D,edmf_w1,edmf_a1 + real(kind_phys), dimension(kts:kte), intent(out) :: tsq,qsq,cov + real(kind_phys), dimension(kts:kte), intent(inout) :: el,qke + real(kind_phys), dimension(kts:kte) :: & + &ql,pdk,pdt,pdq,pdc,dtl,dqw,dtv, & + &gm,gh,sm,sh,qkw,vt,vq + integer :: k,l,lmax + real(kind_phys):: phm,vkz,elq,elv,b1l,b2l,pmz=1.,phh=1., & + &flt=0.,fltv=0.,flq=0.,tmpq + real(kind_phys), dimension(kts:kte) :: theta,thetav + real(kind_phys), dimension(kts:kte) :: rstoch_col + integer ::spp_pbl + +!> - At first ql, vt and vq are set to zero. + DO k = kts,kte + ql(k) = 0.0 + vt(k) = 0.0 + vq(k) = 0.0 + END DO +! +!> - Call mym_level2() to calculate the stability functions at level 2. + CALL mym_level2 ( kts,kte, & + & dz, & + & u, v, thl, thetav, qw, & + & ql, vt, vq, & + & dtl, dqw, dtv, gm, gh, sm, sh ) +! +! ** Preliminary setting ** + + el (kts) = 0.0 + IF (INITIALIZE_QKE) THEN + !qke(kts) = ust**2 * ( b1*pmz )**(2.0/3.0) + qke(kts) = 1.5 * ust**2 * ( b1*pmz )**(2.0/3.0) + DO k = kts+1,kte + !qke(k) = 0.0 + !linearly taper off towards top of pbl + qke(k)=qke(kts)*MAX((ust*700. - zw(k))/(MAX(ust,0.01)*700.), 0.01) + ENDDO + ENDIF +! + phm = phh*b2 / ( b1*pmz )**(1.0/3.0) + tsq(kts) = phm*( flt/ust )**2 + qsq(kts) = phm*( flq/ust )**2 + cov(kts) = phm*( flt/ust )*( flq/ust ) +! + DO k = kts+1,kte + vkz = karman*zw(k) + el (k) = vkz/( 1.0 + vkz/100.0 ) +! qke(k) = 0.0 +! + tsq(k) = 0.0 + qsq(k) = 0.0 + cov(k) = 0.0 + END DO +! +! ** Initialization with an iterative manner ** +! ** lmax is the iteration count. This is arbitrary. ** + lmax = 5 +! + DO l = 1,lmax +! +!> - call mym_length() to calculate the master length scale. + CALL mym_length ( & + & kts,kte,xland, & + & dz, dx, zw, & + & rmo, flt, fltv, flq, & + & vt, vq, & + & u, v, qke, & + & dtv, & + & el, & + & zi,theta, & + & qkw,Psig_bl,cldfra_bl1D, & + & bl_mynn_mixlength, & + & edmf_w1,edmf_a1 ) +! + DO k = kts+1,kte + elq = el(k)*qkw(k) + pdk(k) = elq*( sm(k)*gm(k) + & + & sh(k)*gh(k) ) + pdt(k) = elq* sh(k)*dtl(k)**2 + pdq(k) = elq* sh(k)*dqw(k)**2 + pdc(k) = elq* sh(k)*dtl(k)*dqw(k) + END DO +! +! ** Strictly, vkz*h(i,j) -> karman*( 0.5*dz(1)*h(i,j)+z0 ) ** + vkz = karman*0.5*dz(kts) + elv = 0.5*( el(kts+1)+el(kts) ) / vkz + IF (INITIALIZE_QKE)THEN + !qke(kts) = ust**2 * ( b1*pmz*elv )**(2.0/3.0) + qke(kts) = 1.0 * MAX(ust,0.02)**2 * ( b1*pmz*elv )**(2.0/3.0) + ENDIF + + phm = phh*b2 / ( b1*pmz/elv**2 )**(1.0/3.0) + tsq(kts) = phm*( flt/ust )**2 + qsq(kts) = phm*( flq/ust )**2 + cov(kts) = phm*( flt/ust )*( flq/ust ) + + DO k = kts+1,kte-1 + b1l = b1*0.25*( el(k+1)+el(k) ) + !tmpq=MAX(b1l*( pdk(k+1)+pdk(k) ),qkemin) + !add MIN to limit unreasonable QKE + tmpq=MIN(MAX(b1l*( pdk(k+1)+pdk(k) ),qkemin),125.) +! PRINT *,'tmpqqqqq',tmpq,pdk(k+1),pdk(k) + IF (INITIALIZE_QKE)THEN + qke(k) = tmpq**twothirds + ENDIF + + IF ( qke(k) .LE. 0.0 ) THEN + b2l = 0.0 + ELSE + b2l = b2*( b1l/b1 ) / SQRT( qke(k) ) + END IF + + tsq(k) = b2l*( pdt(k+1)+pdt(k) ) + qsq(k) = b2l*( pdq(k+1)+pdq(k) ) + cov(k) = b2l*( pdc(k+1)+pdc(k) ) + END DO + + END DO + +!! qke(kts)=qke(kts+1) +!! tsq(kts)=tsq(kts+1) +!! qsq(kts)=qsq(kts+1) +!! cov(kts)=cov(kts+1) + + IF (INITIALIZE_QKE)THEN + qke(kts)=0.5*(qke(kts)+qke(kts+1)) + qke(kte)=qke(kte-1) + ENDIF + tsq(kte)=tsq(kte-1) + qsq(kte)=qsq(kte-1) + cov(kte)=cov(kte-1) + +! +! RETURN + + END SUBROUTINE mym_initialize +!> @} + +! +! ================================================================== +! SUBROUTINE mym_level2: +! +! Input variables: see subroutine mym_initialize +! +! Output variables: +! dtl(nx,nz,ny) : Vertical gradient of Theta_l (K/m) +! dqw(nx,nz,ny) : Vertical gradient of Q_w +! dtv(nx,nz,ny) : Vertical gradient of Theta_V (K/m) +! gm (nx,nz,ny) : G_M divided by L^2/q^2 (s^(-2)) +! gh (nx,nz,ny) : G_H divided by L^2/q^2 (s^(-2)) +! sm (nx,nz,ny) : Stability function for momentum, at Level 2 +! sh (nx,nz,ny) : Stability function for heat, at Level 2 +! +! These are defined on the walls of the grid boxes. +! + +!>\ingroup gsd_mynn_edmf +!! This subroutine calculates the level 2, non-dimensional wind shear +!! \f$G_M\f$ and vertical temperature gradient \f$G_H\f$ as well as +!! the level 2 stability funcitons \f$S_h\f$ and \f$S_m\f$. +!!\param kts horizontal dimension +!!\param kte vertical dimension +!!\param dz vertical grid spacings (\f$m\f$) +!!\param u west-east component of the horizontal wind (\f$m s^{-1}\f$) +!!\param v south-north component of the horizontal wind (\f$m s^{-1}\f$) +!!\param thl liquid water potential temperature +!!\param qw total water content \f$Q_w\f$ +!!\param ql liquid water content (\f$kg kg^{-1}\f$) +!!\param vt +!!\param vq +!!\param dtl vertical gradient of \f$\theta_l\f$ (\f$K m^{-1}\f$) +!!\param dqw vertical gradient of \f$Q_w\f$ +!!\param dtv vertical gradient of \f$\theta_V\f$ (\f$K m^{-1}\f$) +!!\param gm \f$G_M\f$ divided by \f$L^{2}/q^{2}\f$ (\f$s^{-2}\f$) +!!\param gh \f$G_H\f$ divided by \f$L^{2}/q^{2}\f$ (\f$s^{-2}\f$) +!!\param sm stability function for momentum, at Level 2 +!!\param sh stability function for heat, at Level 2 +!!\section gen_mym_level2 GSD MYNN-EDMF mym_level2 General Algorithm +!! @ { + SUBROUTINE mym_level2 (kts,kte, & + & dz, & + & u, v, thl, thetav, qw, & + & ql, vt, vq, & + & dtl, dqw, dtv, gm, gh, sm, sh ) +! +!------------------------------------------------------------------- + + integer, intent(in) :: kts,kte + +#ifdef HARDCODE_VERTICAL +# define kts 1 +# define kte HARDCODE_VERTICAL +#endif + + real(kind_phys), dimension(kts:kte), intent(in) :: dz + real(kind_phys), dimension(kts:kte), intent(in) :: u,v, & + &thl,qw,ql,vt,vq,thetav + real(kind_phys), dimension(kts:kte), intent(out) :: & + &dtl,dqw,dtv,gm,gh,sm,sh + + integer :: k + + real(kind_phys):: rfc,f1,f2,rf1,rf2,smc,shc, & + &ri1,ri2,ri3,ri4,duz,dtz,dqz,vtt,vqq,dtq,dzk, & + &afk,abk,ri,rf + + real(kind_phys):: a2fac + +! ev = 2.5e6 +! tv0 = 0.61*tref +! tv1 = 1.61*tref +! gtr = 9.81/tref +! + rfc = g1/( g1+g2 ) + f1 = b1*( g1-c1 ) +3.0*a2*( 1.0 -c2 )*( 1.0-c5 ) & + & +2.0*a1*( 3.0-2.0*c2 ) + f2 = b1*( g1+g2 ) -3.0*a1*( 1.0 -c2 ) + rf1 = b1*( g1-c1 )/f1 + rf2 = b1* g1 /f2 + smc = a1 /a2* f1/f2 + shc = 3.0*a2*( g1+g2 ) +! + ri1 = 0.5/smc + ri2 = rf1*smc + ri3 = 4.0*rf2*smc -2.0*ri2 + ri4 = ri2**2 +! + DO k = kts+1,kte + dzk = 0.5 *( dz(k)+dz(k-1) ) + afk = dz(k)/( dz(k)+dz(k-1) ) + abk = 1.0 -afk + duz = ( u(k)-u(k-1) )**2 +( v(k)-v(k-1) )**2 + duz = duz /dzk**2 + dtz = ( thl(k)-thl(k-1) )/( dzk ) + dqz = ( qw(k)-qw(k-1) )/( dzk ) +! + vtt = 1.0 +vt(k)*abk +vt(k-1)*afk ! Beta-theta in NN09, Eq. 39 + vqq = tv0 +vq(k)*abk +vq(k-1)*afk ! Beta-q + dtq = vtt*dtz +vqq*dqz + !Alternatively, use theta-v without the SGS clouds + !dtq = ( thetav(k)-thetav(k-1) )/( dzk ) +! + dtl(k) = dtz + dqw(k) = dqz + dtv(k) = dtq +!? dtv(i,j,k) = dtz +tv0*dqz +!? : +( xlv/pi0(i,j,k)-tv1 ) +!? : *( ql(i,j,k)-ql(i,j,k-1) )/( dzk*h(i,j) ) +! + gm (k) = duz + gh (k) = -dtq*gtr +! +! ** Gradient Richardson number ** + ri = -gh(k)/MAX( duz, 1.0e-10 ) + + !a2fac is needed for the Canuto/Kitamura mod + IF (CKmod .eq. 1) THEN + a2fac = 1./(1. + MAX(ri,0.0)) + ELSE + a2fac = 1. + ENDIF + + rfc = g1/( g1+g2 ) + f1 = b1*( g1-c1 ) +3.0*a2*a2fac *( 1.0 -c2 )*( 1.0-c5 ) & + & +2.0*a1*( 3.0-2.0*c2 ) + f2 = b1*( g1+g2 ) -3.0*a1*( 1.0 -c2 ) + rf1 = b1*( g1-c1 )/f1 + rf2 = b1* g1 /f2 + smc = a1 /(a2*a2fac)* f1/f2 + shc = 3.0*(a2*a2fac)*( g1+g2 ) + + ri1 = 0.5/smc + ri2 = rf1*smc + ri3 = 4.0*rf2*smc -2.0*ri2 + ri4 = ri2**2 + +! ** Flux Richardson number ** + rf = MIN( ri1*( ri + ri2-SQRT(ri**2 - ri3*ri + ri4) ), rfc ) +! + sh (k) = shc*( rfc-rf )/( 1.0-rf ) + sm (k) = smc*( rf1-rf )/( rf2-rf ) * sh(k) + END DO +! +! RETURN + +#ifdef HARDCODE_VERTICAL +# undef kts +# undef kte +#endif + + END SUBROUTINE mym_level2 +!! @} + +! ================================================================== +! SUBROUTINE mym_length: +! +! Input variables: see subroutine mym_initialize +! +! Output variables: see subroutine mym_initialize +! +! Work arrays: +! elt(nx,ny) : Length scale depending on the PBL depth (m) +! vsc(nx,ny) : Velocity scale q_c (m/s) +! at first, used for computing elt +! +! NOTE: the mixing lengths are meant to be calculated at the full- +! sigmal levels (or interfaces beween the model layers). +! +!>\ingroup gsd_mynn_edmf +!! This subroutine calculates the mixing lengths. + SUBROUTINE mym_length ( & + & kts,kte,xland, & + & dz, dx, zw, & + & rmo, flt, fltv, flq, & + & vt, vq, & + & u1, v1, qke, & + & dtv, & + & el, & + & zi, theta, qkw, & + & Psig_bl, cldfra_bl1D, & + & bl_mynn_mixlength, & + & edmf_w1,edmf_a1 ) + +!------------------------------------------------------------------- + + integer, intent(in) :: kts,kte + +#ifdef HARDCODE_VERTICAL +# define kts 1 +# define kte HARDCODE_VERTICAL +#endif + + integer, intent(in) :: bl_mynn_mixlength + real(kind_phys), dimension(kts:kte), intent(in) :: dz + real(kind_phys), dimension(kts:kte+1), intent(in) :: zw + real(kind_phys), intent(in) :: rmo,flt,fltv,flq,Psig_bl,xland + real(kind_phys), intent(in) :: dx,zi + real(kind_phys), dimension(kts:kte), intent(in) :: u1,v1, & + &qke,vt,vq,cldfra_bl1D,edmf_w1,edmf_a1 + real(kind_phys), dimension(kts:kte), intent(out) :: qkw, el + real(kind_phys), dimension(kts:kte), intent(in) :: dtv + real(kind_phys):: elt,vsc + real(kind_phys), dimension(kts:kte), intent(in) :: theta + real(kind_phys), dimension(kts:kte) :: qtke,elBLmin,elBLavg,thetaw + real(kind_phys):: wt,wt2,zi2,h1,h2,hs,elBLmin0,elBLavg0,cldavg + + ! THE FOLLOWING CONSTANTS ARE IMPORTANT FOR REGULATING THE + ! MIXING LENGTHS: + real(kind_phys):: cns, & !< for surface layer (els) in stable conditions + alp1, & !< for turbulent length scale (elt) + alp2, & !< for buoyancy length scale (elb) + alp3, & !< for buoyancy enhancement factor of elb + alp4, & !< for surface layer (els) in unstable conditions + alp5, & !< for BouLac mixing length or above PBLH + alp6 !< for mass-flux/ + + !THE FOLLOWING LIMITS DO NOT DIRECTLY AFFECT THE ACTUAL PBLH. + !THEY ONLY IMPOSE LIMITS ON THE CALCULATION OF THE MIXING LENGTH + !SCALES SO THAT THE BOULAC MIXING LENGTH (IN FREE ATMOS) DOES + !NOT ENCROACH UPON THE BOUNDARY LAYER MIXING LENGTH (els, elb & elt). + real(kind_phys), parameter :: minzi = 300. !< min mixed-layer height + real(kind_phys), parameter :: maxdz = 750. !< max (half) transition layer depth + !! =0.3*2500 m PBLH, so the transition + !! layer stops growing for PBLHs > 2.5 km. + real(kind_phys), parameter :: mindz = 300. !< 300 !min (half) transition layer depth + + !SURFACE LAYER LENGTH SCALE MODS TO REDUCE IMPACT IN UPPER BOUNDARY LAYER + real(kind_phys), parameter :: ZSLH = 100. !< Max height correlated to surface conditions (m) + real(kind_phys), parameter :: CSL = 2. !< CSL = constant of proportionality to L O(1) + + + integer :: i,j,k + real(kind_phys):: afk,abk,zwk,zwk1,dzk,qdz,vflx,bv,tau_cloud, & + & wstar,elb,els,elf,el_stab,el_mf,el_stab_mf,elb_mf, & + & PBLH_PLUS_ENT,Uonset,Ugrid,wt_u,el_les + real(kind_phys), parameter :: ctau = 1000. !constant for tau_cloud + +! tv0 = 0.61*tref +! gtr = 9.81/tref + + SELECT CASE(bl_mynn_mixlength) + + CASE (0) ! ORIGINAL MYNN MIXING LENGTH + BouLac + + cns = 2.7 + alp1 = 0.23 + alp2 = 1.0 + alp3 = 5.0 + alp4 = 100. + alp5 = 0.3 + + ! Impose limits on the height integration for elt and the transition layer depth + zi2 = MIN(10000.,zw(kte-2)) !originally integrated to model top, not just 10 km. + h1=MAX(0.3*zi2,mindz) + h1=MIN(h1,maxdz) ! 1/2 transition layer depth + h2=h1/2.0 ! 1/4 transition layer depth + + qkw(kts) = SQRT(MAX(qke(kts),1.0e-10)) + DO k = kts+1,kte + afk = dz(k)/( dz(k)+dz(k-1) ) + abk = 1.0 -afk + qkw(k) = SQRT(MAX(qke(k)*abk+qke(k-1)*afk,1.0e-3)) + END DO + + elt = 1.0e-5 + vsc = 1.0e-5 + + ! ** Strictly, zwk*h(i,j) -> ( zwk*h(i,j)+z0 ) ** + k = kts+1 + zwk = zw(k) + DO WHILE (zwk .LE. zi2+h1) + dzk = 0.5*( dz(k)+dz(k-1) ) + qdz = MAX( qkw(k)-qmin, 0.03 )*dzk + elt = elt +qdz*zwk + vsc = vsc +qdz + k = k+1 + zwk = zw(k) + END DO + + elt = alp1*elt/vsc + vflx = ( vt(kts)+1.0 )*flt +( vq(kts)+tv0 )*flq + vsc = ( gtr*elt*MAX( vflx, 0.0 ) )**(1.0/3.0) + + ! ** Strictly, el(i,k=1) is not zero. ** + el(kts) = 0.0 + zwk1 = zw(kts+1) + + DO k = kts+1,kte + zwk = zw(k) !full-sigma levels + + ! ** Length scale limited by the buoyancy effect ** + IF ( dtv(k) .GT. 0.0 ) THEN + bv = SQRT( gtr*dtv(k) ) + elb = alp2*qkw(k) / bv & + & *( 1.0 + alp3/alp2*& + &SQRT( vsc/( bv*elt ) ) ) + elf = alp2 * qkw(k)/bv + + ELSE + elb = 1.0e10 + elf = elb + ENDIF + + ! ** Length scale in the surface layer ** + IF ( rmo .GT. 0.0 ) THEN + els = karman*zwk/(1.0+cns*MIN( zwk*rmo, zmax )) + ELSE + els = karman*zwk*( 1.0 - alp4* zwk*rmo )**0.2 + END IF + + ! ** HARMONC AVERGING OF MIXING LENGTH SCALES: + ! el(k) = MIN(elb/( elb/elt+elb/els+1.0 ),elf) + ! el(k) = elb/( elb/elt+elb/els+1.0 ) + + wt=.5*TANH((zwk - (zi2+h1))/h2) + .5 + + el(k) = MIN(elb/( elb/elt+elb/els+1.0 ),elf) + + END DO + + CASE (1) !NONLOCAL (using BouLac) FORM OF MIXING LENGTH + + ugrid = sqrt(u1(kts)**2 + v1(kts)**2) + uonset= 15. + wt_u = (1.0 - min(max(ugrid - uonset, 0.0)/30.0, 0.5)) + cns = 2.7 !was 3.5 + alp1 = 0.23 + alp2 = 0.3 + alp3 = 2.5 * wt_u !taper off bouyancy enhancement in shear-driven pbls + alp4 = 5.0 + alp5 = 0.3 + alp6 = 50. + + ! Impose limits on the height integration for elt and the transition layer depth + zi2=MAX(zi,300.) !minzi) + h1=MAX(0.3*zi2,300.) + h1=MIN(h1,600.) ! 1/2 transition layer depth + h2=h1/2.0 ! 1/4 transition layer depth + + qtke(kts)=MAX(0.5*qke(kts), 0.01) !tke at full sigma levels + thetaw(kts)=theta(kts) !theta at full-sigma levels + qkw(kts) = SQRT(MAX(qke(kts),1.0e-10)) + + DO k = kts+1,kte + afk = dz(k)/( dz(k)+dz(k-1) ) + abk = 1.0 -afk + qkw(k) = SQRT(MAX(qke(k)*abk+qke(k-1)*afk,1.0e-3)) + qtke(k) = 0.5*(qkw(k)**2) ! q -> TKE + thetaw(k)= theta(k)*abk + theta(k-1)*afk + END DO + + elt = 1.0e-5 + vsc = 1.0e-5 + + ! ** Strictly, zwk*h(i,j) -> ( zwk*h(i,j)+z0 ) ** + k = kts+1 + zwk = zw(k) + DO WHILE (zwk .LE. zi2+h1) + dzk = 0.5*( dz(k)+dz(k-1) ) + qdz = min(max( qkw(k)-qmin, 0.03 ), 30.0)*dzk + elt = elt +qdz*zwk + vsc = vsc +qdz + k = k+1 + zwk = zw(k) + END DO + + elt = MIN( MAX( alp1*elt/vsc, 10.), 400.) + !avoid use of buoyancy flux functions which are ill-defined at the surface + !vflx = ( vt(kts)+1.0 )*flt + ( vq(kts)+tv0 )*flq + vflx = fltv + vsc = ( gtr*elt*MAX( vflx, 0.0 ) )**onethird + + ! ** Strictly, el(i,j,1) is not zero. ** + el(kts) = 0.0 + zwk1 = zw(kts+1) !full-sigma levels + + ! COMPUTE BouLac mixing length + CALL boulac_length(kts,kte,zw,dz,qtke,thetaw,elBLmin,elBLavg) + + DO k = kts+1,kte + zwk = zw(k) !full-sigma levels + + ! ** Length scale limited by the buoyancy effect ** + IF ( dtv(k) .GT. 0.0 ) THEN + bv = max( sqrt( gtr*dtv(k) ), 0.0001) + elb = MAX(alp2*qkw(k), & + & alp6*edmf_a1(k-1)*edmf_w1(k-1)) / bv & + & *( 1.0 + alp3*SQRT( vsc/(bv*elt) ) ) + elb = MIN(elb, zwk) + elf = 1.0 * qkw(k)/bv + elBLavg(k) = MAX(elBLavg(k), alp6*edmf_a1(k-1)*edmf_w1(k-1)/bv) + ELSE + elb = 1.0e10 + elf = elb + ENDIF + + ! ** Length scale in the surface layer ** + IF ( rmo .GT. 0.0 ) THEN + els = karman*zwk/(1.0+cns*MIN( zwk*rmo, zmax )) + ELSE + els = karman*zwk*( 1.0 - alp4* zwk*rmo )**0.2 + END IF + + ! ** NOW BLEND THE MIXING LENGTH SCALES: + wt=.5*TANH((zwk - (zi2+h1))/h2) + .5 + + !add blending to use BouLac mixing length in free atmos; + !defined relative to the PBLH (zi) + transition layer (h1) + !el(k) = MIN(elb/( elb/elt+elb/els+1.0 ),elf) + !try squared-blending - but take out elb (makes it underdiffusive) + !el(k) = SQRT( els**2/(1. + (els**2/elt**2) +(els**2/elb**2))) + el(k) = sqrt( els**2/(1. + (els**2/elt**2))) + el(k) = min(el(k), elb) + el(k) = MIN (el(k), elf) + el(k) = el(k)*(1.-wt) + alp5*elBLavg(k)*wt + + ! include scale-awareness, except for original MYNN + el(k) = el(k)*Psig_bl + + END DO + + CASE (2) !Local (mostly) mixing length formulation + + Uonset = 3.5 + dz(kts)*0.1 + Ugrid = sqrt(u1(kts)**2 + v1(kts)**2) + cns = 3.5 !JOE-test * (1.0 - MIN(MAX(Ugrid - Uonset, 0.0)/10.0, 1.0)) + alp1 = 0.22 + alp2 = 0.30 + alp3 = 2.0 + alp4 = 5.0 + alp5 = alp2 !like alp2, but for free atmosphere + alp6 = 50.0 !used for MF mixing length + + ! Impose limits on the height integration for elt and the transition layer depth + !zi2=MAX(zi,minzi) + zi2=MAX(zi, 300.) + !h1=MAX(0.3*zi2,mindz) + !h1=MIN(h1,maxdz) ! 1/2 transition layer depth + h1=MAX(0.3*zi2,300.) + h1=MIN(h1,600.) + h2=h1*0.5 ! 1/4 transition layer depth + + qtke(kts)=MAX(0.5*qke(kts),0.01) !tke at full sigma levels + qkw(kts) = SQRT(MAX(qke(kts),1.0e-4)) + + DO k = kts+1,kte + afk = dz(k)/( dz(k)+dz(k-1) ) + abk = 1.0 -afk + qkw(k) = SQRT(MAX(qke(k)*abk+qke(k-1)*afk,1.0e-3)) + qtke(k) = 0.5*qkw(k)**2 ! qkw -> TKE + END DO + + elt = 1.0e-5 + vsc = 1.0e-5 + + ! ** Strictly, zwk*h(i,j) -> ( zwk*h(i,j)+z0 ) ** + PBLH_PLUS_ENT = MAX(zi+h1, 100.) + k = kts+1 + zwk = zw(k) + DO WHILE (zwk .LE. PBLH_PLUS_ENT) + dzk = 0.5*( dz(k)+dz(k-1) ) + qdz = min(max( qkw(k)-qmin, 0.03 ), 30.0)*dzk + elt = elt +qdz*zwk + vsc = vsc +qdz + k = k+1 + zwk = zw(k) + END DO + + elt = MIN( MAX(alp1*elt/vsc, 10.), 400.) + !avoid use of buoyancy flux functions which are ill-defined at the surface + !vflx = ( vt(kts)+1.0 )*flt +( vq(kts)+tv0 )*flq + vflx = fltv + vsc = ( gtr*elt*MAX( vflx, 0.0 ) )**onethird + + ! ** Strictly, el(i,j,1) is not zero. ** + el(kts) = 0.0 + zwk1 = zw(kts+1) + + DO k = kts+1,kte + zwk = zw(k) !full-sigma levels + dzk = 0.5*( dz(k)+dz(k-1) ) + cldavg = 0.5*(cldfra_bl1D(k-1)+cldfra_bl1D(k)) + + ! ** Length scale limited by the buoyancy effect ** + IF ( dtv(k) .GT. 0.0 ) THEN + !impose min value on bv + bv = MAX( SQRT( gtr*dtv(k) ), 0.001) + !elb_mf = alp2*qkw(k) / bv & + elb_mf = MAX(alp2*qkw(k), & + & alp6*edmf_a1(k-1)*edmf_w1(k-1)) / bv & + & *( 1.0 + alp3*SQRT( vsc/( bv*elt ) ) ) + elb = MIN(MAX(alp5*qkw(k), alp6*edmf_a1(k)*edmf_w1(k))/bv, zwk) + + !tau_cloud = MIN(MAX(0.5*zi/((gtr*zi*MAX(vflx,1.0e-4))**onethird),30.),150.) + wstar = 1.25*(gtr*zi*MAX(vflx,1.0e-4))**onethird + tau_cloud = MIN(MAX(ctau * wstar/grav, 30.), 150.) + !minimize influence of surface heat flux on tau far away from the PBLH. + wt=.5*TANH((zwk - (zi2+h1))/h2) + .5 + tau_cloud = tau_cloud*(1.-wt) + 50.*wt + elf = MIN(MAX(tau_cloud*SQRT(MIN(qtke(k),40.)), & + & alp6*edmf_a1(k)*edmf_w1(k)/bv), zwk) + + !IF (zwk > zi .AND. elf > 400.) THEN + ! ! COMPUTE BouLac mixing length + ! !CALL boulac_length0(k,kts,kte,zw,dz,qtke,thetaw,elBLmin0,elBLavg0) + ! !elf = alp5*elBLavg0 + ! elf = MIN(MAX(50.*SQRT(qtke(k)), 400.), zwk) + !ENDIF + + ELSE + ! use version in development for RAP/HRRR 2016 + ! JAYMES- + ! tau_cloud is an eddy turnover timescale; + ! see Teixeira and Cheinet (2004), Eq. 1, and + ! Cheinet and Teixeira (2003), Eq. 7. The + ! coefficient 0.5 is tuneable. Expression in + ! denominator is identical to vsc (a convective + ! velocity scale), except that elt is relpaced + ! by zi, and zero is replaced by 1.0e-4 to + ! prevent division by zero. + !tau_cloud = MIN(MAX(0.5*zi/((gtr*zi*MAX(vflx,1.0e-4))**onethird),50.),150.) + wstar = 1.25*(gtr*zi*MAX(vflx,1.0e-4))**onethird + tau_cloud = MIN(MAX(ctau * wstar/grav, 50.), 200.) + !minimize influence of surface heat flux on tau far away from the PBLH. + wt=.5*TANH((zwk - (zi2+h1))/h2) + .5 + !tau_cloud = tau_cloud*(1.-wt) + 50.*wt + tau_cloud = tau_cloud*(1.-wt) + MAX(100.,dzk*0.25)*wt + + elb = MIN(tau_cloud*SQRT(MIN(qtke(k),40.)), zwk) + !elf = elb + elf = elb !/(1. + (elb/800.)) !bound free-atmos mixing length to < 800 m. + elb_mf = elb + END IF + elf = elf/(1. + (elf/800.)) !bound free-atmos mixing length to < 800 m. + elb_mf = MAX(elb_mf, 0.01) !to avoid divide-by-zero below + + ! ** Length scale in the surface layer ** + IF ( rmo .GT. 0.0 ) THEN + els = karman*zwk/(1.0+cns*MIN( zwk*rmo, zmax )) + ELSE + els = karman*zwk*( 1.0 - alp4* zwk*rmo )**0.2 + END IF + + ! ** NOW BLEND THE MIXING LENGTH SCALES: + wt=.5*TANH((zwk - (zi2+h1))/h2) + .5 + + !try squared-blending + el(k) = SQRT( els**2/(1. + (els**2/elt**2) +(els**2/elb_mf**2))) + el(k) = el(k)*(1.-wt) + elf*wt + + ! include scale-awareness. For now, use simple asymptotic kz -> 12 m (should be ~dz). + el_les= MIN(els/(1. + (els/12.)), elb_mf) + el(k) = el(k)*Psig_bl + (1.-Psig_bl)*el_les + + END DO + + END SELECT + + +#ifdef HARDCODE_VERTICAL +# undef kts +# undef kte +#endif + + END SUBROUTINE mym_length + +! ================================================================== +!>\ingroup gsd_mynn_edmf +!! This subroutine was taken from the BouLac scheme in WRF-ARW and modified for +!! integration into the MYNN PBL scheme. WHILE loops were added to reduce the +!! computational expense. This subroutine computes the length scales up and down +!! and then computes the min, average of the up/down length scales, and also +!! considers the distance to the surface. +!\param dlu the distance a parcel can be lifted upwards give a finite +! amount of TKE. +!\param dld the distance a parcel can be displaced downwards given a +! finite amount of TKE. +!\param lb1 the minimum of the length up and length down +!\param lb2 the average of the length up and length down + SUBROUTINE boulac_length0(k,kts,kte,zw,dz,qtke,theta,lb1,lb2) +! +! NOTE: This subroutine was taken from the BouLac scheme in WRF-ARW +! and modified for integration into the MYNN PBL scheme. +! WHILE loops were added to reduce the computational expense. +! This subroutine computes the length scales up and down +! and then computes the min, average of the up/down +! length scales, and also considers the distance to the +! surface. +! +! dlu = the distance a parcel can be lifted upwards give a finite +! amount of TKE. +! dld = the distance a parcel can be displaced downwards given a +! finite amount of TKE. +! lb1 = the minimum of the length up and length down +! lb2 = the average of the length up and length down +!------------------------------------------------------------------- + + integer, intent(in) :: k,kts,kte + real(kind_phys), dimension(kts:kte), intent(in) :: qtke,dz,theta + real(kind_phys), intent(out) :: lb1,lb2 + real(kind_phys), dimension(kts:kte+1), intent(in) :: zw + + !LOCAL VARS + integer :: izz, found + real(kind_phys):: dlu,dld + real(kind_phys):: dzt, zup, beta, zup_inf, bbb, tl, zdo, zdo_sup, zzz + + + !---------------------------------- + ! FIND DISTANCE UPWARD + !---------------------------------- + zup=0. + dlu=zw(kte+1)-zw(k)-dz(k)*0.5 + zzz=0. + zup_inf=0. + beta=gtr !Buoyancy coefficient (g/tref) + + !print*,"FINDING Dup, k=",k," zw=",zw(k) + + if (k .lt. kte) then !cant integrate upwards from highest level + found = 0 + izz=k + DO WHILE (found .EQ. 0) + + if (izz .lt. kte) then + dzt=dz(izz) ! layer depth above + zup=zup-beta*theta(k)*dzt ! initial PE the parcel has at k + !print*," ",k,izz,theta(izz),dz(izz) + zup=zup+beta*(theta(izz+1)+theta(izz))*dzt*0.5 ! PE gained by lifting a parcel to izz+1 + zzz=zzz+dzt ! depth of layer k to izz+1 + !print*," PE=",zup," TKE=",qtke(k)," z=",zw(izz) + if (qtke(k).lt.zup .and. qtke(k).ge.zup_inf) then + bbb=(theta(izz+1)-theta(izz))/dzt + if (bbb .ne. 0.) then + !fractional distance up into the layer where TKE becomes < PE + tl=(-beta*(theta(izz)-theta(k)) + & + & sqrt( max(0.,(beta*(theta(izz)-theta(k)))**2 + & + & 2.*bbb*beta*(qtke(k)-zup_inf))))/bbb/beta + else + if (theta(izz) .ne. theta(k))then + tl=(qtke(k)-zup_inf)/(beta*(theta(izz)-theta(k))) + else + tl=0. + endif + endif + dlu=zzz-dzt+tl + !print*," FOUND Dup:",dlu," z=",zw(izz)," tl=",tl + found =1 + endif + zup_inf=zup + izz=izz+1 + ELSE + found = 1 + ENDIF + + ENDDO + + endif + + !---------------------------------- + ! FIND DISTANCE DOWN + !---------------------------------- + zdo=0. + zdo_sup=0. + dld=zw(k) + zzz=0. + + !print*,"FINDING Ddown, k=",k," zwk=",zw(k) + if (k .gt. kts) then !cant integrate downwards from lowest level + + found = 0 + izz=k + DO WHILE (found .EQ. 0) + + if (izz .gt. kts) then + dzt=dz(izz-1) + zdo=zdo+beta*theta(k)*dzt + !print*," ",k,izz,theta(izz),dz(izz-1) + zdo=zdo-beta*(theta(izz-1)+theta(izz))*dzt*0.5 + zzz=zzz+dzt + !print*," PE=",zdo," TKE=",qtke(k)," z=",zw(izz) + if (qtke(k).lt.zdo .and. qtke(k).ge.zdo_sup) then + bbb=(theta(izz)-theta(izz-1))/dzt + if (bbb .ne. 0.) then + tl=(beta*(theta(izz)-theta(k))+ & + & sqrt( max(0.,(beta*(theta(izz)-theta(k)))**2 + & + & 2.*bbb*beta*(qtke(k)-zdo_sup))))/bbb/beta + else + if (theta(izz) .ne. theta(k)) then + tl=(qtke(k)-zdo_sup)/(beta*(theta(izz)-theta(k))) + else + tl=0. + endif + endif + dld=zzz-dzt+tl + !print*," FOUND Ddown:",dld," z=",zw(izz)," tl=",tl + found = 1 + endif + zdo_sup=zdo + izz=izz-1 + ELSE + found = 1 + ENDIF + ENDDO + + endif + + !---------------------------------- + ! GET MINIMUM (OR AVERAGE) + !---------------------------------- + !The surface layer length scale can exceed z for large z/L, + !so keep maximum distance down > z. + dld = min(dld,zw(k+1))!not used in PBL anyway, only free atmos + lb1 = min(dlu,dld) !minimum + !JOE-fight floating point errors + dlu=MAX(0.1,MIN(dlu,1000.)) + dld=MAX(0.1,MIN(dld,1000.)) + lb2 = sqrt(dlu*dld) !average - biased towards smallest + !lb2 = 0.5*(dlu+dld) !average + + if (k .eq. kte) then + lb1 = 0. + lb2 = 0. + endif + !print*,"IN MYNN-BouLac",k,lb1 + !print*,"IN MYNN-BouLac",k,dld,dlu + + END SUBROUTINE boulac_length0 + +! ================================================================== +!>\ingroup gsd_mynn_edmf +!! This subroutine was taken from the BouLac scheme in WRF-ARW +!! and modified for integration into the MYNN PBL scheme. +!! WHILE loops were added to reduce the computational expense. +!! This subroutine computes the length scales up and down +!! and then computes the min, average of the up/down +!! length scales, and also considers the distance to the +!! surface. + SUBROUTINE boulac_length(kts,kte,zw,dz,qtke,theta,lb1,lb2) +! dlu = the distance a parcel can be lifted upwards give a finite +! amount of TKE. +! dld = the distance a parcel can be displaced downwards given a +! finite amount of TKE. +! lb1 = the minimum of the length up and length down +! lb2 = the average of the length up and length down +!------------------------------------------------------------------- + + integer, intent(in) :: kts,kte + real(kind_phys), dimension(kts:kte), intent(in) :: qtke,dz,theta + real(kind_phys), dimension(kts:kte), intent(out):: lb1,lb2 + real(kind_phys), dimension(kts:kte+1), intent(in) :: zw + + !LOCAL VARS + integer :: iz, izz, found + real(kind_phys), dimension(kts:kte) :: dlu,dld + real(kind_phys), parameter :: Lmax=2000. !soft limit + real(kind_phys):: dzt, zup, beta, zup_inf, bbb, tl, zdo, zdo_sup, zzz + + !print*,"IN MYNN-BouLac",kts, kte + + do iz=kts,kte + + !---------------------------------- + ! FIND DISTANCE UPWARD + !---------------------------------- + zup=0. + dlu(iz)=zw(kte+1)-zw(iz)-dz(iz)*0.5 + zzz=0. + zup_inf=0. + beta=gtr !Buoyancy coefficient (g/tref) + + !print*,"FINDING Dup, k=",iz," zw=",zw(iz) + + if (iz .lt. kte) then !cant integrate upwards from highest level + + found = 0 + izz=iz + DO WHILE (found .EQ. 0) + + if (izz .lt. kte) then + dzt=dz(izz) ! layer depth above + zup=zup-beta*theta(iz)*dzt ! initial PE the parcel has at iz + !print*," ",iz,izz,theta(izz),dz(izz) + zup=zup+beta*(theta(izz+1)+theta(izz))*dzt*0.5 ! PE gained by lifting a parcel to izz+1 + zzz=zzz+dzt ! depth of layer iz to izz+1 + !print*," PE=",zup," TKE=",qtke(iz)," z=",zw(izz) + if (qtke(iz).lt.zup .and. qtke(iz).ge.zup_inf) then + bbb=(theta(izz+1)-theta(izz))/dzt + if (bbb .ne. 0.) then + !fractional distance up into the layer where TKE becomes < PE + tl=(-beta*(theta(izz)-theta(iz)) + & + & sqrt( max(0.,(beta*(theta(izz)-theta(iz)))**2 + & + & 2.*bbb*beta*(qtke(iz)-zup_inf))))/bbb/beta + else + if (theta(izz) .ne. theta(iz))then + tl=(qtke(iz)-zup_inf)/(beta*(theta(izz)-theta(iz))) + else + tl=0. + endif + endif + dlu(iz)=zzz-dzt+tl + !print*," FOUND Dup:",dlu(iz)," z=",zw(izz)," tl=",tl + found =1 + endif + zup_inf=zup + izz=izz+1 + ELSE + found = 1 + ENDIF + + ENDDO + + endif + + !---------------------------------- + ! FIND DISTANCE DOWN + !---------------------------------- + zdo=0. + zdo_sup=0. + dld(iz)=zw(iz) + zzz=0. + + !print*,"FINDING Ddown, k=",iz," zwk=",zw(iz) + if (iz .gt. kts) then !cant integrate downwards from lowest level + + found = 0 + izz=iz + DO WHILE (found .EQ. 0) + + if (izz .gt. kts) then + dzt=dz(izz-1) + zdo=zdo+beta*theta(iz)*dzt + !print*," ",iz,izz,theta(izz),dz(izz-1) + zdo=zdo-beta*(theta(izz-1)+theta(izz))*dzt*0.5 + zzz=zzz+dzt + !print*," PE=",zdo," TKE=",qtke(iz)," z=",zw(izz) + if (qtke(iz).lt.zdo .and. qtke(iz).ge.zdo_sup) then + bbb=(theta(izz)-theta(izz-1))/dzt + if (bbb .ne. 0.) then + tl=(beta*(theta(izz)-theta(iz))+ & + & sqrt( max(0.,(beta*(theta(izz)-theta(iz)))**2 + & + & 2.*bbb*beta*(qtke(iz)-zdo_sup))))/bbb/beta + else + if (theta(izz) .ne. theta(iz)) then + tl=(qtke(iz)-zdo_sup)/(beta*(theta(izz)-theta(iz))) + else + tl=0. + endif + endif + dld(iz)=zzz-dzt+tl + !print*," FOUND Ddown:",dld(iz)," z=",zw(izz)," tl=",tl + found = 1 + endif + zdo_sup=zdo + izz=izz-1 + ELSE + found = 1 + ENDIF + ENDDO + + endif + + !---------------------------------- + ! GET MINIMUM (OR AVERAGE) + !---------------------------------- + !The surface layer length scale can exceed z for large z/L, + !so keep maximum distance down > z. + dld(iz) = min(dld(iz),zw(iz+1))!not used in PBL anyway, only free atmos + lb1(iz) = min(dlu(iz),dld(iz)) !minimum + !JOE-fight floating point errors + dlu(iz)=MAX(0.1,MIN(dlu(iz),1000.)) + dld(iz)=MAX(0.1,MIN(dld(iz),1000.)) + lb2(iz) = sqrt(dlu(iz)*dld(iz)) !average - biased towards smallest + !lb2(iz) = 0.5*(dlu(iz)+dld(iz)) !average + + !Apply soft limit (only impacts very large lb; lb=100 by 5%, lb=500 by 20%). + lb1(iz) = lb1(iz)/(1. + (lb1(iz)/Lmax)) + lb2(iz) = lb2(iz)/(1. + (lb2(iz)/Lmax)) + + if (iz .eq. kte) then + lb1(kte) = lb1(kte-1) + lb2(kte) = lb2(kte-1) + endif + !print*,"IN MYNN-BouLac",kts, kte,lb1(iz) + !print*,"IN MYNN-BouLac",iz,dld(iz),dlu(iz) + + ENDDO + + END SUBROUTINE boulac_length +! +! ================================================================== +! SUBROUTINE mym_turbulence: +! +! Input variables: see subroutine mym_initialize +! closure : closure level (2.5, 2.6, or 3.0) +! +! # ql, vt, vq, qke, tsq, qsq and cov are changed to input variables. +! +! Output variables: see subroutine mym_initialize +! dfm(nx,nz,ny) : Diffusivity coefficient for momentum, +! divided by dz (not dz*h(i,j)) (m/s) +! dfh(nx,nz,ny) : Diffusivity coefficient for heat, +! divided by dz (not dz*h(i,j)) (m/s) +! dfq(nx,nz,ny) : Diffusivity coefficient for q^2, +! divided by dz (not dz*h(i,j)) (m/s) +! tcd(nx,nz,ny) : Countergradient diffusion term for Theta_l +! (K/s) +! qcd(nx,nz,ny) : Countergradient diffusion term for Q_w +! (kg/kg s) +! pd?(nx,nz,ny) : Half of the production terms +! +! Only tcd and qcd are defined at the center of the grid boxes +! +! # DO NOT forget that tcd and qcd are added on the right-hand side +! of the equations for Theta_l and Q_w, respectively. +! +! Work arrays: see subroutine mym_initialize and level2 +! +! # dtl, dqw, dtv, gm and gh are allowed to share storage units with +! dfm, dfh, dfq, tcd and qcd, respectively, for saving memory. +! +!>\ingroup gsd_mynn_edmf +!! This subroutine calculates the vertical diffusivity coefficients and the +!! production terms for the turbulent quantities. +!>\section gen_mym_turbulence GSD mym_turbulence General Algorithm +!! Two subroutines mym_level2() and mym_length() are called within this +!!subrouine to collect variable to carry out successive calculations: +!! - mym_level2() calculates the level 2 nondimensional wind shear \f$G_M\f$ +!! and vertical temperature gradient \f$G_H\f$ as well as the level 2 stability +!! functions \f$S_h\f$ and \f$S_m\f$. +!! - mym_length() calculates the mixing lengths. +!! - The stability criteria from Helfand and Labraga (1989) are applied. +!! - The stability functions for level 2.5 or level 3.0 are calculated. +!! - If level 3.0 is used, counter-gradient terms are calculated. +!! - Production terms of TKE,\f$\theta^{'2}\f$,\f$q^{'2}\f$, and \f$\theta^{'}q^{'}\f$ +!! are calculated. +!! - Eddy diffusivity \f$K_h\f$ and eddy viscosity \f$K_m\f$ are calculated. +!! - TKE budget terms are calculated (if the namelist parameter \p bl_mynn_tkebudget +!! is set to True) + SUBROUTINE mym_turbulence ( & + & kts,kte, & + & xland,closure, & + & dz, dx, zw, & + & u, v, thl, thetav, ql, qw, & + & qke, tsq, qsq, cov, & + & vt, vq, & + & rmo, flt, fltv, flq, & + & zi,theta, & + & sh, sm, & + & El, & + & Dfm, Dfh, Dfq, Tcd, Qcd, Pdk, Pdt, Pdq, Pdc, & + & qWT1D,qSHEAR1D,qBUOY1D,qDISS1D, & + & bl_mynn_tkebudget, & + & Psig_bl,Psig_shcu,cldfra_bl1D, & + & bl_mynn_mixlength, & + & edmf_w1,edmf_a1, & + & TKEprodTD, & + & spp_pbl,rstoch_col ) + +!------------------------------------------------------------------- + + integer, intent(in) :: kts,kte + +#ifdef HARDCODE_VERTICAL +# define kts 1 +# define kte HARDCODE_VERTICAL +#endif + + logical, intent(in) :: bl_mynn_tkebudget + integer, intent(in) :: bl_mynn_mixlength + real(kind_phys), intent(in) :: closure + real(kind_phys), dimension(kts:kte), intent(in) :: dz + real(kind_phys), dimension(kts:kte+1), intent(in) :: zw + real(kind_phys), intent(in) :: rmo,flt,fltv,flq, & + &Psig_bl,Psig_shcu,xland,dx,zi + real(kind_phys), dimension(kts:kte), intent(in) :: u,v,thl,thetav,qw, & + &ql,vt,vq,qke,tsq,qsq,cov,cldfra_bl1D,edmf_w1,edmf_a1, & + &TKEprodTD + + real(kind_phys), dimension(kts:kte), intent(out) :: dfm,dfh,dfq, & + &pdk,pdt,pdq,pdc,tcd,qcd,el + + real(kind_phys), dimension(kts:kte), intent(inout) :: & + qWT1D,qSHEAR1D,qBUOY1D,qDISS1D + real(kind_phys):: q3sq_old,dlsq1,qWTP_old,qWTP_new + real(kind_phys):: dudz,dvdz,dTdz,upwp,vpwp,Tpwp + + real(kind_phys), dimension(kts:kte) :: qkw,dtl,dqw,dtv,gm,gh,sm,sh + + integer :: k +! real(kind_phys):: cc2,cc3,e1c,e2c,e3c,e4c,e5c + real(kind_phys):: e6c,dzk,afk,abk,vtt,vqq, & + &cw25,clow,cupp,gamt,gamq,smd,gamv,elq,elh + + real(kind_phys):: cldavg + real(kind_phys), dimension(kts:kte), intent(in) :: theta + + real(kind_phys):: a2fac, duz, ri !JOE-Canuto/Kitamura mod + + real(kind_phys):: auh,aum,adh,adm,aeh,aem,Req,Rsl,Rsl2, & + gmelq,sm20,sh20,sm25max,sh25max,sm25min,sh25min, & + sm_pbl,sh_pbl,zi2,wt,slht,wtpr + + real(kind=kind_phys8):: q2sq, t2sq, r2sq, c2sq, elsq, gmel, ghel + real(kind=kind_phys8):: q3sq, t3sq, r3sq, c3sq, dlsq, qdiv + real(kind=kind_phys8):: e1, e2, e3, e4, enum, eden, wden + +! Stochastic + integer, intent(in) :: spp_pbl + real(kind_phys), dimension(kts:kte) :: rstoch_col + real(kind_phys):: Prnum, shb + real(kind_phys), parameter :: Prlimit = 5.0 + +! +! tv0 = 0.61*tref +! gtr = 9.81/tref +! +! cc2 = 1.0-c2 +! cc3 = 1.0-c3 +! e1c = 3.0*a2*b2*cc3 +! e2c = 9.0*a1*a2*cc2 +! e3c = 9.0*a2*a2*cc2*( 1.0-c5 ) +! e4c = 12.0*a1*a2*cc2 +! e5c = 6.0*a1*a1 +! + + CALL mym_level2 (kts,kte, & + & dz, & + & u, v, thl, thetav, qw, & + & ql, vt, vq, & + & dtl, dqw, dtv, gm, gh, sm, sh ) +! + CALL mym_length ( & + & kts,kte,xland, & + & dz, dx, zw, & + & rmo, flt, fltv, flq, & + & vt, vq, & + & u, v, qke, & + & dtv, & + & el, & + & zi,theta, & + & qkw,Psig_bl,cldfra_bl1D, & + & bl_mynn_mixlength, & + & edmf_w1,edmf_a1 ) +! + + DO k = kts+1,kte + dzk = 0.5 *( dz(k)+dz(k-1) ) + afk = dz(k)/( dz(k)+dz(k-1) ) + abk = 1.0 -afk + elsq = el (k)**2 + q3sq = qkw(k)**2 + q2sq = b1*elsq*( sm(k)*gm(k)+sh(k)*gh(k) ) + + sh20 = MAX(sh(k), 1e-5) + sm20 = MAX(sm(k), 1e-5) + sh(k)= MAX(sh(k), 1e-5) + + !Canuto/Kitamura mod + duz = ( u(k)-u(k-1) )**2 +( v(k)-v(k-1) )**2 + duz = duz /dzk**2 + ! ** Gradient Richardson number ** + ri = -gh(k)/MAX( duz, 1.0e-10 ) + IF (CKmod .eq. 1) THEN + a2fac = 1./(1. + MAX(ri,0.0)) + ELSE + a2fac = 1. + ENDIF + !end Canuto/Kitamura mod + + !level 2.0 Prandtl number + !Prnum = MIN(sm20/sh20, 4.0) + !The form of Zilitinkevich et al. (2006) but modified + !half-way towards Esau and Grachev (2007, Wind Eng) + !Prnum = MIN(0.76 + 3.0*MAX(ri,0.0), Prlimit) + Prnum = MIN(0.76 + 4.0*MAX(ri,0.0), Prlimit) + !Prnum = MIN(0.76 + 5.0*MAX(ri,0.0), Prlimit) +! +! Modified: Dec/22/2005, from here, (dlsq -> elsq) + gmel = gm (k)*elsq + ghel = gh (k)*elsq +! Modified: Dec/22/2005, up to here + + ! Level 2.0 debug prints + IF ( debug_code ) THEN + IF (sh(k)<0.0 .OR. sm(k)<0.0) THEN + print*,"MYNN; mym_turbulence 2.0; sh=",sh(k)," k=",k + print*," gm=",gm(k)," gh=",gh(k)," sm=",sm(k) + print*," q2sq=",q2sq," q3sq=",q3sq," q3/q2=",q3sq/q2sq + print*," qke=",qke(k)," el=",el(k)," ri=",ri + print*," PBLH=",zi," u=",u(k)," v=",v(k) + ENDIF + ENDIF + +! ** Since qkw is set to more than 0.0, q3sq > 0.0. ** + +! new stability criteria in level 2.5 (as well as level 3) - little/no impact +! ** Limitation on q, instead of L/q ** + dlsq = elsq + IF ( q3sq/dlsq .LT. -gh(k) ) q3sq = -dlsq*gh(k) + + IF ( q3sq .LT. q2sq ) THEN + !Apply Helfand & Labraga mod + qdiv = SQRT( q3sq/q2sq ) !HL89: (1-alfa) +! + !Use level 2.5 stability functions + !e1 = q3sq - e1c*ghel*a2fac + !e2 = q3sq - e2c*ghel*a2fac + !e3 = e1 + e3c*ghel*a2fac**2 + !e4 = e1 - e4c*ghel*a2fac + !eden = e2*e4 + e3*e5c*gmel + !eden = MAX( eden, 1.0d-20 ) + !sm(k) = q3sq*a1*( e3-3.0*c1*e4 )/eden + !!JOE-Canuto/Kitamura mod + !!sh(k) = q3sq*a2*( e2+3.0*c1*e5c*gmel )/eden + !sh(k) = q3sq*(a2*a2fac)*( e2+3.0*c1*e5c*gmel )/eden + !sm(k) = Prnum*sh(k) + !sm(k) = sm(k) * qdiv + + !Use level 2.0 functions as in original MYNN + sh(k) = sh(k) * qdiv + sm(k) = sm(k) * qdiv + ! !sm_pbl = sm(k) * qdiv + ! + ! !Or, use the simple Pr relationship + ! sm(k) = Prnum*sh(k) + ! + ! !or blend them: + ! zi2 = MAX(zi, 300.) + ! wt =.5*TANH((zw(k) - zi2)/200.) + .5 + ! sm(k) = sm_pbl*(1.-wt) + sm(k)*wt + + !Recalculate terms for later use + !JOE-Canuto/Kitamura mod + !e1 = q3sq - e1c*ghel * qdiv**2 + !e2 = q3sq - e2c*ghel * qdiv**2 + !e3 = e1 + e3c*ghel * qdiv**2 + !e4 = e1 - e4c*ghel * qdiv**2 + e1 = q3sq - e1c*ghel*a2fac * qdiv**2 + e2 = q3sq - e2c*ghel*a2fac * qdiv**2 + e3 = e1 + e3c*ghel*a2fac**2 * qdiv**2 + e4 = e1 - e4c*ghel*a2fac * qdiv**2 + eden = e2*e4 + e3*e5c*gmel * qdiv**2 + eden = MAX( eden, 1.0d-20 ) + !!JOE-Canuto/Kitamura mod + !!sh(k) = q3sq*a2*( e2+3.0*c1*e5c*gmel )/eden - retro 5 + !sh(k) = q3sq*(a2*a2fac)*( e2+3.0*c1*e5c*gmel )/eden + !sm(k) = Prnum*sh(k) + ELSE + !JOE-Canuto/Kitamura mod + !e1 = q3sq - e1c*ghel + !e2 = q3sq - e2c*ghel + !e3 = e1 + e3c*ghel + !e4 = e1 - e4c*ghel + e1 = q3sq - e1c*ghel*a2fac + e2 = q3sq - e2c*ghel*a2fac + e3 = e1 + e3c*ghel*a2fac**2 + e4 = e1 - e4c*ghel*a2fac + eden = e2*e4 + e3*e5c*gmel + eden = MAX( eden, 1.0d-20 ) + + qdiv = 1.0 + !Use level 2.5 stability functions + sm(k) = q3sq*a1*( e3-3.0*c1*e4 )/eden + ! sm_pbl = q3sq*a1*( e3-3.0*c1*e4 )/eden + !!JOE-Canuto/Kitamura mod + !!sh(k) = q3sq*a2*( e2+3.0*c1*e5c*gmel )/eden + sh(k) = q3sq*(a2*a2fac)*( e2+3.0*c1*e5c*gmel )/eden + ! sm(k) = Prnum*sh(k) + + ! !or blend them: + ! zi2 = MAX(zi, 300.) + ! wt = .5*TANH((zw(k) - zi2)/200.) + .5 + ! sm(k) = sm_pbl*(1.-wt) + sm(k)*wt + END IF !end Helfand & Labraga check + + !Impose broad limits on Sh and Sm: + gmelq = MAX(gmel/q3sq, 1d-8) + sm25max = 4. !MIN(sm20*3.0, SQRT(.1936/gmelq)) + sh25max = 4. !MIN(sh20*3.0, 0.76*b2) + sm25min = 0.0 !MAX(sm20*0.1, 1e-6) + sh25min = 0.0 !MAX(sh20*0.1, 1e-6) + + !JOE: Level 2.5 debug prints + ! HL88 , lev2.5 criteria from eqs. 3.17, 3.19, & 3.20 + IF ( debug_code ) THEN + IF ((sh(k)sh25max .OR. sm(k)>sm25max) ) THEN + print*,"In mym_turbulence 2.5: k=",k + print*," sm=",sm(k)," sh=",sh(k) + print*," ri=",ri," Pr=",sm(k)/MAX(sh(k),1e-8) + print*," gm=",gm(k)," gh=",gh(k) + print*," q2sq=",q2sq," q3sq=",q3sq, q3sq/q2sq + print*," qke=",qke(k)," el=",el(k) + print*," PBLH=",zi," u=",u(k)," v=",v(k) + print*," SMnum=",q3sq*a1*( e3-3.0*c1*e4)," SMdenom=",eden + print*," SHnum=",q3sq*(a2*a2fac)*( e2+3.0*c1*e5c*gmel ),& + " SHdenom=",eden + ENDIF + ENDIF + + !Enforce constraints for level 2.5 functions + IF ( sh(k) > sh25max ) sh(k) = sh25max + IF ( sh(k) < sh25min ) sh(k) = sh25min + !IF ( sm(k) > sm25max ) sm(k) = sm25max + !IF ( sm(k) < sm25min ) sm(k) = sm25min + !sm(k) = Prnum*sh(k) + + !surface layer PR + !slht = zi*0.1 + !wtpr = min( max( (slht - zw(k))/slht, 0.0), 1.0) ! 1 at z=0, 0 above sfc layer + !Prlim = 1.0*wtpr + (1.0 - wtpr)*Prlimit + !Prlim = 2.0*wtpr + (1.0 - wtpr)*Prlimit + !sm(k) = MIN(sm(k), Prlim*Sh(k)) + !Pending more testing, keep same Pr limit in sfc layer + shb = max(sh(k), 0.002) + sm(k) = MIN(sm(k), Prlimit*shb) + +! ** Level 3 : start ** + IF ( closure .GE. 3.0 ) THEN + t2sq = qdiv*b2*elsq*sh(k)*dtl(k)**2 + r2sq = qdiv*b2*elsq*sh(k)*dqw(k)**2 + c2sq = qdiv*b2*elsq*sh(k)*dtl(k)*dqw(k) + t3sq = MAX( tsq(k)*abk+tsq(k-1)*afk, 0.0 ) + r3sq = MAX( qsq(k)*abk+qsq(k-1)*afk, 0.0 ) + c3sq = cov(k)*abk+cov(k-1)*afk + +! Modified: Dec/22/2005, from here + c3sq = SIGN( MIN( ABS(c3sq), SQRT(t3sq*r3sq) ), c3sq ) +! + vtt = 1.0 +vt(k)*abk +vt(k-1)*afk + vqq = tv0 +vq(k)*abk +vq(k-1)*afk + + t2sq = vtt*t2sq +vqq*c2sq + r2sq = vtt*c2sq +vqq*r2sq + c2sq = MAX( vtt*t2sq+vqq*r2sq, 0.0d0 ) + t3sq = vtt*t3sq +vqq*c3sq + r3sq = vtt*c3sq +vqq*r3sq + c3sq = MAX( vtt*t3sq+vqq*r3sq, 0.0d0 ) +! + cw25 = e1*( e2 + 3.0*c1*e5c*gmel*qdiv**2 )/( 3.0*eden ) +! +! ** Limitation on q, instead of L/q ** + dlsq = elsq + IF ( q3sq/dlsq .LT. -gh(k) ) q3sq = -dlsq*gh(k) +! +! ** Limitation on c3sq (0.12 =< cw =< 0.76) ** + ! Use Janjic's (2001; p 13-17) methodology (eqs 4.11-414 and 5.7-5.10) + ! to calculate an exact limit for c3sq: + auh = 27.*a1*((a2*a2fac)**2)*b2*(gtr)**2 + aum = 54.*(a1**2)*(a2*a2fac)*b2*c1*(gtr) + adh = 9.*a1*((a2*a2fac)**2)*(12.*a1 + 3.*b2)*(gtr)**2 + adm = 18.*(a1**2)*(a2*a2fac)*(b2 - 3.*(a2*a2fac))*(gtr) + + aeh = (9.*a1*((a2*a2fac)**2)*b1 +9.*a1*((a2*a2fac)**2)* & + (12.*a1 + 3.*b2))*(gtr) + aem = 3.*a1*(a2*a2fac)*b1*(3.*(a2*a2fac) + 3.*b2*c1 + & + (18.*a1*c1 - b2)) + & + (18.)*(a1**2)*(a2*a2fac)*(b2 - 3.*(a2*a2fac)) + + Req = -aeh/aem + Rsl = (auh + aum*Req)/(3.*adh + 3.*adm*Req) + !For now, use default values, since tests showed little/no sensitivity + Rsl = .12 !lower limit + Rsl2= 1.0 - 2.*Rsl !upper limit + !IF (k==2)print*,"Dynamic limit RSL=",Rsl + !IF (Rsl < 0.10 .OR. Rsl > 0.18) THEN + ! print*,'--- ERROR: MYNN: Dynamic Cw '// & + ! 'limit exceeds reasonable limits' + ! print*," MYNN: Dynamic Cw limit needs attention=",Rsl + !ENDIF + + !JOE-Canuto/Kitamura mod + !e2 = q3sq - e2c*ghel * qdiv**2 + !e3 = q3sq + e3c*ghel * qdiv**2 + !e4 = q3sq - e4c*ghel * qdiv**2 + e2 = q3sq - e2c*ghel*a2fac * qdiv**2 + e3 = q3sq + e3c*ghel*a2fac**2 * qdiv**2 + e4 = q3sq - e4c*ghel*a2fac * qdiv**2 + eden = e2*e4 + e3 *e5c*gmel * qdiv**2 + + !JOE-Canuto/Kitamura mod + !wden = cc3*gtr**2 * dlsq**2/elsq * qdiv**2 & + ! & *( e2*e4c - e3c*e5c*gmel * qdiv**2 ) + wden = cc3*gtr**2 * dlsq**2/elsq * qdiv**2 & + & *( e2*e4c*a2fac - e3c*e5c*gmel*a2fac**2 * qdiv**2 ) + + IF ( wden .NE. 0.0 ) THEN + !JOE: test dynamic limits + clow = q3sq*( 0.12-cw25 )*eden/wden + cupp = q3sq*( 0.76-cw25 )*eden/wden + !clow = q3sq*( Rsl -cw25 )*eden/wden + !cupp = q3sq*( Rsl2-cw25 )*eden/wden +! + IF ( wden .GT. 0.0 ) THEN + c3sq = MIN( MAX( c3sq, c2sq+clow ), c2sq+cupp ) + ELSE + c3sq = MAX( MIN( c3sq, c2sq+clow ), c2sq+cupp ) + END IF + END IF +! + e1 = e2 + e5c*gmel * qdiv**2 + eden = MAX( eden, 1.0d-20 ) +! Modified: Dec/22/2005, up to here + + !JOE-Canuto/Kitamura mod + !e6c = 3.0*a2*cc3*gtr * dlsq/elsq + e6c = 3.0*(a2*a2fac)*cc3*gtr * dlsq/elsq + + !============================ + ! ** for Gamma_theta ** + !! enum = qdiv*e6c*( t3sq-t2sq ) + IF ( t2sq .GE. 0.0 ) THEN + enum = MAX( qdiv*e6c*( t3sq-t2sq ), 0.0d0 ) + ELSE + enum = MIN( qdiv*e6c*( t3sq-t2sq ), 0.0d0 ) + ENDIF + gamt =-e1 *enum /eden + + !============================ + ! ** for Gamma_q ** + !! enum = qdiv*e6c*( r3sq-r2sq ) + IF ( r2sq .GE. 0.0 ) THEN + enum = MAX( qdiv*e6c*( r3sq-r2sq ), 0.0d0 ) + ELSE + enum = MIN( qdiv*e6c*( r3sq-r2sq ), 0.0d0 ) + ENDIF + gamq =-e1 *enum /eden + + !============================ + ! ** for Sm' and Sh'd(Theta_V)/dz ** + !! enum = qdiv*e6c*( c3sq-c2sq ) + enum = MAX( qdiv*e6c*( c3sq-c2sq ), 0.0d0) + + !JOE-Canuto/Kitamura mod + !smd = dlsq*enum*gtr/eden * qdiv**2 * (e3c+e4c)*a1/a2 + smd = dlsq*enum*gtr/eden * qdiv**2 * (e3c*a2fac**2 + & + & e4c*a2fac)*a1/(a2*a2fac) + + gamv = e1 *enum*gtr/eden + sm(k) = sm(k) +smd + + !============================ + ! ** For elh (see below), qdiv at Level 3 is reset to 1.0. ** + qdiv = 1.0 + + ! Level 3 debug prints + IF ( debug_code ) THEN + IF (sh(k)<-0.3 .OR. sm(k)<-0.3 .OR. & + qke(k) < -0.1 .or. ABS(smd) .gt. 2.0) THEN + print*," MYNN; mym_turbulence3.0; sh=",sh(k)," k=",k + print*," gm=",gm(k)," gh=",gh(k)," sm=",sm(k) + print*," q2sq=",q2sq," q3sq=",q3sq," q3/q2=",q3sq/q2sq + print*," qke=",qke(k)," el=",el(k)," ri=",ri + print*," PBLH=",zi," u=",u(k)," v=",v(k) + ENDIF + ENDIF + +! ** Level 3 : end ** + + ELSE +! ** At Level 2.5, qdiv is not reset. ** + gamt = 0.0 + gamq = 0.0 + gamv = 0.0 + END IF +! +! Add min background stability function (diffusivity) within model levels +! with active plumes and clouds. + cldavg = 0.5*(cldfra_bl1D(k-1) + cldfra_bl1D(k)) + IF (edmf_a1(k) > 0.001 .OR. cldavg > 0.02) THEN + ! for mass-flux columns + sm(k) = MAX(sm(k), 0.03*MIN(10.*edmf_a1(k)*edmf_w1(k),1.0) ) + sh(k) = MAX(sh(k), 0.03*MIN(10.*edmf_a1(k)*edmf_w1(k),1.0) ) + ! for clouds + sm(k) = MAX(sm(k), 0.05*MIN(cldavg,1.0) ) + sh(k) = MAX(sh(k), 0.05*MIN(cldavg,1.0) ) + ENDIF +! + elq = el(k)*qkw(k) + elh = elq*qdiv + + ! Production of TKE (pdk), T-variance (pdt), + ! q-variance (pdq), and covariance (pdc) + pdk(k) = elq*( sm(k)*gm(k) & + & +sh(k)*gh(k)+gamv ) + & + & 0.5*TKEprodTD(k) ! xmchen + pdt(k) = elh*( sh(k)*dtl(k)+gamt )*dtl(k) + pdq(k) = elh*( sh(k)*dqw(k)+gamq )*dqw(k) + pdc(k) = elh*( sh(k)*dtl(k)+gamt ) & + & *dqw(k)*0.5 & + & + elh*( sh(k)*dqw(k)+gamq )*dtl(k)*0.5 + + ! Contergradient terms + tcd(k) = elq*gamt + qcd(k) = elq*gamq + + ! Eddy Diffusivity/Viscosity divided by dz + dfm(k) = elq*sm(k) / dzk + dfh(k) = elq*sh(k) / dzk +! Modified: Dec/22/2005, from here +! ** In sub.mym_predict, dfq for the TKE and scalar variance ** +! ** are set to 3.0*dfm and 1.0*dfm, respectively. (Sqfac) ** + dfq(k) = dfm(k) +! Modified: Dec/22/2005, up to here + + IF (bl_mynn_tkebudget) THEN + !TKE BUDGET +! dudz = ( u(k)-u(k-1) )/dzk +! dvdz = ( v(k)-v(k-1) )/dzk +! dTdz = ( thl(k)-thl(k-1) )/dzk + +! upwp = -elq*sm(k)*dudz +! vpwp = -elq*sm(k)*dvdz +! Tpwp = -elq*sh(k)*dTdz +! Tpwp = SIGN(MAX(ABS(Tpwp),1.E-6),Tpwp) + + +!! TKE budget (Puhales, 2020, WRF 4.2.1) << EOB + + !!!Shear Term + !!!qSHEAR1D(k)=-(upwp*dudz + vpwp*dvdz) + qSHEAR1D(k) = elq*sm(k)*gm(k) !staggered + + !!!Buoyancy Term + !!!qBUOY1D(k)=grav*Tpwp/thl(k) + !qBUOY1D(k)= elq*(sh(k)*gh(k) + gamv) + !qBUOY1D(k) = elq*(sh(k)*(-dTdz*grav/thl(k)) + gamv) !! ORIGINAL CODE + + !! Buoyncy term takes the TKEprodTD(k) production now + qBUOY1D(k) = elq*(sh(k)*gh(k)+gamv)+0.5*TKEprodTD(k) ! xmchen + + !!!Dissipation Term (now it evaluated in mym_predict) + !qDISS1D(k) = (q3sq**(3./2.))/(b1*MAX(el(k),1.)) !! ORIGINAL CODE + + !! >> EOB + ENDIF + + END DO +! + + dfm(kts) = 0.0 + dfh(kts) = 0.0 + dfq(kts) = 0.0 + tcd(kts) = 0.0 + qcd(kts) = 0.0 + + tcd(kte) = 0.0 + qcd(kte) = 0.0 + +! + DO k = kts,kte-1 + dzk = dz(k) + tcd(k) = ( tcd(k+1)-tcd(k) )/( dzk ) + qcd(k) = ( qcd(k+1)-qcd(k) )/( dzk ) + END DO +! + if (spp_pbl==1) then + DO k = kts,kte + dfm(k)= dfm(k) + dfm(k)* rstoch_col(k) * 1.5 * MAX(exp(-MAX(zw(k)-8000.,0.0)/2000.),0.001) + dfh(k)= dfh(k) + dfh(k)* rstoch_col(k) * 1.5 * MAX(exp(-MAX(zw(k)-8000.,0.0)/2000.),0.001) + END DO + endif + +! RETURN +#ifdef HARDCODE_VERTICAL +# undef kts +# undef kte +#endif + + END SUBROUTINE mym_turbulence + +! ================================================================== +! SUBROUTINE mym_predict: +! +! Input variables: see subroutine mym_initialize and turbulence +! qke(nx,nz,ny) : qke at (n)th time level +! tsq, ...cov : ditto +! +! Output variables: +! qke(nx,nz,ny) : qke at (n+1)th time level +! tsq, ...cov : ditto +! +! Work arrays: +! qkw(nx,nz,ny) : q at the center of the grid boxes (m/s) +! bp (nx,nz,ny) : = 1/2*F, see below +! rp (nx,nz,ny) : = P-1/2*F*Q, see below +! +! # The equation for a turbulent quantity Q can be expressed as +! dQ/dt + Ah + Av = Dh + Dv + P - F*Q, (1) +! where A is the advection, D the diffusion, P the production, +! F*Q the dissipation and h and v denote horizontal and vertical, +! respectively. If Q is q^2, F is 2q/B_1L. +! Using the Crank-Nicholson scheme for Av, Dv and F*Q, a finite +! difference equation is written as +! Q{n+1} - Q{n} = dt *( Dh{n} - Ah{n} + P{n} ) +! + dt/2*( Dv{n} - Av{n} - F*Q{n} ) +! + dt/2*( Dv{n+1} - Av{n+1} - F*Q{n+1} ), (2) +! where n denotes the time level. +! When the advection and diffusion terms are discretized as +! dt/2*( Dv - Av ) = a(k)Q(k+1) - b(k)Q(k) + c(k)Q(k-1), (3) +! Eq.(2) can be rewritten as +! - a(k)Q(k+1) + [ 1 + b(k) + dt/2*F ]Q(k) - c(k)Q(k-1) +! = Q{n} + dt *( Dh{n} - Ah{n} + P{n} ) +! + dt/2*( Dv{n} - Av{n} - F*Q{n} ), (4) +! where Q on the left-hand side is at (n+1)th time level. +! +! In this subroutine, a(k), b(k) and c(k) are obtained from +! subprogram coefvu and are passed to subprogram tinteg via +! common. 1/2*F and P-1/2*F*Q are stored in bp and rp, +! respectively. Subprogram tinteg solves Eq.(4). +! +! Modify this subroutine according to your numerical integration +! scheme (program). +! +!------------------------------------------------------------------- +!>\ingroup gsd_mynn_edmf +!! This subroutine predicts the turbulent quantities at the next step. + SUBROUTINE mym_predict (kts,kte, & + & closure, & + & delt, & + & dz, & + & ust, flt, flq, pmz, phh, & + & el, dfq, rho, & + & pdk, pdt, pdq, pdc, & + & qke, tsq, qsq, cov, & + & s_aw,s_awqke,bl_mynn_edmf_tke, & + & qWT1D, qDISS1D,bl_mynn_tkebudget) !! TKE budget (Puhales, 2020) + +!------------------------------------------------------------------- + integer, intent(in) :: kts,kte + +#ifdef HARDCODE_VERTICAL +# define kts 1 +# define kte HARDCODE_VERTICAL +#endif + + logical, intent(in) :: bl_mynn_edmf_tke,bl_mynn_tkebudget + real(kind_phys), intent(in) :: closure + real(kind_phys), dimension(kts:kte), intent(in) :: dz, dfq, el, rho + real(kind_phys), dimension(kts:kte), intent(inout) :: pdk, pdt, pdq, pdc + real(kind_phys), intent(in) :: flt, flq, pmz, phh + real(kind_phys), intent(in) :: ust, delt + real(kind_phys), dimension(kts:kte), intent(inout) :: qke,tsq, qsq, cov +! WA 8/3/15 + real(kind_phys), dimension(kts:kte+1), intent(inout) :: s_awqke,s_aw + + !! TKE budget (Puhales, 2020, WRF 4.2.1) << EOB + real(kind_phys), dimension(kts:kte), intent(out) :: qWT1D, qDISS1D + real(kind_phys), dimension(kts:kte) :: tke_up,dzinv + !! >> EOB + + integer :: k + real(kind_phys), dimension(kts:kte) :: qkw, bp, rp, df3q + real(kind_phys):: vkz,pdk1,phm,pdt1,pdq1,pdc1,b1l,b2l,onoff + real(kind_phys), dimension(kts:kte) :: dtz + real(kind_phys), dimension(kts:kte) :: a,b,c,d,x + + real(kind_phys), dimension(kts:kte) :: rhoinv + real(kind_phys), dimension(kts:kte+1) :: rhoz,kqdz,kmdz + + ! REGULATE THE MOMENTUM MIXING FROM THE MASS-FLUX SCHEME (on or off) + IF (.not. bl_mynn_edmf_tke) THEN + onoff=0.0 + ELSE + onoff=1.0 + ENDIF + +! ** Strictly, vkz*h(i,j) -> karman*( 0.5*dz(1)*h(i,j)+z0 ) ** + vkz = karman*0.5*dz(kts) +! +! ** dfq for the TKE is 3.0*dfm. ** +! + DO k = kts,kte +!! qke(k) = MAX(qke(k), 0.0) + qkw(k) = SQRT( MAX( qke(k), 0.0 ) ) + df3q(k)=Sqfac*dfq(k) + dtz(k)=delt/dz(k) + END DO +! +!JOE-add conservation + stability criteria + !Prepare "constants" for diffusion equation. + !khdz = rho*Kh/dz = rho*dfh + rhoz(kts) =rho(kts) + rhoinv(kts)=1./rho(kts) + kqdz(kts) =rhoz(kts)*df3q(kts) + kmdz(kts) =rhoz(kts)*dfq(kts) + DO k=kts+1,kte + rhoz(k) =(rho(k)*dz(k-1) + rho(k-1)*dz(k))/(dz(k-1)+dz(k)) + rhoz(k) = MAX(rhoz(k),1E-4) + rhoinv(k)=1./MAX(rho(k),1E-4) + kqdz(k) = rhoz(k)*df3q(k) ! for TKE + kmdz(k) = rhoz(k)*dfq(k) ! for T'2, q'2, and T'q' + ENDDO + rhoz(kte+1)=rhoz(kte) + kqdz(kte+1)=rhoz(kte+1)*df3q(kte) + kmdz(kte+1)=rhoz(kte+1)*dfq(kte) + + !stability criteria for mf + DO k=kts+1,kte-1 + kqdz(k) = MAX(kqdz(k), 0.5* s_aw(k)) + kqdz(k) = MAX(kqdz(k), -0.5*(s_aw(k)-s_aw(k+1))) + kmdz(k) = MAX(kmdz(k), 0.5* s_aw(k)) + kmdz(k) = MAX(kmdz(k), -0.5*(s_aw(k)-s_aw(k+1))) + ENDDO + !end conservation mods + + pdk1 = 2.0*ust**3*pmz/( vkz ) + phm = 2.0/ust *phh/( vkz ) + pdt1 = phm*flt**2 + pdq1 = phm*flq**2 + pdc1 = phm*flt*flq +! +! ** pdk(1)+pdk(2) corresponds to pdk1. ** + pdk(kts) = pdk1 - pdk(kts+1) + +!! pdt(kts) = pdt1 -pdt(kts+1) +!! pdq(kts) = pdq1 -pdq(kts+1) +!! pdc(kts) = pdc1 -pdc(kts+1) + pdt(kts) = pdt(kts+1) + pdq(kts) = pdq(kts+1) + pdc(kts) = pdc(kts+1) +! +! ** Prediction of twice the turbulent kinetic energy ** +!! DO k = kts+1,kte-1 + DO k = kts,kte-1 + b1l = b1*0.5*( el(k+1)+el(k) ) + bp(k) = 2.*qkw(k) / b1l + rp(k) = pdk(k+1) + pdk(k) + END DO + +!! a(1)=0. +!! b(1)=1. +!! c(1)=-1. +!! d(1)=0. + +! Since df3q(kts)=0.0, a(1)=0.0 and b(1)=1.+dtz(k)*df3q(k+1)+bp(k)*delt. + DO k=kts,kte-1 +! a(k-kts+1)=-dtz(k)*df3q(k) +! b(k-kts+1)=1.+dtz(k)*(df3q(k)+df3q(k+1))+bp(k)*delt +! c(k-kts+1)=-dtz(k)*df3q(k+1) +! d(k-kts+1)=rp(k)*delt + qke(k) +! WA 8/3/15 add EDMF contribution +! a(k)= - dtz(k)*df3q(k) + 0.5*dtz(k)*s_aw(k)*onoff +! b(k)=1. + dtz(k)*(df3q(k)+df3q(k+1)) & +! + 0.5*dtz(k)*(s_aw(k)-s_aw(k+1))*onoff + bp(k)*delt +! c(k)= - dtz(k)*df3q(k+1) - 0.5*dtz(k)*s_aw(k+1)*onoff +! d(k)=rp(k)*delt + qke(k) + dtz(k)*(s_awqke(k)-s_awqke(k+1))*onoff +!JOE 8/22/20 improve conservation + a(k)= - dtz(k)*kqdz(k)*rhoinv(k) & + & + 0.5*dtz(k)*rhoinv(k)*s_aw(k)*onoff + b(k)=1. + dtz(k)*(kqdz(k)+kqdz(k+1))*rhoinv(k) & + & + 0.5*dtz(k)*rhoinv(k)*(s_aw(k)-s_aw(k+1))*onoff & + & + bp(k)*delt + c(k)= - dtz(k)*kqdz(k+1)*rhoinv(k) & + & - 0.5*dtz(k)*rhoinv(k)*s_aw(k+1)*onoff + d(k)=rp(k)*delt + qke(k) & + & + dtz(k)*rhoinv(k)*(s_awqke(k)-s_awqke(k+1))*onoff + ENDDO + +!! DO k=kts+1,kte-1 +!! a(k-kts+1)=-dtz(k)*df3q(k) +!! b(k-kts+1)=1.+dtz(k)*(df3q(k)+df3q(k+1)) +!! c(k-kts+1)=-dtz(k)*df3q(k+1) +!! d(k-kts+1)=rp(k)*delt + qke(k) - qke(k)*bp(k)*delt +!! ENDDO + +!! "no flux at top" +! a(kte)=-1. !0. +! b(kte)=1. +! c(kte)=0. +! d(kte)=0. +!! "prescribed value" + a(kte)=0. + b(kte)=1. + c(kte)=0. + d(kte)=qke(kte) + +! CALL tridiag(kte,a,b,c,d) + CALL tridiag2(kte,a,b,c,d,x) + + DO k=kts,kte +! qke(k)=max(d(k-kts+1), 1.e-4) + qke(k)=max(x(k), 1.e-4) + qke(k)=min(qke(k), 150.) + ENDDO + + +!! TKE budget (Puhales, 2020, WRF 4.2.1) << EOB + IF (bl_mynn_tkebudget) THEN + !! TKE Vertical transport << EOBvt + tke_up=0.5*qke + dzinv=1./dz + k=kts + qWT1D(k)=dzinv(k)*( & + & (kqdz(k+1)*(tke_up(k+1)-tke_up(k))-kqdz(k)*tke_up(k)) & + & + 0.5*rhoinv(k)*(s_aw(k+1)*tke_up(k+1) & + & + (s_aw(k+1)-s_aw(k))*tke_up(k) & + & + (s_awqke(k)-s_awqke(k+1)))*onoff) !unstaggered + DO k=kts+1,kte-1 + qWT1D(k)=dzinv(k)*( & + & (kqdz(k+1)*(tke_up(k+1)-tke_up(k))-kqdz(k)*(tke_up(k)-tke_up(k-1))) & + & + 0.5*rhoinv(k)*(s_aw(k+1)*tke_up(k+1) & + & + (s_aw(k+1)-s_aw(k))*tke_up(k) & + & - s_aw(k)*tke_up(k-1) & + & + (s_awqke(k)-s_awqke(k+1)))*onoff) !unstaggered + ENDDO + k=kte + qWT1D(k)=dzinv(k)*(-kqdz(k)*(tke_up(k)-tke_up(k-1)) & + & + 0.5*rhoinv(k)*(-s_aw(k)*tke_up(k)-s_aw(k)*tke_up(k-1)+s_awqke(k))*onoff) !unstaggered + !! >> EOBvt + qDISS1D=bp*tke_up !! TKE dissipation rate !unstaggered + END IF +!! >> EOB + + IF ( closure > 2.5 ) THEN + + ! ** Prediction of the moisture variance ** + DO k = kts,kte-1 + b2l = b2*0.5*( el(k+1)+el(k) ) + bp(k) = 2.*qkw(k) / b2l + rp(k) = pdq(k+1) + pdq(k) + END DO + + !zero gradient for qsq at bottom and top + !a(1)=0. + !b(1)=1. + !c(1)=-1. + !d(1)=0. + + ! Since dfq(kts)=0.0, a(1)=0.0 and b(1)=1.+dtz(k)*dfq(k+1)+bp(k)*delt. + DO k=kts,kte-1 + a(k)= - dtz(k)*kmdz(k)*rhoinv(k) + b(k)=1. + dtz(k)*(kmdz(k)+kmdz(k+1))*rhoinv(k) + bp(k)*delt + c(k)= - dtz(k)*kmdz(k+1)*rhoinv(k) + d(k)=rp(k)*delt + qsq(k) + ENDDO + + a(kte)=-1. !0. + b(kte)=1. + c(kte)=0. + d(kte)=0. + +! CALL tridiag(kte,a,b,c,d) + CALL tridiag2(kte,a,b,c,d,x) + + DO k=kts,kte + !qsq(k)=d(k-kts+1) + qsq(k)=MAX(x(k),1e-17) + ENDDO + ELSE + !level 2.5 - use level 2 diagnostic + DO k = kts,kte-1 + IF ( qkw(k) .LE. 0.0 ) THEN + b2l = 0.0 + ELSE + b2l = b2*0.25*( el(k+1)+el(k) )/qkw(k) + END IF + qsq(k) = b2l*( pdq(k+1)+pdq(k) ) + END DO + qsq(kte)=qsq(kte-1) + END IF +!!!!!!!!!!!!!!!!!!!!!!end level 2.6 + + IF ( closure .GE. 3.0 ) THEN +! +! ** dfq for the scalar variance is 1.0*dfm. ** +! +! ** Prediction of the temperature variance ** +!! DO k = kts+1,kte-1 + DO k = kts,kte-1 + b2l = b2*0.5*( el(k+1)+el(k) ) + bp(k) = 2.*qkw(k) / b2l + rp(k) = pdt(k+1) + pdt(k) + END DO + +!zero gradient for tsq at bottom and top + +!! a(1)=0. +!! b(1)=1. +!! c(1)=-1. +!! d(1)=0. + +! Since dfq(kts)=0.0, a(1)=0.0 and b(1)=1.+dtz(k)*dfq(k+1)+bp(k)*delt. + DO k=kts,kte-1 + !a(k-kts+1)=-dtz(k)*dfq(k) + !b(k-kts+1)=1.+dtz(k)*(dfq(k)+dfq(k+1))+bp(k)*delt + !c(k-kts+1)=-dtz(k)*dfq(k+1) + !d(k-kts+1)=rp(k)*delt + tsq(k) +!JOE 8/22/20 improve conservation + a(k)= - dtz(k)*kmdz(k)*rhoinv(k) + b(k)=1. + dtz(k)*(kmdz(k)+kmdz(k+1))*rhoinv(k) + bp(k)*delt + c(k)= - dtz(k)*kmdz(k+1)*rhoinv(k) + d(k)=rp(k)*delt + tsq(k) + ENDDO + +!! DO k=kts+1,kte-1 +!! a(k-kts+1)=-dtz(k)*dfq(k) +!! b(k-kts+1)=1.+dtz(k)*(dfq(k)+dfq(k+1)) +!! c(k-kts+1)=-dtz(k)*dfq(k+1) +!! d(k-kts+1)=rp(k)*delt + tsq(k) - tsq(k)*bp(k)*delt +!! ENDDO + + a(kte)=-1. !0. + b(kte)=1. + c(kte)=0. + d(kte)=0. + +! CALL tridiag(kte,a,b,c,d) + CALL tridiag2(kte,a,b,c,d,x) + + DO k=kts,kte +! tsq(k)=d(k-kts+1) + tsq(k)=x(k) + ENDDO + +! ** Prediction of the temperature-moisture covariance ** +!! DO k = kts+1,kte-1 + DO k = kts,kte-1 + b2l = b2*0.5*( el(k+1)+el(k) ) + bp(k) = 2.*qkw(k) / b2l + rp(k) = pdc(k+1) + pdc(k) + END DO + +!zero gradient for tqcov at bottom and top + +!! a(1)=0. +!! b(1)=1. +!! c(1)=-1. +!! d(1)=0. + +! Since dfq(kts)=0.0, a(1)=0.0 and b(1)=1.+dtz(k)*dfq(k+1)+bp(k)*delt. + DO k=kts,kte-1 + !a(k-kts+1)=-dtz(k)*dfq(k) + !b(k-kts+1)=1.+dtz(k)*(dfq(k)+dfq(k+1))+bp(k)*delt + !c(k-kts+1)=-dtz(k)*dfq(k+1) + !d(k-kts+1)=rp(k)*delt + cov(k) +!JOE 8/22/20 improve conservation + a(k)= - dtz(k)*kmdz(k)*rhoinv(k) + b(k)=1. + dtz(k)*(kmdz(k)+kmdz(k+1))*rhoinv(k) + bp(k)*delt + c(k)= - dtz(k)*kmdz(k+1)*rhoinv(k) + d(k)=rp(k)*delt + cov(k) + ENDDO + +!! DO k=kts+1,kte-1 +!! a(k-kts+1)=-dtz(k)*dfq(k) +!! b(k-kts+1)=1.+dtz(k)*(dfq(k)+dfq(k+1)) +!! c(k-kts+1)=-dtz(k)*dfq(k+1) +!! d(k-kts+1)=rp(k)*delt + cov(k) - cov(k)*bp(k)*delt +!! ENDDO + + a(kte)=-1. !0. + b(kte)=1. + c(kte)=0. + d(kte)=0. + +! CALL tridiag(kte,a,b,c,d) + CALL tridiag2(kte,a,b,c,d,x) + + DO k=kts,kte +! cov(k)=d(k-kts+1) + cov(k)=x(k) + ENDDO + + ELSE + + !Not level 3 - default to level 2 diagnostic + DO k = kts,kte-1 + IF ( qkw(k) .LE. 0.0 ) THEN + b2l = 0.0 + ELSE + b2l = b2*0.25*( el(k+1)+el(k) )/qkw(k) + END IF +! + tsq(k) = b2l*( pdt(k+1)+pdt(k) ) + cov(k) = b2l*( pdc(k+1)+pdc(k) ) + END DO + + tsq(kte)=tsq(kte-1) + cov(kte)=cov(kte-1) + + END IF + +#ifdef HARDCODE_VERTICAL +# undef kts +# undef kte +#endif + + END SUBROUTINE mym_predict + +! ================================================================== +! SUBROUTINE mym_condensation: +! +! Input variables: see subroutine mym_initialize and turbulence +! exner(nz) : Perturbation of the Exner function (J/kg K) +! defined on the walls of the grid boxes +! This is usually computed by integrating +! d(pi)/dz = h*g*tv/tref**2 +! from the upper boundary, where tv is the +! virtual potential temperature minus tref. +! +! Output variables: see subroutine mym_initialize +! cld(nx,nz,ny) : Cloud fraction +! +! Work arrays/variables: +! qmq : Q_w-Q_{sl}, where Q_{sl} is the saturation +! specific humidity at T=Tl +! alp(nx,nz,ny) : Functions in the condensation process +! bet(nx,nz,ny) : ditto +! sgm(nx,nz,ny) : Combined standard deviation sigma_s +! multiplied by 2/alp +! +! # qmq, alp, bet and sgm are allowed to share storage units with +! any four of other work arrays for saving memory. +! +! # Results are sensitive particularly to values of cp and r_d. +! Set these values to those adopted by you. +! +!------------------------------------------------------------------- +!>\ingroup gsd_mynn_edmf +!! This subroutine calculates the nonconvective component of the +!! subgrid cloud fraction and mixing ratio as well as the functions used to +!! calculate the buoyancy flux. Different cloud PDFs can be selected by +!! use of the namelist parameter \p bl_mynn_cloudpdf . + SUBROUTINE mym_condensation (kts,kte, & + & dx, dz, zw, xland, & + & thl, qw, qv, qc, qi, qs, & + & p,exner, & + & tsq, qsq, cov, & + & Sh, el, bl_mynn_cloudpdf, & + & qc_bl1D, qi_bl1D, & + & cldfra_bl1D, & + & PBLH1,HFX1, & + & Vt, Vq, th, sgm, rmo, & + & spp_pbl,rstoch_col ) + +!------------------------------------------------------------------- + + integer, intent(in) :: kts,kte, bl_mynn_cloudpdf + +#ifdef HARDCODE_VERTICAL +# define kts 1 +# define kte HARDCODE_VERTICAL +#endif + + real(kind_phys), intent(in) :: HFX1,rmo,xland + real(kind_phys), intent(in) :: dx,pblh1 + real(kind_phys), dimension(kts:kte), intent(in) :: dz + real(kind_phys), dimension(kts:kte+1), intent(in) :: zw + real(kind_phys), dimension(kts:kte), intent(in) :: p,exner,thl,qw, & + &qv,qc,qi,qs,tsq,qsq,cov,th + + real(kind_phys), dimension(kts:kte), intent(inout) :: vt,vq,sgm + + real(kind_phys), dimension(kts:kte) :: alp,a,bet,b,ql,q1,RH + real(kind_phys), dimension(kts:kte), intent(out) :: qc_bl1D,qi_bl1D, & + &cldfra_bl1D + DOUBLE PRECISION :: t3sq, r3sq, c3sq + + real(kind_phys):: qsl,esat,qsat,dqsl,cld0,q1k,qlk,eq1,qll, & + &q2p,pt,rac,qt,t,xl,rsl,cpm,Fng,qww,alpha,beta,bb, & + &ls,wt,wt2,qpct,cld_factor,fac_damp,liq_frac,ql_ice,ql_water, & + &qmq,qsat_tk,q1_rh,rh_hack,dzm1,zsl,maxqc + real(kind_phys), parameter :: qpct_sfc=0.025 + real(kind_phys), parameter :: qpct_pbl=0.030 + real(kind_phys), parameter :: qpct_trp=0.040 + real(kind_phys), parameter :: rhcrit =0.83 !for cloudpdf = 2 + real(kind_phys), parameter :: rhmax =1.02 !for cloudpdf = 2 + integer :: i,j,k + + real(kind_phys):: erf + + !VARIABLES FOR ALTERNATIVE SIGMA + real(kind_phys):: dth,dtl,dqw,dzk,els + real(kind_phys), dimension(kts:kte), intent(in) :: Sh,el + + !variables for SGS BL clouds + real(kind_phys) :: zagl,damp,PBLH2 + real(kind_phys) :: cfmax + + !JAYMES: variables for tropopause-height estimation + real(kind_phys) :: theta1, theta2, ht1, ht2 + integer :: k_tropo + +! Stochastic + integer, intent(in) :: spp_pbl + real(kind_phys), dimension(kts:kte) :: rstoch_col + real(kind_phys) :: qw_pert + +! First, obtain an estimate for the tropopause height (k), using the method employed in the +! Thompson subgrid-cloud scheme. This height will be a consideration later when determining +! the "final" subgrid-cloud properties. +! JAYMES: added 3 Nov 2016, adapted from G. Thompson + + DO k = kte-3, kts, -1 + theta1 = th(k) + theta2 = th(k+2) + ht1 = 44307.692 * (1.0 - (p(k)/101325.)**0.190) + ht2 = 44307.692 * (1.0 - (p(k+2)/101325.)**0.190) + if ( (((theta2-theta1)/(ht2-ht1)) .lt. 10./1500. ) .AND. & + & (ht1.lt.19000.) .and. (ht1.gt.4000.) ) then + goto 86 + endif + ENDDO + 86 continue + k_tropo = MAX(kts+2, k+2) + + zagl = 0. + + SELECT CASE(bl_mynn_cloudpdf) + + CASE (0) ! ORIGINAL MYNN PARTIAL-CONDENSATION SCHEME + + DO k = kts,kte-1 + t = th(k)*exner(k) + +!x if ( ct .gt. 0.0 ) then +! a = 17.27 +! b = 237.3 +!x else +!x a = 21.87 +!x b = 265.5 +!x end if +! +! ** 3.8 = 0.622*6.11 (hPa) ** + + !SATURATED VAPOR PRESSURE + esat = esat_blend(t,t0c,tice) + !SATURATED SPECIFIC HUMIDITY + !qsl=ep_2*esat/(p(k)-ep_3*esat) + qsl=ep_2*esat/max(1.e-4,(p(k)-ep_3*esat)) + !dqw/dT: Clausius-Clapeyron + dqsl = qsl*ep_2*xlv/( r_d*t**2 ) + + alp(k) = 1.0/( 1.0+dqsl*xlvcp ) + bet(k) = dqsl*exner(k) + + !Sommeria and Deardorff (1977) scheme, as implemented + !in Nakanishi and Niino (2009), Appendix B + t3sq = MAX( tsq(k), 0.0 ) + r3sq = MAX( qsq(k), 0.0 ) + c3sq = cov(k) + c3sq = SIGN( MIN( ABS(c3sq), SQRT(t3sq*r3sq) ), c3sq ) + r3sq = r3sq +bet(k)**2*t3sq -2.0*bet(k)*c3sq + !DEFICIT/EXCESS WATER CONTENT + qmq = qw(k) -qsl + !ORIGINAL STANDARD DEVIATION + sgm(k) = SQRT( MAX( r3sq, 1.0d-10 )) + !NORMALIZED DEPARTURE FROM SATURATION + q1(k) = qmq / sgm(k) + !CLOUD FRACTION. rr2 = 1/SQRT(2) = 0.707 + cldfra_bl1D(k) = 0.5*( 1.0+erf( q1(k)*rr2 ) ) + + q1k = q1(k) + eq1 = rrp*EXP( -0.5*q1k*q1k ) + qll = MAX( cldfra_bl1D(k)*q1k + eq1, 0.0 ) + !ESTIMATED LIQUID WATER CONTENT (UNNORMALIZED) + ql(k) = alp(k)*sgm(k)*qll + !LIMIT SPECIES TO TEMPERATURE RANGES + liq_frac = min(1.0, max(0.0,(t-240.0)/29.0)) + qc_bl1D(k) = liq_frac*ql(k) + qi_bl1D(k) = (1.0 - liq_frac)*ql(k) + + !Now estimate the buoyancy flux functions + q2p = xlvcp/exner(k) + pt = thl(k) +q2p*ql(k) ! potential temp + + !qt is a THETA-V CONVERSION FOR TOTAL WATER (i.e., THETA-V = qt*THETA) + qt = 1.0 +p608*qw(k) -(1.+p608)*(qc_bl1D(k)+qi_bl1D(k))*cldfra_bl1D(k) + rac = alp(k)*( cldfra_bl1D(K)-qll*eq1 )*( q2p*qt-(1.+p608)*pt ) + + !BUOYANCY FACTORS: wherever vt and vq are used, there is a + !"+1" and "+tv0", respectively, so these are subtracted out here. + !vt is unitless and vq has units of K. + vt(k) = qt-1.0 -rac*bet(k) + vq(k) = p608*pt-tv0 +rac + + END DO + + CASE (1, -1) !ALTERNATIVE FORM (Nakanishi & Niino 2004 BLM, eq. B6, and + !Kuwano-Yoshida et al. 2010 QJRMS, eq. 7): + DO k = kts,kte-1 + t = th(k)*exner(k) + !SATURATED VAPOR PRESSURE + esat = esat_blend(t,t0c,tice) + !SATURATED SPECIFIC HUMIDITY + !qsl=ep_2*esat/(p(k)-ep_3*esat) + qsl=ep_2*esat/max(1.e-4,(p(k)-ep_3*esat)) + !dqw/dT: Clausius-Clapeyron + dqsl = qsl*ep_2*xlv/( r_d*t**2 ) + + alp(k) = 1.0/( 1.0+dqsl*xlvcp ) + bet(k) = dqsl*exner(k) + + if (k .eq. kts) then + dzk = 0.5*dz(k) + else + dzk = dz(k) + end if + dth = 0.5*(thl(k+1)+thl(k)) - 0.5*(thl(k)+thl(MAX(k-1,kts))) + dqw = 0.5*(qw(k+1) + qw(k)) - 0.5*(qw(k) + qw(MAX(k-1,kts))) + sgm(k) = SQRT( MAX( (alp(k)**2 * MAX(el(k)**2,0.1) * & + b2 * MAX(Sh(k),0.03))/4. * & + (dqw/dzk - bet(k)*(dth/dzk ))**2 , 1.0e-10) ) + qmq = qw(k) -qsl + q1(k) = qmq / sgm(k) + cldfra_bl1D(K) = 0.5*( 1.0+erf( q1(k)*rr2 ) ) + + !now compute estimated lwc for PBL scheme's use + !qll IS THE NORMALIZED LIQUID WATER CONTENT (Sommeria and + !Deardorff (1977, eq 29a). rrp = 1/(sqrt(2*pi)) = 0.3989 + q1k = q1(k) + eq1 = rrp*EXP( -0.5*q1k*q1k ) + qll = MAX( cldfra_bl1D(K)*q1k + eq1, 0.0 ) + !ESTIMATED LIQUID WATER CONTENT (UNNORMALIZED) + ql (k) = alp(k)*sgm(k)*qll + liq_frac = min(1.0, max(0.0,(t-240.0)/29.0)) + qc_bl1D(k) = liq_frac*ql(k) + qi_bl1D(k) = (1.0 - liq_frac)*ql(k) + + !Now estimate the buoyancy flux functions + q2p = xlvcp/exner(k) + pt = thl(k) +q2p*ql(k) ! potential temp + + !qt is a THETA-V CONVERSION FOR TOTAL WATER (i.e., THETA-V = qt*THETA) + qt = 1.0 +p608*qw(k) -(1.+p608)*(qc_bl1D(k)+qi_bl1D(k))*cldfra_bl1D(k) + rac = alp(k)*( cldfra_bl1D(K)-qll*eq1 )*( q2p*qt-(1.+p608)*pt ) + + !BUOYANCY FACTORS: wherever vt and vq are used, there is a + !"+1" and "+tv0", respectively, so these are subtracted out here. + !vt is unitless and vq has units of K. + vt(k) = qt-1.0 -rac*bet(k) + vq(k) = p608*pt-tv0 +rac + + END DO + + CASE (2, -2) + + !Diagnostic statistical scheme of Chaboureau and Bechtold (2002), JAS + !but with use of higher-order moments to estimate sigma + pblh2=MAX(10._kind_phys,pblh1) + zagl = 0. + dzm1 = 0. + DO k = kts,kte-1 + zagl = zagl + 0.5*(dz(k) + dzm1) + dzm1 = dz(k) + + t = th(k)*exner(k) + xl = xl_blend(t,t0c,tice,cice,cliq,cpv,xls,xlv) ! obtain latent heat + qsat_tk= qsat_blend(t,t0c,tice,p(k)) ! saturation water vapor mixing ratio at tk and p + rh(k) = MAX(MIN(rhmax, qw(k)/MAX(1.E-10,qsat_tk)),0.001_kind_phys) + + !dqw/dT: Clausius-Clapeyron + dqsl = qsat_tk*ep_2*xlv/( r_d*t**2 ) + alp(k) = 1.0/( 1.0+dqsl*xlvcp ) + bet(k) = dqsl*exner(k) + + rsl = xl*qsat_tk / (r_v*t**2) ! slope of C-C curve at t (=abs temperature) + ! CB02, Eqn. 4 + cpm = cp + qw(k)*cpv ! CB02, sec. 2, para. 1 + a(k) = 1./(1. + xl*rsl/cpm) ! CB02 variable "a" + b(k) = a(k)*rsl ! CB02 variable "b" + + !SPP + qw_pert= qw(k) + qw(k)*0.5*rstoch_col(k)*real(spp_pbl) + + !This form of qmq (the numerator of Q1) no longer uses the a(k) factor + qmq = qw_pert - qsat_tk ! saturation deficit/excess; + + !Use the form of Eq. (6) in Chaboureau and Bechtold (2002) + !except neglect all but the first term for sig_r + r3sq = max( qsq(k), 0.0 ) + !Calculate sigma using higher-order moments: + sgm(k) = SQRT( r3sq ) + !Set constraints on sigma relative to saturation water vapor + sgm(k) = min( sgm(k), qsat_tk*0.666 ) + !sgm(k) = max( sgm(k), qsat_tk*0.035 ) + + !introduce vertical grid spacing dependence on min sgm + wt = max(500. - max(dz(k)-100.,0.0), 0.0_kind_phys)/500. !=1 for dz < 100 m, =0 for dz > 600 m + sgm(k) = sgm(k) + sgm(k)*0.2*(1.0-wt) !inflate sgm for coarse dz + + !allow min sgm to vary with dz and z. + qpct = qpct_pbl*wt + qpct_trp*(1.0-wt) + qpct = min(qpct, max(qpct_sfc, qpct_pbl*zagl/500.) ) + sgm(k) = max( sgm(k), qsat_tk*qpct ) + + q1(k) = qmq / sgm(k) ! Q1, the normalized saturation + + !Add condition for falling/settling into low-RH layers, so at least + !some cloud fraction is applied for all qc, qs, and qi. + rh_hack= rh(k) + wt2 = min(max( zagl - pblh2, 0.0 )/300., 1.0) + !ensure adequate RH & q1 when qi is at least 1e-9 (above the PBLH) + if ((qi(k)+qs(k))>1.e-9 .and. (zagl .gt. pblh2)) then + rh_hack =min(rhmax, rhcrit + wt2*0.045*(9.0 + log10(qi(k)+qs(k)))) + rh(k) =max(rh(k), rh_hack) + !add rh-based q1 + q1_rh =-3. + 3.*(rh(k)-rhcrit)/(1.-rhcrit) + q1(k) =max(q1_rh, q1(k) ) + endif + !ensure adequate rh & q1 when qc is at least 1e-6 (above the PBLH) + if (qc(k)>1.e-6 .and. (zagl .gt. pblh2)) then + rh_hack =min(rhmax, rhcrit + wt2*0.08*(6.0 + log10(qc(k)))) + rh(k) =max(rh(k), rh_hack) + !add rh-based q1 + q1_rh =-3. + 3.*(rh(k)-rhcrit)/(1.-rhcrit) + q1(k) =max(q1_rh, q1(k) ) + endif + + q1k = q1(k) ! backup Q1 for later modification + + ! Specify cloud fraction + !Original C-B cloud fraction, allows cloud fractions out to q1 = -3.5 + !cldfra_bl1D(K) = max(0., min(1., 0.5+0.36*atan(1.55*q1(k)))) ! Eq. 7 in CB02 + !Waynes LES fit - over-diffuse, when limits removed from vt & vq & fng + !cldfra_bl1D(K) = max(0., min(1., 0.5+0.36*atan(1.2*(q1(k)+0.4)))) + !Best compromise: Improves marine stratus without adding much cold bias. + cldfra_bl1D(k) = max(0., min(1., 0.5+0.36*atan(1.8*(q1(k)+0.2)))) + + ! Specify hydrometeors + ! JAYMES- this option added 8 May 2015 + ! The cloud water formulations are taken from CB02, Eq. 8. + maxqc = max(qw(k) - qsat_tk, 0.0) + if (q1k < 0.) then !unsaturated + ql_water = sgm(k)*exp(1.2*q1k-1.) + ql_ice = sgm(k)*exp(1.2*q1k-1.) + elseif (q1k > 2.) then !supersaturated + ql_water = min(sgm(k)*q1k, maxqc) + ql_ice = sgm(k)*q1k + else !slightly saturated (0 > q1 < 2) + ql_water = min(sgm(k)*(exp(-1.) + 0.66*q1k + 0.086*q1k**2), maxqc) + ql_ice = sgm(k)*(exp(-1.) + 0.66*q1k + 0.086*q1k**2) + endif + + !In saturated grid cells, use average of SGS and resolved values + !if ( qc(k) > 1.e-6 ) ql_water = 0.5 * ( ql_water + qc(k) ) + !ql_ice is actually the total frozen condensate (snow+ice), + !if ( (qi(k)+qs(k)) > 1.e-9 ) ql_ice = 0.5 * ( ql_ice + (qi(k)+qs(k)) ) + + if (cldfra_bl1D(k) < 0.001) then + ql_ice = 0.0 + ql_water = 0.0 + cldfra_bl1D(k) = 0.0 + endif + + liq_frac = MIN(1.0, MAX(0.0, (t-tice)/(tliq-tice))) + qc_bl1D(k) = liq_frac*ql_water ! apply liq_frac to ql_water and ql_ice + qi_bl1D(k) = (1.0-liq_frac)*ql_ice + + !Above tropopause: eliminate subgrid clouds from CB scheme. Note that this was + !"k_tropo - 1" as of 20 Feb 2023. Changed to allow more high-level clouds. + if (k .ge. k_tropo) then + cldfra_bl1D(K) = 0. + qc_bl1D(k) = 0. + qi_bl1D(k) = 0. + endif + + !Buoyancy-flux-related calculations follow... + !limiting Q1 to avoid too much diffusion in cloud layers + !q1k=max(Q1(k),-2.0) + if ((xland-1.5).GE.0) then ! water + q1k=max(Q1(k),-2.5) + else ! land + q1k=max(Q1(k),-2.0) + endif + ! "Fng" represents the non-Gaussian transport factor + ! (non-dimensional) from Bechtold et al. 1995 + ! (hereafter BCMT95), section 3(c). Their suggested + ! forms for Fng (from their Eq. 20) are: + !IF (q1k < -2.) THEN + ! Fng = 2.-q1k + !ELSE IF (q1k > 0.) THEN + ! Fng = 1. + !ELSE + ! Fng = 1.-1.5*q1k + !ENDIF + ! Use the form of "Fng" from Bechtold and Siebesma (1998, JAS) + if (q1k .ge. 1.0) then + Fng = 1.0 + elseif (q1k .ge. -1.7 .and. q1k .lt. 1.0) then + Fng = exp(-0.4*(q1k-1.0)) + elseif (q1k .ge. -2.5 .and. q1k .lt. -1.7) then + Fng = 3.0 + exp(-3.8*(q1k+1.7)) + else + Fng = min(23.9 + exp(-1.6*(q1k+2.5)), 60._kind_phys) + endif + + cfmax = min(cldfra_bl1D(k), 0.6_kind_phys) + !Further limit the cf going into vt & vq near the surface + zsl = min(max(25., 0.1*pblh2), 100.) + wt = min(zagl/zsl, 1.0) !=0 at z=0 m, =1 above ekman layer + cfmax = cfmax*wt + + bb = b(k)*t/th(k) ! bb is "b" in BCMT95. Their "b" differs from + ! "b" in CB02 (i.e., b(k) above) by a factor + ! of T/theta. Strictly, b(k) above is formulated in + ! terms of sat. mixing ratio, but bb in BCMT95 is + ! cast in terms of sat. specific humidity. The + ! conversion is neglected here. + qww = 1.+0.61*qw(k) + alpha = 0.61*th(k) + beta = (th(k)/t)*(xl/cp) - 1.61*th(k) + vt(k) = qww - cfmax*beta*bb*Fng - 1. + vq(k) = alpha + cfmax*beta*a(k)*Fng - tv0 + ! vt and vq correspond to beta-theta and beta-q, respectively, + ! in NN09, Eq. B8. They also correspond to the bracketed + ! expressions in BCMT95, Eq. 15, since (s*ql/sigma^2) = cldfra*Fng + ! The "-1" and "-tv0" terms are included for consistency with + ! the legacy vt and vq formulations (above). + + ! dampen amplification factor where need be + fac_damp = min(zagl * 0.0025, 1.0) + !cld_factor = 1.0 + fac_damp*MAX(0.0, ( RH(k) - 0.75 ) / 0.26 )**1.9 !HRRRv4 + !cld_factor = 1.0 + fac_damp*min((max(0.0, ( RH(k) - 0.92 )) / 0.25 )**2, 0.3) + cld_factor = 1.0 + fac_damp*min((max(0.0, ( RH(k) - 0.92 )) / 0.145)**2, 0.37) + cldfra_bl1D(K) = min( 1., cld_factor*cldfra_bl1D(K) ) + enddo + + END SELECT !end cloudPDF option + + !For testing purposes only, option for isolating on the mass-flux clouds. + IF (bl_mynn_cloudpdf .LT. 0) THEN + DO k = kts,kte-1 + cldfra_bl1D(k) = 0.0 + qc_bl1D(k) = 0.0 + qi_bl1D(k) = 0.0 + END DO + ENDIF +! + ql(kte) = ql(kte-1) + vt(kte) = vt(kte-1) + vq(kte) = vq(kte-1) + qc_bl1D(kte)=0. + qi_bl1D(kte)=0. + cldfra_bl1D(kte)=0. + RETURN + +#ifdef HARDCODE_VERTICAL +# undef kts +# undef kte +#endif + + END SUBROUTINE mym_condensation + +! ================================================================== +!>\ingroup gsd_mynn_edmf +!! This subroutine solves for tendencies of U, V, \f$\theta\f$, qv, +!! qc, and qi + SUBROUTINE mynn_tendencies(kts,kte, & + &delt,dz,rho, & + &u,v,th,tk,qv,qc,qi,qs,qnc,qni, & + &psfc,p,exner, & + &thl,sqv,sqc,sqi,sqs,sqw, & + &qnwfa,qnifa,qnbca,ozone, & + &ust,flt,flq,flqv,flqc,wspd, & + &uoce,voce, & + &tsq,qsq,cov, & + &tcd,qcd, & + &dfm,dfh,dfq, & + &Du,Dv,Dth,Dqv,Dqc,Dqi,Dqs,Dqnc,Dqni, & + &Dqnwfa,Dqnifa,Dqnbca,Dozone, & + &diss_heat, & + &s_aw,s_awthl,s_awqt,s_awqv,s_awqc, & + &s_awu,s_awv, & + &s_awqnc,s_awqni, & + &s_awqnwfa,s_awqnifa,s_awqnbca, & + &sd_aw,sd_awthl,sd_awqt,sd_awqv, & + &sd_awqc,sd_awu,sd_awv, & + &sub_thl,sub_sqv, & + &sub_u,sub_v, & + &det_thl,det_sqv,det_sqc, & + &det_u,det_v, & + &FLAG_QC,FLAG_QI,FLAG_QNC,FLAG_QNI, & + &FLAG_QS, & + &FLAG_QNWFA,FLAG_QNIFA,FLAG_QNBCA, & + &FLAG_OZONE, & + &cldfra_bl1d, & + &bl_mynn_cloudmix, & + &bl_mynn_mixqt, & + &bl_mynn_edmf_mom, & + &bl_mynn_mixscalars ) + +!------------------------------------------------------------------- + integer, intent(in) :: kts,kte + +#ifdef HARDCODE_VERTICAL +# define kts 1 +# define kte HARDCODE_VERTICAL +#endif + + logical, intent(in) :: bl_mynn_edmf_mom + logical, intent(in) :: bl_mynn_mixscalars,bl_mynn_cloudmix,bl_mynn_mixqt + logical, intent(in) :: FLAG_QI,FLAG_QNI,FLAG_QC,FLAG_QS, & + &FLAG_QNC,FLAG_QNWFA,FLAG_QNIFA,FLAG_QNBCA,FLAG_OZONE + +! thl - liquid water potential temperature +! qw - total water +! dfm,dfh,dfq - diffusivities i.e., dfh(k) = elq*sh(k) / dzk +! flt - surface flux of thl +! flq - surface flux of qw + +! mass-flux plumes + real(kind_phys), dimension(kts:kte+1), intent(in) :: s_aw, & + &s_awthl,s_awqt,s_awqnc,s_awqni,s_awqv,s_awqc,s_awu,s_awv, & + &s_awqnwfa,s_awqnifa,s_awqnbca, & + &sd_aw,sd_awthl,sd_awqt,sd_awqv,sd_awqc,sd_awu,sd_awv +! tendencies from mass-flux environmental subsidence and detrainment + real(kind_phys), dimension(kts:kte), intent(in) :: sub_thl,sub_sqv, & + &sub_u,sub_v,det_thl,det_sqv,det_sqc,det_u,det_v + real(kind_phys), dimension(kts:kte), intent(in) :: u,v,th,tk,qv,qc,qi,& + &qs,qni,qnc,rho,p,exner,dfq,dz,tsq,qsq,cov,tcd,qcd, & + &cldfra_bl1d,diss_heat + real(kind_phys), dimension(kts:kte), intent(inout) :: thl,sqw,sqv,sqc,& + &sqi,sqs,qnwfa,qnifa,qnbca,ozone,dfm,dfh + real(kind_phys), dimension(kts:kte), intent(inout) :: du,dv,dth,dqv, & + &dqc,dqi,dqs,dqni,dqnc,dqnwfa,dqnifa,dqnbca,dozone + real(kind_phys), intent(in) :: flt,flq,flqv,flqc,uoce,voce + real(kind_phys), intent(in) :: ust,delt,psfc,wspd + !debugging + real(kind_phys):: wsp,wsp2,tk2,th2 + logical :: problem + integer :: kproblem + +! real(kind_phys), intent(in) :: gradu_top,gradv_top,gradth_top,gradqv_top + +!local vars + + real(kind_phys), dimension(kts:kte) :: dtz,dfhc,dfmc,delp + real(kind_phys), dimension(kts:kte) :: sqv2,sqc2,sqi2,sqs2,sqw2, & + &qni2,qnc2,qnwfa2,qnifa2,qnbca2,ozone2 + real(kind_phys), dimension(kts:kte) :: zfac,plumeKh,rhoinv + real(kind_phys), dimension(kts:kte) :: a,b,c,d,x + real(kind_phys), dimension(kts:kte+1) :: rhoz, & !rho on model interface + &khdz,kmdz + real(kind_phys):: rhs,gfluxm,gfluxp,dztop,maxdfh,mindfh,maxcf,maxKh,zw + real(kind_phys):: t,esat,qsl,onoff,kh,km,dzk,rhosfc + real(kind_phys):: ustdrag,ustdiff,qvflux + real(kind_phys):: th_new,portion_qc,portion_qi,condensate,qsat + integer :: k,kk + + !Activate nonlocal mixing from the mass-flux scheme for + !number concentrations and aerosols (0.0 = no; 1.0 = yes) + real(kind_phys), parameter :: nonloc = 1.0 + + dztop=.5*(dz(kte)+dz(kte-1)) + + ! REGULATE THE MOMENTUM MIXING FROM THE MASS-FLUX SCHEME (on or off) + ! Note that s_awu and s_awv already come in as 0.0 if bl_mynn_edmf_mom == .false., so + ! we only need to zero-out the MF term + IF (.not. bl_mynn_edmf_mom) THEN + onoff=0.0 + ELSE + onoff=1.0 + ENDIF + + !Prepare "constants" for diffusion equation. + !khdz = rho*Kh/dz = rho*dfh + rhosfc = psfc/(R_d*(tk(kts)+p608*qv(kts))) + dtz(kts) =delt/dz(kts) + rhoz(kts) =rho(kts) + rhoinv(kts)=1./rho(kts) + khdz(kts) =rhoz(kts)*dfh(kts) + kmdz(kts) =rhoz(kts)*dfm(kts) + delp(kts) = psfc - (p(kts+1)*dz(kts) + p(kts)*dz(kts+1))/(dz(kts)+dz(kts+1)) + DO k=kts+1,kte + dtz(k) =delt/dz(k) + rhoz(k) =(rho(k)*dz(k-1) + rho(k-1)*dz(k))/(dz(k-1)+dz(k)) + rhoz(k) = MAX(rhoz(k),1E-4) + rhoinv(k)=1./MAX(rho(k),1E-4) + dzk = 0.5 *( dz(k)+dz(k-1) ) + khdz(k) = rhoz(k)*dfh(k) + kmdz(k) = rhoz(k)*dfm(k) + ENDDO + DO k=kts+1,kte-1 + delp(k) = (p(k)*dz(k-1) + p(k-1)*dz(k))/(dz(k)+dz(k-1)) - & + (p(k+1)*dz(k) + p(k)*dz(k+1))/(dz(k)+dz(k+1)) + ENDDO + delp(kte) =delp(kte-1) + rhoz(kte+1)=rhoz(kte) + khdz(kte+1)=rhoz(kte+1)*dfh(kte) + kmdz(kte+1)=rhoz(kte+1)*dfm(kte) + + !stability criteria for mf + DO k=kts+1,kte-1 + khdz(k) = MAX(khdz(k), 0.5*s_aw(k)) + khdz(k) = MAX(khdz(k), -0.5*(s_aw(k)-s_aw(k+1))) + kmdz(k) = MAX(kmdz(k), 0.5*s_aw(k)) + kmdz(k) = MAX(kmdz(k), -0.5*(s_aw(k)-s_aw(k+1))) + ENDDO + + ustdrag = MIN(ust*ust,0.99)/wspd ! limit at ~ 20 m/s + ustdiff = MIN(ust*ust,0.01)/wspd ! limit at ~ 2 m/s + dth(kts:kte) = 0.0 ! must initialize for moisture_check routine + +!!============================================ +!! u +!!============================================ + + k=kts + +!rho-weighted (drag in b-vector): + a(k)= -dtz(k)*kmdz(k)*rhoinv(k) + b(k)=1.+dtz(k)*(kmdz(k+1)+rhosfc*ust**2/wspd)*rhoinv(k) & + & - 0.5*dtz(k)*rhoinv(k)*s_aw(k+1)*onoff & + & - 0.5*dtz(k)*rhoinv(k)*sd_aw(k+1)*onoff + c(k)= -dtz(k)*kmdz(k+1)*rhoinv(k) & + & - 0.5*dtz(k)*rhoinv(k)*s_aw(k+1)*onoff & + & - 0.5*dtz(k)*rhoinv(k)*sd_aw(k+1)*onoff + d(k)=u(k) + dtz(k)*uoce*ust**2/wspd & + & - dtz(k)*rhoinv(k)*s_awu(k+1)*onoff & + & + dtz(k)*rhoinv(k)*sd_awu(k+1)*onoff & + & + sub_u(k)*delt + det_u(k)*delt + + do k=kts+1,kte-1 + a(k)= -dtz(k)*kmdz(k)*rhoinv(k) & + & + 0.5*dtz(k)*rhoinv(k)*s_aw(k)*onoff & + & + 0.5*dtz(k)*rhoinv(k)*sd_aw(k)*onoff + b(k)=1.+ dtz(k)*(kmdz(k)+kmdz(k+1))*rhoinv(k) & + & + 0.5*dtz(k)*rhoinv(k)*(s_aw(k)-s_aw(k+1))*onoff & + & + 0.5*dtz(k)*rhoinv(k)*(sd_aw(k)-sd_aw(k+1))*onoff + c(k)= - dtz(k)*kmdz(k+1)*rhoinv(k) & + & - 0.5*dtz(k)*rhoinv(k)*s_aw(k+1)*onoff & + & - 0.5*dtz(k)*rhoinv(k)*sd_aw(k+1)*onoff + d(k)=u(k) + dtz(k)*rhoinv(k)*(s_awu(k)-s_awu(k+1))*onoff & + & - dtz(k)*rhoinv(k)*(sd_awu(k)-sd_awu(k+1))*onoff & + & + sub_u(k)*delt + det_u(k)*delt + enddo + +!! no flux at the top +! a(kte)=-1. +! b(kte)=1. +! c(kte)=0. +! d(kte)=0. + +!! specified gradient at the top +! a(kte)=-1. +! b(kte)=1. +! c(kte)=0. +! d(kte)=gradu_top*dztop + +!! prescribed value + a(kte)=0 + b(kte)=1. + c(kte)=0. + d(kte)=u(kte) + +! CALL tridiag(kte,a,b,c,d) + CALL tridiag2(kte,a,b,c,d,x) +! CALL tridiag3(kte,a,b,c,d,x) + + DO k=kts,kte +! du(k)=(d(k-kts+1)-u(k))/delt + du(k)=(x(k)-u(k))/delt + ENDDO + +!!============================================ +!! v +!!============================================ + + k=kts + +!rho-weighted (drag in b-vector): + a(k)= -dtz(k)*kmdz(k)*rhoinv(k) + b(k)=1.+dtz(k)*(kmdz(k+1) + rhosfc*ust**2/wspd)*rhoinv(k) & + & - 0.5*dtz(k)*rhoinv(k)*s_aw(k+1)*onoff & + & - 0.5*dtz(k)*rhoinv(k)*sd_aw(k+1)*onoff + c(k)= -dtz(k)*kmdz(k+1)*rhoinv(k) & + & - 0.5*dtz(k)*rhoinv(k)*s_aw(k+1)*onoff & + & - 0.5*dtz(k)*rhoinv(k)*sd_aw(k+1)*onoff + d(k)=v(k) + dtz(k)*voce*ust**2/wspd & + & - dtz(k)*rhoinv(k)*s_awv(k+1)*onoff & + & + dtz(k)*rhoinv(k)*sd_awv(k+1)*onoff & + & + sub_v(k)*delt + det_v(k)*delt + + do k=kts+1,kte-1 + a(k)= -dtz(k)*kmdz(k)*rhoinv(k) & + & + 0.5*dtz(k)*rhoinv(k)*s_aw(k)*onoff & + & + 0.5*dtz(k)*rhoinv(k)*sd_aw(k)*onoff + b(k)=1.+dtz(k)*(kmdz(k)+kmdz(k+1))*rhoinv(k) & + & + 0.5*dtz(k)*rhoinv(k)*(s_aw(k)-s_aw(k+1))*onoff & + & + 0.5*dtz(k)*rhoinv(k)*(sd_aw(k)-sd_aw(k+1))*onoff + c(k)= -dtz(k)*kmdz(k+1)*rhoinv(k) & + & - 0.5*dtz(k)*rhoinv(k)*s_aw(k+1)*onoff & + & - 0.5*dtz(k)*rhoinv(k)*sd_aw(k+1)*onoff + d(k)=v(k) + dtz(k)*rhoinv(k)*(s_awv(k)-s_awv(k+1))*onoff & + & - dtz(k)*rhoinv(k)*(sd_awv(k)-sd_awv(k+1))*onoff & + & + sub_v(k)*delt + det_v(k)*delt + enddo + +!! no flux at the top +! a(kte)=-1. +! b(kte)=1. +! c(kte)=0. +! d(kte)=0. + +!! specified gradient at the top +! a(kte)=-1. +! b(kte)=1. +! c(kte)=0. +! d(kte)=gradv_top*dztop + +!! prescribed value + a(kte)=0 + b(kte)=1. + c(kte)=0. + d(kte)=v(kte) + +! CALL tridiag(kte,a,b,c,d) + CALL tridiag2(kte,a,b,c,d,x) +! CALL tridiag3(kte,a,b,c,d,x) + + DO k=kts,kte +! dv(k)=(d(k-kts+1)-v(k))/delt + dv(k)=(x(k)-v(k))/delt + ENDDO + +!!============================================ +!! thl tendency +!!============================================ + k=kts + +! a(k)=0. +! b(k)=1.+dtz(k)*dfh(k+1) - 0.5*dtz(k)*s_aw(k+1) +! c(k)= -dtz(k)*dfh(k+1) - 0.5*dtz(k)*s_aw(k+1) +! d(k)=thl(k) + dtz(k)*flt + tcd(k)*delt & +! & -dtz(k)*s_awthl(kts+1) + diss_heat(k)*delt + & +! & sub_thl(k)*delt + det_thl(k)*delt +! +! DO k=kts+1,kte-1 +! a(k)= -dtz(k)*dfh(k) + 0.5*dtz(k)*s_aw(k) +! b(k)=1.+dtz(k)*(dfh(k)+dfh(k+1)) + 0.5*dtz(k)*(s_aw(k)-s_aw(k+1)) +! c(k)= -dtz(k)*dfh(k+1) - 0.5*dtz(k)*s_aw(k+1) +! d(k)=thl(k) + tcd(k)*delt + dtz(k)*(s_awthl(k)-s_awthl(k+1)) & +! & + diss_heat(k)*delt + & +! & sub_thl(k)*delt + det_thl(k)*delt +! ENDDO + +!rho-weighted: rhosfc*X*rhoinv(k) + a(k)= -dtz(k)*khdz(k)*rhoinv(k) + b(k)=1.+dtz(k)*(khdz(k+1)+khdz(k))*rhoinv(k) - 0.5*dtz(k)*rhoinv(k)*s_aw(k+1) - 0.5*dtz(k)*rhoinv(k)*sd_aw(k+1) + c(k)= -dtz(k)*khdz(k+1)*rhoinv(k) - 0.5*dtz(k)*rhoinv(k)*s_aw(k+1) - 0.5*dtz(k)*rhoinv(k)*sd_aw(k+1) + d(k)=thl(k) + dtz(k)*rhosfc*flt*rhoinv(k) + tcd(k)*delt & + & - dtz(k)*rhoinv(k)*s_awthl(k+1) -dtz(k)*rhoinv(k)*sd_awthl(k+1) + & + & diss_heat(k)*delt + sub_thl(k)*delt + det_thl(k)*delt + + DO k=kts+1,kte-1 + a(k)= -dtz(k)*khdz(k)*rhoinv(k) + 0.5*dtz(k)*rhoinv(k)*s_aw(k) + 0.5*dtz(k)*rhoinv(k)*sd_aw(k) + b(k)=1.+dtz(k)*(khdz(k)+khdz(k+1))*rhoinv(k) + & + & 0.5*dtz(k)*rhoinv(k)*(s_aw(k)-s_aw(k+1)) + 0.5*dtz(k)*rhoinv(k)*(sd_aw(k)-sd_aw(k+1)) + c(k)= -dtz(k)*khdz(k+1)*rhoinv(k) - 0.5*dtz(k)*rhoinv(k)*s_aw(k+1) - 0.5*dtz(k)*rhoinv(k)*sd_aw(k+1) + d(k)=thl(k) + tcd(k)*delt + & + & dtz(k)*rhoinv(k)*(s_awthl(k)-s_awthl(k+1)) + dtz(k)*rhoinv(k)*(sd_awthl(k)-sd_awthl(k+1)) + & + & diss_heat(k)*delt + & + & sub_thl(k)*delt + det_thl(k)*delt + ENDDO + +!! no flux at the top +! a(kte)=-1. +! b(kte)=1. +! c(kte)=0. +! d(kte)=0. + +!! specified gradient at the top +!assume gradthl_top=gradth_top +! a(kte)=-1. +! b(kte)=1. +! c(kte)=0. +! d(kte)=gradth_top*dztop + +!! prescribed value + a(kte)=0. + b(kte)=1. + c(kte)=0. + d(kte)=thl(kte) + +! CALL tridiag(kte,a,b,c,d) + CALL tridiag2(kte,a,b,c,d,x) +! CALL tridiag3(kte,a,b,c,d,x) + + DO k=kts,kte + !thl(k)=d(k-kts+1) + thl(k)=x(k) + ENDDO + +IF (bl_mynn_mixqt) THEN + !============================================ + ! MIX total water (sqw = sqc + sqv + sqi) + ! NOTE: no total water tendency is output; instead, we must calculate + ! the saturation specific humidity and then + ! subtract out the moisture excess (sqc & sqi) + !============================================ + + k=kts + +! a(k)=0. +! b(k)=1.+dtz(k)*dfh(k+1) - 0.5*dtz(k)*s_aw(k+1) +! c(k)= -dtz(k)*dfh(k+1) - 0.5*dtz(k)*s_aw(k+1) +! !rhs= qcd(k) !+ (gfluxp - gfluxm)/dz(k)& +! d(k)=sqw(k) + dtz(k)*flq + qcd(k)*delt - dtz(k)*s_awqt(k+1) +! +! DO k=kts+1,kte-1 +! a(k)= -dtz(k)*dfh(k) + 0.5*dtz(k)*s_aw(k) +! b(k)=1.+dtz(k)*(dfh(k)+dfh(k+1)) + 0.5*dtz(k)*(s_aw(k)-s_aw(k+1)) +! c(k)= -dtz(k)*dfh(k+1) - 0.5*dtz(k)*s_aw(k+1) +! d(k)=sqw(k) + qcd(k)*delt + dtz(k)*(s_awqt(k)-s_awqt(k+1)) +! ENDDO + +!rho-weighted: + a(k)= -dtz(k)*khdz(k)*rhoinv(k) + b(k)=1.+dtz(k)*(khdz(k+1)+khdz(k))*rhoinv(k) - 0.5*dtz(k)*rhoinv(k)*s_aw(k+1) - 0.5*dtz(k)*rhoinv(k)*sd_aw(k+1) + c(k)= -dtz(k)*khdz(k+1)*rhoinv(k) - 0.5*dtz(k)*rhoinv(k)*s_aw(k+1) - 0.5*dtz(k)*rhoinv(k)*sd_aw(k+1) + d(k)=sqw(k) + dtz(k)*rhosfc*flq*rhoinv(k) + qcd(k)*delt - dtz(k)*rhoinv(k)*s_awqt(k+1) - dtz(k)*rhoinv(k)*sd_awqt(k+1) + + DO k=kts+1,kte-1 + a(k)= -dtz(k)*khdz(k)*rhoinv(k) + 0.5*dtz(k)*rhoinv(k)*s_aw(k) + 0.5*dtz(k)*rhoinv(k)*sd_aw(k) + b(k)=1.+dtz(k)*(khdz(k)+khdz(k+1))*rhoinv(k) + & + & 0.5*dtz(k)*rhoinv(k)*(s_aw(k)-s_aw(k+1)) + 0.5*dtz(k)*rhoinv(k)*(sd_aw(k)-sd_aw(k+1)) + c(k)= -dtz(k)*khdz(k+1)*rhoinv(k) - 0.5*dtz(k)*rhoinv(k)*s_aw(k+1) - 0.5*dtz(k)*rhoinv(k)*sd_aw(k+1) + d(k)=sqw(k) + qcd(k)*delt + dtz(k)*rhoinv(k)*(s_awqt(k)-s_awqt(k+1)) + dtz(k)*rhoinv(k)*(sd_awqt(k)-sd_awqt(k+1)) + ENDDO + +!! no flux at the top +! a(kte)=-1. +! b(kte)=1. +! c(kte)=0. +! d(kte)=0. +!! specified gradient at the top +!assume gradqw_top=gradqv_top +! a(kte)=-1. +! b(kte)=1. +! c(kte)=0. +! d(kte)=gradqv_top*dztop +!! prescribed value + a(kte)=0. + b(kte)=1. + c(kte)=0. + d(kte)=sqw(kte) + +! CALL tridiag(kte,a,b,c,d) + CALL tridiag2(kte,a,b,c,d,sqw2) +! CALL tridiag3(kte,a,b,c,d,sqw2) + +! DO k=kts,kte +! sqw2(k)=d(k-kts+1) +! ENDDO +ELSE + sqw2=sqw +ENDIF + +IF (.not. bl_mynn_mixqt) THEN +!============================================ +! cloud water ( sqc ). If mixing total water (bl_mynn_mixqt > 0), +! then sqc will be backed out of saturation check (below). +!============================================ + IF (bl_mynn_cloudmix .AND. FLAG_QC) THEN + + k=kts + +! a(k)=0. +! b(k)=1.+dtz(k)*dfh(k+1) - 0.5*dtz(k)*s_aw(k+1) +! c(k)= -dtz(k)*dfh(k+1) - 0.5*dtz(k)*s_aw(k+1) +! d(k)=sqc(k) + dtz(k)*flqc + qcd(k)*delt - & +! dtz(k)*s_awqc(k+1) + det_sqc(k)*delt +! +! DO k=kts+1,kte-1 +! a(k)= -dtz(k)*dfh(k) + 0.5*dtz(k)*s_aw(k) +! b(k)=1.+dtz(k)*(dfh(k)+dfh(k+1)) + 0.5*dtz(k)*(s_aw(k)-s_aw(k+1)) +! c(k)= -dtz(k)*dfh(k+1) - 0.5*dtz(k)*s_aw(k+1) +! d(k)=sqc(k) + qcd(k)*delt + dtz(k)*(s_awqc(k)-s_awqc(k+1)) + & +! det_sqc(k)*delt +! ENDDO + +!rho-weighted: + a(k)= -dtz(k)*khdz(k)*rhoinv(k) + b(k)=1.+dtz(k)*(khdz(k+1)+khdz(k))*rhoinv(k) - 0.5*dtz(k)*rhoinv(k)*s_aw(k+1) - 0.5*dtz(k)*rhoinv(k)*sd_aw(k+1) + c(k)= -dtz(k)*khdz(k+1)*rhoinv(k) - 0.5*dtz(k)*rhoinv(k)*s_aw(k+1) - 0.5*dtz(k)*rhoinv(k)*sd_aw(k+1) + d(k)=sqc(k) + dtz(k)*rhosfc*flqc*rhoinv(k) + qcd(k)*delt & + & - dtz(k)*rhoinv(k)*s_awqc(k+1) - dtz(k)*rhoinv(k)*sd_awqc(k+1) + & + & det_sqc(k)*delt + + DO k=kts+1,kte-1 + a(k)= -dtz(k)*khdz(k)*rhoinv(k) + 0.5*dtz(k)*rhoinv(k)*s_aw(k) + 0.5*dtz(k)*rhoinv(k)*sd_aw(k) + b(k)=1.+dtz(k)*(khdz(k)+khdz(k+1))*rhoinv(k) + & + & 0.5*dtz(k)*rhoinv(k)*(s_aw(k)-s_aw(k+1)) + 0.5*dtz(k)*rhoinv(k)*(sd_aw(k)-sd_aw(k+1)) + c(k)= -dtz(k)*khdz(k+1)*rhoinv(k) - 0.5*dtz(k)*rhoinv(k)*s_aw(k+1) - 0.5*dtz(k)*rhoinv(k)*sd_aw(k+1) + d(k)=sqc(k) + qcd(k)*delt + dtz(k)*rhoinv(k)*(s_awqc(k)-s_awqc(k+1)) + dtz(k)*rhoinv(k)*(sd_awqc(k)-sd_awqc(k+1)) + & + & det_sqc(k)*delt + ENDDO + +! prescribed value + a(kte)=0. + b(kte)=1. + c(kte)=0. + d(kte)=sqc(kte) + +! CALL tridiag(kte,a,b,c,d) + CALL tridiag2(kte,a,b,c,d,sqc2) +! CALL tridiag3(kte,a,b,c,d,sqc2) + +! DO k=kts,kte +! sqc2(k)=d(k-kts+1) +! ENDDO + ELSE + !If not mixing clouds, set "updated" array equal to original array + sqc2=sqc + ENDIF +ENDIF + +IF (.not. bl_mynn_mixqt) THEN + !============================================ + ! MIX WATER VAPOR ONLY ( sqv ). If mixing total water (bl_mynn_mixqt > 0), + ! then sqv will be backed out of saturation check (below). + !============================================ + + k=kts + +! a(k)=0. +! b(k)=1.+dtz(k)*dfh(k+1) - 0.5*dtz(k)*s_aw(k+1) +! c(k)= -dtz(k)*dfh(k+1) - 0.5*dtz(k)*s_aw(k+1) +! d(k)=sqv(k) + dtz(k)*flqv + qcd(k)*delt - dtz(k)*s_awqv(k+1) + & +! & sub_sqv(k)*delt + det_sqv(k)*delt +! +! DO k=kts+1,kte-1 +! a(k)= -dtz(k)*dfh(k) + 0.5*dtz(k)*s_aw(k) +! b(k)=1.+dtz(k)*(dfh(k)+dfh(k+1)) + 0.5*dtz(k)*(s_aw(k)-s_aw(k+1)) +! c(k)= -dtz(k)*dfh(k+1) - 0.5*dtz(k)*s_aw(k+1) +! d(k)=sqv(k) + qcd(k)*delt + dtz(k)*(s_awqv(k)-s_awqv(k+1)) + & +! & sub_sqv(k)*delt + det_sqv(k)*delt +! ENDDO + + !limit unreasonably large negative fluxes: + qvflux = flqv + if (qvflux < 0.0) then + !do not allow specified surface flux to reduce qv below 1e-8 kg/kg + qvflux = max(qvflux, (min(0.9*sqv(kts) - 1e-8, 0.0)/dtz(kts))) + endif + +!rho-weighted: rhosfc*X*rhoinv(k) + a(k)= -dtz(k)*khdz(k)*rhoinv(k) + b(k)=1.+dtz(k)*(khdz(k+1)+khdz(k))*rhoinv(k) - 0.5*dtz(k)*rhoinv(k)*s_aw(k+1) - 0.5*dtz(k)*rhoinv(k)*sd_aw(k+1) + c(k)= -dtz(k)*khdz(k+1)*rhoinv(k) - 0.5*dtz(k)*rhoinv(k)*s_aw(k+1) - 0.5*dtz(k)*rhoinv(k)*sd_aw(k+1) + d(k)=sqv(k) + dtz(k)*rhosfc*qvflux*rhoinv(k) + qcd(k)*delt & + & - dtz(k)*rhoinv(k)*s_awqv(k+1) - dtz(k)*rhoinv(k)*sd_awqv(k+1) + & + & sub_sqv(k)*delt + det_sqv(k)*delt + + DO k=kts+1,kte-1 + a(k)= -dtz(k)*khdz(k)*rhoinv(k) + 0.5*dtz(k)*rhoinv(k)*s_aw(k) + 0.5*dtz(k)*rhoinv(k)*sd_aw(k) + b(k)=1.+dtz(k)*(khdz(k)+khdz(k+1))*rhoinv(k) + & + & 0.5*dtz(k)*rhoinv(k)*(s_aw(k)-s_aw(k+1)) + 0.5*dtz(k)*rhoinv(k)*(sd_aw(k)-sd_aw(k+1)) + c(k)= -dtz(k)*khdz(k+1)*rhoinv(k) - 0.5*dtz(k)*rhoinv(k)*s_aw(k+1) - 0.5*dtz(k)*rhoinv(k)*sd_aw(k+1) + d(k)=sqv(k) + qcd(k)*delt + dtz(k)*rhoinv(k)*(s_awqv(k)-s_awqv(k+1)) + dtz(k)*rhoinv(k)*(sd_awqv(k)-sd_awqv(k+1)) + & + & sub_sqv(k)*delt + det_sqv(k)*delt + ENDDO + +! no flux at the top +! a(kte)=-1. +! b(kte)=1. +! c(kte)=0. +! d(kte)=0. + +! specified gradient at the top +! assume gradqw_top=gradqv_top +! a(kte)=-1. +! b(kte)=1. +! c(kte)=0. +! d(kte)=gradqv_top*dztop + +! prescribed value + a(kte)=0. + b(kte)=1. + c(kte)=0. + d(kte)=sqv(kte) + +! CALL tridiag(kte,a,b,c,d) + CALL tridiag2(kte,a,b,c,d,sqv2) +! CALL tridiag3(kte,a,b,c,d,sqv2) + +! DO k=kts,kte +! sqv2(k)=d(k-kts+1) +! ENDDO +ELSE + sqv2=sqv +ENDIF + +!============================================ +! MIX CLOUD ICE ( sqi ) +!============================================ +IF (bl_mynn_cloudmix .AND. FLAG_QI) THEN + + k=kts +!rho-weighted: + a(k)= -dtz(k)*khdz(k)*rhoinv(k) + b(k)=1.+dtz(k)*(khdz(k+1)+khdz(k))*rhoinv(k) + c(k)= -dtz(k)*khdz(k+1)*rhoinv(k) + d(k)=sqi(k) + + DO k=kts+1,kte-1 + a(k)= -dtz(k)*khdz(k)*rhoinv(k) + b(k)=1.+dtz(k)*(khdz(k)+khdz(k+1))*rhoinv(k) + c(k)= -dtz(k)*khdz(k+1)*rhoinv(k) + d(k)=sqi(k) + ENDDO + +!! no flux at the top +! a(kte)=-1. +! b(kte)=1. +! c(kte)=0. +! d(kte)=0. + +!! specified gradient at the top +!assume gradqw_top=gradqv_top +! a(kte)=-1. +! b(kte)=1. +! c(kte)=0. +! d(kte)=gradqv_top*dztop + +!! prescribed value + a(kte)=0. + b(kte)=1. + c(kte)=0. + d(kte)=sqi(kte) + +! CALL tridiag(kte,a,b,c,d) + CALL tridiag2(kte,a,b,c,d,sqi2) +! CALL tridiag3(kte,a,b,c,d,sqi2) + +! DO k=kts,kte +! sqi2(k)=d(k-kts+1) +! ENDDO +ELSE + sqi2=sqi +ENDIF + +!============================================ +! MIX SNOW ( sqs ) +!============================================ +!hard-code to not mix snow +IF (bl_mynn_cloudmix .AND. .false.) THEN + + k=kts +!rho-weighted: + a(k)= -dtz(k)*khdz(k)*rhoinv(k) + b(k)=1.+dtz(k)*(khdz(k+1)+khdz(k))*rhoinv(k) + c(k)= -dtz(k)*khdz(k+1)*rhoinv(k) + d(k)=sqs(k) + + DO k=kts+1,kte-1 + a(k)= -dtz(k)*khdz(k)*rhoinv(k) + b(k)=1.+dtz(k)*(khdz(k)+khdz(k+1))*rhoinv(k) + c(k)= -dtz(k)*khdz(k+1)*rhoinv(k) + d(k)=sqs(k) + ENDDO + +!! prescribed value + a(kte)=0. + b(kte)=1. + c(kte)=0. + d(kte)=sqs(kte) + +! CALL tridiag(kte,a,b,c,d) + CALL tridiag2(kte,a,b,c,d,sqs2) +! CALL tridiag3(kte,a,b,c,d,sqs2) + +! DO k=kts,kte +! sqs2(k)=d(k-kts+1) +! ENDDO +ELSE + sqs2=sqs +ENDIF + +!!============================================ +!! cloud ice number concentration (qni) +!!============================================ +IF (bl_mynn_cloudmix .AND. FLAG_QNI .AND. & + bl_mynn_mixscalars) THEN + + k=kts + + a(k)= -dtz(k)*khdz(k)*rhoinv(k) + b(k)=1.+dtz(k)*(khdz(k+1)+khdz(k))*rhoinv(k) - 0.5*dtz(k)*rhoinv(k)*s_aw(k+1)*nonloc + c(k)= -dtz(k)*khdz(k+1)*rhoinv(k) - 0.5*dtz(k)*rhoinv(k)*s_aw(k+1)*nonloc + d(k)=qni(k) - dtz(k)*rhoinv(k)*s_awqni(k+1)*nonloc + + DO k=kts+1,kte-1 + a(k)= -dtz(k)*khdz(k)*rhoinv(k) + 0.5*dtz(k)*rhoinv(k)*s_aw(k)*nonloc + b(k)=1.+dtz(k)*(khdz(k)+khdz(k+1))*rhoinv(k) + & + & 0.5*dtz(k)*rhoinv(k)*(s_aw(k)-s_aw(k+1))*nonloc + c(k)= -dtz(k)*khdz(k+1)*rhoinv(k) - 0.5*dtz(k)*rhoinv(k)*s_aw(k+1)*nonloc + d(k)=qni(k) + dtz(k)*rhoinv(k)*(s_awqni(k)-s_awqni(k+1))*nonloc + ENDDO + +!! prescribed value + a(kte)=0. + b(kte)=1. + c(kte)=0. + d(kte)=qni(kte) + +! CALL tridiag(kte,a,b,c,d) + CALL tridiag2(kte,a,b,c,d,x) +! CALL tridiag3(kte,a,b,c,d,x) + + DO k=kts,kte + !qni2(k)=d(k-kts+1) + qni2(k)=x(k) + ENDDO + +ELSE + qni2=qni +ENDIF + +!!============================================ +!! cloud water number concentration (qnc) +!! include non-local transport +!!============================================ + IF (bl_mynn_cloudmix .AND. FLAG_QNC .AND. & + bl_mynn_mixscalars) THEN + + k=kts + + a(k)= -dtz(k)*khdz(k)*rhoinv(k) + b(k)=1.+dtz(k)*(khdz(k+1)+khdz(k))*rhoinv(k) - 0.5*dtz(k)*rhoinv(k)*s_aw(k+1)*nonloc + c(k)= -dtz(k)*khdz(k+1)*rhoinv(k) - 0.5*dtz(k)*rhoinv(k)*s_aw(k+1)*nonloc + d(k)=qnc(k) - dtz(k)*rhoinv(k)*s_awqnc(k+1)*nonloc + + DO k=kts+1,kte-1 + a(k)= -dtz(k)*khdz(k)*rhoinv(k) + 0.5*dtz(k)*rhoinv(k)*s_aw(k)*nonloc + b(k)=1.+dtz(k)*(khdz(k)+khdz(k+1))*rhoinv(k) + & + & 0.5*dtz(k)*rhoinv(k)*(s_aw(k)-s_aw(k+1))*nonloc + c(k)= -dtz(k)*khdz(k+1)*rhoinv(k) - 0.5*dtz(k)*rhoinv(k)*s_aw(k+1)*nonloc + d(k)=qnc(k) + dtz(k)*rhoinv(k)*(s_awqnc(k)-s_awqnc(k+1))*nonloc + ENDDO + +!! prescribed value + a(kte)=0. + b(kte)=1. + c(kte)=0. + d(kte)=qnc(kte) + +! CALL tridiag(kte,a,b,c,d) + CALL tridiag2(kte,a,b,c,d,x) +! CALL tridiag3(kte,a,b,c,d,x) + + DO k=kts,kte + !qnc2(k)=d(k-kts+1) + qnc2(k)=x(k) + ENDDO + +ELSE + qnc2=qnc +ENDIF + +!============================================ +! Water-friendly aerosols ( qnwfa ). +!============================================ +IF (bl_mynn_cloudmix .AND. FLAG_QNWFA .AND. & + bl_mynn_mixscalars) THEN + + k=kts + + a(k)= -dtz(k)*khdz(k)*rhoinv(k) + b(k)=1.+dtz(k)*(khdz(k) + khdz(k+1))*rhoinv(k) - & + & 0.5*dtz(k)*rhoinv(k)*s_aw(k+1)*nonloc + c(k)= -dtz(k)*khdz(k+1)*rhoinv(k) - 0.5*dtz(k)*rhoinv(k)*s_aw(k+1)*nonloc + d(k)=qnwfa(k) - dtz(k)*rhoinv(k)*s_awqnwfa(k+1)*nonloc + + DO k=kts+1,kte-1 + a(k)= -dtz(k)*khdz(k)*rhoinv(k) + 0.5*dtz(k)*rhoinv(k)*s_aw(k)*nonloc + b(k)=1.+dtz(k)*(khdz(k) + khdz(k+1))*rhoinv(k) + & + & 0.5*dtz(k)*rhoinv(k)*(s_aw(k)-s_aw(k+1))*nonloc + c(k)= -dtz(k)*khdz(k+1)*rhoinv(k) - 0.5*dtz(k)*rhoinv(k)*s_aw(k+1)*nonloc + d(k)=qnwfa(k) + dtz(k)*rhoinv(k)*(s_awqnwfa(k)-s_awqnwfa(k+1))*nonloc + ENDDO + +! prescribed value + a(kte)=0. + b(kte)=1. + c(kte)=0. + d(kte)=qnwfa(kte) + +! CALL tridiag(kte,a,b,c,d) + CALL tridiag2(kte,a,b,c,d,x) +! CALL tridiag3(kte,a,b,c,d,x) + + DO k=kts,kte + !qnwfa2(k)=d(k) + qnwfa2(k)=x(k) + ENDDO + +ELSE + !If not mixing aerosols, set "updated" array equal to original array + qnwfa2=qnwfa +ENDIF + +!============================================ +! Ice-friendly aerosols ( qnifa ). +!============================================ +IF (bl_mynn_cloudmix .AND. FLAG_QNIFA .AND. & + bl_mynn_mixscalars) THEN + + k=kts + + a(k)= -dtz(k)*khdz(k)*rhoinv(k) + b(k)=1.+dtz(k)*(khdz(k) + khdz(k+1))*rhoinv(k) - & + & 0.5*dtz(k)*rhoinv(k)*s_aw(k+1)*nonloc + c(k)= -dtz(k)*khdz(k+1)*rhoinv(k) - 0.5*dtz(k)*rhoinv(k)*s_aw(k+1)*nonloc + d(k)=qnifa(k) - dtz(k)*rhoinv(k)*s_awqnifa(k+1)*nonloc + + DO k=kts+1,kte-1 + a(k)= -dtz(k)*khdz(k)*rhoinv(k) + 0.5*dtz(k)*rhoinv(k)*s_aw(k)*nonloc + b(k)=1.+dtz(k)*(khdz(k) + khdz(k+1))*rhoinv(k) + & + & 0.5*dtz(k)*rhoinv(k)*(s_aw(k)-s_aw(k+1))*nonloc + c(k)= -dtz(k)*khdz(k+1)*rhoinv(k) - 0.5*dtz(k)*rhoinv(k)*s_aw(k+1)*nonloc + d(k)=qnifa(k) + dtz(k)*rhoinv(k)*(s_awqnifa(k)-s_awqnifa(k+1))*nonloc + ENDDO + +! prescribed value + a(kte)=0. + b(kte)=1. + c(kte)=0. + d(kte)=qnifa(kte) + +! CALL tridiag(kte,a,b,c,d) + CALL tridiag2(kte,a,b,c,d,x) +! CALL tridiag3(kte,a,b,c,d,x) + + DO k=kts,kte + !qnifa2(k)=d(k-kts+1) + qnifa2(k)=x(k) + ENDDO + +ELSE + !If not mixing aerosols, set "updated" array equal to original array + qnifa2=qnifa +ENDIF + +!============================================ +! Black-carbon aerosols ( qnbca ). +!============================================ +IF (bl_mynn_cloudmix .AND. FLAG_QNBCA .AND. & + bl_mynn_mixscalars) THEN + + k=kts + + a(k)= -dtz(k)*khdz(k)*rhoinv(k) + b(k)=1.+dtz(k)*(khdz(k) + khdz(k+1))*rhoinv(k) - & + & 0.5*dtz(k)*rhoinv(k)*s_aw(k+1)*nonloc + c(k)= -dtz(k)*khdz(k+1)*rhoinv(k) - 0.5*dtz(k)*rhoinv(k)*s_aw(k+1)*nonloc + d(k)=qnbca(k) - dtz(k)*rhoinv(k)*s_awqnbca(k+1)*nonloc + + DO k=kts+1,kte-1 + a(k)= -dtz(k)*khdz(k)*rhoinv(k) + 0.5*dtz(k)*rhoinv(k)*s_aw(k)*nonloc + b(k)=1.+dtz(k)*(khdz(k) + khdz(k+1))*rhoinv(k) + & + & 0.5*dtz(k)*rhoinv(k)*(s_aw(k)-s_aw(k+1))*nonloc + c(k)= -dtz(k)*khdz(k+1)*rhoinv(k) - 0.5*dtz(k)*rhoinv(k)*s_aw(k+1)*nonloc + d(k)=qnbca(k) + dtz(k)*rhoinv(k)*(s_awqnbca(k)-s_awqnbca(k+1))*nonloc + ENDDO + +! prescribed value + a(kte)=0. + b(kte)=1. + c(kte)=0. + d(kte)=qnbca(kte) + +! CALL tridiag(kte,a,b,c,d) + CALL tridiag2(kte,a,b,c,d,x) +! CALL tridiag3(kte,a,b,c,d,x) + + DO k=kts,kte + !qnbca2(k)=d(k-kts+1) + qnbca2(k)=x(k) + ENDDO + +ELSE + !If not mixing aerosols, set "updated" array equal to original array + qnbca2=qnbca +ENDIF + +!============================================ +! Ozone - local mixing only +!============================================ +IF (FLAG_OZONE) THEN + k=kts + +!rho-weighted: + a(k)= -dtz(k)*khdz(k)*rhoinv(k) + b(k)=1.+dtz(k)*(khdz(k+1)+khdz(k))*rhoinv(k) + c(k)= -dtz(k)*khdz(k+1)*rhoinv(k) + d(k)=ozone(k) + + DO k=kts+1,kte-1 + a(k)= -dtz(k)*khdz(k)*rhoinv(k) + b(k)=1.+dtz(k)*(khdz(k)+khdz(k+1))*rhoinv(k) + c(k)= -dtz(k)*khdz(k+1)*rhoinv(k) + d(k)=ozone(k) + ENDDO + +! prescribed value + a(kte)=0. + b(kte)=1. + c(kte)=0. + d(kte)=ozone(kte) + +! CALL tridiag(kte,a,b,c,d) + CALL tridiag2(kte,a,b,c,d,x) +! CALL tridiag3(kte,a,b,c,d,x) + + DO k=kts,kte + !ozone2(k)=d(k-kts+1) + dozone(k)=(x(k)-ozone(k))/delt + ENDDO +ELSE + dozone(:)=0.0 +ENDIF + +!!============================================ +!! Compute tendencies and convert to mixing ratios for WRF. +!! Note that the momentum tendencies are calculated above. +!!============================================ + + IF (bl_mynn_mixqt) THEN + DO k=kts,kte + !compute updated theta using updated thl and old condensate + th_new = thl(k) + xlvcp/exner(k)*sqc(k) & + & + xlscp/exner(k)*sqi(k) + + t = th_new*exner(k) + qsat = qsat_blend(t,t0c,tice,p(k)) + !SATURATED VAPOR PRESSURE + !esat=esat_blend(t,t0c,tice) + !SATURATED SPECIFIC HUMIDITY + !qsl=ep_2*esat/(p(k)-ep_3*esat) + !qsl=ep_2*esat/max(1.e-4,(p(k)-ep_3*esat)) + + IF (sqc(k) > 0.0 .or. sqi(k) > 0.0) THEN !initially saturated + sqv2(k) = MIN(sqw2(k),qsat) + portion_qc = sqc(k)/(sqc(k) + sqi(k)) + portion_qi = sqi(k)/(sqc(k) + sqi(k)) + condensate = MAX(sqw2(k) - qsat, 0.0) + sqc2(k) = condensate*portion_qc + sqi2(k) = condensate*portion_qi + ELSE ! initially unsaturated ----- + sqv2(k) = sqw2(k) ! let microphys decide what to do + sqi2(k) = 0.0 ! if sqw2 > qsat + sqc2(k) = 0.0 + ENDIF + ENDDO + ENDIF + + + !===================== + ! WATER VAPOR TENDENCY + !===================== + DO k=kts,kte + Dqv(k)=(sqv2(k) - sqv(k))/delt + !if (sqv2(k) < 0.0)print*,"neg qv:",sqv2(k),k + ENDDO + + IF (bl_mynn_cloudmix) THEN + !===================== + ! CLOUD WATER TENDENCY + !===================== + !print*,"FLAG_QC:",FLAG_QC + IF (FLAG_QC) THEN + DO k=kts,kte + Dqc(k)=(sqc2(k) - sqc(k))/delt + !if (sqc2(k) < 0.0)print*,"neg qc:",sqc2(k),k + ENDDO + ELSE + DO k=kts,kte + Dqc(k) = 0. + ENDDO + ENDIF + + !=================== + ! CLOUD WATER NUM CONC TENDENCY + !=================== + IF (FLAG_QNC .AND. bl_mynn_mixscalars) THEN + DO k=kts,kte + Dqnc(k) = (qnc2(k)-qnc(k))/delt + !IF(Dqnc(k)*delt + qnc(k) < 0.)Dqnc(k)=-qnc(k)/delt + ENDDO + ELSE + DO k=kts,kte + Dqnc(k) = 0. + ENDDO + ENDIF + + !=================== + ! CLOUD ICE TENDENCY + !=================== + IF (FLAG_QI) THEN + DO k=kts,kte + Dqi(k)=(sqi2(k) - sqi(k))/delt + !if (sqi2(k) < 0.0)print*,"neg qi:",sqi2(k),k + ENDDO + ELSE + DO k=kts,kte + Dqi(k) = 0. + ENDDO + ENDIF + + !=================== + ! CLOUD SNOW TENDENCY + !=================== + IF (.false.) THEN !disabled + DO k=kts,kte + Dqs(k)=(sqs2(k) - sqs(k))/delt + ENDDO + ELSE + DO k=kts,kte + Dqs(k) = 0. + ENDDO + ENDIF + + !=================== + ! CLOUD ICE NUM CONC TENDENCY + !=================== + IF (FLAG_QNI .AND. bl_mynn_mixscalars) THEN + DO k=kts,kte + Dqni(k)=(qni2(k)-qni(k))/delt + !IF(Dqni(k)*delt + qni(k) < 0.)Dqni(k)=-qni(k)/delt + ENDDO + ELSE + DO k=kts,kte + Dqni(k)=0. + ENDDO + ENDIF + ELSE !-MIX CLOUD SPECIES? + !CLOUDS ARE NOT MIXED (when bl_mynn_cloudmix == .false.) + DO k=kts,kte + Dqc(k) =0. + Dqnc(k)=0. + Dqi(k) =0. + Dqni(k)=0. + Dqs(k) =0. + ENDDO + ENDIF + + !ensure non-negative moist species + CALL moisture_check(kte, delt, delp, exner, & + sqv2, sqc2, sqi2, sqs2, thl, & + dqv, dqc, dqi, dqs, dth ) + + !===================== + ! OZONE TENDENCY CHECK + !===================== + DO k=kts,kte + IF(Dozone(k)*delt + ozone(k) < 0.) THEN + Dozone(k)=-ozone(k)*0.99/delt + ENDIF + ENDDO + + !=================== + ! THETA TENDENCY + !=================== + IF (FLAG_QI) THEN + DO k=kts,kte + Dth(k)=(thl(k) + xlvcp/exner(k)*sqc2(k) & + & + xlscp/exner(k)*(sqi2(k)+sqs(k)) & + & - th(k))/delt + !Use form from Tripoli and Cotton (1981) with their + !suggested min temperature to improve accuracy: + !Dth(k)=(thl(k)*(1.+ xlvcp/MAX(tk(k),TKmin)*sqc(k) & + ! & + xlscp/MAX(tk(k),TKmin)*sqi(k)) & + ! & - th(k))/delt + ENDDO + ELSE + DO k=kts,kte + Dth(k)=(thl(k)+xlvcp/exner(k)*sqc2(k) - th(k))/delt + !Use form from Tripoli and Cotton (1981) with their + !suggested min temperature to improve accuracy. + !Dth(k)=(thl(k)*(1.+ xlvcp/MAX(tk(k),TKmin)*sqc(k)) & + !& - th(k))/delt + ENDDO + ENDIF + + !=================== + ! AEROSOL TENDENCIES + !=================== + IF (FLAG_QNWFA .AND. FLAG_QNIFA .AND. & + bl_mynn_mixscalars) THEN + DO k=kts,kte + !===================== + ! WATER-friendly aerosols + !===================== + Dqnwfa(k)=(qnwfa2(k) - qnwfa(k))/delt + !===================== + ! Ice-friendly aerosols + !===================== + Dqnifa(k)=(qnifa2(k) - qnifa(k))/delt + ENDDO + ELSE + DO k=kts,kte + Dqnwfa(k)=0. + Dqnifa(k)=0. + ENDDO + ENDIF + + !======================== + ! BLACK-CARBON TENDENCIES + !======================== + IF (FLAG_QNBCA .AND. bl_mynn_mixscalars) THEN + DO k=kts,kte + Dqnbca(k)=(qnbca2(k) - qnbca(k))/delt + ENDDO + ELSE + DO k=kts,kte + Dqnbca(k)=0. + ENDDO + ENDIF + + !ensure non-negative moist species + !note: if called down here, dth needs to be updated, but + ! if called before the theta-tendency calculation, do not compute dth + !CALL moisture_check(kte, delt, delp, exner, & + ! sqv, sqc, sqi, thl, & + ! dqv, dqc, dqi, dth ) + + if (debug_code) then + problem = .false. + do k=kts,kte + wsp = sqrt(u(k)**2 + v(k)**2) + wsp2 = sqrt((u(k)+du(k)*delt)**2 + (v(k)+du(k)*delt)**2) + th2 = th(k) + Dth(k)*delt + tk2 = th2*exner(k) + if (wsp2 > 200. .or. tk2 > 360. .or. tk2 < 160.) then + problem = .true. + print*,"Outgoing problem at: k=",k + print*," incoming wsp=",wsp," outgoing wsp=",wsp2 + print*," incoming T=",th(k)*exner(k),"outgoing T:",tk2 + print*," du=",du(k)*delt," dv=",dv(k)*delt," dth=",dth(k)*delt + print*," km=",kmdz(k)*dz(k)," kh=",khdz(k)*dz(k) + print*," u*=",ust," wspd=",wspd,"rhosfc=",rhosfc + print*," LH=",flq*rhosfc*1004.," HFX=",flt*rhosfc*1004. + print*," drag term=",ust**2/wspd*dtz(k)*rhosfc/rho(kts) + kproblem = k + endif + enddo + if (problem) then + print*,"==thl:",thl(max(kproblem-3,1):min(kproblem+3,kte)) + print*,"===qv:",sqv2(max(kproblem-3,1):min(kproblem+3,kte)) + print*,"===qc:",sqc2(max(kproblem-3,1):min(kproblem+3,kte)) + print*,"===qi:",sqi2(max(kproblem-3,1):min(kproblem+3,kte)) + print*,"====u:",u(max(kproblem-3,1):min(kproblem+3,kte)) + print*,"====v:",v(max(kproblem-3,1):min(kproblem+3,kte)) + endif + endif + +#ifdef HARDCODE_VERTICAL +# undef kts +# undef kte +#endif + + END SUBROUTINE mynn_tendencies + +! ================================================================== + SUBROUTINE moisture_check(kte, delt, dp, exner, & + qv, qc, qi, qs, th, & + dqv, dqc, dqi, dqs, dth ) + + ! This subroutine was adopted from the CAM-UW ShCu scheme and + ! adapted for use here. + ! + ! If qc < qcmin, qi < qimin, or qv < qvmin happens in any layer, + ! force them to be larger than minimum value by (1) condensating + ! water vapor into liquid or ice, and (2) by transporting water vapor + ! from the very lower layer. + ! + ! We then update the final state variables and tendencies associated + ! with this correction. If any condensation happens, update theta too. + ! Note that (qv,qc,qi,th) are the final state variables after + ! applying corresponding input tendencies and corrective tendencies. + + implicit none + integer, intent(in) :: kte + real(kind_phys), intent(in) :: delt + real(kind_phys), dimension(kte), intent(in) :: dp, exner + real(kind_phys), dimension(kte), intent(inout) :: qv, qc, qi, qs, th + real(kind_phys), dimension(kte), intent(inout) :: dqv, dqc, dqi, dqs, dth + integer k + real(kind_phys):: dqc2, dqi2, dqs2, dqv2, sum, aa, dum + real(kind_phys), parameter :: qvmin = 1e-20, & + qcmin = 0.0, & + qimin = 0.0 + + do k = kte, 1, -1 ! From the top to the surface + dqc2 = max(0.0, qcmin-qc(k)) !qc deficit (>=0) + dqi2 = max(0.0, qimin-qi(k)) !qi deficit (>=0) + dqs2 = max(0.0, qimin-qs(k)) !qs deficit (>=0) + + !fix tendencies + dqc(k) = dqc(k) + dqc2/delt + dqi(k) = dqi(k) + dqi2/delt + dqs(k) = dqs(k) + dqs2/delt + dqv(k) = dqv(k) - (dqc2+dqi2+dqs2)/delt + dth(k) = dth(k) + xlvcp/exner(k)*(dqc2/delt) + & + xlscp/exner(k)*((dqi2+dqs2)/delt) + !update species + qc(k) = qc(k) + dqc2 + qi(k) = qi(k) + dqi2 + qs(k) = qs(k) + dqs2 + qv(k) = qv(k) - dqc2 - dqi2 - dqs2 + th(k) = th(k) + xlvcp/exner(k)*dqc2 + & + xlscp/exner(k)*(dqi2+dqs2) + + !then fix qv + dqv2 = max(0.0, qvmin-qv(k)) !qv deficit (>=0) + dqv(k) = dqv(k) + dqv2/delt + qv(k) = qv(k) + dqv2 + if( k .ne. 1 ) then + qv(k-1) = qv(k-1) - dqv2*dp(k)/dp(k-1) + dqv(k-1) = dqv(k-1) - dqv2*dp(k)/dp(k-1)/delt + endif + qv(k) = max(qv(k),qvmin) + qc(k) = max(qc(k),qcmin) + qi(k) = max(qi(k),qimin) + qs(k) = max(qs(k),qimin) + end do + ! Extra moisture used to satisfy 'qv(1)>=qvmin' is proportionally + ! extracted from all the layers that has 'qv > 2*qvmin'. This fully + ! preserves column moisture. + if( dqv2 .gt. 1.e-20 ) then + sum = 0.0 + do k = 1, kte + if( qv(k) .gt. 2.0*qvmin ) sum = sum + qv(k)*dp(k) + enddo + aa = dqv2*dp(1)/max(1.e-20,sum) + if( aa .lt. 0.5 ) then + do k = 1, kte + if( qv(k) .gt. 2.0*qvmin ) then + dum = aa*qv(k) + qv(k) = qv(k) - dum + dqv(k) = dqv(k) - dum/delt + endif + enddo + else + ! For testing purposes only (not yet found in any output): + ! write(*,*) 'Full moisture conservation is impossible' + endif + endif + + return + + END SUBROUTINE moisture_check + +! ================================================================== + + SUBROUTINE mynn_mix_chem(kts,kte, & + delt,dz,pblh, & + nchem, kdvel, ndvel, & + chem1, vd1, & + rho, & + flt, tcd, qcd, & + dfh, & + s_aw, s_awchem, & + emis_ant_no, frp, rrfs_sd, & + enh_mix, smoke_dbg ) + +!------------------------------------------------------------------- + integer, intent(in) :: kts,kte + real(kind_phys), dimension(kts:kte), intent(in) :: dfh,dz,tcd,qcd + real(kind_phys), dimension(kts:kte), intent(inout) :: rho + real(kind_phys), intent(in) :: flt + real(kind_phys), intent(in) :: delt,pblh + integer, intent(in) :: nchem, kdvel, ndvel + real(kind_phys), dimension( kts:kte+1), intent(in) :: s_aw + real(kind_phys), dimension( kts:kte, nchem ), intent(inout) :: chem1 + real(kind_phys), dimension( kts:kte+1,nchem), intent(in) :: s_awchem + real(kind_phys), dimension( ndvel ), intent(in) :: vd1 + real(kind_phys), intent(in) :: emis_ant_no,frp + logical, intent(in) :: rrfs_sd,enh_mix,smoke_dbg +!local vars + + real(kind_phys), dimension(kts:kte) :: dtz + real(kind_phys), dimension(kts:kte) :: a,b,c,d,x + real(kind_phys):: rhs,dztop + real(kind_phys):: t,dzk + real(kind_phys):: hght + real(kind_phys):: khdz_old, khdz_back + integer :: k,kk,kmaxfire ! JLS 12/21/21 + integer :: ic ! Chemical array loop index + + integer, SAVE :: icall + + real(kind_phys), dimension(kts:kte) :: rhoinv + real(kind_phys), dimension(kts:kte+1) :: rhoz,khdz + real(kind_phys), parameter :: NO_threshold = 10.0 ! For anthropogenic sources + real(kind_phys), parameter :: frp_threshold = 10.0 ! RAR 02/11/22: I increased the frp threshold to enhance mixing over big fires + real(kind_phys), parameter :: pblh_threshold = 100.0 + + dztop=.5*(dz(kte)+dz(kte-1)) + + DO k=kts,kte + dtz(k)=delt/dz(k) + ENDDO + + !Prepare "constants" for diffusion equation. + !khdz = rho*Kh/dz = rho*dfh + rhoz(kts) =rho(kts) + rhoinv(kts)=1./rho(kts) + khdz(kts) =rhoz(kts)*dfh(kts) + + DO k=kts+1,kte + rhoz(k) =(rho(k)*dz(k-1) + rho(k-1)*dz(k))/(dz(k-1)+dz(k)) + rhoz(k) = MAX(rhoz(k),1E-4) + rhoinv(k)=1./MAX(rho(k),1E-4) + dzk = 0.5 *( dz(k)+dz(k-1) ) + khdz(k) = rhoz(k)*dfh(k) + ENDDO + rhoz(kte+1)=rhoz(kte) + khdz(kte+1)=rhoz(kte+1)*dfh(kte) + + !stability criteria for mf + DO k=kts+1,kte-1 + khdz(k) = MAX(khdz(k), 0.5*s_aw(k)) + khdz(k) = MAX(khdz(k), -0.5*(s_aw(k)-s_aw(k+1))) + ENDDO + + !Enhanced mixing over fires + IF ( rrfs_sd .and. enh_mix ) THEN + DO k=kts+1,kte-1 + khdz_old = khdz(k) + khdz_back = pblh * 0.15 / dz(k) + !Modify based on anthropogenic emissions of NO and FRP + IF ( pblh < pblh_threshold ) THEN + IF ( emis_ant_no > NO_threshold ) THEN + khdz(k) = MAX(1.1*khdz(k),sqrt((emis_ant_no / NO_threshold)) / dz(k) * rhoz(k)) ! JLS 12/21/21 +! khdz(k) = MAX(khdz(k),khdz_back) + ENDIF + IF ( frp > frp_threshold ) THEN + kmaxfire = ceiling(log(frp)) + khdz(k) = MAX(1.1*khdz(k), (1. - k/(kmaxfire*2.)) * ((log(frp))**2.- 2.*log(frp)) / dz(k)*rhoz(k)) ! JLS 12/21/21 +! khdz(k) = MAX(khdz(k),khdz_back) + ENDIF + ENDIF + ENDDO + ENDIF + + !============================================ + ! Patterned after mixing of water vapor in mynn_tendencies. + !============================================ + + DO ic = 1,nchem + k=kts + + a(k)= -dtz(k)*khdz(k)*rhoinv(k) + b(k)=1.+dtz(k)*(khdz(k+1)+khdz(k))*rhoinv(k) - 0.5*dtz(k)*rhoinv(k)*s_aw(k+1) + c(k)= -dtz(k)*khdz(k+1)*rhoinv(k) - 0.5*dtz(k)*rhoinv(k)*s_aw(k+1) + d(k)=chem1(k,ic) & !dtz(k)*flt !neglecting surface sources + & - dtz(k)*vd1(ic)*chem1(k,ic) & + & - dtz(k)*rhoinv(k)*s_awchem(k+1,ic) + + DO k=kts+1,kte-1 + a(k)= -dtz(k)*khdz(k)*rhoinv(k) + 0.5*dtz(k)*rhoinv(k)*s_aw(k) + b(k)=1.+dtz(k)*(khdz(k)+khdz(k+1))*rhoinv(k) + & + & 0.5*dtz(k)*rhoinv(k)*(s_aw(k)-s_aw(k+1)) + c(k)= -dtz(k)*khdz(k+1)*rhoinv(k) - 0.5*dtz(k)*rhoinv(k)*s_aw(k+1) + d(k)=chem1(k,ic) + dtz(k)*rhoinv(k)*(s_awchem(k,ic)-s_awchem(k+1,ic)) + ENDDO + + ! prescribed value at top + a(kte)=0. + b(kte)=1. + c(kte)=0. + d(kte)=chem1(kte,ic) + + CALL tridiag3(kte,a,b,c,d,x) + + DO k=kts,kte + chem1(k,ic)=x(k) + ENDDO + ENDDO + + END SUBROUTINE mynn_mix_chem + +! ================================================================== +!>\ingroup gsd_mynn_edmf + SUBROUTINE retrieve_exchange_coeffs(kts,kte,& + &dfm,dfh,dz,K_m,K_h) + +!------------------------------------------------------------------- + + integer , intent(in) :: kts,kte + + real(kind_phys), dimension(KtS:KtE), intent(in) :: dz,dfm,dfh + + real(kind_phys), dimension(KtS:KtE), intent(out) :: K_m, K_h + + + integer :: k + real(kind_phys):: dzk + + K_m(kts)=0. + K_h(kts)=0. + + DO k=kts+1,kte + dzk = 0.5 *( dz(k)+dz(k-1) ) + K_m(k)=dfm(k)*dzk + K_h(k)=dfh(k)*dzk + ENDDO + + END SUBROUTINE retrieve_exchange_coeffs + +! ================================================================== +!>\ingroup gsd_mynn_edmf + SUBROUTINE tridiag(n,a,b,c,d) + +!! to solve system of linear eqs on tridiagonal matrix n times n +!! after Peaceman and Rachford, 1955 +!! a,b,c,d - are vectors of order n +!! a,b,c - are coefficients on the LHS +!! d - is initially RHS on the output becomes a solution vector + +!------------------------------------------------------------------- + + integer, intent(in):: n + real(kind_phys), dimension(n), intent(in) :: a,b + real(kind_phys), dimension(n), intent(inout) :: c,d + + integer :: i + real(kind_phys):: p + real(kind_phys), dimension(n) :: q + + c(n)=0. + q(1)=-c(1)/b(1) + d(1)=d(1)/b(1) + + DO i=2,n + p=1./(b(i)+a(i)*q(i-1)) + q(i)=-c(i)*p + d(i)=(d(i)-a(i)*d(i-1))*p + ENDDO + + DO i=n-1,1,-1 + d(i)=d(i)+q(i)*d(i+1) + ENDDO + + END SUBROUTINE tridiag + +! ================================================================== +!>\ingroup gsd_mynn_edmf + subroutine tridiag2(n,a,b,c,d,x) + implicit none +! a - sub-diagonal (means it is the diagonal below the main diagonal) +! b - the main diagonal +! c - sup-diagonal (means it is the diagonal above the main diagonal) +! d - right part +! x - the answer +! n - number of unknowns (levels) + + integer,intent(in) :: n + real(kind_phys), dimension(n), intent(in) :: a,b,c,d + real(kind_phys), dimension(n), intent(out):: x + real(kind_phys), dimension(n) :: cp,dp + real(kind_phys):: m + integer :: i + + ! initialize c-prime and d-prime + cp(1) = c(1)/b(1) + dp(1) = d(1)/b(1) + ! solve for vectors c-prime and d-prime + do i = 2,n + m = b(i)-cp(i-1)*a(i) + cp(i) = c(i)/m + dp(i) = (d(i)-dp(i-1)*a(i))/m + enddo + ! initialize x + x(n) = dp(n) + ! solve for x from the vectors c-prime and d-prime + do i = n-1, 1, -1 + x(i) = dp(i)-cp(i)*x(i+1) + end do + + end subroutine tridiag2 +! ================================================================== +!>\ingroup gsd_mynn_edmf + subroutine tridiag3(kte,a,b,c,d,x) + +!ccccccccccccccccccccccccccccccc +! Aim: Inversion and resolution of a tridiagonal matrix +! A X = D +! Input: +! a(*) lower diagonal (Ai,i-1) +! b(*) principal diagonal (Ai,i) +! c(*) upper diagonal (Ai,i+1) +! d +! Output +! x results +!ccccccccccccccccccccccccccccccc + + implicit none + integer,intent(in) :: kte + integer, parameter :: kts=1 + real(kind_phys), dimension(kte) :: a,b,c,d + real(kind_phys), dimension(kte), intent(out) :: x + integer :: in + +! integer kms,kme,kts,kte,in +! real(kind_phys)a(kms:kme,3),c(kms:kme),x(kms:kme) + + do in=kte-1,kts,-1 + d(in)=d(in)-c(in)*d(in+1)/b(in+1) + b(in)=b(in)-c(in)*a(in+1)/b(in+1) + enddo + + do in=kts+1,kte + d(in)=d(in)-a(in)*d(in-1)/b(in-1) + enddo + + do in=kts,kte + x(in)=d(in)/b(in) + enddo + + return + end subroutine tridiag3 + +! ================================================================== +!>\ingroup gsd_mynn_edmf +!! This subroutine calculates hybrid diagnotic boundary-layer height (PBLH). +!! +!! NOTES ON THE PBLH FORMULATION: The 1.5-theta-increase method defines +!!PBL heights as the level at. +!!which the potential temperature first exceeds the minimum potential. +!!temperature within the boundary layer by 1.5 K. When applied to. +!!observed temperatures, this method has been shown to produce PBL- +!!height estimates that are unbiased relative to profiler-based. +!!estimates (Nielsen-Gammon et al. 2008 \cite Nielsen_Gammon_2008). +!! However, their study did not +!!include LLJs. Banta and Pichugina (2008) \cite Pichugina_2008 show that a TKE-based. +!!threshold is a good estimate of the PBL height in LLJs. Therefore, +!!a hybrid definition is implemented that uses both methods, weighting +!!the TKE-method more during stable conditions (PBLH < 400 m). +!!A variable tke threshold (TKEeps) is used since no hard-wired +!!value could be found to work best in all conditions. +!>\section gen_get_pblh GSD get_pblh General Algorithm +!> @{ + SUBROUTINE GET_PBLH(KTS,KTE,zi,thetav1D,qke1D,zw1D,dz1D,landsea,kzi) + + !--------------------------------------------------------------- + ! NOTES ON THE PBLH FORMULATION + ! + !The 1.5-theta-increase method defines PBL heights as the level at + !which the potential temperature first exceeds the minimum potential + !temperature within the boundary layer by 1.5 K. When applied to + !observed temperatures, this method has been shown to produce PBL- + !height estimates that are unbiased relative to profiler-based + !estimates (Nielsen-Gammon et al. 2008). However, their study did not + !include LLJs. Banta and Pichugina (2008) show that a TKE-based + !threshold is a good estimate of the PBL height in LLJs. Therefore, + !a hybrid definition is implemented that uses both methods, weighting + !the TKE-method more during stable conditions (PBLH < 400 m). + !A variable tke threshold (TKEeps) is used since no hard-wired + !value could be found to work best in all conditions. + !--------------------------------------------------------------- + + integer,intent(in) :: KTS,KTE + +#ifdef HARDCODE_VERTICAL +# define kts 1 +# define kte HARDCODE_VERTICAL +#endif + + real(kind_phys), intent(out) :: zi + real(kind_phys), intent(in) :: landsea + real(kind_phys), dimension(kts:kte), intent(in) :: thetav1D, qke1D, dz1D + real(kind_phys), dimension(kts:kte+1), intent(in) :: zw1D + !LOCAL VARS + real(kind_phys):: PBLH_TKE,qtke,qtkem1,wt,maxqke,TKEeps,minthv + real(kind_phys):: delt_thv !delta theta-v; dependent on land/sea point + real(kind_phys), parameter :: sbl_lim = 200. !upper limit of stable BL height (m). + real(kind_phys), parameter :: sbl_damp = 400. !transition length for blending (m). + integer :: I,J,K,kthv,ktke,kzi + + !Initialize KPBL (kzi) + kzi = 2 + + !> - FIND MIN THETAV IN THE LOWEST 200 M AGL + k = kts+1 + kthv = 1 + minthv = 9.E9 + DO WHILE (zw1D(k) .LE. 200.) + !DO k=kts+1,kte-1 + IF (minthv > thetav1D(k)) then + minthv = thetav1D(k) + kthv = k + ENDIF + k = k+1 + !IF (zw1D(k) .GT. sbl_lim) exit + ENDDO + + !> - FIND THETAV-BASED PBLH (BEST FOR DAYTIME). + zi=0. + k = kthv+1 + IF((landsea-1.5).GE.0)THEN + ! WATER + delt_thv = 1.0 + ELSE + ! LAND + delt_thv = 1.25 + ENDIF + + zi=0. + k = kthv+1 +! DO WHILE (zi .EQ. 0.) + DO k=kts+1,kte-1 + IF (thetav1D(k) .GE. (minthv + delt_thv))THEN + zi = zw1D(k) - dz1D(k-1)* & + & MIN((thetav1D(k)-(minthv + delt_thv))/ & + & MAX(thetav1D(k)-thetav1D(k-1),1E-6),1.0) + ENDIF + !k = k+1 + IF (k .EQ. kte-1) zi = zw1D(kts+1) !EXIT SAFEGUARD + IF (zi .NE. 0.0) exit + ENDDO + !print*,"IN GET_PBLH:",thsfc,zi + + !> - FOR STABLE BOUNDARY LAYERS, USE TKE METHOD TO COMPLEMENT THE + !! THETAV-BASED DEFINITION (WHEN THE THETA-V BASED PBLH IS BELOW ~0.5 KM). + !!THE TANH WEIGHTING FUNCTION WILL MAKE THE TKE-BASED DEFINITION NEGLIGIBLE + !!WHEN THE THETA-V-BASED DEFINITION IS ABOVE ~1 KM. + ktke = 1 + maxqke = MAX(Qke1D(kts),0.) + !Use 5% of tke max (Kosovic and Curry, 2000; JAS) + !TKEeps = maxtke/20. = maxqke/40. + TKEeps = maxqke/40. + TKEeps = MAX(TKEeps,0.02) !0.025) + PBLH_TKE=0. + + k = ktke+1 +! DO WHILE (PBLH_TKE .EQ. 0.) + DO k=kts+1,kte-1 + !QKE CAN BE NEGATIVE (IF CKmod == 0)... MAKE TKE NON-NEGATIVE. + qtke =MAX(Qke1D(k)/2.,0.) ! maximum TKE + qtkem1=MAX(Qke1D(k-1)/2.,0.) + IF (qtke .LE. TKEeps) THEN + PBLH_TKE = zw1D(k) - dz1D(k-1)* & + & MIN((TKEeps-qtke)/MAX(qtkem1-qtke, 1E-6), 1.0) + !IN CASE OF NEAR ZERO TKE, SET PBLH = LOWEST LEVEL. + PBLH_TKE = MAX(PBLH_TKE,zw1D(kts+1)) + !print *,"PBLH_TKE:",i,PBLH_TKE, Qke1D(k)/2., zw1D(kts+1) + ENDIF + !k = k+1 + IF (k .EQ. kte-1) PBLH_TKE = zw1D(kts+1) !EXIT SAFEGUARD + IF (PBLH_TKE .NE. 0.) exit + ENDDO + + !> - With TKE advection turned on, the TKE-based PBLH can be very large + !! in grid points with convective precipitation (> 8 km!), + !! so an artificial limit is imposed to not let PBLH_TKE exceed the + !!theta_v-based PBL height +/- 350 m. + !!This has no impact on 98-99% of the domain, but is the simplest patch + !!that adequately addresses these extremely large PBLHs. + PBLH_TKE = MIN(PBLH_TKE,zi+350.) + PBLH_TKE = MAX(PBLH_TKE,MAX(zi-350.,10.)) + + wt=.5*TANH((zi - sbl_lim)/sbl_damp) + .5 + IF (maxqke <= 0.05) THEN + !Cold pool situation - default to theta_v-based def + ELSE + !BLEND THE TWO PBLH TYPES HERE: + zi=PBLH_TKE*(1.-wt) + zi*wt + ENDIF + + !Compute KPBL (kzi) + DO k=kts+1,kte-1 + IF ( zw1D(k) >= zi) THEN + kzi = k-1 + exit + ENDIF + ENDDO + +#ifdef HARDCODE_VERTICAL +# undef kts +# undef kte +#endif + + END SUBROUTINE GET_PBLH +!> @} + +! ================================================================== +!>\ingroup gsd_mynn_edmf +!! This subroutine is the Dynamic Multi-Plume (DMP) Mass-Flux Scheme. +!! +!! dmp_mf() calculates the nonlocal turbulent transport from the dynamic +!! multiplume mass-flux scheme as well as the shallow-cumulus component of +!! the subgrid clouds. Note that this mass-flux scheme is called when the +!! namelist paramter \p bl_mynn_edmf is set to true (recommended). +!! +!! Much thanks to Kay Suslj of NASA-JPL for contributing the original version +!! of this mass-flux scheme. Considerable changes have been made from it's +!! original form. Some additions include: +!! -# scale-aware tapering as dx -> 0 +!! -# transport of TKE (extra namelist option) +!! -# Chaboureau-Bechtold cloud fraction & coupling to radiation (when icloud_bl > 0) +!! -# some extra limits for numerical stability +!! +!! This scheme remains under development, so consider it experimental code. +!! + SUBROUTINE DMP_mf(ii, & + & kts,kte,dt,zw,dz,p,rho, & + & momentum_opt, & + & tke_opt, & + & scalar_opt, & + & u,v,w,th,thl,thv,tk, & + & qt,qv,qc,qke, & + & qnc,qni,qnwfa,qnifa,qnbca, & + & exner,vt,vq,sgm, & + & ust,flt,fltv,flq,flqv, & + & pblh,kpbl,dx,landsea,ts, & + ! outputs - updraft properties + & edmf_a,edmf_w, & + & edmf_qt,edmf_thl, & + & edmf_ent,edmf_qc, & + ! outputs - variables needed for solver + & s_aw,s_awthl,s_awqt, & + & s_awqv,s_awqc, & + & s_awu,s_awv,s_awqke, & + & s_awqnc,s_awqni, & + & s_awqnwfa,s_awqnifa, & + & s_awqnbca, & + & sub_thl,sub_sqv, & + & sub_u,sub_v, & + & det_thl,det_sqv,det_sqc, & + & det_u,det_v, & + ! chem/smoke + & nchem,chem1,s_awchem, & + & mix_chem, & + ! in/outputs - subgrid scale clouds + & qc_bl1d,cldfra_bl1d, & + & qc_bl1D_old,cldfra_bl1D_old, & + ! inputs - flags for moist arrays + & F_QC,F_QI, & + & F_QNC,F_QNI, & + & F_QNWFA,F_QNIFA,F_QNBCA, & + & Psig_shcu, & + ! output info + & maxwidth,ktop,maxmf,ztop, & + ! inputs for stochastic perturbations + & spp_pbl,rstoch_col ) + + ! inputs: + integer, intent(in) :: ii + integer, intent(in) :: KTS,KTE,KPBL + logical, intent(in) :: momentum_opt,scalar_opt,tke_opt + +#ifdef HARDCODE_VERTICAL +# define kts 1 +# define kte HARDCODE_VERTICAL +#endif + +! Stochastic + integer, intent(in) :: spp_pbl + real(kind_phys), dimension(kts:kte) :: rstoch_col + + real(kind_phys),dimension(kts:kte), intent(in) :: & + &U,V,W,TH,THL,TK,QT,QV,QC, & + &exner,dz,THV,P,rho,qke,qnc,qni,qnwfa,qnifa,qnbca + real(kind_phys),dimension(kts:kte+1), intent(in) :: zw !height at full-sigma + real(kind_phys), intent(in) :: flt,fltv,flq,flqv,Psig_shcu, & + &landsea,ts,dx,dt,ust,pblh + logical, optional :: F_QC,F_QI,F_QNC,F_QNI,F_QNWFA,F_QNIFA,F_QNBCA + + ! outputs - updraft properties + real(kind_phys),dimension(kts:kte), intent(out) :: edmf_a,edmf_w, & + & edmf_qt,edmf_thl,edmf_ent,edmf_qc + !add one local edmf variable: + real(kind_phys),dimension(kts:kte) :: edmf_th + ! output + integer, intent(out) :: ktop + real(kind_phys), intent(out) :: maxmf,ztop,maxwidth + ! outputs - variables needed for solver + real(kind_phys),dimension(kts:kte+1) :: s_aw, & !sum ai*rho*wis_awphi + &s_awthl,s_awqt,s_awqv,s_awqc,s_awqnc,s_awqni, & + &s_awqnwfa,s_awqnifa,s_awqnbca,s_awu,s_awv, & + &s_awqke,s_aw2 + + real(kind_phys),dimension(kts:kte), intent(inout) :: & + &qc_bl1d,cldfra_bl1d,qc_bl1d_old,cldfra_bl1d_old + + integer, parameter :: nup=8, debug_mf=0 + real(kind_phys) :: nup2 + + !------------- local variables ------------------- + ! updraft properties defined on interfaces (k=1 is the top of the + ! first model layer + real(kind_phys),dimension(kts:kte+1,1:NUP) :: & + &UPW,UPTHL,UPQT,UPQC,UPQV, & + &UPA,UPU,UPV,UPTHV,UPQKE,UPQNC, & + &UPQNI,UPQNWFA,UPQNIFA,UPQNBCA + ! entrainment variables + real(kind_phys),dimension(kts:kte,1:NUP) :: ENT,ENTf + integer,dimension(kts:kte,1:NUP) :: ENTi + ! internal variables + integer :: K,I,k50 + real(kind_phys):: fltv2,wstar,qstar,thstar,sigmaW,sigmaQT, & + &sigmaTH,z0,pwmin,pwmax,wmin,wmax,wlv,Psig_w,maxw,maxqc,wpbl + real(kind_phys):: B,QTn,THLn,THVn,QCn,Un,Vn,QKEn,QNCn,QNIn, & + & QNWFAn,QNIFAn,QNBCAn, & + & Wn2,Wn,EntEXP,EntEXM,EntW,BCOEFF,THVkm1,THVk,Pk,rho_int + + ! w parameters + real(kind_phys), parameter :: & + &Wa=2./3., & + &Wb=0.002, & + &Wc=1.5 + + ! Lateral entrainment parameters ( L0=100 and ENT0=0.1) were taken from + ! Suselj et al (2013, jas). Note that Suselj et al (2014,waf) use L0=200 and ENT0=0.2. + real(kind_phys),parameter :: & + & L0=100., & + & ENT0=0.1 + + ! Parameters/variables for regulating plumes: + real(kind_phys), parameter :: Atot = 0.10 ! Maximum total fractional area of all updrafts + real(kind_phys), parameter :: lmax = 1000.! diameter of largest plume (absolute maximum, can be smaller) + real(kind_phys), parameter :: lmin = 300. ! diameter of smallest plume (absolute minimum, can be larger) + real(kind_phys), parameter :: dlmin = 0. ! delta increase in the diameter of smallest plume (large fltv) + real(kind_phys) :: minwidth ! actual width of smallest plume + real(kind_phys) :: dl ! variable increment of plume size + real(kind_phys), parameter :: dcut = 1.2 ! max diameter of plume to parameterize relative to dx (km) + real(kind_phys):: d != -2.3 to -1.7 ;=-1.9 in Neggers paper; power law exponent for number density (N=Cl^d). + ! Note that changing d to -2.0 makes each size plume equally contribute to the total coverage of all plumes. + ! Note that changing d to -1.7 doubles the area coverage of the largest plumes relative to the smallest plumes. + real(kind_phys):: cn,c,l,n,an2,hux,wspd_pbl,cloud_base,width_flx + + ! chem/smoke + integer, intent(in) :: nchem + real(kind_phys),dimension(:, :) :: chem1 + real(kind_phys),dimension(kts:kte+1, nchem) :: s_awchem + real(kind_phys),dimension(nchem) :: chemn + real(kind_phys),dimension(kts:kte+1,1:NUP, nchem) :: UPCHEM + integer :: ic + real(kind_phys),dimension(kts:kte+1, nchem) :: edmf_chem + logical, intent(in) :: mix_chem + + !JOE: add declaration of ERF + real(kind_phys):: ERF + + logical :: superadiabatic + + ! VARIABLES FOR CHABOUREAU-BECHTOLD CLOUD FRACTION + real(kind_phys),dimension(kts:kte), intent(inout) :: vt, vq, sgm + real(kind_phys):: sigq,xl,rsl,cpm,a,qmq,mf_cf,Aup,Q1,diffqt,qsat_tk,& + Fng,qww,alpha,beta,bb,f,pt,t,q2p,b9,satvp,rhgrid, & + Ac_mf,Ac_strat,qc_mf + real(kind_phys), parameter :: cf_thresh = 0.5 ! only overwrite stratus CF less than this value + + ! Variables for plume interpolation/saturation check + real(kind_phys),dimension(kts:kte) :: exneri,dzi,rhoz + real(kind_phys):: THp, QTp, QCp, QCs, esat, qsl + real(kind_phys):: csigma,acfac,ac_wsp + + !plume overshoot + integer :: overshoot + real(kind_phys):: bvf, Frz, dzp + + !Flux limiter: not let mass-flux of heat between k=1&2 exceed (fluxportion)*(surface heat flux). + !This limiter makes adjustments to the entire column. + real(kind_phys):: adjustment, flx1 + real(kind_phys), parameter :: fluxportion=0.75 ! set liberally, so has minimal impact. Note that + ! 0.5 starts to have a noticeable impact + ! over land (decrease maxMF by 10-20%), but no impact over water. + + !Subsidence + real(kind_phys),dimension(kts:kte) :: sub_thl,sub_sqv,sub_u,sub_v, & !tendencies due to subsidence + det_thl,det_sqv,det_sqc,det_u,det_v, & !tendencied due to detrainment + envm_a,envm_w,envm_thl,envm_sqv,envm_sqc, & + envm_u,envm_v !environmental variables defined at middle of layer + real(kind_phys),dimension(kts:kte+1) :: envi_a,envi_w !environmental variables defined at model interface + real(kind_phys):: temp,sublim,qc_ent,qv_ent,qt_ent,thl_ent,detrate, & + detrateUV,oow,exc_fac,aratio,detturb,qc_grid,qc_sgs, & + qc_plume,exc_heat,exc_moist,tk_int,tvs + real(kind_phys), parameter :: Cdet = 1./45. + real(kind_phys), parameter :: dzpmax = 300. !limit dz used in detrainment - can be excessing in thick layers + !parameter "Csub" determines the propotion of upward vertical velocity that contributes to + !environmenatal subsidence. Some portion is expected to be compensated by downdrafts instead of + !gentle environmental subsidence. 1.0 assumes all upward vertical velocity in the mass-flux scheme + !is compensated by "gentle" environmental subsidence. + real(kind_phys), parameter :: Csub=0.25 + + !Factor for the pressure gradient effects on momentum transport + real(kind_phys), parameter :: pgfac = 0.00 ! Zhang and Wu showed 0.4 is more appropriate for lower troposphere + real(kind_phys):: Uk,Ukm1,Vk,Vkm1,dxsa + +! check the inputs +! print *,'dt',dt +! print *,'dz',dz +! print *,'u',u +! print *,'v',v +! print *,'thl',thl +! print *,'qt',qt +! print *,'ust',ust +! print *,'flt',flt +! print *,'flq',flq +! print *,'pblh',pblh + +! Initialize individual updraft properties + UPW=0. + UPTHL=0. + UPTHV=0. + UPQT=0. + UPA=0. + UPU=0. + UPV=0. + UPQC=0. + UPQV=0. + UPQKE=0. + UPQNC=0. + UPQNI=0. + UPQNWFA=0. + UPQNIFA=0. + UPQNBCA=0. + if ( mix_chem ) then + UPCHEM(kts:kte+1,1:NUP,1:nchem)=0.0 + endif + + ENT=0.001 +! Initialize mean updraft properties + edmf_a =0. + edmf_w =0. + edmf_qt =0. + edmf_thl=0. + edmf_ent=0. + edmf_qc =0. + if ( mix_chem ) then + edmf_chem(kts:kte+1,1:nchem) = 0.0 + endif + +! Initialize the variables needed for implicit solver + s_aw=0. + s_awthl=0. + s_awqt=0. + s_awqv=0. + s_awqc=0. + s_awu=0. + s_awv=0. + s_awqke=0. + s_awqnc=0. + s_awqni=0. + s_awqnwfa=0. + s_awqnifa=0. + s_awqnbca=0. + if ( mix_chem ) then + s_awchem(kts:kte+1,1:nchem) = 0.0 + endif + +! Initialize explicit tendencies for subsidence & detrainment + sub_thl = 0. + sub_sqv = 0. + sub_u = 0. + sub_v = 0. + det_thl = 0. + det_sqv = 0. + det_sqc = 0. + det_u = 0. + det_v = 0. + nup2 = nup !start with nup, but set to zero if activation criteria fails + + ! Taper off MF scheme when significant resolved-scale motions + ! are present This function needs to be asymetric... + maxw = 0.0 + cloud_base = 9000.0 + do k=1,kte-1 + if (zw(k) > pblh + 500.) exit + + wpbl = w(k) + if (w(k) < 0.)wpbl = 2.*w(k) + maxw = max(maxw,abs(wpbl)) + + !Find highest k-level below 50m AGL + if (ZW(k)<=50.)k50=k + + !Search for cloud base + qc_sgs = max(qc(k), qc_bl1d(k)) + if (qc_sgs> 1E-5 .and. (cldfra_bl1d(k) .ge. 0.5) .and. cloud_base == 9000.0) then + cloud_base = 0.5*(ZW(k)+ZW(k+1)) + endif + enddo + + !do nothing for small w (< 1 m/s), but linearly taper off for w > 1.0 m/s + maxw = max(0.,maxw - 1.0) + Psig_w = max(0.0, 1.0 - maxw) + Psig_w = min(Psig_w, Psig_shcu) + + !Completely shut off MF scheme for strong resolved-scale vertical velocities. + fltv2 = fltv + if(Psig_w == 0.0 .and. fltv > 0.0) fltv2 = -1.*fltv + + ! If surface buoyancy is positive we do integration, otherwise no. + ! Also, ensure that it is at least slightly superadiabatic up through 50 m + superadiabatic = .false. + if ((landsea-1.5).ge.0) then + hux = -0.001 ! WATER ! dT/dz must be < - 0.1 K per 100 m. + else + hux = -0.005 ! LAND ! dT/dz must be < - 0.5 K per 100 m. + endif + tvs = ts*(1.0+p608*qv(kts)) + do k=1,max(1,k50-1) !use "-1" because k50 used interface heights (zw). + if (k == 1) then + if ((thv(k)-tvs)/(0.5*dz(k)) < hux) then + superadiabatic = .true. + else + superadiabatic = .false. + exit + endif + else + if ((thv(k)-thv(k-1))/(0.5*(dz(k)+dz(k-1))) < hux) then + superadiabatic = .true. + else + superadiabatic = .false. + exit + endif + endif + enddo + + ! Determine the numer of updrafts/plumes in the grid column: + ! Some of these criteria may be a little redundant but useful for bullet-proofing. + ! (1) largest plume = 1.2 * dx. + ! (2) Apply a scale-break, assuming no plumes with diameter larger than 1.1*PBLH can exist. + ! (3) max plume size beneath clouds deck approx = 0.5 * cloud_base. + ! (4) add wspd-dependent limit, when plume model breaks down. (hurricanes) + ! (5) limit to reduce max plume sizes in weakly forced conditions. This is only + ! meant to "soften" the activation of the mass-flux scheme. + ! Criteria (1) + maxwidth = min(dx*dcut, lmax) + !Criteria (2) + maxwidth = min(maxwidth, 1.1_kind_phys*PBLH) + ! Criteria (3) + if ((landsea-1.5) .lt. 0) then !land + maxwidth = MIN(maxwidth, 0.5_kind_phys*cloud_base) + else !water + maxwidth = MIN(maxwidth, 0.9_kind_phys*cloud_base) + endif + ! Criteria (4) + wspd_pbl=SQRT(MAX(u(kts)**2 + v(kts)**2, 0.01_kind_phys)) + !Note: area fraction (acfac) is modified below + ! Criteria (5) - only a function of flt (not fltv) + if ((landsea-1.5).LT.0) then !land + width_flx = MAX(MIN(1000.*(0.6*tanh((fltv - 0.040)/0.04) + .5),1000._kind_phys), 0._kind_phys) + else !water + width_flx = MAX(MIN(1000.*(0.6*tanh((fltv - 0.007)/0.02) + .5),1000._kind_phys), 0._kind_phys) + endif + maxwidth = MIN(maxwidth, width_flx) + minwidth = lmin + !allow min plume size to increase in large flux conditions (eddy diffusivity should be + !large enough to handle the representation of small plumes). + if (maxwidth .ge. (lmax - 1.0) .and. fltv .gt. 0.2)minwidth = lmin + dlmin*min((fltv-0.2)/0.3, 1._kind_phys) + + if (maxwidth .le. minwidth) then ! deactivate MF component + nup2 = 0 + maxwidth = 0.0 + endif + + ! Initialize values for 2d output fields: + ktop = 0 + ztop = 0.0 + maxmf= 0.0 + +!Begin plume processing if passes criteria +if ( fltv2 > 0.002 .AND. (maxwidth > minwidth) .AND. superadiabatic) then + + ! Find coef C for number size density N + cn = 0. + d =-1.9 !set d to value suggested by Neggers 2015 (JAMES). + dl = (maxwidth - minwidth)/real(nup-1,kind=kind_phys) + do i=1,NUP + ! diameter of plume + l = minwidth + dl*real(i-1) + cn = cn + l**d * (l*l)/(dx*dx) * dl ! sum fractional area of each plume + enddo + C = Atot/cn !Normalize C according to the defined total fraction (Atot) + + ! Make updraft area (UPA) a function of the buoyancy flux + if ((landsea-1.5).LT.0) then !land + acfac = .5*tanh((fltv2 - 0.02)/0.05) + .5 + else !water + acfac = .5*tanh((fltv2 - 0.01)/0.03) + .5 + endif + !add a windspeed-dependent adjustment to acfac that tapers off + !the mass-flux scheme linearly above sfc wind speeds of 10 m/s. + !Note: this effect may be better represented by an increase in + !entrainment rate for high wind consitions (more ambient turbulence). + if (wspd_pbl .le. 10.) then + ac_wsp = 1.0 + else + ac_wsp = 1.0 - min((wspd_pbl - 10.0)/15., 1.0) + endif + acfac = acfac * ac_wsp + + ! Find the portion of the total fraction (Atot) of each plume size: + An2 = 0. + do i=1,NUP + ! diameter of plume + l = minwidth + dl*real(i-1) + N = C*l**d ! number density of plume n + UPA(1,i) = N*l*l/(dx*dx) * dl ! fractional area of plume n + + UPA(1,i) = UPA(1,i)*acfac + An2 = An2 + UPA(1,i) ! total fractional area of all plumes + !print*," plume size=",l,"; area=",UPA(1,I),"; total=",An2 + end do + + ! set initial conditions for updrafts + z0=50. + pwmin=0.1 ! was 0.5 + pwmax=0.4 ! was 3.0 + + wstar=max(1.E-2,(gtr*fltv2*pblh)**(onethird)) + qstar=max(flq,1.0E-5)/wstar + thstar=flt/wstar + + if ((landsea-1.5) .ge. 0) then + csigma = 1.34 ! WATER + else + csigma = 1.34 ! LAND + endif + + if (env_subs) then + exc_fac = 0.0 + else + if ((landsea-1.5).GE.0) then + !water: increase factor to compensate for decreased pwmin/pwmax + exc_fac = 0.58*4.0 + else + !land: no need to increase factor - already sufficiently large superadiabatic layers + exc_fac = 0.58 + endif + endif + !decrease excess for large wind speeds + exc_fac = exc_fac * ac_wsp + + !Note: sigmaW is typically about 0.5*wstar + sigmaW =csigma*wstar*(z0/pblh)**(onethird)*(1 - 0.8*z0/pblh) + sigmaQT=csigma*qstar*(z0/pblh)**(onethird) + sigmaTH=csigma*thstar*(z0/pblh)**(onethird) + + !Note: Given the pwmin & pwmax set above, these max/mins are + ! rarely exceeded. + wmin=MIN(sigmaW*pwmin,0.1) + wmax=MIN(sigmaW*pwmax,0.5) + + !SPECIFY SURFACE UPDRAFT PROPERTIES AT MODEL INTERFACE BETWEEN K = 1 & 2 + do i=1,NUP + wlv=wmin+(wmax-wmin)/NUP2*(i-1) + + !SURFACE UPDRAFT VERTICAL VELOCITY + UPW(1,I)=wmin + real(i)/real(NUP)*(wmax-wmin) + UPU(1,I)=(U(KTS)*DZ(KTS+1)+U(KTS+1)*DZ(KTS))/(DZ(KTS)+DZ(KTS+1)) + UPV(1,I)=(V(KTS)*DZ(KTS+1)+V(KTS+1)*DZ(KTS))/(DZ(KTS)+DZ(KTS+1)) + UPQC(1,I)=0.0 + !UPQC(1,I)=(QC(KTS)*DZ(KTS+1)+QC(KTS+1)*DZ(KTS))/(DZ(KTS)+DZ(KTS+1)) + + exc_heat = exc_fac*UPW(1,I)*sigmaTH/sigmaW + UPTHV(1,I)=(THV(KTS)*DZ(KTS+1)+THV(KTS+1)*DZ(KTS))/(DZ(KTS)+DZ(KTS+1)) & + & + exc_heat + UPTHL(1,I)=(THL(KTS)*DZ(KTS+1)+THL(KTS+1)*DZ(KTS))/(DZ(KTS)+DZ(KTS+1)) & + & + exc_heat + + !calculate exc_moist by use of surface fluxes + exc_moist=exc_fac*UPW(1,I)*sigmaQT/sigmaW + UPQT(1,I)=(QT(KTS)*DZ(KTS+1)+QT(KTS+1)*DZ(KTS))/(DZ(KTS)+DZ(KTS+1))& + & +exc_moist + + UPQKE(1,I)=(QKE(KTS)*DZ(KTS+1)+QKE(KTS+1)*DZ(KTS))/(DZ(KTS)+DZ(KTS+1)) + UPQNC(1,I)=(QNC(KTS)*DZ(KTS+1)+QNC(KTS+1)*DZ(KTS))/(DZ(KTS)+DZ(KTS+1)) + UPQNI(1,I)=(QNI(KTS)*DZ(KTS+1)+QNI(KTS+1)*DZ(KTS))/(DZ(KTS)+DZ(KTS+1)) + UPQNWFA(1,I)=(QNWFA(KTS)*DZ(KTS+1)+QNWFA(KTS+1)*DZ(KTS))/(DZ(KTS)+DZ(KTS+1)) + UPQNIFA(1,I)=(QNIFA(KTS)*DZ(KTS+1)+QNIFA(KTS+1)*DZ(KTS))/(DZ(KTS)+DZ(KTS+1)) + UPQNBCA(1,I)=(QNBCA(KTS)*DZ(KTS+1)+QNBCA(KTS+1)*DZ(KTS))/(DZ(KTS)+DZ(KTS+1)) + enddo + + if ( mix_chem ) then + do i=1,NUP + do ic = 1,nchem + UPCHEM(1,i,ic)=(chem1(KTS,ic)*DZ(KTS+1)+chem1(KTS+1,ic)*DZ(KTS))/(DZ(KTS)+DZ(KTS+1)) + enddo + enddo + endif + + !Initialize environmental variables which can be modified by detrainment + envm_thl(kts:kte)=THL(kts:kte) + envm_sqv(kts:kte)=QV(kts:kte) + envm_sqc(kts:kte)=QC(kts:kte) + envm_u(kts:kte)=U(kts:kte) + envm_v(kts:kte)=V(kts:kte) + do k=kts,kte-1 + rhoz(k) = (rho(k)*dz(k+1)+rho(k+1)*dz(k))/(dz(k+1)+dz(k)) + enddo + rhoz(kte) = rho(kte) + + !dxsa is scale-adaptive factor governing the pressure-gradient term of the momentum transport + dxsa = 1. - MIN(MAX((12000.0-dx)/(12000.0-3000.0), 0.), 1.) + + ! do integration updraft + do i=1,NUP + QCn = 0. + overshoot = 0 + l = minwidth + dl*real(i-1) ! diameter of plume + do k=kts+1,kte-1 + !Entrainment from Tian and Kuang (2016) + !ENT(k,i) = 0.35/(MIN(MAX(UPW(K-1,I),0.75),1.9)*l) + wmin = 0.3 + l*0.0005 !* MAX(pblh-ZW(k+1), 0.0)/pblh + ENT(k,i) = 0.33/(MIN(MAX(UPW(K-1,I),wmin),0.9)*l) + + !Entrainment from Negggers (2015, JAMES) + !ENT(k,i) = 0.02*l**-0.35 - 0.0009 + !ENT(k,i) = 0.04*l**-0.50 - 0.0009 !more plume diversity + !ENT(k,i) = 0.04*l**-0.495 - 0.0009 !"neg1+" + + !Minimum background entrainment + ENT(k,i) = max(ENT(k,i),0.0003) + !ENT(k,i) = max(ENT(k,i),0.05/ZW(k)) !not needed for Tian and Kuang + + !increase entrainment for plumes extending very high. + IF(ZW(k) >= MIN(pblh+1500., 4000.))THEN + ENT(k,i)=ENT(k,i) + (ZW(k)-MIN(pblh+1500.,4000.))*5.0E-6 + ENDIF + + !SPP + ENT(k,i) = ENT(k,i) * (1.0 - rstoch_col(k)) + + ENT(k,i) = min(ENT(k,i),0.9/(ZW(k+1)-ZW(k))) + + ! Define environment U & V at the model interface levels + Uk =(U(k)*DZ(k+1)+U(k+1)*DZ(k))/(DZ(k+1)+DZ(k)) + Ukm1=(U(k-1)*DZ(k)+U(k)*DZ(k-1))/(DZ(k-1)+DZ(k)) + Vk =(V(k)*DZ(k+1)+V(k+1)*DZ(k))/(DZ(k+1)+DZ(k)) + Vkm1=(V(k-1)*DZ(k)+V(k)*DZ(k-1))/(DZ(k-1)+DZ(k)) + + ! Linear entrainment: + EntExp= ENT(K,I)*(ZW(k+1)-ZW(k)) + EntExm= EntExp*0.3333 !reduce entrainment for momentum + QTn =UPQT(k-1,I) *(1.-EntExp) + QT(k)*EntExp + THLn=UPTHL(k-1,I)*(1.-EntExp) + THL(k)*EntExp + Un =UPU(k-1,I) *(1.-EntExm) + U(k)*EntExm + dxsa*pgfac*(Uk - Ukm1) + Vn =UPV(k-1,I) *(1.-EntExm) + V(k)*EntExm + dxsa*pgfac*(Vk - Vkm1) + QKEn=UPQKE(k-1,I)*(1.-EntExp) + QKE(k)*EntExp + QNCn=UPQNC(k-1,I)*(1.-EntExp) + QNC(k)*EntExp + QNIn=UPQNI(k-1,I)*(1.-EntExp) + QNI(k)*EntExp + QNWFAn=UPQNWFA(k-1,I)*(1.-EntExp) + QNWFA(k)*EntExp + QNIFAn=UPQNIFA(k-1,I)*(1.-EntExp) + QNIFA(k)*EntExp + QNBCAn=UPQNBCA(k-1,I)*(1.-EntExp) + QNBCA(k)*EntExp + + !capture the updated qc, qt & thl modified by entranment alone, + !since they will be modified later if condensation occurs. + qc_ent = QCn + qt_ent = QTn + thl_ent = THLn + + ! Exponential Entrainment: + !EntExp= exp(-ENT(K,I)*(ZW(k)-ZW(k-1))) + !QTn =QT(K) *(1-EntExp)+UPQT(K-1,I)*EntExp + !THLn=THL(K)*(1-EntExp)+UPTHL(K-1,I)*EntExp + !Un =U(K) *(1-EntExp)+UPU(K-1,I)*EntExp + !Vn =V(K) *(1-EntExp)+UPV(K-1,I)*EntExp + !QKEn=QKE(k)*(1-EntExp)+UPQKE(K-1,I)*EntExp + + if ( mix_chem ) then + do ic = 1,nchem + ! Exponential Entrainment: + !chemn(ic) = chem(k,ic)*(1-EntExp)+UPCHEM(K-1,I,ic)*EntExp + ! Linear entrainment: + chemn(ic)=UPCHEM(k-1,i,ic)*(1.-EntExp) + chem1(k,ic)*EntExp + enddo + endif + + ! Define pressure at model interface + Pk =(P(k)*DZ(k+1)+P(k+1)*DZ(k))/(DZ(k+1)+DZ(k)) + ! Compute plume properties thvn and qcn + call condensation_edmf(QTn,THLn,Pk,ZW(k+1),THVn,QCn) + + ! Define environment THV at the model interface levels + THVk =(THV(k)*DZ(k+1)+THV(k+1)*DZ(k))/(DZ(k+1)+DZ(k)) + THVkm1=(THV(k-1)*DZ(k)+THV(k)*DZ(k-1))/(DZ(k-1)+DZ(k)) + +! B=g*(0.5*(THVn+UPTHV(k-1,I))/THV(k-1) - 1.0) + B=grav*(THVn/THVk - 1.0) + IF(B>0.)THEN + BCOEFF = 0.15 !w typically stays < 2.5, so doesnt hit the limits nearly as much + ELSE + BCOEFF = 0.2 !0.33 + ENDIF + + ! Original StEM with exponential entrainment + !EntW=exp(-2.*(Wb+Wc*ENT(K,I))*(ZW(k)-ZW(k-1))) + !Wn2=UPW(K-1,I)**2*EntW + (1.-EntW)*0.5*Wa*B/(Wb+Wc*ENT(K,I)) + ! Original StEM with linear entrainment + !Wn2=UPW(K-1,I)**2*(1.-EntExp) + EntExp*0.5*Wa*B/(Wb+Wc*ENT(K,I)) + !Wn2=MAX(Wn2,0.0) + !WA: TEMF form +! IF (B>0.0 .AND. UPW(K-1,I) < 0.2 ) THEN + IF (UPW(K-1,I) < 0.2 ) THEN + Wn = UPW(K-1,I) + (-2. * ENT(K,I) * UPW(K-1,I) + BCOEFF*B / MAX(UPW(K-1,I),0.2)) * MIN(ZW(k)-ZW(k-1), 250.) + ELSE + Wn = UPW(K-1,I) + (-2. * ENT(K,I) * UPW(K-1,I) + BCOEFF*B / UPW(K-1,I)) * MIN(ZW(k)-ZW(k-1), 250.) + ENDIF + !Do not allow a parcel to accelerate more than 1.25 m/s over 200 m. + !Add max increase of 2.0 m/s for coarse vertical resolution. + IF(Wn > UPW(K-1,I) + MIN(1.25*(ZW(k)-ZW(k-1))/200., 2.0) ) THEN + Wn = UPW(K-1,I) + MIN(1.25*(ZW(k)-ZW(k-1))/200., 2.0) + ENDIF + !Add symmetrical max decrease in w + IF(Wn < UPW(K-1,I) - MIN(1.25*(ZW(k)-ZW(k-1))/200., 2.0) ) THEN + Wn = UPW(K-1,I) - MIN(1.25*(ZW(k)-ZW(k-1))/200., 2.0) + ENDIF + Wn = MIN(MAX(Wn,0.0), 3.0) + + !Check to make sure that the plume made it up at least one level. + !if it failed, then set nup2=0 and exit the mass-flux portion. + IF (k==kts+1 .AND. Wn == 0.) THEN + NUP2=0 + exit + ENDIF + + IF (debug_mf == 1) THEN + IF (Wn .GE. 3.0) THEN + ! surface values + print *," **** SUSPICIOUSLY LARGE W:" + print *,' QCn:',QCn,' ENT=',ENT(k,i),' Nup2=',Nup2 + print *,'pblh:',pblh,' Wn:',Wn,' UPW(k-1)=',UPW(K-1,I) + print *,'K=',k,' B=',B,' dz=',ZW(k)-ZW(k-1) + ENDIF + ENDIF + + !Allow strongly forced plumes to overshoot if KE is sufficient + IF (Wn <= 0.0 .AND. overshoot == 0) THEN + overshoot = 1 + IF ( THVk-THVkm1 .GT. 0.0 ) THEN + bvf = SQRT( gtr*(THVk-THVkm1)/dz(k) ) + !vertical Froude number + Frz = UPW(K-1,I)/(bvf*dz(k)) + !IF ( Frz >= 0.5 ) Wn = MIN(Frz,1.0)*UPW(K-1,I) + dzp = dz(k)*MAX(MIN(Frz,1.0),0.0) ! portion of highest layer the plume penetrates + ENDIF + ELSE + dzp = dz(k) + ENDIF + + !minimize the plume penetratration in stratocu-topped PBL + !IF (fltv2 < 0.06) THEN + ! IF(ZW(k+1) >= pblh-200. .AND. qc(k) > 1e-5 .AND. I > 4) Wn=0. + !ENDIF + + !Modify environment variables (representative of the model layer - envm*) + !following the updraft dynamical detrainment of Asai and Kasahara (1967, JAS). + !Reminder: w is limited to be non-negative (above) + aratio = MIN(UPA(K-1,I)/(1.-UPA(K-1,I)), 0.5) !limit should never get hit + detturb = 0.00008 + oow = -0.060/MAX(1.0,(0.5*(Wn+UPW(K-1,I)))) !coef for dynamical detrainment rate + detrate = MIN(MAX(oow*(Wn-UPW(K-1,I))/dz(k), detturb), .0002) ! dynamical detrainment rate (m^-1) + detrateUV= MIN(MAX(oow*(Wn-UPW(K-1,I))/dz(k), detturb), .0001) ! dynamical detrainment rate (m^-1) + envm_thl(k)=envm_thl(k) + (0.5*(thl_ent + UPTHL(K-1,I)) - thl(k))*detrate*aratio*MIN(dzp,dzpmax) + qv_ent = 0.5*(MAX(qt_ent-qc_ent,0.) + MAX(UPQT(K-1,I)-UPQC(K-1,I),0.)) + envm_sqv(k)=envm_sqv(k) + (qv_ent-QV(K))*detrate*aratio*MIN(dzp,dzpmax) + IF (UPQC(K-1,I) > 1E-8) THEN + IF (QC(K) > 1E-6) THEN + qc_grid = QC(K) + ELSE + qc_grid = cldfra_bl1d(k)*qc_bl1d(K) + ENDIF + envm_sqc(k)=envm_sqc(k) + MAX(UPA(K-1,I)*0.5*(QCn + UPQC(K-1,I)) - qc_grid, 0.0)*detrate*aratio*MIN(dzp,dzpmax) + ENDIF + envm_u(k) =envm_u(k) + (0.5*(Un + UPU(K-1,I)) - U(K))*detrateUV*aratio*MIN(dzp,dzpmax) + envm_v(k) =envm_v(k) + (0.5*(Vn + UPV(K-1,I)) - V(K))*detrateUV*aratio*MIN(dzp,dzpmax) + + IF (Wn > 0.) THEN + !Update plume variables at current k index + UPW(K,I)=Wn !sqrt(Wn2) + UPTHV(K,I)=THVn + UPTHL(K,I)=THLn + UPQT(K,I)=QTn + UPQC(K,I)=QCn + UPU(K,I)=Un + UPV(K,I)=Vn + UPQKE(K,I)=QKEn + UPQNC(K,I)=QNCn + UPQNI(K,I)=QNIn + UPQNWFA(K,I)=QNWFAn + UPQNIFA(K,I)=QNIFAn + UPQNBCA(K,I)=QNBCAn + UPA(K,I)=UPA(K-1,I) + IF ( mix_chem ) THEN + do ic = 1,nchem + UPCHEM(k,I,ic) = chemn(ic) + enddo + ENDIF + ktop = MAX(ktop,k) + ELSE + exit !exit k-loop + END IF + ENDDO + + IF (debug_mf == 1) THEN + IF (MAXVAL(UPW(:,I)) > 10.0 .OR. MINVAL(UPA(:,I)) < 0.0 .OR. & + MAXVAL(UPA(:,I)) > Atot .OR. NUP2 > 10) THEN + ! surface values + print *,'flq:',flq,' fltv:',fltv2,' Nup2=',Nup2 + print *,'pblh:',pblh,' wstar:',wstar,' ktop=',ktop + print *,'sigmaW=',sigmaW,' sigmaTH=',sigmaTH,' sigmaQT=',sigmaQT + ! means + print *,'u:',u + print *,'v:',v + print *,'thl:',thl + print *,'UPA:',UPA(:,I) + print *,'UPW:',UPW(:,I) + print *,'UPTHL:',UPTHL(:,I) + print *,'UPQT:',UPQT(:,I) + print *,'ENT:',ENT(:,I) + ENDIF + ENDIF + ENDDO +ELSE + !At least one of the conditions was not met for activating the MF scheme. + NUP2=0. +END IF !end criteria check for mass-flux scheme + +ktop=MIN(ktop,KTE-1) +IF (ktop == 0) THEN + ztop = 0.0 +ELSE + ztop=zw(ktop) +ENDIF + +IF (nup2 > 0) THEN + !Calculate the fluxes for each variable + !All s_aw* variable are == 0 at k=1 + DO i=1,NUP + DO k=KTS,KTE-1 + s_aw(k+1) = s_aw(k+1) + rhoz(k)*UPA(K,i)*UPW(K,i)*Psig_w + s_awthl(k+1)= s_awthl(k+1) + rhoz(k)*UPA(K,i)*UPW(K,i)*UPTHL(K,i)*Psig_w + s_awqt(k+1) = s_awqt(k+1) + rhoz(k)*UPA(K,i)*UPW(K,i)*UPQT(K,i)*Psig_w + !to conform to grid mean properties, move qc to qv in grid mean + !saturated layers, so total water fluxes are preserved but + !negative qc fluxes in unsaturated layers is reduced. +! if (qc(k) > 1e-12 .or. qc(k+1) > 1e-12) then + qc_plume = UPQC(K,i) +! else +! qc_plume = 0.0 +! endif + s_awqc(k+1) = s_awqc(k+1) + rhoz(k)*UPA(K,i)*UPW(K,i)*qc_plume*Psig_w + s_awqv(k+1) = s_awqt(k+1) - s_awqc(k+1) + ENDDO + ENDDO + !momentum + if (momentum_opt) then + do i=1,nup + do k=kts,kte-1 + s_awu(k+1) = s_awu(k+1) + rhoz(k)*UPA(K,i)*UPW(K,i)*UPU(K,i)*Psig_w + s_awv(k+1) = s_awv(k+1) + rhoz(k)*UPA(K,i)*UPW(K,i)*UPV(K,i)*Psig_w + enddo + enddo + endif + !tke + if (tke_opt) then + do i=1,nup + do k=kts,kte-1 + s_awqke(k+1)= s_awqke(k+1) + rhoz(k)*UPA(K,i)*UPW(K,i)*UPQKE(K,i)*Psig_w + enddo + enddo + endif + !chem + if ( mix_chem ) then + do k=kts,kte + do i=1,nup + do ic = 1,nchem + s_awchem(k+1,ic) = s_awchem(k+1,ic) + rhoz(k)*UPA(K,i)*UPW(K,i)*UPCHEM(K,i,ic)*Psig_w + enddo + enddo + enddo + endif + + if (scalar_opt) then + do k=kts,kte + do I=1,nup + s_awqnc(k+1) = s_awqnc(K+1) + rhoz(k)*UPA(K,i)*UPW(K,i)*UPQNC(K,i)*Psig_w + s_awqni(k+1) = s_awqni(K+1) + rhoz(k)*UPA(K,i)*UPW(K,i)*UPQNI(K,i)*Psig_w + s_awqnwfa(k+1)= s_awqnwfa(K+1) + rhoz(k)*UPA(K,i)*UPW(K,i)*UPQNWFA(K,i)*Psig_w + s_awqnifa(k+1)= s_awqnifa(K+1) + rhoz(k)*UPA(K,i)*UPW(K,i)*UPQNIFA(K,i)*Psig_w + s_awqnbca(k+1)= s_awqnbca(K+1) + rhoz(k)*UPA(K,i)*UPW(K,i)*UPQNBCA(K,i)*Psig_w + enddo + enddo + endif + + !Flux limiter: Check ratio of heat flux at top of first model layer + !and at the surface. Make sure estimated flux out of the top of the + !layer is < fluxportion*surface_heat_flux + IF (s_aw(kts+1) /= 0.) THEN + dzi(kts) = 0.5*(DZ(kts)+DZ(kts+1)) !dz centered at model interface + flx1 = MAX(s_aw(kts+1)*(TH(kts)-TH(kts+1))/dzi(kts),1.0e-5) + ELSE + flx1 = 0.0 + !print*,"ERROR: s_aw(kts+1) == 0, NUP=",NUP," NUP2=",NUP2,& + ! " superadiabatic=",superadiabatic," KTOP=",KTOP + ENDIF + adjustment=1.0 + !Print*,"Flux limiter in MYNN-EDMF, adjustment=",fluxportion*flt/dz(kts)/flx1 + !Print*,"flt/dz=",flt/dz(kts)," flx1=",flx1," s_aw(kts+1)=",s_aw(kts+1) + IF (flx1 > fluxportion*flt/dz(kts) .AND. flx1>0.0) THEN + adjustment= fluxportion*flt/dz(kts)/flx1 + s_aw = s_aw*adjustment + s_awthl = s_awthl*adjustment + s_awqt = s_awqt*adjustment + s_awqc = s_awqc*adjustment + s_awqv = s_awqv*adjustment + s_awqnc = s_awqnc*adjustment + s_awqni = s_awqni*adjustment + s_awqnwfa = s_awqnwfa*adjustment + s_awqnifa = s_awqnifa*adjustment + s_awqnbca = s_awqnbca*adjustment + IF (momentum_opt) THEN + s_awu = s_awu*adjustment + s_awv = s_awv*adjustment + ENDIF + IF (tke_opt) THEN + s_awqke= s_awqke*adjustment + ENDIF + IF ( mix_chem ) THEN + s_awchem = s_awchem*adjustment + ENDIF + UPA = UPA*adjustment + ENDIF + !Print*,"adjustment=",adjustment," fluxportion=",fluxportion," flt=",flt + + !Calculate mean updraft properties for output: + !all edmf_* variables at k=1 correspond to the interface at top of first model layer + do k=kts,kte-1 + do I=1,nup + edmf_a(K) =edmf_a(K) +UPA(K,i) + edmf_w(K) =edmf_w(K) +rhoz(k)*UPA(K,i)*UPW(K,i) + edmf_qt(K) =edmf_qt(K) +rhoz(k)*UPA(K,i)*UPQT(K,i) + edmf_thl(K)=edmf_thl(K)+rhoz(k)*UPA(K,i)*UPTHL(K,i) + edmf_ent(K)=edmf_ent(K)+rhoz(k)*UPA(K,i)*ENT(K,i) + edmf_qc(K) =edmf_qc(K) +rhoz(k)*UPA(K,i)*UPQC(K,i) + enddo + enddo + do k=kts,kte-1 + !Note that only edmf_a is multiplied by Psig_w. This takes care of the + !scale-awareness of the subsidence below: + if (edmf_a(k)>0.) then + edmf_w(k)=edmf_w(k)/edmf_a(k) + edmf_qt(k)=edmf_qt(k)/edmf_a(k) + edmf_thl(k)=edmf_thl(k)/edmf_a(k) + edmf_ent(k)=edmf_ent(k)/edmf_a(k) + edmf_qc(k)=edmf_qc(k)/edmf_a(k) + edmf_a(k)=edmf_a(k)*Psig_w + !FIND MAXIMUM MASS-FLUX IN THE COLUMN: + if(edmf_a(k)*edmf_w(k) > maxmf) maxmf = edmf_a(k)*edmf_w(k) + endif + enddo ! end k + + !smoke/chem + if ( mix_chem ) then + do k=kts,kte-1 + do I=1,nup + do ic = 1,nchem + edmf_chem(k,ic) = edmf_chem(k,ic) + rhoz(k)*UPA(K,I)*UPCHEM(k,i,ic) + enddo + enddo + enddo + do k=kts,kte-1 + if (edmf_a(k)>0.) then + do ic = 1,nchem + edmf_chem(k,ic) = edmf_chem(k,ic)/edmf_a(k) + enddo + endif + enddo ! end k + endif + + !Calculate the effects environmental subsidence. + !All envi_*variables are valid at the interfaces, like the edmf_* variables + IF (env_subs) THEN + DO k=kts+1,kte-1 + !First, smooth the profiles of w & a, since sharp vertical gradients + !in plume variables are not likely extended to env variables + !Note1: w is treated as negative further below + !Note2: both w & a will be transformed into env variables further below + envi_w(k) = onethird*(edmf_w(k-1)+edmf_w(k)+edmf_w(k+1)) + envi_a(k) = onethird*(edmf_a(k-1)+edmf_a(k)+edmf_a(k+1))*adjustment + ENDDO + !define env variables at k=1 (top of first model layer) + envi_w(kts) = edmf_w(kts) + envi_a(kts) = edmf_a(kts) + !define env variables at k=kte + envi_w(kte) = 0.0 + envi_a(kte) = edmf_a(kte) + !define env variables at k=kte+1 + envi_w(kte+1) = 0.0 + envi_a(kte+1) = edmf_a(kte) + !Add limiter for very long time steps (i.e. dt > 300 s) + !Note that this is not a robust check - only for violations in + ! the first model level. + IF (envi_w(kts) > 0.9*DZ(kts)/dt) THEN + sublim = 0.9*DZ(kts)/dt/envi_w(kts) + ELSE + sublim = 1.0 + ENDIF + !Transform w & a into env variables + DO k=kts,kte + temp=envi_a(k) + envi_a(k)=1.0-temp + envi_w(k)=csub*sublim*envi_w(k)*temp/(1.-temp) + ENDDO + !calculate tendencies from subsidence and detrainment valid at the middle of + !each model layer. The lowest model layer uses an assumes w=0 at the surface. + dzi(kts) = 0.5*(dz(kts)+dz(kts+1)) + sub_thl(kts)= 0.5*envi_w(kts)*envi_a(kts)* & + (rho(kts+1)*thl(kts+1)-rho(kts)*thl(kts))/dzi(kts)/rhoz(k) + sub_sqv(kts)= 0.5*envi_w(kts)*envi_a(kts)* & + (rho(kts+1)*qv(kts+1)-rho(kts)*qv(kts))/dzi(kts)/rhoz(k) + DO k=kts+1,kte-1 + dzi(k) = 0.5*(dz(k)+dz(k+1)) + sub_thl(k)= 0.5*(envi_w(k)+envi_w(k-1))*0.5*(envi_a(k)+envi_a(k-1)) * & + (rho(k+1)*thl(k+1)-rho(k)*thl(k))/dzi(k)/rhoz(k) + sub_sqv(k)= 0.5*(envi_w(k)+envi_w(k-1))*0.5*(envi_a(k)+envi_a(k-1)) * & + (rho(k+1)*qv(k+1)-rho(k)*qv(k))/dzi(k)/rhoz(k) + ENDDO + + DO k=KTS,KTE-1 + det_thl(k)=Cdet*(envm_thl(k)-thl(k))*envi_a(k)*Psig_w + det_sqv(k)=Cdet*(envm_sqv(k)-qv(k))*envi_a(k)*Psig_w + det_sqc(k)=Cdet*(envm_sqc(k)-qc(k))*envi_a(k)*Psig_w + ENDDO + + IF (momentum_opt) THEN + sub_u(kts)=0.5*envi_w(kts)*envi_a(kts)* & + (rho(kts+1)*u(kts+1)-rho(kts)*u(kts))/dzi(kts)/rhoz(k) + sub_v(kts)=0.5*envi_w(kts)*envi_a(kts)* & + (rho(kts+1)*v(kts+1)-rho(kts)*v(kts))/dzi(kts)/rhoz(k) + DO k=kts+1,kte-1 + sub_u(k)=0.5*(envi_w(k)+envi_w(k-1))*0.5*(envi_a(k)+envi_a(k-1)) * & + (rho(k+1)*u(k+1)-rho(k)*u(k))/dzi(k)/rhoz(k) + sub_v(k)=0.5*(envi_w(k)+envi_w(k-1))*0.5*(envi_a(k)+envi_a(k-1)) * & + (rho(k+1)*v(k+1)-rho(k)*v(k))/dzi(k)/rhoz(k) + ENDDO + + DO k=KTS,KTE-1 + det_u(k) = Cdet*(envm_u(k)-u(k))*envi_a(k)*Psig_w + det_v(k) = Cdet*(envm_v(k)-v(k))*envi_a(k)*Psig_w + ENDDO + ENDIF + ENDIF !end subsidence/env detranment + + !First, compute exner, plume theta, and dz centered at interface + !Here, k=1 is the top of the first model layer. These values do not + !need to be defined at k=kte (unused level). + DO K=KTS,KTE-1 + exneri(k) = (exner(k)*dz(k+1)+exner(k+1)*dz(k))/(dz(k+1)+dz(k)) + edmf_th(k)= edmf_thl(k) + xlvcp/exneri(k)*edmf_qc(K) + dzi(k) = 0.5*(dz(k)+dz(k+1)) + ENDDO + +!JOE: ADD CLDFRA_bl1d, qc_bl1d. Note that they have already been defined in +! mym_condensation. Here, a shallow-cu component is added, but no cumulus +! clouds can be added at k=1 (start loop at k=2). + do k=kts+1,kte-2 + if (k > KTOP) exit + if(0.5*(edmf_qc(k)+edmf_qc(k-1))>0.0 .and. (cldfra_bl1d(k) < cf_thresh))THEN + !interpolate plume quantities to mass levels + Aup = (edmf_a(k)*dzi(k-1)+edmf_a(k-1)*dzi(k))/(dzi(k-1)+dzi(k)) + THp = (edmf_th(k)*dzi(k-1)+edmf_th(k-1)*dzi(k))/(dzi(k-1)+dzi(k)) + QTp = (edmf_qt(k)*dzi(k-1)+edmf_qt(k-1)*dzi(k))/(dzi(k-1)+dzi(k)) + !convert TH to T +! t = THp*exner(k) + !SATURATED VAPOR PRESSURE + esat = esat_blend(tk(k),t0c,tice) + !SATURATED SPECIFIC HUMIDITY + qsl=ep_2*esat/max(1.e-7,(p(k)-ep_3*esat)) + + !condensed liquid in the plume on mass levels + if (edmf_qc(k)>0.0 .and. edmf_qc(k-1)>0.0) then + QCp = (edmf_qc(k)*dzi(k-1)+edmf_qc(k-1)*dzi(k))/(dzi(k-1)+dzi(k)) + else + QCp = max(edmf_qc(k),edmf_qc(k-1)) + endif + + !COMPUTE CLDFRA & QC_BL FROM MASS-FLUX SCHEME and recompute vt & vq + xl = xl_blend(tk(k),t0c,tice,cice,cliq,cpv,xls,xlv) ! obtain blended heat capacity + qsat_tk = qsat_blend(tk(k),t0c,tice,p(k)) ! get saturation water vapor mixing ratio + ! at t and p + rsl = xl*qsat_tk / (r_v*tk(k)**2) ! slope of C-C curve at t (abs temp) + ! CB02, Eqn. 4 + cpm = cp + qt(k)*cpv ! CB02, sec. 2, para. 1 + a = 1./(1. + xl*rsl/cpm) ! CB02 variable "a" + b9 = a*rsl ! CB02 variable "b" + + q2p = xlvcp/exner(k) + pt = thl(k) +q2p*QCp*Aup ! potential temp (env + plume) + bb = b9*tk(k)/pt ! bb is "b9" in BCMT95. Their "b9" differs from + ! "b9" in CB02 by a factor + ! of T/theta. Strictly, b9 above is formulated in + ! terms of sat. mixing ratio, but bb in BCMT95 is + ! cast in terms of sat. specific humidity. The + ! conversion is neglected here. + qww = 1.+0.61*qt(k) + alpha = 0.61*pt + beta = pt*xl/(tk(k)*cp) - 1.61*pt + !Buoyancy flux terms have been moved to the end of this section... + + !Now calculate convective component of the cloud fraction: + if (a > 0.0) then + f = MIN(1.0/a, 4.0) ! f is vertical profile scaling function (CB2005) + else + f = 1.0 + endif + + !CB form: + !sigq = 3.5E-3 * Aup * 0.5*(edmf_w(k)+edmf_w(k-1)) * f ! convective component of sigma (CB2005) + !sigq = SQRT(sigq**2 + sgm(k)**2) ! combined conv + stratus components + !Per S.DeRoode 2009? + !sigq = 5. * Aup * (QTp - qt(k)) + sigq = 10. * Aup * (QTp - qt(k)) + !constrain sigq wrt saturation: + sigq = max(sigq, qsat_tk*0.02 ) + sigq = min(sigq, qsat_tk*0.25 ) + + qmq = a * (qt(k) - qsat_tk) ! saturation deficit/excess; + Q1 = qmq/sigq ! the numerator of Q1 + + if ((landsea-1.5).GE.0) then ! WATER + !modified form from LES + !mf_cf = min(max(0.5 + 0.36 * atan(1.20*(Q1+0.2)),0.01),0.6) + !Original CB + mf_cf = min(max(0.5 + 0.36 * atan(1.55*Q1),0.01),0.6) + mf_cf = max(mf_cf, 1.2 * Aup) + mf_cf = min(mf_cf, 5.0 * Aup) + else ! LAND + !LES form + !mf_cf = min(max(0.5 + 0.36 * atan(1.20*(Q1+0.4)),0.01),0.6) + !Original CB + mf_cf = min(max(0.5 + 0.36 * atan(1.55*Q1),0.01),0.6) + mf_cf = max(mf_cf, 1.8 * Aup) + mf_cf = min(mf_cf, 5.0 * Aup) + endif + + !IF ( debug_code ) THEN + ! print*,"In MYNN, StEM edmf" + ! print*," CB: env qt=",qt(k)," qsat=",qsat_tk + ! print*," k=",k," satdef=",QTp - qsat_tk," sgm=",sgm(k) + ! print*," CB: sigq=",sigq," qmq=",qmq," tk=",tk(k) + ! print*," CB: mf_cf=",mf_cf," cldfra_bl=",cldfra_bl1d(k)," edmf_a=",edmf_a(k) + !ENDIF + + ! Update cloud fractions and specific humidities in grid cells + ! where the mass-flux scheme is active. The specific humidities + ! are converted to grid means (not in-cloud quantities). + if ((landsea-1.5).GE.0) then ! water + if (QCp * Aup > 5e-5) then + qc_bl1d(k) = 1.86 * (QCp * Aup) - 2.2e-5 + else + qc_bl1d(k) = 1.18 * (QCp * Aup) + endif + cldfra_bl1d(k) = mf_cf + Ac_mf = mf_cf + else ! land + if (QCp * Aup > 5e-5) then + qc_bl1d(k) = 1.86 * (QCp * Aup) - 2.2e-5 + else + qc_bl1d(k) = 1.18 * (QCp * Aup) + endif + cldfra_bl1d(k) = mf_cf + Ac_mf = mf_cf + endif + + !Now recalculate the terms for the buoyancy flux for mass-flux clouds: + !See mym_condensation for details on these formulations. + !Use Bechtold and Siebesma (1998) piecewise estimation of Fng with + !limits ,since they really should be recalculated after all the other changes...: + !Only overwrite vt & vq in non-stratus condition + !if ((landsea-1.5).GE.0) then ! WATER + Q1=max(Q1,-2.25) + !else + ! Q1=max(Q1,-2.0) + !endif + + if (Q1 .ge. 1.0) then + Fng = 1.0 + elseif (Q1 .ge. -1.7 .and. Q1 .lt. 1.0) then + Fng = EXP(-0.4*(Q1-1.0)) + elseif (Q1 .ge. -2.5 .and. Q1 .lt. -1.7) then + Fng = 3.0 + EXP(-3.8*(Q1+1.7)) + else + Fng = min(23.9 + EXP(-1.6*(Q1+2.5)), 60.) + endif + + !link the buoyancy flux function to active clouds only (c*Aup): + vt(k) = qww - (1.5*Aup)*beta*bb*Fng - 1. + vq(k) = alpha + (1.5*Aup)*beta*a*Fng - tv0 + endif !check for (qc in plume) .and. (cldfra_bl < threshold) + enddo !k-loop + +ENDIF !end nup2 > 0 + +!modify output (negative: dry plume, positive: moist plume) +if (ktop > 0) then + maxqc = maxval(edmf_qc(1:ktop)) + if ( maxqc < 1.E-8) maxmf = -1.0*maxmf +endif + +! +! debugging +! +if (edmf_w(1) > 4.0) then +! surface values + print *,'flq:',flq,' fltv:',fltv2 + print *,'pblh:',pblh,' wstar:',wstar + print *,'sigmaW=',sigmaW,' sigmaTH=',sigmaTH,' sigmaQT=',sigmaQT +! means +! print *,'u:',u +! print *,'v:',v +! print *,'thl:',thl +! print *,'thv:',thv +! print *,'qt:',qt +! print *,'p:',p + +! updrafts +! DO I=1,NUP2 +! print *,'up:A',i +! print *,UPA(:,i) +! print *,'up:W',i +! print*,UPW(:,i) +! print *,'up:thv',i +! print *,UPTHV(:,i) +! print *,'up:thl',i +! print *,UPTHL(:,i) +! print *,'up:qt',i +! print *,UPQT(:,i) +! print *,'up:tQC',i +! print *,UPQC(:,i) +! print *,'up:ent',i +! print *,ENT(:,i) +! ENDDO + +! mean updrafts + print *,' edmf_a',edmf_a(1:14) + print *,' edmf_w',edmf_w(1:14) + print *,' edmf_qt:',edmf_qt(1:14) + print *,' edmf_thl:',edmf_thl(1:14) + +ENDIF !END Debugging + + +#ifdef HARDCODE_VERTICAL +# undef kts +# undef kte +#endif + +END SUBROUTINE DMP_MF +!================================================================= +!>\ingroup gsd_mynn_edmf +!! This subroutine +subroutine condensation_edmf(QT,THL,P,zagl,THV,QC) +! +! zero or one condensation for edmf: calculates THV and QC +! +real(kind_phys),intent(in) :: QT,THL,P,zagl +real(kind_phys),intent(out) :: THV +real(kind_phys),intent(inout):: QC + +integer :: niter,i +real(kind_phys):: diff,exn,t,th,qs,qcold + +! constants used from module_model_constants.F +! p1000mb +! rcp ... Rd/cp +! xlv ... latent heat for water (2.5e6) +! cp +! rvord .. r_v/r_d (1.6) + +! number of iterations + niter=50 +! minimum difference (usually converges in < 8 iterations with diff = 2e-5) + diff=1.e-6 + + EXN=(P/p1000mb)**rcp + !QC=0. !better first guess QC is incoming from lower level, do not set to zero + do i=1,NITER + T=EXN*THL + xlvcp*QC + QS=qsat_blend(T,t0c,tice,P) + QCOLD=QC + QC=0.5*QC + 0.5*MAX((QT-QS),0.) + if (abs(QC-QCOLD) 0.0) THEN +! PRINT*,"EDMF SAT, p:",p," iterations:",i +! PRINT*," T=",T," THL=",THL," THV=",THV +! PRINT*," QS=",QS," QT=",QT," QC=",QC,"ratio=",qc/qs +! ENDIF + + !THIS BASICALLY GIVE THE SAME RESULT AS THE PREVIOUS LINE + !TH = THL + xlv/cp/EXN*QC + !THV= TH*(1. + p608*QT) + + !print *,'t,p,qt,qs,qc' + !print *,t,p,qt,qs,qc + + +end subroutine condensation_edmf + +!=============================================================== + +subroutine condensation_edmf_r(QT,THL,P,zagl,THV,QC) +! +! zero or one condensation for edmf: calculates THL and QC +! similar to condensation_edmf but with different inputs +! +real(kind_phys),intent(in) :: QT,THV,P,zagl +real(kind_phys),intent(out) :: THL, QC + +integer :: niter,i +real(kind_phys):: diff,exn,t,th,qs,qcold + +! number of iterations + niter=50 +! minimum difference + diff=2.e-5 + + EXN=(P/p1000mb)**rcp + ! assume first that th = thv + T = THV*EXN + !QS = qsat_blend(T,t0c,tice,P) + !QC = QS - QT + + QC=0. + + do i=1,NITER + QCOLD = QC + T = EXN*THV/(1.+QT*(rvovrd-1.)-rvovrd*QC) + QS=qsat_blend(T,t0c,tice,P) + QC= MAX((QT-QS),0.) + if (abs(QC-QCOLD)0) then +! Wn2=DOWNW(K+1,I)**2*EntW - Wa*B/Beta_dm * (1. - EntW) +! else +! Wn2=DOWNW(K+1,I)**2 - 2.*Wa*B*dz(k) +! end if + + mindownw = MIN(DOWNW(K+1,I),-0.2) + Wn = DOWNW(K+1,I) + (-2.*ENT(K,I)*DOWNW(K+1,I) - & + BCOEFF*B/mindownw)*MIN(dz(k), 250.) + + !Do not allow a parcel to accelerate more than 1.25 m/s over 200 m. + !Add max acceleration of -2.0 m/s for coarse vertical resolution. + IF (Wn < DOWNW(K+1,I) - MIN(1.25*dz(k)/200., -2.0))THEN + Wn = DOWNW(K+1,I) - MIN(1.25*dz(k)/200., -2.0) + ENDIF + !Add symmetrical max decrease in velocity (less negative) + IF (Wn > DOWNW(K+1,I) + MIN(1.25*dz(k)/200., 2.0))THEN + Wn = DOWNW(K+1,I) + MIN(1.25*dz(k)/200., 2.0) + ENDIF + Wn = MAX(MIN(Wn,0.0), -3.0) + + !print *, " k =", k, " z =", ZW(k) + !print *, " entw =",ENT(K,I), " Bouy =", B + !print *, " downthv =", THVn, " thvk =", thvk + !print *, " downthl =", THLn, " thl =", thl(k) + !print *, " downqt =", QTn , " qt =", qt(k) + !print *, " downw+1 =",DOWNW(K+1,I), " Wn2 =", Wn + + IF (Wn .lt. 0.) THEN !terminate when velocity is too small + DOWNW(K,I) = Wn !-sqrt(Wn2) + DOWNTHV(K,I)= THVn + DOWNTHL(K,I)= THLn + DOWNQT(K,I) = QTn + DOWNQC(K,I) = QCn + DOWNU(K,I) = Un + DOWNV(K,I) = Vn + DOWNA(K,I) = DOWNA(K+1,I) + ELSE + !plumes must go at least 2 levels + if (DD_initK(I) - K .lt. 2) then + DOWNW(:,I) = 0.0 + DOWNTHV(:,I)= 0.0 + DOWNTHL(:,I)= 0.0 + DOWNQT(:,I) = 0.0 + DOWNQC(:,I) = 0.0 + DOWNU(:,I) = 0.0 + DOWNV(:,I) = 0.0 + endif + exit + ENDIF + ENDDO + ENDDO + endif ! end cloud flag + + DOWNW(1,:) = 0. !make sure downdraft does not go to the surface + DOWNA(1,:) = 0. + + ! Combine both moist and dry plume, write as one averaged plume + ! Even though downdraft starts at different height, average all up to qlTop + DO k=qlTop,KTS,-1 + DO I=1,NDOWN + edmf_a_dd(K) =edmf_a_dd(K) +DOWNA(K-1,I) + edmf_w_dd(K) =edmf_w_dd(K) +DOWNA(K-1,I)*DOWNW(K-1,I) + edmf_qt_dd(K) =edmf_qt_dd(K) +DOWNA(K-1,I)*DOWNQT(K-1,I) + edmf_thl_dd(K)=edmf_thl_dd(K)+DOWNA(K-1,I)*DOWNTHL(K-1,I) + edmf_ent_dd(K)=edmf_ent_dd(K)+DOWNA(K-1,I)*ENT(K-1,I) + edmf_qc_dd(K) =edmf_qc_dd(K) +DOWNA(K-1,I)*DOWNQC(K-1,I) + ENDDO + + IF (edmf_a_dd(k) >0.) THEN + edmf_w_dd(k) =edmf_w_dd(k) /edmf_a_dd(k) + edmf_qt_dd(k) =edmf_qt_dd(k) /edmf_a_dd(k) + edmf_thl_dd(k)=edmf_thl_dd(k)/edmf_a_dd(k) + edmf_ent_dd(k)=edmf_ent_dd(k)/edmf_a_dd(k) + edmf_qc_dd(k) =edmf_qc_dd(k) /edmf_a_dd(k) + ENDIF + ENDDO + + ! + ! computing variables needed for solver + ! + + DO k=KTS,qlTop + rho_int = (rho(k)*DZ(k+1)+rho(k+1)*DZ(k))/(DZ(k+1)+DZ(k)) + DO I=1,NDOWN + sd_aw(k) =sd_aw(k) +rho_int*DOWNA(k,i)*DOWNW(k,i) + sd_awthl(k)=sd_awthl(k)+rho_int*DOWNA(k,i)*DOWNW(k,i)*DOWNTHL(k,i) + sd_awqt(k) =sd_awqt(k) +rho_int*DOWNA(k,i)*DOWNW(k,i)*DOWNQT(k,i) + sd_awqc(k) =sd_awqc(k) +rho_int*DOWNA(k,i)*DOWNW(k,i)*DOWNQC(k,i) + sd_awu(k) =sd_awu(k) +rho_int*DOWNA(k,i)*DOWNW(k,i)*DOWNU(k,i) + sd_awv(k) =sd_awv(k) +rho_int*DOWNA(k,i)*DOWNW(k,i)*DOWNV(k,i) + ENDDO + sd_awqv(k) = sd_awqt(k) - sd_awqc(k) + ENDDO + +END SUBROUTINE DDMF_JPL +!=============================================================== + + +SUBROUTINE SCALE_AWARE(dx,PBL1,Psig_bl,Psig_shcu) + + !--------------------------------------------------------------- + ! NOTES ON SCALE-AWARE FORMULATION + ! + !JOE: add scale-aware factor (Psig) here, taken from Honnert et al. (2011, + ! JAS) and/or from Hyeyum Hailey Shin and Song-You Hong (2013, JAS) + ! + ! Psig_bl tapers local mixing + ! Psig_shcu tapers nonlocal mixing + + real(kind_phys), intent(in) :: dx,pbl1 + real(kind_phys), intent(out) :: Psig_bl,Psig_shcu + real(kind_phys) :: dxdh + + Psig_bl=1.0 + Psig_shcu=1.0 + dxdh=MAX(2.5*dx,10.)/MIN(PBL1,3000.) + ! Honnert et al. 2011, TKE in PBL *** original form used until 201605 + !Psig_bl= ((dxdh**2) + 0.07*(dxdh**0.667))/((dxdh**2) + & + ! (3./21.)*(dxdh**0.67) + (3./42.)) + ! Honnert et al. 2011, TKE in entrainment layer + !Psig_bl= ((dxdh**2) + (4./21.)*(dxdh**0.667))/((dxdh**2) + & + ! (3./20.)*(dxdh**0.67) + (7./21.)) + ! New form to preseve parameterized mixing - only down 5% at dx = 750 m + Psig_bl= ((dxdh**2) + 0.106*(dxdh**0.667))/((dxdh**2) +0.066*(dxdh**0.667) + 0.071) + + !assume a 500 m cloud depth for shallow-cu clods + dxdh=MAX(2.5*dx,10.)/MIN(PBL1+500.,3500.) + ! Honnert et al. 2011, TKE in entrainment layer *** original form used until 201605 + !Psig_shcu= ((dxdh**2) + (4./21.)*(dxdh**0.667))/((dxdh**2) + & + ! (3./20.)*(dxdh**0.67) + (7./21.)) + + ! Honnert et al. 2011, TKE in cumulus + !Psig(i)= ((dxdh**2) + 1.67*(dxdh**1.4))/((dxdh**2) +1.66*(dxdh**1.4) + + !0.2) + + ! Honnert et al. 2011, w'q' in PBL + !Psig(i)= 0.5 + 0.5*((dxdh**2) + 0.03*(dxdh**1.4) - + !(4./13.))/((dxdh**2) + 0.03*(dxdh**1.4) + (4./13.)) + ! Honnert et al. 2011, w'q' in cumulus + !Psig(i)= ((dxdh**2) - 0.07*(dxdh**1.4))/((dxdh**2) -0.07*(dxdh**1.4) + + !0.02) + + ! Honnert et al. 2011, q'q' in PBL + !Psig(i)= 0.5 + 0.5*((dxdh**2) + 0.25*(dxdh**0.667) -0.73)/((dxdh**2) + !-0.03*(dxdh**0.667) + 0.73) + ! Honnert et al. 2011, q'q' in cumulus + !Psig(i)= ((dxdh**2) - 0.34*(dxdh**1.4))/((dxdh**2) - 0.35*(dxdh**1.4) + !+ 0.37) + + ! Hyeyum Hailey Shin and Song-You Hong 2013, TKE in PBL (same as Honnert's above) + !Psig_shcu= ((dxdh**2) + 0.070*(dxdh**0.667))/((dxdh**2) + !+0.142*(dxdh**0.667) + 0.071) + ! Hyeyum Hailey Shin and Song-You Hong 2013, TKE in entrainment zone *** switch to this form 201605 + Psig_shcu= ((dxdh**2) + 0.145*(dxdh**0.667))/((dxdh**2) +0.172*(dxdh**0.667) + 0.170) + + ! Hyeyum Hailey Shin and Song-You Hong 2013, w'theta' in PBL + !Psig(i)= 0.5 + 0.5*((dxdh**2) -0.098)/((dxdh**2) + 0.106) + ! Hyeyum Hailey Shin and Song-You Hong 2013, w'theta' in entrainment zone + !Psig(i)= 0.5 + 0.5*((dxdh**2) - 0.112*(dxdh**0.25) -0.071)/((dxdh**2) + !+ 0.054*(dxdh**0.25) + 0.10) + + !print*,"in scale_aware; dx, dxdh, Psig(i)=",dx,dxdh,Psig(i) + !If(Psig_bl(i) < 0.0 .OR. Psig(i) > 1.)print*,"dx, dxdh, Psig(i)=",dx,dxdh,Psig_bl(i) + If(Psig_bl > 1.0) Psig_bl=1.0 + If(Psig_bl < 0.0) Psig_bl=0.0 + + If(Psig_shcu > 1.0) Psig_shcu=1.0 + If(Psig_shcu < 0.0) Psig_shcu=0.0 + + END SUBROUTINE SCALE_AWARE +! =================================================================== + FUNCTION phim(zet) + ! New stability function parameters for momentum (Puhales, 2020, WRF 4.2.1) + ! The forms in unstable conditions (z/L < 0) use Grachev et al. (2000), which are a blend of + ! the classical (Kansas) forms (i.e., Paulson 1970, Dyer and Hicks 1970), valid for weakly + ! unstable conditions (-1 < z/L < 0). The stability functions for stable conditions use an + ! updated form taken from Cheng and Brutsaert (2005), which extends the validity into very + ! stable conditions [z/L ~ O(10)]. + IMPLICIT NONE + + real(kind_phys), intent(in):: zet + real(kind_phys):: dummy_0,dummy_1,dummy_11,dummy_2,dummy_22,dummy_3,dummy_33,dummy_4,dummy_44,dummy_psi + real(kind_phys), parameter :: am_st=6.1, bm_st=2.5, rbm_st=1./bm_st + real(kind_phys), parameter :: ah_st=5.3, bh_st=1.1, rbh_st=1./bh_st + real(kind_phys), parameter :: am_unst=10., ah_unst=34. + real(kind_phys):: phi_m,phim + + if ( zet >= 0.0 ) then + dummy_0=1+zet**bm_st + dummy_1=zet+dummy_0**(rbm_st) + dummy_11=1+dummy_0**(rbm_st-1)*zet**(bm_st-1) + dummy_2=(-am_st/dummy_1)*dummy_11 + phi_m = 1-zet*dummy_2 + else + dummy_0 = (1.0-cphm_unst*zet)**0.25 + phi_m = 1./dummy_0 + dummy_psi = 2.*log(0.5*(1.+dummy_0))+log(0.5*(1.+dummy_0**2))-2.*atan(dummy_0)+1.570796 + + dummy_0=(1.-am_unst*zet) ! parentesis arg + dummy_1=dummy_0**0.333333 ! y + dummy_11=-0.33333*am_unst*dummy_0**(-0.6666667) ! dy/dzet + dummy_2 = 0.33333*(dummy_1**2.+dummy_1+1.) ! f + dummy_22 = 0.3333*dummy_11*(2.*dummy_1+1.) ! df/dzet + dummy_3 = 0.57735*(2.*dummy_1+1.) ! g + dummy_33 = 1.1547*dummy_11 ! dg/dzet + dummy_4 = 1.5*log(dummy_2)-1.73205*atan(dummy_3)+1.813799364 !psic + dummy_44 = (1.5/dummy_2)*dummy_22-1.73205*dummy_33/(1.+dummy_3**2)! dpsic/dzet + + dummy_0 = zet**2 + dummy_1 = 1./(1.+dummy_0) ! denon + dummy_11 = 2.*zet ! denon/dzet + dummy_2 = ((1-phi_m)/zet+dummy_11*dummy_4+dummy_0*dummy_44)*dummy_1 + dummy_22 = -dummy_11*(dummy_psi+dummy_0*dummy_4)*dummy_1**2 + + phi_m = 1.-zet*(dummy_2+dummy_22) + end if + + !phim = phi_m - zet + phim = phi_m + + END FUNCTION phim +! =================================================================== + + FUNCTION phih(zet) + ! New stability function parameters for heat (Puhales, 2020, WRF 4.2.1) + ! The forms in unstable conditions (z/L < 0) use Grachev et al. (2000), which are a blend of + ! the classical (Kansas) forms (i.e., Paulson 1970, Dyer and Hicks 1970), valid for weakly + ! unstable conditions (-1 < z/L < 0). The stability functions for stable conditions use an + ! updated form taken from Cheng and Brutsaert (2005), which extends the validity into very + ! stable conditions [z/L ~ O(10)]. + IMPLICIT NONE + + real(kind_phys), intent(in):: zet + real(kind_phys):: dummy_0,dummy_1,dummy_11,dummy_2,dummy_22,dummy_3,dummy_33,dummy_4,dummy_44,dummy_psi + real(kind_phys), parameter :: am_st=6.1, bm_st=2.5, rbm_st=1./bm_st + real(kind_phys), parameter :: ah_st=5.3, bh_st=1.1, rbh_st=1./bh_st + real(kind_phys), parameter :: am_unst=10., ah_unst=34. + real(kind_phys):: phh,phih + + if ( zet >= 0.0 ) then + dummy_0=1+zet**bh_st + dummy_1=zet+dummy_0**(rbh_st) + dummy_11=1+dummy_0**(rbh_st-1)*zet**(bh_st-1) + dummy_2=(-ah_st/dummy_1)*dummy_11 + phih = 1-zet*dummy_2 + else + dummy_0 = (1.0-cphh_unst*zet)**0.5 + phh = 1./dummy_0 + dummy_psi = 2.*log(0.5*(1.+dummy_0)) + + dummy_0=(1.-ah_unst*zet) ! parentesis arg + dummy_1=dummy_0**0.333333 ! y + dummy_11=-0.33333*ah_unst*dummy_0**(-0.6666667) ! dy/dzet + dummy_2 = 0.33333*(dummy_1**2.+dummy_1+1.) ! f + dummy_22 = 0.3333*dummy_11*(2.*dummy_1+1.) ! df/dzet + dummy_3 = 0.57735*(2.*dummy_1+1.) ! g + dummy_33 = 1.1547*dummy_11 ! dg/dzet + dummy_4 = 1.5*log(dummy_2)-1.73205*atan(dummy_3)+1.813799364 !psic + dummy_44 = (1.5/dummy_2)*dummy_22-1.73205*dummy_33/(1.+dummy_3**2)! dpsic/dzet + + dummy_0 = zet**2 + dummy_1 = 1./(1.+dummy_0) ! denon + dummy_11 = 2.*zet ! ddenon/dzet + dummy_2 = ((1-phh)/zet+dummy_11*dummy_4+dummy_0*dummy_44)*dummy_1 + dummy_22 = -dummy_11*(dummy_psi+dummy_0*dummy_4)*dummy_1**2 + + phih = 1.-zet*(dummy_2+dummy_22) + end if + +END FUNCTION phih +! ================================================================== + SUBROUTINE topdown_cloudrad(kts,kte, & + &dz1,zw,fltv,xland,kpbl,PBLH, & + &sqc,sqi,sqw,thl,th1,ex1,p1,rho1,thetav, & + &cldfra_bl1D,rthraten, & + &maxKHtopdown,KHtopdown,TKEprodTD ) + + !input + integer, intent(in) :: kte,kts + real(kind_phys), dimension(kts:kte), intent(in) :: dz1,sqc,sqi,sqw,& + thl,th1,ex1,p1,rho1,thetav,cldfra_bl1D + real(kind_phys), dimension(kts:kte), intent(in) :: rthraten + real(kind_phys), dimension(kts:kte+1), intent(in) :: zw + real(kind_phys), intent(in) :: pblh,fltv + real(kind_phys), intent(in) :: xland + integer , intent(in) :: kpbl + !output + real(kind_phys), intent(out) :: maxKHtopdown + real(kind_phys), dimension(kts:kte), intent(out) :: KHtopdown,TKEprodTD + !local + real(kind_phys), dimension(kts:kte) :: zfac,wscalek2,zfacent + real(kind_phys) :: bfx0,wm2,wm3,bfxpbl,dthvx,tmp1 + real(kind_phys) :: temps,templ,zl1,wstar3_2 + real(kind_phys) :: ent_eff,radsum,radflux,we,rcldb,rvls,minrad,zminrad + real(kind_phys), parameter :: pfac =2.0, zfmin = 0.01, phifac=8.0 + integer :: k,kk,kminrad + logical :: cloudflg + + cloudflg=.false. + minrad=100. + kminrad=kpbl + zminrad=PBLH + KHtopdown(kts:kte)=0.0 + TKEprodTD(kts:kte)=0.0 + maxKHtopdown=0.0 + + !CHECK FOR STRATOCUMULUS-TOPPED BOUNDARY LAYERS + DO kk = MAX(1,kpbl-2),kpbl+3 + if (sqc(kk).gt. 1.e-6 .OR. sqi(kk).gt. 1.e-6 .OR. & + cldfra_bl1D(kk).gt.0.5) then + cloudflg=.true. + endif + if (rthraten(kk) < minrad)then + minrad=rthraten(kk) + kminrad=kk + zminrad=zw(kk) + 0.5*dz1(kk) + endif + ENDDO + + IF (MAX(kminrad,kpbl) < 2)cloudflg = .false. + IF (cloudflg) THEN + zl1 = dz1(kts) + k = MAX(kpbl-1, kminrad-1) + !Best estimate of height of TKE source (top of downdrafts): + !zminrad = 0.5*pblh(i) + 0.5*zminrad + + templ=thl(k)*ex1(k) + !rvls is ws at full level + rvls=100.*6.112*EXP(17.67*(templ-273.16)/(templ-29.65))*(ep_2/p1(k+1)) + temps=templ + (sqw(k)-rvls)/(cp/xlv + ep_2*xlv*rvls/(r_d*templ**2)) + rvls=100.*6.112*EXP(17.67*(temps-273.15)/(temps-29.65))*(ep_2/p1(k+1)) + rcldb=max(sqw(k)-rvls,0.) + + !entrainment efficiency + dthvx = (thl(k+2) + th1(k+2)*p608*sqw(k+2)) & + - (thl(k) + th1(k) *p608*sqw(k)) + dthvx = max(dthvx,0.1) + tmp1 = xlvcp * rcldb/(ex1(k)*dthvx) + !Originally from Nichols and Turton (1986), where a2 = 60, but lowered + !here to 8, as in Grenier and Bretherton (2001). + ent_eff = 0.2 + 0.2*8.*tmp1 + + radsum=0. + DO kk = MAX(1,kpbl-3),kpbl+3 + radflux=rthraten(kk)*ex1(kk) !converts theta/s to temp/s + radflux=radflux*cp/grav*(p1(kk)-p1(kk+1)) ! converts temp/s to W/m^2 + if (radflux < 0.0 ) radsum=abs(radflux)+radsum + ENDDO + + !More strict limits over land to reduce stable-layer mixouts + if ((xland-1.5).GE.0)THEN ! WATER + radsum=MIN(radsum,90.0) + bfx0 = max(radsum/rho1(k)/cp,0.) + else ! LAND + radsum=MIN(0.25*radsum,30.0)!practically turn off over land + bfx0 = max(radsum/rho1(k)/cp - max(fltv,0.0),0.) + endif + + !entrainment from PBL top thermals + wm3 = grav/thetav(k)*bfx0*MIN(pblh,1500.) ! this is wstar3(i) +! wm2 = wm2 + wm3**twothirds + bfxpbl = - ent_eff * bfx0 + dthvx = max(thetav(k+1)-thetav(k),0.1) + we = max(bfxpbl/dthvx,-sqrt(wm3**twothirds)) + + DO kk = kts,kpbl+3 + !Analytic vertical profile + zfac(kk) = min(max((1.-(zw(kk+1)-zl1)/(zminrad-zl1)),zfmin),1.) + zfacent(kk) = 10.*MAX((zminrad-zw(kk+1))/zminrad,0.0)*(1.-zfac(kk))**3 + + !Calculate an eddy diffusivity profile (not used at the moment) + wscalek2(kk) = (phifac*karman*wm3*(zfac(kk)))**onethird + !Modify shape of Kh to be similar to Lock et al (2000): use pfac = 3.0 + KHtopdown(kk) = wscalek2(kk)*karman*(zminrad-zw(kk+1))*(1.-zfac(kk))**3 !pfac + KHtopdown(kk) = MAX(KHtopdown(kk),0.0) + + !Calculate TKE production = 2(g/TH)(w'TH'), where w'TH' = A(TH/g)wstar^3/PBLH, + !A = ent_eff, and wstar is associated with the radiative cooling at top of PBL. + !An analytic profile controls the magnitude of this TKE prod in the vertical. + TKEprodTD(kk)=2.*ent_eff*wm3/MAX(pblh,100.)*zfacent(kk) + TKEprodTD(kk)= MAX(TKEprodTD(kk),0.0) + ENDDO + ENDIF !end cloud check + maxKHtopdown=MAXVAL(KHtopdown(:)) + + END SUBROUTINE topdown_cloudrad +! ================================================================== +! =================================================================== +! =================================================================== + +END MODULE bl_mynn_subroutines diff --git a/src/core_atmosphere/physics/physics_mmm/bl_ysu.F b/src/core_atmosphere/physics/physics_mmm/bl_ysu.F index 5483574e28..601c232cb9 100644 --- a/src/core_atmosphere/physics/physics_mmm/bl_ysu.F +++ b/src/core_atmosphere/physics/physics_mmm/bl_ysu.F @@ -561,6 +561,7 @@ subroutine bl_ysu_run(ux,vx,tx,qvx,qcx,qix,nmix,qmix,p2d,p2di,pi2d, & hgamt(i) = 0. hgamq(i) = 0. wscale(i) = 0. + we(i) = 0. kpbl(i) = 1 hpbl(i) = zq(i,1) zl1(i) = za(i,1) diff --git a/src/core_atmosphere/physics/physics_mmm/mp_radar.F b/src/core_atmosphere/physics/physics_mmm/mp_radar.F index 00b8ed47f4..08199da7df 100644 --- a/src/core_atmosphere/physics/physics_mmm/mp_radar.F +++ b/src/core_atmosphere/physics/physics_mmm/mp_radar.F @@ -1,7 +1,6 @@ !================================================================================================================= module mp_radar use ccpp_kinds,only: kind_phys - use mpas_atmphys_utilities implicit none private @@ -376,7 +375,7 @@ complex(kind=R8KIND) function get_m_mix_nested (m_a, m_i, m_w, volair, & if (host .eq. 'air') then if (matrix .eq. 'air') then write(radar_debug,*) 'GET_M_MIX_NESTED: bad matrix: ', matrix - call physics_message(radar_debug) +! call physics_message(radar_debug) cumulerror = cumulerror + 1 else vol1 = volice / MAX(volice+volwater,1d-10) @@ -397,7 +396,7 @@ complex(kind=R8KIND) function get_m_mix_nested (m_a, m_i, m_w, volair, & cumulerror = cumulerror + error else write(radar_debug,*) 'GET_M_MIX_NESTED: bad hostmatrix: ', hostmatrix - call physics_message(radar_debug) +! call physics_message(radar_debug) cumulerror = cumulerror + 1 endif endif @@ -406,7 +405,7 @@ complex(kind=R8KIND) function get_m_mix_nested (m_a, m_i, m_w, volair, & if (matrix .eq. 'ice') then write(radar_debug,*) 'GET_M_MIX_NESTED: bad matrix: ', matrix - call physics_message(radar_debug) +! call physics_message(radar_debug) cumulerror = cumulerror + 1 else vol1 = volair / MAX(volair+volwater,1d-10) @@ -427,7 +426,7 @@ complex(kind=R8KIND) function get_m_mix_nested (m_a, m_i, m_w, volair, & cumulerror = cumulerror + error else write(radar_debug,*) 'GET_M_MIX_NESTED: bad hostmatrix: ', hostmatrix - call physics_message(radar_debug) +! call physics_message(radar_debug) cumulerror = cumulerror + 1 endif endif @@ -436,7 +435,7 @@ complex(kind=R8KIND) function get_m_mix_nested (m_a, m_i, m_w, volair, & if (matrix .eq. 'water') then write(radar_debug,*) 'GET_M_MIX_NESTED: bad matrix: ', matrix - call physics_message(radar_debug) +! call physics_message(radar_debug) cumulerror = cumulerror + 1 else vol1 = volair / MAX(volice+volair,1d-10) @@ -457,7 +456,7 @@ complex(kind=R8KIND) function get_m_mix_nested (m_a, m_i, m_w, volair, & cumulerror = cumulerror + error else write(radar_debug,*) 'GET_M_MIX_NESTED: bad hostmatrix: ', hostmatrix - call physics_message(radar_debug) +! call physics_message(radar_debug) cumulerror = cumulerror + 1 endif endif @@ -471,13 +470,13 @@ complex(kind=R8KIND) function get_m_mix_nested (m_a, m_i, m_w, volair, & else write(radar_debug,*) 'GET_M_MIX_NESTED: unknown matrix: ', host - call physics_message(radar_debug) +! call physics_message(radar_debug) cumulerror = cumulerror + 1 endif if (cumulerror .ne. 0) then write(radar_debug,*) 'get_m_mix_nested: error encountered' - call physics_message(radar_debug) +! call physics_message(radar_debug) get_m_mix_nested = cmplx(1.0d0,0.0d0) endif @@ -516,19 +515,19 @@ complex(kind=R8KIND) function get_m_mix (m_a, m_i, m_w, volair, volice, & m_a, m_w, m_i, inclusion, error) else write(radar_debug,*) 'GET_M_MIX: unknown matrix: ', matrix - call physics_message(radar_debug) +! call physics_message(radar_debug) error = 1 endif else write(radar_debug,*) 'GET_M_MIX: unknown mixingrule: ', mixingrule - call physics_message(radar_debug) +! call physics_message(radar_debug) error = 2 endif if (error .ne. 0) then write(radar_debug,*) 'GET_M_MIX: error encountered' - call physics_message(radar_debug) +! call physics_message(radar_debug) endif end function get_m_mix @@ -560,7 +559,7 @@ complex(kind=R8KIND) function m_complex_maxwellgarnett(vol1, vol2, vol3, & if (dabs(vol1+vol2+vol3-1.0d0) .gt. 1d-6) then write(radar_debug,*) 'M_COMPLEX_MAXWELLGARNETT: sum of the ', & 'partial volume fractions is not 1...ERROR' - call physics_message(radar_debug) +! call physics_message(radar_debug) m_complex_maxwellgarnett = CMPLX(-999.99d0,-999.99d0) error = 1 return @@ -578,7 +577,7 @@ complex(kind=R8KIND) function m_complex_maxwellgarnett(vol1, vol2, vol3, & beta3 = 2.0d0*m1t/(m3t-m1t) * (m3t/(m3t-m1t)*LOG(m3t/m1t)-1.0d0) else write(radar_debug,*) 'M_COMPLEX_MAXWELLGARNETT: ', 'unknown inclusion: ', inclusion - call physics_message(radar_debug) +! call physics_message(radar_debug) m_complex_maxwellgarnett=cmplx(-999.99d0,-999.99d0,kind=R8KIND) error = 1 return diff --git a/src/core_atmosphere/physics/physics_mmm/mynn_shared.F b/src/core_atmosphere/physics/physics_mmm/mynn_shared.F new file mode 100644 index 0000000000..ee74077ba3 --- /dev/null +++ b/src/core_atmosphere/physics/physics_mmm/mynn_shared.F @@ -0,0 +1,133 @@ +!================================================================================================================= + module mynn_shared + use mpas_kind_types,only: kind_phys => RKIND + + implicit none + private + public:: esat_blend,qsat_blend,xl_blend + + +!> Constants used for empirical calculations of saturation vapor pressures (in function "esat") and +!! saturation mixing ratios (in function "qsat"), reproduced from module_mp_thompson.F. + real(kind=kind_phys),parameter:: j0 = .611583699e03 + real(kind=kind_phys),parameter:: j1 = .444606896e02 + real(kind=kind_phys),parameter:: j2 = .143177157e01 + real(kind=kind_phys),parameter:: j3 = .264224321e-1 + real(kind=kind_phys),parameter:: j4 = .299291081e-3 + real(kind=kind_phys),parameter:: j5 = .203154182e-5 + real(kind=kind_phys),parameter:: j6 = .702620698e-8 + real(kind=kind_phys),parameter:: j7 = .379534310e-11 + real(kind=kind_phys),parameter:: j8 =-.321582393e-13 + + real(kind=kind_phys),parameter:: k0 = .609868993e03 + real(kind=kind_phys),parameter:: k1 = .499320233e02 + real(kind=kind_phys),parameter:: k2 = .184672631e01 + real(kind=kind_phys),parameter:: k3 = .402737184e-1 + real(kind=kind_phys),parameter:: k4 = .565392987e-3 + real(kind=kind_phys),parameter:: k5 = .521693933e-5 + real(kind=kind_phys),parameter:: k6 = .307839583e-7 + real(kind=kind_phys),parameter:: k7 = .105785160e-9 + real(kind=kind_phys),parameter:: k8 = .161444444e-12 + + +contains + + +!================================================================================================================= +!>\ingroup gsd_mynn_edmf +!! \author JAYMES- added 22 Apr 2015 +!! This function calculates saturation vapor pressure. Separate ice and liquid functions are used (identical to +!! those in module_mp_thompson.F, v3.6). Then, the final returned value is a temperature-dependent "blend". +!! Because the final value is "phase-aware", this formulation may be preferred for use throughout bl_mynn.F and +!! sf_mynn.F (replacing "svp"). + + function esat_blend(t,t0c,tice) + implicit none + + real(kind=kind_phys),intent(in):: t,t0c,tice + real(kind=kind_phys):: esat_blend,xc,esl,esi,chi + + xc = max(-80.,t-t0c) + +!For 253 < t < 273.16 K, the vapor pressures are "blended" as a function of temperature, using the approach of +!Chaboureau and Bechtold (2002), JAS, p. 2363. The resulting values are returned from the function. + if(t .ge. t0c) then + esat_blend = j0+xc*(j1+xc*(j2+xc*(j3+xc*(j4+xc*(j5+xc*(j6+xc*(j7+xc*j8))))))) + else if(t .le. tice) then + esat_blend = k0+xc*(k1+xc*(k2+xc*(k3+xc*(k4+xc*(k5+xc*(k6+xc*(k7+xc*k8))))))) + else + esl = j0+xc*(j1+xc*(j2+xc*(j3+xc*(j4+xc*(j5+xc*(j6+xc*(j7+xc*j8))))))) + esi = k0+xc*(k1+xc*(k2+xc*(k3+xc*(k4+xc*(k5+xc*(k6+xc*(k7+xc*k8))))))) + chi = (273.16-t)/20.16 + esat_blend = (1.-chi)*esl + chi*esi + end if + + end function esat_blend + +!================================================================================================================= +!>\ingroup gsd_mynn_edmf +!! \author JAYMES- added 22 Apr 2015 +!! This function extends function "esat" and returns a "blended" saturation mixing ratio. + + function qsat_blend(t,t0c,tice,p,waterice) + implicit none + + real(kind=kind_phys),intent(in):: t,t0c,tice,p + character(len=1),intent(in),optional:: waterice + character(len=1):: wrt + real(kind=kind_phys):: qsat_blend,xc,esl,esi,rslf,rsif,chi + + if(.not. present(waterice) ) then + wrt = 'b' + else + wrt = waterice + endif + + xc=max(-80.,t-t0c) + + if((t .ge. t0c) .or. (wrt .eq. 'w')) then + esl = j0+xc*(j1+xc*(j2+xc*(j3+xc*(j4+xc*(j5+xc*(j6+xc*(j7+xc*j8))))))) + qsat_blend = 0.622*esl/(p-esl) + else if(t .le. tice) then + esi = k0+xc*(k1+xc*(k2+xc*(k3+xc*(k4+xc*(k5+xc*(k6+xc*(k7+xc*k8))))))) + qsat_blend = 0.622*esi/(p-esi) + else + esl = j0+xc*(j1+xc*(j2+xc*(j3+xc*(j4+xc*(j5+xc*(j6+xc*(j7+xc*j8))))))) + esi = k0+xc*(k1+xc*(k2+xc*(k3+xc*(k4+xc*(k5+xc*(k6+xc*(k7+xc*k8))))))) + rslf = 0.622*esl/(p-esl) + rsif = 0.622*esi/(p-esi) + chi = (t0c-t)/(t0c-tice) + qsat_blend = (1.-chi)*rslf + chi*rsif + end if + + end function qsat_blend + +!================================================================================================================= +!>\ingroup gsd_mynn_edmf +!! \author jaymes- added 22 apr 2015 +!! this function interpolates the latent heats of vaporization and sublimation into a single, temperature- +!! dependent "blended" value, following chaboureau and bechtold (2002) \cite chaboureau_2002, appendix. + + function xl_blend(t,t0c,tice,cice,cliq,cpv,xls,xlv) + implicit none + + real(kind=kind_phys),intent(in):: t,t0c,tice + real(kind=kind_phys),intent(in):: cice,cliq,cpv,xls,xlv + real(kind=kind_phys):: xl_blend,xlvt,xlst,chi + + if(t .ge. t0c) then + xl_blend = xlv + (cpv-cliq)*(t-t0c) !vaporization/condensation + else if (t .le. tice) then + xl_blend = xls + (cpv-cice)*(t-t0c) !sublimation/deposition + else + xlvt = xlv + (cpv-cliq)*(t-t0c) !vaporization/condensation + xlst = xls + (cpv-cice)*(t-t0c) !sublimation/deposition + chi = (t0c-t)/(t0c-tice) + xl_blend = (1.-chi)*xlvt + chi*xlst !blended + end if + + end function xl_blend + +!================================================================================================================= + end module mynn_shared +!================================================================================================================= diff --git a/src/core_atmosphere/physics/physics_mmm/sf_mynn.F b/src/core_atmosphere/physics/physics_mmm/sf_mynn.F new file mode 100644 index 0000000000..e324ef4aab --- /dev/null +++ b/src/core_atmosphere/physics/physics_mmm/sf_mynn.F @@ -0,0 +1,2237 @@ +!================================================================================================================= + module sf_mynn + +!------------------------------------------------------------------- +!Modifications implemented by Joseph Olson NOAA/GSL +!The following overviews the current state of this scheme:: +! +! BOTH LAND AND WATER: +!1) Calculation of stability parameter (z/L) taken from Li et al. (2010 BLM) +! for first iteration of first time step; afterwards, exact calculation +! using a brute force iterative method described in Olson et al. (2021 NOAA +! Tech memorandum). This method replaces the iterative technique used in +! module_sf_sfclayrev.F (Jimenez et al. 2013) with mods. Either technique +! gives about the same result. The former technique is retained in this +! module (commented out) for potential subsequent benchmarking. +!2) Fixed isflux=0 option to turn off scalar fluxes, but keep momentum +! fluxes for idealized studies (credit: Anna Fitch). +!3) Kinematic viscosity varies with temperature according to Andreas (1989). +!4) Uses the blended Monin-Obukhov flux-profile relationships COARE (Fairall +! et al 2003) for the unstable regime (a blended mix of Dyer-Hicks 1974 and +! Grachev et al (2000). Uses Cheng and Brutsaert (2005) for stable conditions. +!5) The following overviews the namelist variables that control the +! aerodynamic roughness lengths (over water) and the thermal and moisture +! roughness lengths (defaults are recommended): +! +! LAND only: +! "iz0tlnd" namelist option is used to select the following options: +! (default) =0: Zilitinkevich (1995); Czil now set to 0.085 +! =1: Czil_new (modified according to Chen & Zhang 2008) +! =2: Modified Yang et al (2002, 2008) - generalized for all landuse +! =3: constant zt = z0/7.4 (original form; Garratt 1992) +! +! WATER only: +! "isftcflx" namelist option is used to select the following options: +! (default) =0: z0, zt, and zq from the COARE algorithm. Set COARE_OPT (below) to +! 3.0 (Fairall et al. 2003, default) +! 3.5 (Edson et al 2013) - now with bug fix (Edson et al. 2014, JPO) +! =1: z0 from Davis et al (2008), zt & zq from COARE 3.0/3.5 +! =2: z0 from Davis et al (2008), zt & zq from Garratt (1992) +! =3: z0 from Taylor and Yelland (2004), zt and zq from COARE 3.0/3.5 +! +! SNOW/ICE only: +! Andreas (2002) snow/ice parameterization for thermal and +! moisture roughness is used over all gridpoints with snow deeper than +! 0.1 m. This algorithm calculates a z0 for snow (Andreas et al. 2005, BLM), +! which is only used as part of the thermal and moisture roughness +! length calculation, not to directly impact the surface winds. +! +! Misc: +!1) Added a more elaborate diagnostic for u10 & V10 for high vertical resolution +! model configurations but for most model configurations with depth of +! the lowest half-model level near 10 m, a neutral-log diagnostic is used. +! +!2) Option to activate stochastic parameter perturbations (SPP), which +! perturb z0, zt, and zq, along with many other parameters in the MYNN- +! EDMF scheme. +! +!NOTE: This code was primarily tested in combination with the RUC LSM. +! Performance with the Noah (or other) LSM is relatively unknown. +!------------------------------------------------------------------- + use ccpp_kinds,only: kind_phys + use mynn_shared,only: esat_blend,qsat_blend,xl_blend + + implicit none + private + public:: sf_mynn_run, & + sf_mynn_init, & + sf_mynn_finalize + + + logical,parameter:: debug_code = .false. + integer,parameter:: psi_opt = 0 ! 0 = stable: Cheng and Brustaert + ! unstable: blended COARE + ! 1 = GFS + real,parameter:: wmin = 0.1 + real,parameter:: vconvc = 1.25 + real,parameter:: snowz0 = 0.011 + real,parameter:: coare_opt = 3.0 ! 3.0 or 3.5 + !For debugging purposes: + + real,dimension(0:1000),save:: psim_stab,psim_unstab, & + psih_stab,psih_unstab + + + contains + + +!================================================================================================================= +!>\section arg_table_sf_mynn_init +!!\html\include sf_mynn_init.html +!! + subroutine sf_mynn_init(errmsg,errflg) +!================================================================================================================= + +!--- output arguments: + character(len=*),intent(out):: errmsg + integer,intent(out):: errflg + +!----------------------------------------------------------------------------------------------------------------- + + call psi_init(psi_opt) + + errmsg = ' ' + errflg = 0 + + end subroutine sf_mynn_init + +!================================================================================================================= +!>\section arg_table_sf_mynn_finalize +!!\html\include sf_mynn_finalize.html +!! + subroutine sf_mynn_finalize(errmsg,errflg) +!================================================================================================================= + +!--- output arguments: + character(len=*),intent(out):: errmsg + integer,intent(out):: errflg + +!----------------------------------------------------------------------------------------------------------------- + + errmsg = ' ' + errflg = 0 + + end subroutine sf_mynn_finalize + +!================================================================================================================= +!>\section arg_table_sf_mynn_run +!!\html\include sf_mynn_run.html +!! + subroutine sf_mynn_run( & + u1d,v1d,t1d,qv1d,p1d,dz8w1d,rho1d, & + u1d2,v1d2,dz2w1d,cp,g,rovcp,r,xlv, & + psfcpa,chs,chs2,cqs2,cpm,pblh,rmol, & + znt,ust,mavail,zol,mol,regime,psim, & + psih,xland,hfx,qfx,tsk,u10,v10,th2, & + t2,q2,flhc,flqc,snowh,qgh,qsfc,lh, & + gz1oz0,wspd,br,isfflx,dx,svp1,svp2, & + svp3,svpt0,ep1,ep2,karman,ch,qcg, & + itimestep,wstar,qstar,ustm,ck,cka, & + cd,cda,spp_pbl,rstoch1d,isftcflx, & + iz0tlnd,its,ite,errmsg,errflg & + ) + implicit none +!================================================================================================================= + +!----------------------------- +! scalars: +!----------------------------- + integer,intent(in):: its,ite + integer,intent(in):: itimestep + + real(kind=kind_phys),intent(in):: svp1,svp2,svp3,svpt0,ep1,ep2 + real(kind=kind_phys),intent(in):: karman,cp,g,rovcp,r,xlv + + real(kind=kind_phys),parameter:: prt=1. !prandlt number + real(kind=kind_phys),parameter:: xka=2.4e-5 !molecular diffusivity + + character(len=*),intent(out):: errmsg + integer,intent(out):: errflg + +!----------------------------- +! namelist options +!----------------------------- + logical,intent(in):: spp_pbl + + integer,intent(in):: isfflx + integer,intent(in),optional:: isftcflx,iz0tlnd + +!----------------------------- +! 1d arrays +!----------------------------- + real(kind=kind_phys),intent(in),dimension(its:ite):: mavail, & + pblh, & + xland, & + tsk, & + psfcpa, & + qcg, & + snowh, & + dx + + real(kind=kind_phys),intent(in),dimension(its:ite):: u1d, & + v1d, & + u1d2, & + v1d2, & + qv1d, & + p1d, & + t1d, & + dz8w1d, & + dz2w1d, & + rho1d + real(kind=kind_phys),intent(in),dimension(its:ite):: & + rstoch1d + + + real(kind=kind_phys),intent(inout),dimension(its:ite):: & + regime, & + hfx, & + qfx, & + lh, & + mol, & + rmol, & + qgh, & + qsfc, & + znt, & + zol, & + ust, & + cpm, & + chs2, & + cqs2, & + chs, & + ch, & + flhc, & + flqc, & + gz1oz0, & + wspd, & + br, & + psim, & + psih + +!----------------------------- +! diagnostic outputs: +!----------------------------- + real(kind=kind_phys),intent(out),dimension(its:ite):: & + u10, & + v10, & + th2, & + t2, & + q2 + + real(kind=kind_phys),intent(out),dimension(its:ite):: & + wstar, & + qstar + + real(kind=kind_phys),intent(out),dimension(its:ite),optional:: & + ck, & + cka, & + cd, & + cda, & + ustm + +!----------------------------- +! local variables +!----------------------------- + integer:: n,i,k,l,yesno + + real(kind=kind_phys):: ep3 + real(kind=kind_phys):: pl,thcon,tvcon,e1 + real(kind=kind_phys):: dthvdz,dthvm,vconv,zol2,zol10,zolza,zolz0,zolzt + real(kind=kind_phys):: dtg,psix,dtthx,dthdz,psix10,psit,psit2, & + psiq,psiq2,psiq10,dzdt + real(kind=kind_phys):: fluxc,vsgd + real(kind=kind_phys):: restar,visc,dqg,oldust,oldtst + + real(kind=kind_phys),dimension(its:ite) :: & + za, & !height of lowest 1/2 sigma level(m) + za2, & !height of 2nd lowest 1/2 sigma level(m) + thv1d, & !theta-v at lowest 1/2 sigma (K) + th1d, & !theta at lowest 1/2 sigma (K) + tc1d, & !t at lowest 1/2 sigma (Celsius) + tv1d, & !tv at lowest 1/2 sigma (K) + qvsh, & !qv at lowest 1/2 sigma (spec humidity) + psih2, & !m-o stability functions at z=2 m + psim10, & !m-o stability functions at z=10 m + psih10, & !m-o stability functions at z=10 m + wspdi, & + z_q, & !moisture roughness length + z_t, & !thermalroughness length + ZNTstoch, & + govrth, & !g/theta + thgb, & !theta at ground + thvgb, & !theta-v at ground + psfc, & !press at surface (Pa/1000) + qsfcmr, & !qv at surface (mixing ratio, kg/kg) + gz2oz0, & !log((2.0+znt(i))/znt(i)) + gz10oz0, & !log((10.+znt(i))/znt(i)) + gz2ozt, & !log((2.0+z_t(i))/z_t(i)) + gz10ozt, & !log((10.+z_t(i))/z_t(i)) + gz1ozt, & !log((za(i)+z_t(i))/z_t(i)) + zratio !z0/zt + +!----------------------------------------------------------------------------------------------------------------- + + ep3 = 1.-ep2 + + do i=its,ite + !convert ground & lowest layer temperature to potential temperature: + !psfc cmb + psfc(i)=psfcpa(i)/1000. + thgb(i)=tsk(i)*(100./psfc(i))**rovcp !(K) + !PL cmb + pl=p1d(i)/1000. + thcon=(100./pl)**rovcp + th1d(i)=t1d(i)*thcon !(Theta, K) + tc1d(i)=t1d(i)-273.15 !(T, Celsius) + + !convert to virtual temperature + qvsh(i)=qv1d(i)/(1.+qv1d(i)) !convert to spec hum (kg/kg) + tvcon=(1.+ep1*qvsh(i)) + thv1d(i)=th1d(i)*tvcon !(K) + tv1d(i)=t1d(i)*tvcon !(K) + + !rho1d(i)=psfcpa(i)/(r*tv1d(i)) !now using value calculated in sfc driver + za(i)=0.5*dz8w1d(i) !height of first half-sigma level + za2(i)=dz8w1d(i) + 0.5*dz2w1d(i) !height of 2nd half-sigma level + govrth(i)=g/th1d(i) + enddo + + do i=its,ite + if (tsk(i) .lt. 273.15) then + !saturation vapor pressure wrt ice (svp1=.6112; 10*mb) + e1=svp1*exp(4648*(1./273.15 - 1./tsk(i)) - & + & 11.64*log(273.15/tsk(i)) + 0.02265*(273.15 - tsk(i))) + else + !saturation vapor pressure wrt water (Bolton 1980) + e1=svp1*exp(svp2*(tsk(i)-svpt0)/(tsk(i)-svp3)) + endif + !for land points, qsfc can come from lsm, only recompute over water + if (xland(i).gt.1.5 .or. qsfc(i).le.0.0) then !water + qsfc(i)=ep2*e1/(psfc(i)-ep3*e1) !specific humidity + qsfcmr(i)=ep2*e1/(psfc(i)-e1) !mixing ratio + else !land + qsfcmr(i)=qsfc(i)/(1.-qsfc(i)) + endif + + !qgh changed to use lowest-level air temp consistent with myjsfc change + !q2sat = qgh in LSM + if (tsk(i) .lt. 273.15) then + !saturation vapor pressure wrt ice + e1=svp1*exp(4648*(1./273.15 - 1./t1d(i)) - & + & 11.64*log(273.15/t1d(i)) + 0.02265*(273.15 - t1d(i))) + else + !saturation vapor pressure wrt water (Bolton 1980) + e1=svp1*exp(svp2*(t1d(i)-svpt0)/(t1d(i)-svp3)) + endif + pl=p1d(i)/1000. + !qgh(i)=ep2*e1/(pl-ep_3*e1) !specific humidity + qgh(i)=ep2*e1/(pl-e1) !mixing ratio + cpm(i)=cp*(1.+0.84*qv1d(i)) + enddo + + do i=its,ite + wspd(i)=sqrt(u1d(i)*u1d(i)+v1d(i)*v1d(i)) + + !tgs:thvgb(i)=thgb(i)*(1.+ep1*qsfc(i)*mavail(i)) + thvgb(i)=thgb(i)*(1.+ep1*qsfc(i)) + + dthdz=(th1d(i)-thgb(i)) + dthvdz=(thv1d(i)-thvgb(i)) + + !-------------------------------------------------------- + ! Calculate the convective velocity scale (WSTAR) and + ! subgrid-scale velocity (VSGD) following Beljaars (1995, QJRMS) + ! and Mahrt and Sun (1995, MWR), respectively + !------------------------------------------------------- + !Use Beljaars over land and water + fluxc = max(hfx(i)/rho1d(i)/cp & + & + ep1*thvgb(i)*qfx(i)/rho1d(i),0.) + !wstar(i) = vconvc*(g/tsk(i)*pblh(i)*fluxc)**.33 + if (xland(i).gt.1.5 .or. qsfc(i).le.0.0) then !water + wstar(i) = vconvc*(g/tsk(i)*pblh(i)*fluxc)**.33 + else !land + !increase height scale, assuming that the non-local transoport + !from the mass-flux (plume) mixing exceedsd the pblh. + wstar(i) = vconvc*(g/tsk(i)*min(1.5*pblh(i),4000.)*fluxc)**.33 + endif + !-------------------------------------------------------- + ! Mahrt and Sun low-res correction + ! (for 13 km ~ 0.37 m/s; for 3 km == 0 m/s) + !-------------------------------------------------------- + vsgd = 0.32 * (max(dx(i)/5000.-1.,0.))**.33 + wspd(i)=sqrt(wspd(i)*wspd(i)+wstar(i)*wstar(i)+vsgd*vsgd) + wspd(i)=max(wspd(i),wmin) + + !-------------------------------------------------------- + ! calculate the bulk richardson number of surface layer, + ! according to Akb(1976), Eq(12). + !-------------------------------------------------------- + br(i)=govrth(i)*za(i)*dthvdz/(wspd(i)*wspd(i)) + if (itimestep == 1) then + !set limits according to Li et al. (2010) boundary-layer meteorol (p.158) + br(i)=max(br(i),-2.0) + br(i)=min(br(i),2.0) + else + br(i)=max(br(i),-4.0) + br(i)=min(br(i), 4.0) + endif + + ! if previously unstable, do not let into regimes 1 and 2 (stable) + ! if (itimestep .gt. 1) then + ! if(mol(i).lt.0.)br(i)=min(br(i),0.0) + !endif + + enddo + + 1006 format(a,f7.3,a,f9.4,a,f9.5,a,f9.4) + 1007 format(a,f2.0,a,f6.2,a,f7.3,a,f7.2) + +!-------------------------------------------------------------------- +!-------------------------------------------------------------------- +!--- begin i-loop +!-------------------------------------------------------------------- +!-------------------------------------------------------------------- + + do i=its,ite + + !compute kinematic viscosity (m2/s) Andreas (1989) CRREL Rep. 89-11 + !valid between -173 and 277 degrees C. + visc=1.326e-5*(1. + 6.542e-3*tc1d(i) + 8.301e-6*tc1d(i)*tc1d(i) & + - 4.84e-9*tc1d(i)*tc1d(i)*tc1d(i)) + + if ((xland(i)-1.5).ge.0) then + !-------------------------------------- + ! water + !-------------------------------------- + ! calculate z0 (znt) + !-------------------------------------- + if ( present(isftcflx) ) then + if ( isftcflx .eq. 0 ) then + if (coare_opt .eq. 3.0) then + !COARE 3.0 (misleading subroutine name) + call charnock_1955(znt(i),ust(i),wspd(i),visc,za(i)) + else + !COARE 3.5 + call edson_etal_2013(znt(i),ust(i),wspd(i),visc,za(i)) + endif + elseif ( isftcflx .eq. 1 .or. isftcflx .eq. 2 ) then + call davis_etal_2008(znt(i),ust(i)) + elseif ( isftcflx .eq. 3 ) then + call taylor_yelland_2001(znt(i),ust(i),wspd(i)) + elseif ( isftcflx .eq. 4 ) then + if (coare_opt .eq. 3.0) then + !COARE 3.0 (MISLEADING SUBROUTINE NAME) + call charnock_1955(znt(i),ust(i),wspd(i),visc,za(i)) + else + !COARE 3.5 + call edson_etal_2013(znt(i),ust(i),wspd(i),visc,za(i)) + endif + endif + else + !default to COARE 3.0/3.5 + if (coare_opt .eq. 3.0) then + !COARE 3.0 + call charnock_1955(znt(i),ust(i),wspd(i),visc,za(i)) + else + !COARE 3.5 + call edson_etal_2013(znt(i),ust(i),wspd(i),visc,za(i)) + endif + endif + + !add stochastic perturbaction of ZNT + if (spp_pbl) then + zntstoch(i) = max(znt(i) + znt(i)*1.0*rstoch1d(i), 1e-6) + else + zntstoch(i) = znt(i) + endif + + !compute roughness reynolds number (restar) using new znt + ! AHW: Garrattt formula: Calculate roughness Reynolds number + ! Kinematic viscosity of air (linear approx to + ! temp dependence at sea level) + restar=max(ust(i)*zntstoch(i)/visc, 0.1) + + !-------------------------------------- + !calculate z_t and z_q + !-------------------------------------- + if ( present(isftcflx) ) then + if ( isftcflx .eq. 0 ) then + if (coare_opt .eq. 3.0) then + call fairall_etal_2003(z_t(i),z_q(i),restar,ust(i),visc,rstoch1d(i),spp_pbl) + else + !presumably, this will be published soon, but hasn't yet + call fairall_etal_2014(z_t(i),z_q(i),restar,ust(i),visc,rstoch1d(i),spp_pbl) + endif + elseif ( isftcflx .eq. 1 ) then + if (coare_opt .eq. 3.0) then + call fairall_etal_2003(z_t(i),z_q(i),restar,ust(i),visc,rstoch1d(i),spp_pbl) + else + call fairall_etal_2014(z_t(i),z_q(i),restar,ust(i),visc,rstoch1d(i),spp_pbl) + endif + elseif ( isftcflx .eq. 2 ) then + call garratt_1992(z_t(i),z_q(i),zntstoch(i),restar,xland(i)) + elseif ( isftcflx .eq. 3 ) then + if (coare_opt .eq. 3.0) then + call fairall_etal_2003(z_t(i),z_q(i),restar,ust(i),visc,rstoch1d(i),spp_pbl) + else + call fairall_etal_2014(z_t(i),z_q(i),restar,ust(i),visc,rstoch1d(i),spp_pbl) + endif + endif + else + !default to COARE 3.0/3.5 + if (coare_opt .eq. 3.0) then + call fairall_etal_2003(z_t(i),z_q(i),restar,ust(i),visc,rstoch1d(i),spp_pbl) + else + call fairall_etal_2014(z_t(i),z_q(i),restar,ust(i),visc,rstoch1d(i),spp_pbl) + endif + endif + + else + + !add stochastic perturbaction of znt + if (spp_pbl) then + zntstoch(i) = max(znt(i) + znt(i)*1.0*rstoch1d(i), 1e-6) + else + zntstoch(i) = znt(i) + endif + + !-------------------------------------- + ! land + !-------------------------------------- + !compute roughness reynolds number (restar) using default znt + restar=max(ust(i)*zntstoch(i)/visc, 0.1) + + !-------------------------------------- + ! get z_t and z_q + !-------------------------------------- + !check for snow/ice points over land + if ( snowh(i) .ge. 0.1) then + call andreas_2002(zntstoch(i),visc,ust(i),z_t(i),z_q(i)) + else + if ( present(iz0tlnd) ) then + if ( iz0tlnd .le. 1 ) then + call zilitinkevich_1995(zntstoch(i),z_t(i),z_q(i),restar,& + ust(i),karman,xland(i),iz0tlnd,spp_pbl,rstoch1d(i)) + elseif ( iz0tlnd .eq. 2 ) then + call yang_2008(zntstoch(i),z_t(i),z_q(i),ust(i),mol(i),& + qstar(i),restar,visc,xland(i)) + elseif ( iz0tlnd .eq. 3 ) then + !original mynn in wrf-arw used this form: + call garratt_1992(z_t(i),z_q(i),zntstoch(i),restar,xland(i)) + endif + else + !default to zilitinkevich + call zilitinkevich_1995(zntstoch(i),z_t(i),z_q(i),restar,& + ust(i),karman,xland(i),0,spp_pbl,rstoch1d(i)) + endif + endif + + endif + zratio(i)=zntstoch(i)/z_t(i) !needed for Li et al. + + gz1oz0(i)= log((za(i)+zntstoch(i))/zntstoch(i)) + gz1ozt(i)= log((za(i)+zntstoch(i))/z_t(i)) + gz2oz0(i)= log((2.0+zntstoch(i))/zntstoch(i)) + gz2ozt(i)= log((2.0+zntstoch(i))/z_t(i)) + gz10oz0(i)=log((10.+zntstoch(i))/zntstoch(i)) + gz10ozt(i)=log((10.+zntstoch(i))/z_t(i)) + + !-------------------------------------------------------------------- + !--- DIAGNOSE BASIC PARAMETERS FOR THE APPROPRIATE STABILITY CLASS: + ! + ! THE STABILITY CLASSES ARE DETERMINED BY BR (BULK RICHARDSON NO.). + ! + ! CRITERIA FOR THE CLASSES ARE AS FOLLOWS: + ! + ! 1. BR .GE. 0.2; + ! REPRESENTS NIGHTTIME STABLE CONDITIONS (REGIME=1), + ! + ! 2. BR .LT. 0.2 .AND. BR .GT. 0.0; + ! REPRESENTS DAMPED MECHANICAL TURBULENT CONDITIONS + ! (REGIME=2), + ! + ! 3. BR .EQ. 0.0 + ! REPRESENTS FORCED CONVECTION CONDITIONS (REGIME=3), + ! + ! 4. BR .LT. 0.0 + ! REPRESENTS FREE CONVECTION CONDITIONS (REGIME=4). + ! + !-------------------------------------------------------------------- + if (br(i) .gt. 0.0) then + if (br(i) .gt. 0.2) then + !---class 1; stable (nighttime) conditions: + regime(i)=1. + else + !---class 2; damped mechanical turbulence: + regime(i)=2. + endif + + !compute z/l first guess: + if (itimestep .le. 1) then + call li_etal_2010(zol(i),br(i),za(i)/zntstoch(i),zratio(i)) + else + zol(i)=za(i)*karman*g*mol(i)/(th1d(i)*max(ust(i)*ust(i),0.0001)) + zol(i)=max(zol(i),0.0) + zol(i)=min(zol(i),20.) + endif + + !Use Pedros iterative function to find z/L + !zol(i)=zolri(br(i),za(i),zntstoch(i),z_t(i),zol(i),psi_opt) + !Use brute-force method + zol(i)=zolrib(br(i),za(i),zntstoch(i),z_t(i),gz1oz0(i),gz1ozt(i),zol(i),psi_opt) + zol(i)=max(zol(i),0.0) + zol(i)=min(zol(i),20.) + + zolzt = zol(i)*z_t(i)/za(i) ! zt/l + zolz0 = zol(i)*zntstoch(i)/za(i) ! z0/l + zolza = zol(i)*(za(i)+zntstoch(i))/za(i) ! (z+z0/l + zol10 = zol(i)*(10.+zntstoch(i))/za(i) ! (10+z0)/l + zol2 = zol(i)*(2.+zntstoch(i))/za(i) ! (2+z0)/l + + !compute psim and psih + if ((xland(i)-1.5).ge.0) then + ! water + !call psi_suselj_sood_2010(psim(i),psih(i),zol(i)) + !call psi_beljaars_holtslag_1991(psim(i),psih(i),zol(i)) + !call psi_businger_1971(psim(i),psih(i),zol(i)) + !call psi_dyerhicks(psim(i),psih(i),zol(i),z_t(i),zntstoch(i),za(i)) + !call psi_cb2005(psim(i),psih(i),zolza,zolz0) + ! or use tables + psim(i)=psim_stable(zolza,psi_opt)-psim_stable(zolz0,psi_opt) + psih(i)=psih_stable(zolza,psi_opt)-psih_stable(zolzt,psi_opt) + psim10(i)=psim_stable(zol10,psi_opt)-psim_stable(zolz0,psi_opt) + psih10(i)=psih_stable(zol10,psi_opt)-psih_stable(zolz0,psi_opt) + psih2(i)=psih_stable(zol2,psi_opt)-psih_stable(zolz0,psi_opt) + else + ! land + !call psi_beljaars_holtslag_1991(psim(i),psih(i),zol(i)) + !call psi_businger_1971(psim(i),psih(i),zol(i)) + !call psi_zilitinkevich_esau_2007(psim(i),psih(i),zol(i)) + !call psi_dyerhicks(psim(i),psih(i),zol(i),z_t(i),zntstoch(i),za(i)) + !call psi_cb2005(psim(i),psih(i),zolza,zolz0) + ! or use tables + psim(i)=psim_stable(zolza,psi_opt)-psim_stable(zolz0,psi_opt) + psih(i)=psih_stable(zolza,psi_opt)-psih_stable(zolzt,psi_opt) + psim10(i)=psim_stable(zol10,psi_opt)-psim_stable(zolz0,psi_opt) + psih10(i)=psih_stable(zol10,psi_opt)-psih_stable(zolz0,psi_opt) + psih2(i)=psih_stable(zol2,psi_opt)-psih_stable(zolz0,psi_opt) + endif + + !psim10(i)=10./za(i)*psim(i) + !psih10(i)=10./za(i)*psih(i) + !psim2(i)=2./za(i)*psim(i) + !psih2(i)=2./za(i)*psih(i) + + ! 1.0 over monin-obukhov length + rmol(i)= zol(i)/za(i) + + elseif(br(i) .eq. 0.) then + !========================================================= + !-----class 3; forced convection/neutral: + !========================================================= + regime(i)=3. + + psim(i)=0.0 + psih(i)=psim(i) + psim10(i)=0. + psih10(i)=0. + psih2(i)=0. + + zol(i)=0. + !if (ust(i) .lt. 0.01) then + ! zol(i)=br(i)*gz1oz0(i) + !else + ! zol(i)=karman*govrth(i)*za(i)*mol(i)/(max(ust(i)*ust(i),0.001)) + !endif + rmol(i) = zol(i)/za(i) + + elseif(br(i) .lt. 0.)then + !========================================================== + !-----class 4; free convection: + !========================================================== + regime(i)=4. + + !compute z/l first guess: + if (itimestep .le. 1) then + call li_etal_2010(zol(i),br(i),za(i)/zntstoch(i),zratio(i)) + else + zol(i)=za(i)*karman*g*mol(i)/(th1d(i)*max(ust(i)*ust(i),0.001)) + zol(i)=max(zol(i),-20.0) + zol(i)=min(zol(i),0.0) + endif + + !Use Pedros iterative function to find z/L + !zol(I)=zolri(br(I),ZA(I),ZNTstoch(I),z_t(I),ZOL(I),psi_opt) + !Use alternative method + zol(i)=zolrib(br(i),za(i),zntstoch(i),z_t(i),gz1oz0(i),gz1ozt(i),zol(i),psi_opt) + zol(i)=max(zol(i),-20.0) + zol(i)=min(zol(i),0.0) + + zolzt = zol(i)*z_t(i)/za(i) ! zt/l + zolz0 = zol(i)*zntstoch(i)/za(i) ! z0/l + zolza = zol(i)*(za(i)+zntstoch(i))/za(i) ! (z+z0/l + zol10 = zol(i)*(10.+zntstoch(i))/za(i) ! (10+z0)/l + zol2 = zol(i)*(2.+zntstoch(i))/za(i) ! (2+z0)/l + + !compute psim and psih + if ((xland(i)-1.5).ge.0) then + ! water + !call psi_suselj_sood_2010(psim(i),psih(i),zol(i)) + !call psi_hogstrom_1996(psim(i),psih(i),zol(i), z_t(i), zntstoch(i), za(i)) + !call psi_businger_1971(psim(i),psih(i),zol(i)) + !call psi_dyerhicks(psim(i),psih(i),zol(i),z_t(i),zntstoch(i),za(i)) + ! use tables + psim(i)=psim_unstable(zolza,psi_opt)-psim_unstable(zolz0,psi_opt) + psih(i)=psih_unstable(zolza,psi_opt)-psih_unstable(zolzt,psi_opt) + psim10(i)=psim_unstable(zol10,psi_opt)-psim_unstable(zolz0,psi_opt) + psih10(i)=psih_unstable(zol10,psi_opt)-psih_unstable(zolz0,psi_opt) + psih2(i)=psih_unstable(zol2,psi_opt)-psih_unstable(zolz0,psi_opt) + else + ! land + !call psi_hogstrom_1996(psim(i),psih(i),zol(i), z_t(i), zntstoch(i), za(i)) + !call psi_businger_1971(psim(i),psih(i),zol(i)) + !call psi_dyerhicks(psim(i),psih(i),zol(i),z_t(i),zntstoch(i),za(i)) + ! use tables + psim(i)=psim_unstable(zolza,psi_opt)-psim_unstable(zolz0,psi_opt) + psih(i)=psih_unstable(zolza,psi_opt)-psih_unstable(zolzt,psi_opt) + psim10(i)=psim_unstable(zol10,psi_opt)-psim_unstable(zolz0,psi_opt) + psih10(i)=psih_unstable(zol10,psi_opt)-psih_unstable(zolz0,psi_opt) + psih2(i)=psih_unstable(zol2,psi_opt)-psih_unstable(zolz0,psi_opt) + endif + + !psim10(i)=10./za(i)*psim(i) + !psih2(i)=2./za(i)*psih(i) + + !---limit psih and psim in the case of thin layers and + !---high roughness. this prevents denominator in fluxes + !---from getting too small + psih(i)=min(psih(i),0.9*gz1ozt(i)) + psim(i)=min(psim(i),0.9*gz1oz0(i)) + psih2(i)=min(psih2(i),0.9*gz2ozt(i)) + psim10(i)=min(psim10(i),0.9*gz10oz0(i)) + psih10(i)=min(psih10(i),0.9*gz10ozt(i)) + + rmol(i) = zol(i)/za(i) + + endif + + !------------------------------------------------------------ + !-----compute the frictional velocity: + !------------------------------------------------------------ + ! Za(1982) Eqs(2.60),(2.61). + psix=gz1oz0(i)-psim(i) + psix10=gz10oz0(i)-psim10(i) + ! to prevent oscillations average with old value + oldust = ust(i) + ust(i)=0.5*ust(i)+0.5*karman*wspd(i)/psix + !non-averaged: ust(i)=karman*wspd(i)/psix + + ! compute u* without vconv for use in hfx calc when isftcflx > 0 + wspdi(i)=max(sqrt(u1d(i)*u1d(i)+v1d(i)*v1d(i)), wmin) + if ( present(ustm) ) then + ustm(i)=0.5*ustm(i)+0.5*karman*wspdi(i)/psix + endif + + if ((xland(i)-1.5).lt.0.) then !land + ust(i)=max(ust(i),0.005) !further relaxing this limit - no need to go lower + !keep ustm = ust over land. + if ( present(ustm) ) ustm(i)=ust(i) + endif + + !------------------------------------------------------------ + !-----compute the thermal and moisture resistance (psiq and psit): + !------------------------------------------------------------ + ! lower limit added to prevent large flhc in soil model + ! activates in unstable conditions with thin layers or high z0 + gz1ozt(i)= log((za(i)+zntstoch(i))/z_t(i)) + gz2ozt(i)= log((2.0+zntstoch(i))/z_t(i)) + + psit =max(gz1ozt(i)-psih(i) ,1.) + psit2=max(gz2ozt(i)-psih2(i),1.) + + psiq=max(log((za(i)+zntstoch(i))/z_q(i))-psih(i) ,1.0) + psiq2=max(log((2.0+zntstoch(i))/z_q(i))-psih2(i) ,1.0) + psiq10=max(log((10.0+zntstoch(i))/z_q(i))-psih10(i) ,1.0) + !---------------------------------------------------- + !compute the temperature scale (or friction temperature, T*) + !---------------------------------------------------- + dtg=thv1d(i)-thvgb(i) + oldtst=mol(i) + mol(i)=karman*dtg/psit/prt + !t_star(i) = -hfx(i)/(ust(i)*cpm(i)*rho1d(i)) + !t_star(i) = mol(i) + !---------------------------------------------------- + !compute the moisture scale (or q*) + dqg=(qvsh(i)-qsfc(i))*1000. !(kg/kg -> g/kg) + qstar(i)=karman*dqg/psiq/prt + + !if () then + ! write(*,1001)"regime:",regime(i)," z/l:",zol(i)," u*:",ust(i)," tstar:",mol(i) + ! write(*,1002)"psim:",psim(i)," psih:",psih(i)," w*:",wstar(i)," dthv:",thv1d(i)-thvgb(i) + ! write(*,1003)"cpm:",cpm(i)," rho1d:",rho1d(i)," l:",zol(i)/za(i)," dth:",th1d(i)-thgb(i) + ! write(*,1004)"z0/zt:",zratio(i)," z0:",zntstoch(i)," zt:",z_t(i)," za:",za(i) + ! write(*,1005)"re:",restar," mavail:",mavail(i)," qsfc(i):",qsfc(i)," qvsh(i):",qvsh(i) + ! print*,"visc=",visc," z0:",zntstoch(i)," t1d(i):",t1d(i) + ! write(*,*)"=============================================" + !endif + + enddo ! end i-loop + + 1000 format(a,f6.1, a,f6.1, a,f5.1, a,f7.1) + 1001 format(a,f2.0, a,f10.4,a,f5.3, a,f11.5) + 1002 format(a,f7.2, a,f7.2, a,f7.2, a,f10.3) + 1003 format(a,f7.2, a,f7.2, a,f10.3,a,f10.3) + 1004 format(a,f11.3,a,f9.7, a,f9.7, a,f6.2, a,f10.3) + 1005 format(a,f9.2,a,f6.4,a,f7.4,a,f7.4) + + !---------------------------------------------------------- + ! compute surface heat and moisture fluxes + !---------------------------------------------------------- + do i=its,ite + + !For computing the diagnostics and fluxes (below), whether the fluxes + !are turned off or on, we need the following: + psix=gz1oz0(i)-psim(i) + psix10=gz10oz0(i)-psim10(i) + + psit =max(gz1ozt(i)-psih(i), 1.0) + psit2=max(gz2ozt(i)-psih2(i),1.0) + + psiq=max(log((za(i)+z_q(i))/z_q(i))-psih(i) ,1.0) + psiq2=max(log((2.0+z_q(i))/z_q(i))-psih2(i) ,1.0) + psiq10=max(log((10.0+z_q(i))/z_q(i))-psih10(i) ,1.0) + + if (isfflx .lt. 1) then + + qfx(i) = 0. + hfx(i) = 0. + flhc(i) = 0. + flqc(i) = 0. + lh(i) = 0. + chs(i) = 0. + ch(i) = 0. + chs2(i) = 0. + cqs2(i) = 0. + if(present(ck) .and. present(cd) .and. & + &present(cka) .and. present(cda)) then + ck(i) = 0. + cd(i) = 0. + cka(i)= 0. + cda(i)= 0. + endif + else + + !------------------------------------------ + ! calculate the exchange coefficients for heat (flhc) + ! and moisture (flqc) + !------------------------------------------ + flqc(i)=rho1d(i)*mavail(i)*ust(i)*karman/psiq + flhc(i)=rho1d(i)*cpm(i)*ust(i)*karman/psit + + !---------------------------------- + ! compute surface moisture flux: + !---------------------------------- + qfx(i)=flqc(i)*(qsfcmr(i)-qv1d(i)) + !joe: qfx(i)=max(qfx(i),0.) !originally did not allow neg qfx + qfx(i)=max(qfx(i),-0.02) !allows small neg qfx, like myj + lh(i)=xlv*qfx(i) + + !---------------------------------- + ! compute surface heat flux: + !---------------------------------- + if(xland(i)-1.5.gt.0.)then !water + hfx(i)=flhc(i)*(thgb(i)-th1d(i)) + if ( present(isftcflx) ) then + if ( isftcflx.ne.0 ) then + ! ahw: add dissipative heating term + hfx(i)=hfx(i)+rho1d(i)*ustm(i)*ustm(i)*wspdi(i) + endif + endif + elseif(xland(i)-1.5.lt.0.)then !land + hfx(i)=flhc(i)*(thgb(i)-th1d(i)) + hfx(i)=max(hfx(i),-250.) + endif + + !chs(i)=ust(i)*karman/(alog(karman*ust(i)*za(i) & + ! /xka+za(i)/zl)-psih(i)) + + chs(i)=ust(i)*karman/psit + + ! the exchange coefficient for cloud water is assumed to be the + ! same as that for heat. ch is multiplied by wspd. + + !ch(i)=chs(i) + ch(i)=flhc(i)/( cpm(i)*rho1d(i) ) + + !these are used for 2-m diagnostics only + cqs2(i)=ust(i)*karman/psiq2 + chs2(i)=ust(i)*karman/psit2 + + if(present(ck) .and. present(cd) .and. & + &present(cka) .and. present(cda)) then + ck(i)=(karman/psix10)*(karman/psiq10) + cd(i)=(karman/psix10)*(karman/psix10) + cka(i)=(karman/psix)*(karman/psiq) + cda(i)=(karman/psix)*(karman/psix) + endif + + endif !end isfflx option + + !----------------------------------------------------- + !compute diagnostics + !----------------------------------------------------- + !compute 10 m wnds + !----------------------------------------------------- + ! If the lowest model level is close to 10-m, use it + ! instead of the flux-based diagnostic formula. + if (za(i) .le. 7.0) then + ! high vertical resolution + if(za2(i) .gt. 7.0 .and. za2(i) .lt. 13.0) then + !use 2nd model level + u10(i)=u1d2(i) + v10(i)=v1d2(i) + else + u10(i)=u1d(i)*log(10./zntstoch(i))/log(za(i)/zntstoch(i)) + v10(i)=v1d(i)*log(10./zntstoch(i))/log(za(i)/zntstoch(i)) + endif + elseif(za(i) .gt. 7.0 .and. za(i) .lt. 13.0) then + !moderate vertical resolution + !u10(i)=u1d(i)*psix10/psix + !v10(i)=v1d(i)*psix10/psix + !use neutral-log: + u10(i)=u1d(i)*log(10./zntstoch(i))/log(za(i)/zntstoch(i)) + v10(i)=v1d(i)*log(10./zntstoch(i))/log(za(i)/zntstoch(i)) + else + ! very coarse vertical resolution + u10(i)=u1d(i)*psix10/psix + v10(i)=v1d(i)*psix10/psix + endif + + !----------------------------------------------------- + !compute 2m t, th, and q + !these will be overwritten for land points in the lsm + !----------------------------------------------------- + dtg=th1d(i)-thgb(i) + th2(i)=thgb(i)+dtg*psit2/psit + !*** be certain that the 2-m theta is bracketed by + !*** the values at the surface and lowest model level. + if ((th1d(i)>thgb(i) .and. (th2(i)th1d(i))) .or. & + (th1d(i)thgb(i) .or. th2(i) 1200. .or. hfx(i) < -700.)then + print*,"suspicious values in mynn sfclayer",& + i, "hfx: ",hfx(i) + yesno = 1 + endif + if (lh(i) > 1200. .or. lh(i) < -700.)then + print*,"suspicious values in mynn sfclayer",& + i, "lh: ",lh(i) + yesno = 1 + endif + if (ust(i) < 0.0 .or. ust(i) > 4.0 )then + print*,"suspicious values in mynn sfclayer",& + i, "ust: ",ust(i) + yesno = 1 + endif + if (wstar(i)<0.0 .or. wstar(i) > 6.0)then + print*,"suspicious values in mynn sfclayer",& + i, "wstar: ",wstar(i) + yesno = 1 + endif + if (rho1d(i)<0.0 .or. rho1d(i) > 1.6 )then + print*,"suspicious values in mynn sfclayer",& + i, "rho: ",rho1d(i) + yesno = 1 + endif + if (qsfc(i)*1000. <0.0 .or. qsfc(i)*1000. >40.)then + print*,"suspicious values in mynn sfclayer",& + i, "qsfc: ",qsfc(i) + yesno = 1 + endif + if (pblh(i)<0. .or. pblh(i)>6000.)then + print*,"suspicious values in mynn sfclayer",& + i, "pblh: ",pblh(i) + yesno = 1 + endif + + if (yesno == 1) then + print*," other info:" + write(*,1001)"regime:",regime(i)," z/l:",zol(i)," u*:",ust(i),& + " tstar:",mol(i) + write(*,1002)"psim:",psim(i)," psih:",psih(i)," w*:",wstar(i),& + " dthv:",thv1d(i)-thvgb(i) + write(*,1003)"cpm:",cpm(i)," rho1d:",rho1d(i)," l:",& + zol(i)/za(i)," dth:",th1d(i)-thgb(i) + write(*,*)" z0:",zntstoch(i)," zt:",z_t(i)," za:",za(i) + write(*,1005)"re:",restar," mavail:",mavail(i)," qsfc(i):",& + qsfc(i)," qvsh(i):",qvsh(i) + print*,"psix=",psix," z0:",zntstoch(i)," t1d(i):",t1d(i) + write(*,*)"=============================================" + endif + endif + + enddo !end i-loop + + errmsg = ' ' + errflg = 0 + + end subroutine sf_mynn_run + +!================================================================================================================= + subroutine zilitinkevich_1995(z_0,zt,zq,restar,ustar,karman,landsea,iz0tlnd2,spp_pbl,rstoch) +!this subroutine returns the thermal and moisture roughness lengths +!from Zilitinkevich (1995) and Zilitinkevich et al. (2001) over +!land and water, respectively. +! +!MODS: +!20120705 : added IZ0TLND option. Note: This option was designed +! to work with the Noah LSM and may be specific for that +! LSM only. Tests with RUC LSM showed no improvements. + implicit none +!================================================================================================================= + +!--- input arguments: + logical,intent(in):: spp_pbl + integer,optional,intent(in):: iz0tlnd2 + + real(kind=kind_phys),intent(in):: rstoch + real(kind=kind_phys),intent(in):: z_0,restar,ustar,karman,landsea + +!--- output arguments: + real(kind=kind_phys),intent(out):: zt,zq + +!--- local variables: + real(kind=kind_phys):: czil !=0.100 in Chen et al. (1997) + !=0.075 in Zilitinkevich (1995) + !=0.500 in Lemone et al. (2008) + +!----------------------------------------------------------------------------------------------------------------- + + if (landsea-1.5 .gt. 0) then !water + +!this is based on Zilitinkevich, Grachev, and Fairall (2001): +!their equations 15 and 16). + if (restar .lt. 0.1) then + zt = z_0*exp(karman*2.0) + zt = min( zt, 6.0e-5) + zt = max( zt, 2.0e-9) + zq = z_0*exp(karman*3.0) + zq = min( zq, 6.0e-5) + zq = max( zq, 2.0e-9) + else + zt = z_0*exp(-karman*(4.0*sqrt(restar)-3.2)) + zt = min( zt, 6.0e-5) + zt = max( zt, 2.0e-9) + zq = z_0*exp(-karman*(4.0*sqrt(restar)-4.2)) + zq = min( zt, 6.0e-5) + zq = max( zt, 2.0e-9) + endif + + else !land + +!option to modify czil according to Chen & Zhang (2009): + if ( iz0tlnd2 .eq. 1 ) then + czil = 10.0 ** ( -0.40 * ( z_0 / 0.07 ) ) + else + czil = 0.085 !0.075 !0.10 + end if + + zt = z_0*exp(-karman*czil*sqrt(restar)) + zt = min( zt, 0.75*z_0) + + zq = z_0*exp(-karman*czil*sqrt(restar)) + zq = min( zq, 0.75*z_0) + +!stochastically perturb thermal and moisture roughness length. +!currently set to half the amplitude: + if (spp_pbl) then + zt = zt + zt * 0.5 * rstoch + zt = max(zt, 0.0001) + zq = zt + endif + + endif + + end subroutine zilitinkevich_1995 + +!================================================================================================================= + subroutine davis_etal_2008(Z_0,ustar) +!a.k.a. : Donelan et al. (2004) +!this formulation for roughness length was designed to match +!the labratory experiments of Donelan et al. (2004). +!this is an update version from Davis et al. 2008, which +!corrects a small-bias in Z_0 (AHW real-time 2012). + implicit none +!================================================================================================================= + +!--- input arguments: + real(kind=kind_phys),intent(in):: ustar + +!--- output arguments: + real(kind=kind_phys),intent(out):: z_0 + +!--- local variables: + real(kind=kind_phys):: zw, zn1, zn2 + real(kind=kind_phys),parameter:: g=9.81,ozo=1.59e-5 + +!----------------------------------------------------------------------------------------------------------------- + +!old form: z_0 = 10.*exp(-10./(ustar**(1./3.))) +!new form: + + zw = min((ustar/1.06)**(0.3),1.0) + zn1 = 0.011*ustar*ustar/g + ozo + zn2 = 10.*exp(-9.5*ustar**(-.3333)) + & + 0.11*1.5e-5/amax1(ustar,0.01) + z_0 = (1.0-zw) * zn1 + zw * zn2 + + z_0 = max( z_0, 1.27e-7) !these max/mins were suggested by + z_0 = min( z_0, 2.85e-3) !Davis et al. (2008) + + end subroutine davis_etal_2008 + +!================================================================================================================= + subroutine taylor_yelland_2001(z_0,ustar,wsp10) +!this formulation for roughness length was designed account for +!wave steepness. + implicit none +!================================================================================================================= + +!--- input arguments: + real(kind=kind_phys),intent(in):: ustar,wsp10 + +!--- output arguments: + real(kind=kind_phys),intent(out):: z_0 + +!--- local variables: + real(kind=kind_phys),parameter:: g=9.81, pi=3.14159265 + real(kind=kind_phys):: hs, tp, lp + +!----------------------------------------------------------------------------------------------------------------- + +!hs is the significant wave height + hs = 0.0248*(wsp10**2.) +!Tp dominant wave period + tp = 0.729*max(wsp10,0.1) +!lp is the wavelength of the dominant wave + lp = g*tp**2/(2*pi) + + z_0 = 1200.*hs*(hs/lp)**4.5 + z_0 = max( z_0, 1.27e-7) !these max/mins were suggested by + z_0 = min( z_0, 2.85e-3) !Davis et al. (2008) + + end subroutine taylor_yelland_2001 + +!================================================================================================================= + subroutine charnock_1955(Z_0,ustar,wsp10,visc,zu) +!This version of Charnock's relation employs a varying +!Charnock parameter, similar to COARE3.0 [Fairall et al. (2003)]. +!The Charnock parameter CZC is varied from .011 to .018 +!between 10-m wsp = 10 and 18. + implicit none +!================================================================================================================= + +!--- input arguments: + real(kind=kind_phys),intent(in):: ustar,visc,wsp10,zu + +!--- output arguments: + real(kind=kind_phys),intent(out):: z_0 + +!--- local variables: + real(kind=kind_phys),parameter:: G=9.81, CZO2=0.011 + real(kind=kind_phys):: czc !variable charnock "constant" + real(kind=kind_phys):: wsp10m ! logarithmically calculated 10 m + +!----------------------------------------------------------------------------------------------------------------- + + wsp10m = wsp10*log(10./1e-4)/log(zu/1e-4) + czc = czo2 + 0.007*min(max((wsp10m-10.)/8., 0.), 1.0) + + z_0 = czc*ustar*ustar/g + (0.11*visc/max(ustar,0.05)) + z_0 = max( z_0, 1.27e-7) !these max/mins were suggested by + z_0 = min( z_0, 2.85e-3) !Davis et al. (2008) + + end subroutine charnock_1955 + +!================================================================================================================= + subroutine edson_etal_2013(z_0,ustar,wsp10,visc,zu) +!This version of Charnock's relation employs a varying +!Charnock parameter, taken from COARE 3.5 [Edson et al. (2001, JPO)]. +!The Charnock parameter CZC is varied from about .005 to .028 +!between 10-m wind speeds of 6 and 19 m/s. +!11 Nov 2021: Note that this was finally fixed according to the +! Edson et al (2014) corrigendum, where "m" was corrected. + implicit none +!================================================================================================================= + +!--- input arguments: + real(kind=kind_phys),intent(in):: ustar,visc,wsp10,zu + +!--- output arguments: + real(kind=kind_phys),intent(out):: z_0 + +!--- local variables: + real(kind=kind_phys),parameter:: g=9.81 + real(kind=kind_phys),parameter:: m=0.0017, b=-0.005 + real(kind=kind_phys):: czc ! variable charnock "constant" + real(kind=kind_phys):: wsp10m ! logarithmically calculated 10 m + +!----------------------------------------------------------------------------------------------------------------- + + wsp10m = wsp10*log(10/1e-4)/log(zu/1e-4) + wsp10m = min(19.,wsp10m) + czc = m*wsp10m + b + czc = max(czc, 0.0) + + z_0 = czc*ustar*ustar/g + (0.11*visc/max(ustar,0.07)) + z_0 = max( z_0, 1.27e-7) !These max/mins were suggested by + z_0 = min( z_0, 2.85e-3) !Davis et al. (2008) + + end subroutine edson_etal_2013 + +!================================================================================================================= + subroutine garratt_1992(zt,zq,z_0,ren,landsea) +!This formulation for the thermal and moisture roughness lengths +!(Zt and Zq) relates them to Z0 via the roughness Reynolds number (Ren). +!This formula comes from Fairall et al. (2003). It is modified from +!the original Garratt-Brutsaert model to better fit the COARE/HEXMAX +!data. The formula for land uses a constant ratio (Z_0/7.4) taken +!from Garratt (1992). + implicit none +!================================================================================================================= + +!--- input arguments: + real(kind=kind_phys),intent(in):: ren, z_0,landsea + +!--- output arguments: + real(kind=kind_phys),intent(out):: zt,zq + +!--- local variables: + real(kind=kind_phys):: rq + real(kind=kind_phys),parameter:: e=2.71828183 + +!----------------------------------------------------------------------------------------------------------------- + + if (landsea-1.5 .gt. 0) then !water + + zt = z_0*exp(2.0 - (2.48*(ren**0.25))) + zq = z_0*exp(2.0 - (2.28*(ren**0.25))) + + zq = min( zq, 5.5e-5) + zq = max( zq, 2.0e-9) + zt = min( zt, 5.5e-5) + zt = max( zt, 2.0e-9) !same lower limit as ecmwf + + else !land + + zq = z_0/(e**2.) !taken from Garratt (1980,1992) + zt = zq + + endif + + end subroutine garratt_1992 + +!================================================================================================================= + subroutine fairall_etal_2003(zt,zq,ren,ustar,visc,rstoch,spp_pbl) +!This formulation for thermal and moisture roughness length (Zt and Zq) +!as a function of the roughness Reynolds number (Ren) comes from the +!COARE3.0 formulation, empirically derived from COARE and HEXMAX data +![Fairall et al. (2003)]. Edson et al. (2004; JGR) suspected that this +!relationship overestimated the scalar roughness lengths for low Reynolds +!number flows, so an optional smooth flow relationship, taken from Garratt +!(1992, p. 102), is available for flows with Ren < 2. +! +!This is for use over water only. + implicit none +!================================================================================================================= + +!--- input arguments: + logical,intent(in):: spp_pbl + real(kind=kind_phys),intent(in):: ren,ustar,visc,rstoch + +!--- output arguments: + real(kind=kind_phys),intent(out):: zt,zq + +!----------------------------------------------------------------------------------------------------------------- + + if (ren .le. 2.) then + + zt = (5.5e-5)*(ren**(-0.60)) + zq = zt + !for smooth seas, can use Garratt + !zq = 0.2*visc/max(ustar,0.1) + !zq = 0.3*visc/max(ustar,0.1) + + else + + !for rough seas, use coare + zt = (5.5e-5)*(ren**(-0.60)) + zq = zt + + endif + + if (spp_pbl) then + zt = zt + zt * 0.5 * rstoch + zq = zt + endif + + zt = min(zt,1.0e-4) + zt = max(zt,2.0e-9) + + zq = min(zt,1.0e-4) + zq = max(zt,2.0e-9) + + end subroutine fairall_etal_2003 + +!================================================================================================================= + subroutine fairall_etal_2014(zt,zq,ren,ustar,visc,rstoch,spp_pbl) +!This formulation for thermal and moisture roughness length (Zt and Zq) +!as a function of the roughness Reynolds number (Ren) comes from the +!COARE 3.5/4.0 formulation, empirically derived from COARE and HEXMAX data +![Fairall et al. (2014? coming soon, not yet published as of July 2014)]. +!This is for use over water only. + implicit none +!================================================================================================================= + +!--- input arguments: + logical,intent(in):: spp_pbl + real(kind=kind_phys),intent(in):: ren,ustar,visc,rstoch + +!--- output arguments: + real(kind=kind_phys),intent(out):: Zt,Zq + +!----------------------------------------------------------------------------------------------------------------- + +!zt = (5.5e-5)*(ren**(-0.60)) + zt = min(1.6e-4, 5.8e-5/(ren**0.72)) + zq = zt + + if (spp_pbl) then + zt = max(zt + zt*0.5*rstoch,2.0e-9) + zq = max(zt + zt*0.5*rstoch,2.0e-9) + else + zt = max(zt,2.0e-9) + zq = max(zt,2.0e-9) + endif + + + end subroutine fairall_etal_2014 + +!================================================================================================================= + subroutine yang_2008(z_0,zt,zq,ustar,tstar,qst,ren,visc,landsea) +!This is a modified version of Yang et al (2002 QJRMS, 2008 JAMC) +!and Chen et al (2010, J of Hydromet). Although it was originally +!designed for arid regions with bare soil, it is modified +!here to perform over a broader spectrum of vegetation. +! +!The original formulation relates the thermal roughness length (Zt) +!to u* and T*: +! +! Zt = ht * EXP(-beta*(ustar**0.5)*(ABS(tstar)**0.25)) +! +!where ht = Renc*visc/ustar and the critical Reynolds number +!(Renc) = 70. Beta was originally = 10 (2002 paper) but was revised +!to 7.2 (in 2008 paper). Their form typically varies the +!ratio Z0/Zt by a few orders of magnitude (1-1E4). +! +!This modified form uses beta = 1.5 and a variable Renc (function of Z_0), +!so zt generally varies similarly to the Zilitinkevich form (with Czil ~ 0.1) +!for very small or negative surface heat fluxes but can become close to the +!Zilitinkevich with Czil = 0.2 for very large HFX (large negative T*). +!Also, the exponent (0.25) on tstar was changed to 1.0, since we found +!Zt was reduced too much for low-moderate positive heat fluxes. +! +!This should only be used over land! + implicit none +!================================================================================================================= + +!--- input arguments: + real(kind=kind_phys),intent(in):: z_0,ren,ustar,tstar,qst,visc,landsea + +!--- output arguments: + real(kind=kind_phys),intent(out):: zt,zq + +!--- local variables: + real(kind=kind_phys):: ht, &! roughness height at critical Reynolds number + tstar2, &! bounded T*, forced to be non-positive + qstar2, &! bounded q*, forced to be non-positive + z_02, &! bounded Z_0 for variable Renc2 calc + renc2 ! variable Renc, function of Z_0 + + real(kind=kind_phys),parameter:: renc=300., & !old constant Renc + beta=1.5, & !important for diurnal variation + m=170., & !slope for Renc2 function + b=691. !y-intercept for Renc2 function + +!----------------------------------------------------------------------------------------------------------------- + + z_02 = min(z_0,0.5) + z_02 = max(z_02,0.04) + renc2= b + m*log(z_02) + ht = renc2*visc/max(ustar,0.01) + tstar2 = min(tstar, 0.0) + qstar2 = min(qst,0.0) + + zt = ht * exp(-beta*(ustar**0.5)*(abs(tstar2)**1.0)) + zq = ht * exp(-beta*(ustar**0.5)*(abs(qstar2)**1.0)) +!zq = zt + + zt = min(zt, z_0/2.0) + zq = min(zq, z_0/2.0) + + end subroutine yang_2008 + +!================================================================================================================= + subroutine andreas_2002(z_0,bvisc,ustar,zt,zq) +! This is taken from Andreas (2002; J. of Hydromet) and +! Andreas et al. (2005; BLM). +! +! This should only be used over snow/ice! + implicit none +!================================================================================================================= + +!--- input arguments: + real(kind=kind_phys),intent(in):: z_0,bvisc,ustar + +!--- output arguments: + real(kind=kind_phys),intent(out):: zt, zq + +!--- local variables: + real(kind=kind_phys):: ren2,zntsno + + real(kind=kind_phys),parameter:: bt0_s=1.25, bt0_t=0.149, bt0_r=0.317, & + bt1_s=0.0, bt1_t=-0.55, bt1_r=-0.565, & + bt2_s=0.0, bt2_t=0.0, bt2_r=-0.183 + + real(kind=kind_phys),parameter:: bq0_s=1.61, bq0_t=0.351, bq0_r=0.396, & + bq1_s=0.0, bq1_t=-0.628, bq1_r=-0.512, & + bq2_s=0.0, bq2_t=0.0, bq2_r=-0.180 + +!----------------------------------------------------------------------------------------------------------------- + +!calculate zo for snow (Andreas et al. 2005, BLM): + zntsno = 0.135*bvisc/ustar + & + (0.035*(ustar*ustar)/9.8) * & + (5.*exp(-1.*(((ustar - 0.18)/0.1)*((ustar - 0.18)/0.1))) + 1.) + ren2 = ustar*zntsno/bvisc + +!Make sure that Re is not outside of the range of validity +!for using their equations + if (ren2 .gt. 1000.) ren2 = 1000. + + if (ren2 .le. 0.135) then + + zt = zntsno*exp(bt0_s + bt1_s*log(ren2) + bt2_s*log(ren2)**2) + zq = zntsno*exp(bq0_s + bq1_s*log(ren2) + bq2_s*log(ren2)**2) + + else if (ren2 .gt. 0.135 .and. ren2 .lt. 2.5) then + + zt = zntsno*exp(bt0_t + bt1_t*log(ren2) + bt2_t*log(ren2)**2) + zq = zntsno*exp(bq0_t + bq1_t*log(ren2) + bq2_t*log(ren2)**2) + + else + + zt = zntsno*exp(bt0_r + bt1_r*log(ren2) + bt2_r*log(ren2)**2) + zq = zntsno*exp(bq0_r + bq1_r*log(ren2) + bq2_r*log(ren2)**2) + + endif + + end subroutine andreas_2002 + +!================================================================================================================= + subroutine psi_hogstrom_1996(psi_m,psi_h,zl,zt,z_0,za) +!this subroutine returns the stability functions based off +!of hogstrom (1996). + implicit none +!================================================================================================================= + +!--- input arguments: + real(kind=kind_phys),intent(in):: zl,zt,z_0,za + +!--- output arguments: + real(kind=kind_phys),intent(out):: psi_m,psi_h + +!--- local variables: + real(kind=kind_phys):: x,x0,y,y0,zml,zhl + +!----------------------------------------------------------------------------------------------------------------- + + zml = z_0*zl/za + zhl = zt*zl/za + + if (zl .gt. 0.) then !stable (not well tested - seem large) + + psi_m = -5.3*(zl - zml) + psi_h = -8.0*(zl - zhl) + + else !unstable + + x = (1.-19.0*zl)**0.25 + x0= (1.-19.0*zml)**0.25 + y = (1.-11.6*zl)**0.5 + y0= (1.-11.6*zhl)**0.5 + + psi_m = 2.*log((1.+x)/(1.+x0)) + & + &log((1.+x**2.)/(1.+x0**2.)) - & + &2.0*atan(x) + 2.0*atan(x0) + psi_h = 2.*log((1.+y)/(1.+y0)) + + endif + + end subroutine psi_hogstrom_1996 + +!================================================================================================================= + subroutine psi_dyerhicks(psi_m,psi_h,zl,zt,z_0,za) +!This subroutine returns the stability functions based off +!of Hogstrom (1996), but with different constants compatible +!with Dyer and Hicks (1970/74?). This formulation is used for +!testing/development by Nakanishi (personal communication). + implicit none +!================================================================================================================= + +!--- input arguments: + real(kind=kind_phys),intent(in):: zl,zt,z_0,za + +!--- output arguments: + real(kind=kind_phys),intent(out):: psi_m,psi_h + +!--- local variables: + real(kind=kind_phys):: x,x0,y,y0,zml,zhl + +!----------------------------------------------------------------------------------------------------------------- + + zml = z_0*zl/za !zo/l + zhl = zt*zl/za !zt/l + + if (zl .gt. 0.) then !stable + + psi_m = -5.0*(zl - zml) + psi_h = -5.0*(zl - zhl) + + else !unstable + + x = (1.-16.*zl)**0.25 + x0= (1.-16.*zml)**0.25 + + y = (1.-16.*zl)**0.5 + y0= (1.-16.*zhl)**0.5 + + psi_m = 2.*log((1.+x)/(1.+x0)) + & + &log((1.+x**2.)/(1.+x0**2.)) - & + &2.0*atan(x) + 2.0*atan(x0) + psi_h = 2.*log((1.+y)/(1.+y0)) + + endif + + end subroutine psi_dyerhicks + +!================================================================================================================= + subroutine psi_beljaars_holtslag_1991(psi_m,psi_h,zl) +!this subroutine returns the stability functions based off +!of Beljaar and Holtslag 1991, which is an extension of Holtslag +!and Debruin 1989. + implicit none +!================================================================================================================= + +!--- input arguments: + real(kind=kind_phys),intent(in):: zl + +!--- output arguments: + real(kind=kind_phys),intent(out):: psi_m, psi_h + +!--- local variables: + real(kind=kind_phys):: a=1.,b=0.666,c=5.,d=0.35 + +!----------------------------------------------------------------------------------------------------------------- + + if (zl .lt. 0.) then !unstable + + write(*,*)"WARNING: Universal stability functions from" + write(*,*)" Beljaars and Holtslag (1991) should only" + write(*,*)" be used in the stable regime!" + psi_m = 0. + psi_h = 0. + + else !stable + + psi_m = -(a*zl + b*(zl -(c/d))*exp(-d*zl) + (b*c/d)) + psi_h = -((1.+.666*a*zl)**1.5 + & + b*(zl - (c/d))*exp(-d*zl) + (b*c/d) -1.) + + endif + + end subroutine psi_beljaars_holtslag_1991 + +!================================================================================================================= + subroutine psi_zilitinkevich_esau_2007(psi_m,psi_h,zl) +!this subroutine returns the stability functions come from +!Zilitinkevich and Esau (2007, BM), which are formulatioed from the +!"generalized similarity theory" and tuned to the LES DATABASE64 +!to determine their dependence on z/L. + IMPLICIT NONE +!================================================================================================================= + +!--- input arguments: + real(kind=kind_phys),intent(in):: zl + +!--- output arguments: + real(kind=kind_phys),intent(out):: psi_m, psi_h + +!--- local variables: + real(kind=kind_phys),parameter:: cm=3.0,ct=2.5 + +!----------------------------------------------------------------------------------------------------------------- + + if (zl .lt. 0.) then !unstable + +! write(*,*)"WARNING: Universal stability function from" +! write(*,*)" Zilitinkevich and Esau (2007) should only" +! write(*,*)" be used in the stable regime!" + psi_m = 0. + psi_h = 0. + + else !stable + + psi_m = -cm*(zl**(5./6.)) + psi_h = -ct*(zl**(4./5.)) + + endif + + end subroutine psi_zilitinkevich_esau_2007 + +!================================================================================================================= + subroutine psi_businger_1971(psi_m,psi_h,zl) +!this subroutine returns the flux-profile relationships +!of Businger el al. 1971. + implicit none +!================================================================================================================= + +!--- input arguments: + real(kind=kind_phys),intent(in):: zl + +!--- output arguments: + real(kind=kind_phys),intent(out):: psi_m, psi_h + +!--- local variables: + real(kind=kind_phys):: x, y + real(kind=kind_phys),parameter:: pi180 = 3.14159265/180. + +!----------------------------------------------------------------------------------------------------------------- + + if (zl .lt. 0.) then !unstable + + x = (1. - 15.0*zl)**0.25 + y = (1. - 9.0*zl)**0.5 + + psi_m = log(((1.+x)/2.)**2.) + & + & log((1.+x**2.)/2.) - & + & 2.0*atan(x) + pi180*90. + psi_h = 2.*log((1.+y)/2.) + + else !stable + + psi_m = -4.7*zl + psi_h = -(4.7/0.74)*zl + + endif + + end subroutine psi_businger_1971 + +!================================================================================================================= + subroutine psi_suselj_sood_2010(psi_m,psi_h,zl) +!this subroutine returns flux-profile relatioships based off +!of Lobocki (1993), which is derived from the MY-level 2 model. +!Suselj and Sood (2010) applied the surface layer length scales +!from Nakanishi (2001) to get this new relationship. These functions +!are more agressive (larger magnitude) than most formulations. They +!showed improvement over water, but untested over land. + implicit none +!================================================================================================================= + +!--- input arguments: + real(kind=kind_phys),intent(in):: zl + +!--- output arguments: + real(kind=kind_phys),intent(out):: psi_m, psi_h + +!--- local variables: + real(kind=kind_phys),parameter:: rfc=0.19, ric=0.183, phit=0.8 + +!----------------------------------------------------------------------------------------------------------------- + + if (zl .gt. 0.) then !stable + + psi_m = -(zl/rfc + 1.1223*exp(1.-1.6666/zl)) + !psi_h = -zl*ric/((rfc**2.)*phit) + 8.209*(zl**1.1091) + !their eq for psi_h crashes the model and does not match + !their fig 1. this eq (below) matches their fig 1 better: + psi_h = -(zl*ric/((rfc**2.)*5.) + 7.09*(zl**1.1091)) + + else !unstable + + psi_m = 0.9904*log(1. - 14.264*zl) + psi_h = 1.0103*log(1. - 16.3066*zl) + + endif + + end subroutine psi_suselj_sood_2010 + +!================================================================================================================= + subroutine psi_cb2005(psim1,psih1,zl,z0l) +!this subroutine returns the stability functions based off +!of Cheng and Brutseart (2005, BLM), for use in stable conditions only. +!the returned values are the combination of psi((za+zo)/L) - psi(z0/L) + implicit none +!================================================================================================================= + +!--- input arguments: + real(kind=kind_phys),intent(in):: zl,z0l + +!--- output arguments: + real(kind=kind_phys),intent(out):: psim1,psih1 + +!----------------------------------------------------------------------------------------------------------------- + + psim1 = -6.1*log(zl + (1.+ zl **2.5)**0.4) & + -6.1*log(z0l + (1.+ z0l**2.5)**0.4) + psih1 = -5.5*log(zl + (1.+ zl **1.1)**0.90909090909) & + -5.5*log(z0l + (1.+ z0l**1.1)**0.90909090909) + + end subroutine psi_cb2005 + +!================================================================================================================= + subroutine li_etal_2010(zl,rib,zaz0,z0zt) +!this subroutine returns a more robust z/l that best matches +!the z/l from hogstrom (1996) for unstable conditions and beljaars +!and holtslag (1991) for stable conditions. + implicit none +!================================================================================================================= + +!--- input arguments: + real(kind=kind_phys),intent(in):: rib,zaz0,z0zt + +!--- output arguments: + real(kind=kind_phys),intent(out):: zl + +!--- local variables: + real(kind=kind_phys):: alfa,beta,zaz02,z0zt2 + + real(kind=kind_phys),parameter:: au11=0.045, bu11=0.003, bu12=0.0059, & + &bu21=-0.0828, bu22=0.8845, bu31=0.1739, & + &bu32=-0.9213, bu33=-0.1057 + real(kind=kind_phys),parameter:: aw11=0.5738, aw12=-0.4399, aw21=-4.901, & + &aw22=52.50, bw11=-0.0539, bw12=1.540, & + &bw21=-0.669, bw22=-3.282 + real(kind=kind_phys),parameter:: as11=0.7529, as21=14.94, bs11=0.1569, & + &bs21=-0.3091, bs22=-1.303 + +!----------------------------------------------------------------------------------------------------------------- + +!set limits according to Li et al (2010), p 157. + zaz02=zaz0 + if (zaz0 .lt. 100.0) zaz02=100. + if (zaz0 .gt. 100000.0) zaz02=100000. + +!set more limits according to Li et al (2010) + z0zt2=z0zt + if (z0zt .lt. 0.5) z0zt2=0.5 + if (z0zt .gt. 100.0) z0zt2=100. + + alfa = log(zaz02) + beta = log(z0zt2) + + if (rib .le. 0.0) then + zl = au11*alfa*rib**2 + ( & + & (bu11*beta + bu12)*alfa**2 + & + & (bu21*beta + bu22)*alfa + & + & (bu31*beta**2 + bu32*beta + bu33))*rib + + !if(zL .LT. -15 .OR. zl .GT. 0.)print*,"VIOLATION Rib<0:",zL + zl = max(zl,-15.) !limits set according to Li et al (2010) + zl = min(zl,0.) !Figure 1. + elseif (rib .gt. 0.0 .and. rib .le. 0.2) then + zl = ((aw11*beta + aw12)*alfa + & + & (aw21*beta + aw22))*rib**2 + & + & ((bw11*beta + bw12)*alfa + & + & (bw21*beta + bw22))*rib + + !if(zl .lt. 0 .or. zl .gt. 4)print*,"violation 00.2:",zl + zl = min(zl,20.) !limits according to Li et al (2010), their Figure 1c. + zl = max(zl,1.) + endif + + end subroutine li_etal_2010 + +!================================================================================================================= + real(kind=kind_phys) function zolri(ri,za,z0,zt,zol1,psi_opt) + implicit none +! This iterative algorithm is a two-point secant method taken from the revised +! surface layer scheme in WRF-ARW, written by Pedro Jimenez and Jimy Dudhia and +! summarized in Jimenez et al. (2012, MWR). This function was adapted +! to input the thermal roughness length, zt, (as well as z0) and use initial +! estimate of z/L. +!================================================================================================================= + +!--- input arguments: + integer, intent(in):: psi_opt + real(kind=kind_phys),intent(in):: ri,za,z0,zt,zol1 + +!--- local variables and arrays: + integer:: n + integer,parameter:: nmax = 20 + real(kind=kind_phys):: x1,x2,fx1,fx2 + +!----------------------------------------------------------------------------------------------------------------- + + if (ri.lt.0.)then + x1=zol1 - 0.02 !-5. + x2=0. + else + x1=0. + x2=zol1 + 0.02 !5. + endif + + n=0 + fx1=zolri2(x1,ri,za,z0,zt,psi_opt) + fx2=zolri2(x2,ri,za,z0,zt,psi_opt) + + do while (abs(x1 - x2) > 0.01 .and. n < nmax) + if(abs(fx2) .lt. abs(fx1))then + x1=x1-fx1/(fx2-fx1)*(x2-x1) + fx1=zolri2(x1,ri,za,z0,zt,psi_opt) + zolri=x1 + else + x2=x2-fx2/(fx2-fx1)*(x2-x1) + fx2=zolri2(x2,ri,za,z0,zt,psi_opt) + zolri=x2 + endif + n=n+1 + enddo + + if (n==nmax .and. abs(x1 - x2) >= 0.01) then + !if convergence fails, use approximate values: + call li_etal_2010(zolri, ri, za/z0, z0/zt) + !print*,"failed, n=",n," ri=",ri," zt=",zt + else + !print*,"success,n=",n," ri=",ri," z/l=",zolri + endif + + end function zolri + +!================================================================================================================= + real(kind=kind_phys) function zolri2(zol2,ri2,za,z0,zt,psi_opt) + implicit none +! input: ================================= +! zol2 - estimated z/l +! ri2 - calculated bulk richardson number +! za - 1/2 depth of first model layer +! z0 - aerodynamic roughness length +! zt - thermal roughness length +! output: ================================ +! zolri2 - delta ri +!================================================================================================================= + +!--- input arguments: + integer,intent(in):: psi_opt + real(kind=kind_phys),intent(in):: ri2,za,z0,zt + +!--- inout arguments: + real(kind=kind_phys),intent(inout):: zol2 + +!--- local variables and arrays: + real(kind=kind_phys):: zol20,zol3,psim1,psih1,psix2,psit2,zolt + +!----------------------------------------------------------------------------------------------------------------- + + if(zol2*ri2 .lt. 0.) then + !print*,"wrong quadrants: z/l=",zol2," ri=",ri2 + zol2=0. + endif + + zol20=zol2*z0/za ! z0/l + zol3=zol2+zol20 ! (z+z0)/l + zolt=zol2*zt/za ! zt/l + + if (ri2.lt.0) then + psit2=max(log((za+z0)/zt)-(psih_unstable(zol3,psi_opt)-psih_unstable(zolt,psi_opt)), 1.0) + psix2=max(log((za+z0)/z0)-(psim_unstable(zol3,psi_opt)-psim_unstable(zol20,psi_opt)),1.0) + else + psit2=max(log((za+z0)/zt)-(psih_stable(zol3,psi_opt)-psih_stable(zolt,psi_opt)), 1.0) + psix2=max(log((za+z0)/z0)-(psim_stable(zol3,psi_opt)-psim_stable(zol20,psi_opt)),1.0) + endif + + zolri2=zol2*psit2/psix2**2 - ri2 +!print*," target ri=",ri2," est ri=",zol2*psit2/psix2**2 + + end function zolri2 + +!================================================================================================================= + real(kind=kind_phys) function zolrib(ri,za,z0,zt,logz0,logzt,zol1,psi_opt) + implicit none +!this iterative algorithm to compute z/L from bulk-Ri +!================================================================================================================= + +!--- input arguments: + integer,intent(in):: psi_opt + real(kind=kind_phys),intent(in):: ri,za,z0,zt,logz0,logzt + +!--- inout arguments: + real(kind=kind_phys),intent(inout):: zol1 + +!--- local variables and arrays: + integer:: n + integer,parameter :: nmax = 20 + real(kind=kind_phys):: zol20,zol3,zolt,zolold + real(kind=kind_phys):: psit2,psix2 +!real(kind=kind_phys),dimension(nmax):: zlhux + +!----------------------------------------------------------------------------------------------------------------- + + if(zol1*ri .lt. 0.) then +! print*,"WRONG QUADRANTS: z/L=",zol1," ri=",ri + zol1=0. + endif + + if (ri .lt. 0.) then + zolold=-99999. + zolrib=-66666. + else + zolold=99999. + zolrib=66666. + endif + + n=1 + do while (abs(zolold - zolrib) > 0.01 .and. n < nmax) + + if(n==1)then + zolold=zol1 + else + zolold=zolrib + endif + zol20=zolold*z0/za ! z0/L + zol3=zolold+zol20 ! (z+z0)/L + zolt=zolold*zt/za ! zt/L + + if (ri.lt.0) then + psit2=MAX(logzt-(psih_unstable(zol3,psi_opt)-psih_unstable(zolt,psi_opt)), 1.0) + psix2=MAX(logz0-(psim_unstable(zol3,psi_opt)-psim_unstable(zol20,psi_opt)), 1.0) + else + psit2=MAX(logzt-(psih_stable(zol3,psi_opt)-psih_stable(zolt,psi_opt)), 1.0) + psix2=MAX(logz0-(psim_stable(zol3,psi_opt)-psim_stable(zol20,psi_opt)), 1.0) + endif + + zolrib=ri*psix2**2/psit2 + !zLhux(n)=zolrib + n=n+1 + enddo + + if (n==nmax .and. abs(zolold - zolrib) > 0.01 ) then + !print*,"iter FAIL, n=",n," Ri=",ri," z/L=",zolri + !if convergence fails, use approximate values: + call li_etal_2010(zolrib,ri,za/z0,z0/zt) + !zLhux(n)=zolri + !print*,"FAILED, n=",n," Ri=",ri," zt=",zt + !print*,"z/L=",zLhux(1:nmax) + else + !print*,"SUCCESS,n=",n," Ri=",ri," z/L=",zolrib + endif + + end function zolrib + +!================================================================================================================= + subroutine psi_init(psi_opt) + implicit none +!define tables from -10 <= z/L <= 10 +!================================================================================================================= + + integer,intent(in):: psi_opt + integer:: n + real(kind=kind_phys):: zolf + +!----------------------------------------------------------------------------------------------------------------- + + if (psi_opt == 0) then + do n = 0,1000 + !stable function tables + zolf = float(n)*0.01 + psim_stab(n)=psim_stable_full(zolf) + psih_stab(n)=psih_stable_full(zolf) + + !unstable function tables + zolf = -float(n)*0.01 + psim_unstab(n)=psim_unstable_full(zolf) + psih_unstab(n)=psih_unstable_full(zolf) + enddo + else + do n = 0,1000 + !stable function tables + zolf = float(n)*0.01 + psim_stab(n)=psim_stable_full_gfs(zolf) + psih_stab(n)=psih_stable_full_gfs(zolf) + + !unstable function tables + zolf = -float(n)*0.01 + psim_unstab(n)=psim_unstable_full_gfs(zolf) + psih_unstab(n)=psih_unstable_full_gfs(zolf) + enddo + endif + + end subroutine psi_init + +!================================================================================================================= +! ... Full equations for the integrated similarity functions ... +!================================================================================================================= + real(kind=kind_phys) function psim_stable_full(zolf) + implicit none + + real(kind=kind_phys),intent(in):: zolf + + psim_stable_full=-6.1*log(zolf+(1+zolf**2.5)**(1./2.5)) + + end function psim_stable_full + +!================================================================================================================= + real(kind=kind_phys) function psih_stable_full(zolf) + implicit none + + real(kind=kind_phys),intent(in):: zolf + + psih_stable_full=-5.3*log(zolf+(1+zolf**1.1)**(1./1.1)) + + end function psih_stable_full + +!================================================================================================================= + real(kind=kind_phys) function psim_unstable_full(zolf) + implicit none + + real(kind=kind_phys),intent(in):: zolf + real(kind=kind_phys):: x,ym,psimc,psimk + + x=(1.-16.*zolf)**.25 + psimk=2*ALOG(0.5*(1+X))+ALOG(0.5*(1+X*X))-2.*ATAN(X)+2.*ATAN(1.) + + ym=(1.-10.*zolf)**0.33 + psimc=(3./2.)*log((ym**2.+ym+1.)/3.)-sqrt(3.)*ATAN((2.*ym+1)/sqrt(3.))+4.*ATAN(1.)/sqrt(3.) + + psim_unstable_full=(psimk+zolf**2*(psimc))/(1+zolf**2.) + + end function psim_unstable_full + +!================================================================================================================= + real(kind=kind_phys) function psih_unstable_full(zolf) + implicit none + + real(kind=kind_phys),intent(in):: zolf + real(kind=kind_phys):: y,yh,psihc,psihk + + y=(1.-16.*zolf)**.5 + psihk=2.*log((1+y)/2.) + + yh=(1.-34.*zolf)**0.33 + psihc=(3./2.)*log((yh**2.+yh+1.)/3.)-sqrt(3.)*ATAN((2.*yh+1)/sqrt(3.))+4.*ATAN(1.)/sqrt(3.) + + psih_unstable_full=(psihk+zolf**2*(psihc))/(1+zolf**2.) + + end function psih_unstable_full + +!================================================================================================================= +! ... integrated similarity functions from GFS... +! +!================================================================================================================= + real(kind=kind_phys) function psim_stable_full_gfs(zolf) + implicit none + + real(kind=kind_phys),intent(in):: zolf + real(kind=kind_phys):: aa + real(kind=kind_phys),parameter:: alpha4 = 20. + + aa = sqrt(1. + alpha4 * zolf) + psim_stable_full_gfs = -1.*aa + log(aa + 1.) + + end function psim_stable_full_gfs + +!================================================================================================================= + real(kind=kind_phys) function psih_stable_full_gfs(zolf) + implicit none + + real(kind=kind_phys):: zolf + real(kind=kind_phys):: bb + real(kind=kind_phys),parameter:: alpha4 = 20. + + bb = sqrt(1. + alpha4 * zolf) + psih_stable_full_gfs = -1.*bb + log(bb + 1.) + + end function psih_stable_full_gfs + +!================================================================================================================= + real(kind=kind_phys) function psim_unstable_full_gfs(zolf) + implicit none + + real(kind=kind_phys),intent(in):: zolf + real(kind=kind_phys):: hl1,tem1 + real(kind=kind_phys),parameter:: a0=-3.975, a1=12.32, & + b1=-7.755, b2=6.041 + + if (zolf .ge. -0.5) then + hl1 = zolf + psim_unstable_full_gfs = (a0 + a1*hl1) * hl1 / (1.+ (b1+b2*hl1) *hl1) + else + hl1 = -zolf + tem1 = 1.0 / sqrt(hl1) + psim_unstable_full_gfs = log(hl1) + 2. * sqrt(tem1) - .8776 + end if + + end function psim_unstable_full_gfs + +!================================================================================================================= + real(kind=kind_phys) function psih_unstable_full_gfs(zolf) + implicit none + + real(kind=kind_phys),intent(in):: zolf + real(kind=kind_phys):: hl1,tem1 + real(kind=kind_phys),parameter:: a0p=-7.941, a1p=24.75, & + b1p=-8.705, b2p=7.899 + + if (zolf .ge. -0.5) then + hl1 = zolf + psih_unstable_full_gfs = (a0p + a1p*hl1) * hl1 / (1.+ (b1p+b2p*hl1)*hl1) + else + hl1 = -zolf + tem1 = 1.0 / sqrt(hl1) + psih_unstable_full_gfs = log(hl1) + .5 * tem1 + 1.386 + end if + + end function psih_unstable_full_gfs + +!================================================================================================================= +! These functions use the look-up table functions when |z/L| <= 10 +! but default to the full equations when |z/L| > 10. +!================================================================================================================= + real(kind=kind_phys) function psim_stable(zolf,psi_opt) + implicit none + + integer,intent(in):: psi_opt + integer:: nzol + real(kind=kind_phys),intent(in):: zolf + real(kind=kind_phys):: rzol + +!----------------------------------------------------------------------------------------------------------------- + + nzol = int(zolf*100.) + rzol = zolf*100. - nzol + if(nzol+1 .le. 1000)then + psim_stable = psim_stab(nzol) + rzol*(psim_stab(nzol+1)-psim_stab(nzol)) + else + if (psi_opt == 0) then + psim_stable = psim_stable_full(zolf) + else + psim_stable = psim_stable_full_gfs(zolf) + endif + endif + + end function psim_stable + +!================================================================================================================= + real(kind=kind_phys) function psih_stable(zolf,psi_opt) + implicit none + + integer,intent(in):: psi_opt + integer:: nzol + real(kind=kind_phys),intent(in):: zolf + real(kind=kind_phys):: rzol + +!----------------------------------------------------------------------------------------------------------------- + + nzol = int(zolf*100.) + rzol = zolf*100. - nzol + if(nzol+1 .le. 1000)then + psih_stable = psih_stab(nzol) + rzol*(psih_stab(nzol+1)-psih_stab(nzol)) + else + if (psi_opt == 0) then + psih_stable = psih_stable_full(zolf) + else + psih_stable = psih_stable_full_gfs(zolf) + endif + endif + + end function psih_stable + +!================================================================================================================= + real(kind=kind_phys) function psim_unstable(zolf,psi_opt) + implicit none + + integer,intent(in):: psi_opt + integer:: nzol + real(kind=kind_phys),intent(in):: zolf + real(kind=kind_phys):: rzol + +!----------------------------------------------------------------------------------------------------------------- + + nzol = int(-zolf*100.) + rzol = -zolf*100. - nzol + if(nzol+1 .le. 1000)then + psim_unstable = psim_unstab(nzol) + rzol*(psim_unstab(nzol+1)-psim_unstab(nzol)) + else + if (psi_opt == 0) then + psim_unstable = psim_unstable_full(zolf) + else + psim_unstable = psim_unstable_full_gfs(zolf) + endif + endif + + end function psim_unstable + +!================================================================================================================= + real(kind=kind_phys) function psih_unstable(zolf,psi_opt) + implicit none + + integer,intent(in):: psi_opt + integer:: nzol + real(kind=kind_phys),intent(in):: zolf + real(kind=kind_phys):: rzol + +!----------------------------------------------------------------------------------------------------------------- + + nzol = int(-zolf*100.) + rzol = -zolf*100. - nzol + if(nzol+1 .le. 1000)then + psih_unstable = psih_unstab(nzol) + rzol*(psih_unstab(nzol+1)-psih_unstab(nzol)) + else + if (psi_opt == 0) then + psih_unstable = psih_unstable_full(zolf) + else + psih_unstable = psih_unstable_full_gfs(zolf) + endif + endif + + end function psih_unstable + +!================================================================================================================= + end module sf_mynn +!================================================================================================================= + diff --git a/src/core_atmosphere/physics/physics_mmm/sf_sfclayrev.F b/src/core_atmosphere/physics/physics_mmm/sf_sfclayrev.F index 0fa2b5f446..6ca81441ad 100644 --- a/src/core_atmosphere/physics/physics_mmm/sf_sfclayrev.F +++ b/src/core_atmosphere/physics/physics_mmm/sf_sfclayrev.F @@ -1,6 +1,5 @@ !================================================================================================================= module sf_sfclayrev - use mpas_log use ccpp_kinds,only: kind_phys implicit none diff --git a/src/core_atmosphere/physics/physics_wrf/Makefile b/src/core_atmosphere/physics/physics_wrf/Makefile index b8a99b0a33..e9dabbc0ed 100644 --- a/src/core_atmosphere/physics/physics_wrf/Makefile +++ b/src/core_atmosphere/physics/physics_wrf/Makefile @@ -40,14 +40,18 @@ OBJS = \ module_sf_oml.o \ module_sf_sfclay.o \ module_sf_sfclayrev.o \ - module_sf_urban.o + module_sf_urban.o \ + bl_mynn_post.o \ + bl_mynn_pre.o \ + sf_mynn_pre.o physics_wrf: $(OBJS) ar -ru ./../libphys.a $(OBJS) # DEPENDENCIES: module_bl_mynn.o: \ - module_cam_error_function.o + bl_mynn_post.o \ + bl_mynn_pre.o module_cam_support.o: \ module_cam_shr_kind_mod.o @@ -73,8 +77,7 @@ module_sf_bep_bem.o: \ module_sf_urban.o module_sf_mynn.o: \ - module_bl_mynn.o \ - module_sf_sfclay.o + sf_mynn_pre.o module_sf_noahdrv.o: \ module_sf_bem.o \ diff --git a/src/core_atmosphere/physics/physics_wrf/bl_mynn_post.F b/src/core_atmosphere/physics/physics_wrf/bl_mynn_post.F new file mode 100644 index 0000000000..096010ed15 --- /dev/null +++ b/src/core_atmosphere/physics/physics_wrf/bl_mynn_post.F @@ -0,0 +1,156 @@ +!================================================================================================================= + module bl_mynn_post + use ccpp_kinds,only: kind_phys + + implicit none + private + public:: bl_mynn_post_init, & + bl_mynn_post_finalize, & + bl_mynn_post_run + + + contains + + +!================================================================================================================= +!>\section arg_table_bl_mynn_post_init +!!\html\include bl_mynn_post_init.html +!! + subroutine bl_mynn_post_init(errmsg,errflg) +!================================================================================================================= + +!--- output arguments: + character(len=*),intent(out):: & + errmsg ! output error message (-). + + integer,intent(out):: & + errflg ! output error flag (-). + +!----------------------------------------------------------------------------------------------------------------- + +!--- output error flag and message: + errflg = 0 + errmsg = " " + + end subroutine bl_mynn_post_init + +!================================================================================================================= +!>\section arg_table_bl_mynn_post_finalize +!!\html\include bl_mynn_post_finalize.html +!! + subroutine bl_mynn_post_finalize(errmsg,errflg) +!================================================================================================================= + +!--- output arguments: + character(len=*),intent(out):: & + errmsg ! output error message (-). + + integer,intent(out):: & + errflg ! output error flag (-). + +!----------------------------------------------------------------------------------------------------------------- + +!--- output error flag and message: + errflg = 0 + errmsg = " " + + end subroutine bl_mynn_post_finalize + +!================================================================================================================= + subroutine bl_mynn_post_run(its,ite,kte,f_qc,f_qi,f_qs,delt,qv,qc,qi,qs,dqv,dqc,dqi,dqs,errmsg,errflg) +!================================================================================================================= + +!--- input arguments: + logical,intent(in):: & + f_qc, &! if true,the physics package includes the cloud liquid water mixing ratio. + f_qi, &! if true,the physics package includes the cloud ice mixing ratio. + f_qs ! if true,the physics package includes the snow mixing ratio. + + integer,intent(in):: its,ite + integer,intent(in):: kte + + real(kind=kind_phys),intent(in):: & + delt ! + + real(kind=kind_phys),intent(in),dimension(its:ite,1:kte):: & + qv, &! + qc, &! + qi, &! + qs ! + + +!--- inout arguments: + real(kind=kind_phys),intent(inout),dimension(its:ite,1:kte):: & + dqv, &! + dqc, &! + dqi, &! + dqs ! + + +!--- output arguments: + character(len=*),intent(out):: errmsg + integer,intent(out):: errflg + + +!--- local variables: + integer:: i,k,kts + real(kind=kind_phys):: rq,sq,tem + real(kind=kind_phys),dimension(its:ite,1:kte):: sqv,sqc,sqi,sqs + +!----------------------------------------------------------------------------------------------------------------- + +!--- initialization: + kts = 1 + +!--- + do i = its,ite + do k = kts,kte + sq = qv(i,k)/(1.+qv(i,k)) !conversion of qv at time-step n from mixing ratio to specific humidity. + sqv(i,k) = sq + dqv(i,k)*delt !calculation of specific humidity at time-step n+1. + rq = sqv(i,k)/(1.-sqv(i,k)) !conversion of qv at time-step n+1 from specific humidity to mixing ratio. + dqv(i,k) = (rq - qv(i,k))/delt !calculation of the tendency. + enddo + enddo + + if(f_qc) then + do i = its,ite + do k = kts,kte + sq = qc(i,k)/(1.+qv(i,k)) + sqc(i,k) = sq + dqc(i,k)*delt + rq = sqc(i,k)*(1.+sqv(i,k)) + dqc(i,k) = (rq - qc(i,k))/delt + enddo + enddo + endif + + if(f_qi) then + do i = its,ite + do k = kts,kte + sq = qi(i,k)/(1.+qv(i,k)) + sqi(i,k) = sq + dqi(i,k)*delt + rq = sqi(i,k)*(1.+sqv(i,k)) + dqi(i,k) = (rq - qi(i,k))/delt + enddo + enddo + endif + + if(f_qs) then + do i = its,ite + do k = kts,kte + sq = qs(i,k)/(1.+qv(i,k)) + sqs(i,k) = sq + dqs(i,k)*delt + rq = sqs(i,k)*(1.+sqv(i,k)) + dqs(i,k) = (rq - qs(i,k))/delt + enddo + enddo + endif + +!--- output error flag and message: + errmsg = " " + errflg = 0 + + end subroutine bl_mynn_post_run + +!================================================================================================================= + end module bl_mynn_post +!================================================================================================================= diff --git a/src/core_atmosphere/physics/physics_wrf/bl_mynn_pre.F b/src/core_atmosphere/physics/physics_wrf/bl_mynn_pre.F new file mode 100644 index 0000000000..dfd5831203 --- /dev/null +++ b/src/core_atmosphere/physics/physics_wrf/bl_mynn_pre.F @@ -0,0 +1,148 @@ +!================================================================================================================= + module bl_mynn_pre + use ccpp_kinds,only: kind_phys + + implicit none + private + public:: bl_mynn_pre_init, & + bl_mynn_pre_finalize, & + bl_mynn_pre_run + + + contains + + +!================================================================================================================= +!>\section arg_table_bl_mynn_pre_init +!!\html\include bl_mynn_pre_init.html +!! + subroutine bl_mynn_pre_init(errmsg,errflg) +!================================================================================================================= + +!--- output arguments: + character(len=*),intent(out):: & + errmsg ! output error message (-). + + integer,intent(out):: & + errflg ! output error flag (-). + +!----------------------------------------------------------------------------------------------------------------- + +!--- output error flag and message: + errflg = 0 + errmsg = " " + + end subroutine bl_mynn_pre_init + +!================================================================================================================= +!>\section arg_table_bl_mynn_pre_finalize +!!\html\include bl_mynn_pre_finalize.html +!! + subroutine bl_mynn_pre_finalize(errmsg,errflg) +!================================================================================================================= + +!--- output arguments: + character(len=*),intent(out):: & + errmsg ! output error message (-). + + integer,intent(out):: & + errflg ! output error flag (-). + +!----------------------------------------------------------------------------------------------------------------- + +!--- output error flag and message: + errflg = 0 + errmsg = " " + + end subroutine bl_mynn_pre_finalize + +!================================================================================================================= +!>\section arg_table_bl_mynn_pre_run +!!\html\include bl_mynn_pre_run.html +!! + subroutine bl_mynn_pre_run(its,ite,kte,f_qc,f_qi,f_qs,qv,qc,qi,qs,sqv,sqc,sqi,sqs,errmsg,errflg) +!================================================================================================================= + +!--- input arguments: + logical,intent(in):: & + f_qc, &! if true,the physics package includes the cloud liquid water mixing ratio. + f_qi, &! if true,the physics package includes the cloud ice mixing ratio. + f_qs ! if true,the physics package includes the snow mixing ratio. + + integer,intent(in):: its,ite + integer,intent(in):: kte + + real(kind=kind_phys),intent(in),dimension(its:ite,1:kte):: & + qv, &! + qc, &! + qi, &! + qs ! + + +!--- output arguments: + character(len=*),intent(out):: & + errmsg ! output error message (-). + + integer,intent(out):: & + errflg ! output error flag (-). + + real(kind=kind_phys),intent(out),dimension(its:ite,1:kte):: & + sqv, &! + sqc, &! + sqi , &! + sqs ! + + +!--- local variables: + integer:: i,k,kts + +!----------------------------------------------------------------------------------------------------------------- + +!--- initialization: + kts = 1 + do k = kts,kte + do i = its,ite + sqc(i,k) = 0._kind_phys + sqi(i,k) = 0._kind_phys + enddo + enddo + +!--- conversion from water vapor mixing ratio to specific humidity: + do k = kts,kte + do i = its,ite + sqv(i,k) = qv(i,k)/(1.+qv(i,k)) + enddo + enddo + +!--- conversion from cloud liquid water,cloud ice,and snow mixing ratios to specific contents: + if(f_qc) then + do k = kts,kte + do i = its,ite + sqc(i,k) = qc(i,k)/(1.+qv(i,k)) + enddo + enddo + endif + if(f_qi) then + do k = kts,kte + do i = its,ite + sqi(i,k) = qi(i,k)/(1.+qv(i,k)) + enddo + enddo + endif + if(f_qs) then + do k = kts,kte + do i = its,ite + sqs(i,k) = qs(i,k)/(1.+qs(i,k)) + enddo + enddo + endif + +!--- output error flag and message: + errflg = 0 + errmsg = " " + + end subroutine bl_mynn_pre_run + +!================================================================================================================= + end module bl_mynn_pre +!================================================================================================================= diff --git a/src/core_atmosphere/physics/physics_wrf/module_bl_mynn.F b/src/core_atmosphere/physics/physics_wrf/module_bl_mynn.F index 23c41a6812..5f542bac92 100644 --- a/src/core_atmosphere/physics/physics_wrf/module_bl_mynn.F +++ b/src/core_atmosphere/physics/physics_wrf/module_bl_mynn.F @@ -1,3064 +1,751 @@ -!================================================================================================== -! copied for implementation in MPAS from WRF version 3.6.1. - -! modifications made to sourcecode: -! * used preprocessing option to replace module_model_constants with mpas_atmphys_constants. -! * used preprocessing option to not compile subroutine mynn_bl_init_driver. -! Laura D. Fowler (laura@ucar.edu) / 2014-09-25. - -!================================================================================================== - -! translated from NN f77 to F90 and put into WRF by Mariusz Pagowski -! NOAA/GSD & CIRA/CSU, Feb 2008 -! changes to original code: -! 1. code is 1d (in z) -! 2. no advection of TKE, covariances and variances -! 3. Cranck-Nicholson replaced with the implicit scheme -! 4. removed terrain dependent grid since input in WRF in actual -! distances in z[m] -! 5. cosmetic changes to adhere to WRF standard (remove common blocks, -! intent etc) -!------------------------------------------------------------------- -!Modifications implemented by Joseph Olson NOAA/GSD/AMB - CU/CIRES -!(approved by Mikio Nakanishi or under consideration): -! 1. Addition of BouLac mixing length in the free atmosphere. -! 2. Changed the turbulent mixing length to be integrated from the -! surface to the top of the BL + a transition layer depth. -! 3. v3.4.1: Option to use Kitamura/Canuto modification which removes -! the critical Richardson number and negative TKE (default). -! 4. v3.4.1: Hybrid PBL height diagnostic, which blends a theta-v-based -! definition in neutral/convective BL and a TKE-based definition -! in stable conditions. -! 5. v3.4.1: TKE budget output option (bl_mynn_tkebudget) -! 6. v3.5.0: TKE advection option (bl_mynn_tkeadvect) -! 7. v3.5.1: Fog deposition related changes. -! -! For changes 1 and 3, see "JOE's mods" below: -!------------------------------------------------------------------- - -MODULE module_bl_mynn - -#if defined(mpas) - use mpas_atmphys_constants, only: & - karman, & - g => gravity, & - p1000mb => P0, & - cp, & - r_d => R_d, & - rcp, & - xlv, & - xlf, & - svp1, & - svp2, & - svp3, & - svpt0, & - ep_1, & - ep_2 - use error_function, only: erf +!================================================================================================================= + module module_bl_mynn + use mpas_kind_types,only: kind_phys => RKIND + use mpas_log + + use bl_mynn,only: bl_mynn_run + use bl_mynn_post,only: bl_mynn_post_run + use bl_mynn_pre,only: bl_mynn_pre_run implicit none private - public:: tv0,mym_condensation,mynn_bl_driver -#else - USE module_model_constants, only: & - &karman, g, p1000mb, & - &cp, r_d, rcp, xlv, xlf,& - &svp1, svp2, svp3, svpt0, ep_1, ep_2 - USE module_state_description, only: param_first_scalar, & - &p_qc, p_qr, p_qi, p_qs, p_qg, p_qnc, p_qni -!------------------------------------------------------------------- - IMPLICIT NONE -!------------------------------------------------------------------- + public:: mynn_bl_driver + + + contains + + +!================================================================================================================= + subroutine mynn_bl_driver & + (ids , ide , jds , jde , & + kds , kde , ims , ime , & + jms , jme , kms , kme , & + its , ite , jts , jte , & + kts , kte , f_qc , f_qi , & + f_qs , f_qoz , f_nc , f_ni , & + f_nifa , f_nwfa , f_nbca , initflag , & + do_restart , do_DAcycling , icloud_bl , delt , & + dx , xland , ps , ts , & + qsfc , ust , ch , hfx , & + qfx , rmol , wspd , znt , & + uoce , voce , dz , u , & + v , w , th , tt , & + p , exner , rho , qv , & + qc , qi , qs , nc , & + ni , nifa , nwfa , nbca , & + qoz , rthraten , pblh , kpbl , & + cldfra_bl , qc_bl , qi_bl , maxwidth , & + maxmf , ktop_plume , ztop_plume , qke , & + qke_adv , tsq , qsq , cov , & + el_pbl , rublten , rvblten , rthblten , & + rqvblten , rqcblten , rqiblten , rqsblten , & + rncblten , rniblten , rnifablten , rnwfablten , & + rnbcablten , rqozblten , edmf_a , edmf_w , & + edmf_qt , edmf_thl , edmf_ent , edmf_qc , & + sub_thl , sub_sqv , det_thl , det_sqv , & + exch_h , exch_m , dqke , qwt , & + qshear , qbuoy , qdiss , sh3d , & + sm3d , spp_pbl , pattern_spp , & + bl_mynn_tkeadvect , bl_mynn_tkebudget , bl_mynn_cloudpdf , bl_mynn_mixlength , & + bl_mynn_closure , bl_mynn_stfunc , bl_mynn_topdown , bl_mynn_scaleaware , & + bl_mynn_dheat_opt , bl_mynn_edmf , bl_mynn_edmf_dd , bl_mynn_edmf_mom , & + bl_mynn_edmf_tke , bl_mynn_output , bl_mynn_mixscalars , bl_mynn_cloudmix , & + bl_mynn_mixqt , errmsg , errflg & +#if(WRF_CHEM == 1) + ,mix_chem , nchem , kdvel , ndvel , chem3 , vd3d , & + frp_mean , emis_ant_no & #endif - -! The parameters below depend on stability functions of module_sf_mynn. - REAL, PARAMETER :: cphm_st=5.0, cphm_unst=16.0, & - cphh_st=5.0, cphh_unst=16.0 - - REAL, PARAMETER :: xlvcp=xlv/cp, xlscp=(xlv+xlf)/cp, ev=xlv, rd=r_d, & - &rk=cp/rd, svp11=svp1*1.e3, p608=ep_1, ep_3=1.-ep_2 - - REAL, PARAMETER :: tref=300.0 ! reference temperature (K) - REAL, PARAMETER :: tv0=p608*tref, tv1=(1.+p608)*tref, gtr=g/tref - -! Closure constants - REAL, PARAMETER :: & - &vk = karman, & - &pr = 0.74, & - &g1 = 0.229, & ! NN2009 = 0.235 - &b1 = 24.0, & - &b2 = 15.0, & ! CKmod NN2009 - &c2 = 0.729, & ! 0.729, & !0.75, & - &c3 = 0.340, & ! 0.340, & !0.352, & - &c4 = 0.0, & - &c5 = 0.2, & - &a1 = b1*( 1.0-3.0*g1 )/6.0, & -! &c1 = g1 -1.0/( 3.0*a1*b1**(1.0/3.0) ), & - &c1 = g1 -1.0/( 3.0*a1*2.88449914061481660), & - &a2 = a1*( g1-c1 )/( g1*pr ), & - &g2 = b2/b1*( 1.0-c3 ) +2.0*a1/b1*( 3.0-2.0*c2 ) - - REAL, PARAMETER :: & - &cc2 = 1.0-c2, & - &cc3 = 1.0-c3, & - &e1c = 3.0*a2*b2*cc3, & - &e2c = 9.0*a1*a2*cc2, & - &e3c = 9.0*a2*a2*cc2*( 1.0-c5 ), & - &e4c = 12.0*a1*a2*cc2, & - &e5c = 6.0*a1*a1 - -! Constants for length scale (alps & cns) and TKE diffusion (Sqfac) -! Original (Nakanishi and Niino 2009) (for CKmod=0.): -! REAL, PARAMETER :: qmin=0.0, zmax=1.0, cns=2.7, & -! &alp1=0.23, alp2=1.0, alp3=5.0, alp4=100.0, & -! &alp5=0.40, Sqfac=3.0 -! Modified for Rapid Refresh/HRRR (and for CKmod=1.): - REAL, PARAMETER :: qmin=0.0, zmax=1.0, cns=2.1, & - &alp1=0.23, alp2=0.65, alp3=3.0, alp4=20.0, & - &alp5=1.0, Sqfac=2.0 - -! Constants for gravitational settling -! REAL, PARAMETER :: gno=1.e6/(1.e8)**(2./3.), gpw=5./3., qcgmin=1.e-8 - REAL, PARAMETER :: gno=1.0 !original value seems too agressive: 4.64158883361278196 - REAL, PARAMETER :: gpw=5./3., qcgmin=1.e-8, qkemin=1.e-12 -! REAL, PARAMETER :: pblh_ref=1500. - -! Constants for cloud PDF (mym_condensation) - REAL, PARAMETER :: rr2=0.7071068, rrp=0.3989423 - -!JOE's mods - !Use Canuto/Kitamura mod (remove Ric and negative TKE) (1:yes, 0:no) - !For more info, see Canuto et al. (2008 JAS) and Kitamura (Journal of the - !Meteorological Society of Japan, Vol. 88, No. 5, pp. 857-864, 2010). - !Note that this change required further modification of other parameters - !above (c2, c3, alp2, and Sqfac). If you want to remove this option, set these - !parameters back to NN2009 values (see commented out lines next to the - !parameters above). This only removes the negative TKE problem - !but does not necessarily improve performance - neutral impact. - REAL, PARAMETER :: CKmod=1. - - !Use BouLac mixing length in free atmosphere (1:yes, 0:no) - !This helps remove excessively large mixing in unstable layers aloft. - REAL, PARAMETER :: BLmod=1. - - !Mix couds (water & ice): (0: no, 1: yes) -! REAL, PARAMETER :: Cloudmix=0. - REAL, PARAMETER :: Cloudmix=1. -!JOE-end - - INTEGER :: mynn_level=2 - - INTEGER, PARAMETER :: kdebug=27 - -CONTAINS - -! ********************************************************************** -! * An improved Mellor-Yamada turbulence closure model * -! * * -! * Aug/2005 M. Nakanishi (N.D.A) * -! * Modified: Dec/2005 M. Nakanishi (N.D.A) * -! * naka@nda.ac.jp * -! * * -! * Contents: * -! * 1. mym_initialize (to be called once initially) * -! * gives the closure constants and initializes the turbulent * -! * quantities. * -! * (2) mym_level2 (called in the other subroutines) * -! * calculates the stability functions at Level 2. * -! * (3) mym_length (called in the other subroutines) * -! * calculates the master length scale. * -! * 4. mym_turbulence * -! * calculates the vertical diffusivity coefficients and the * -! * production terms for the turbulent quantities. * -! * 5. mym_predict * -! * predicts the turbulent quantities at the next step. * -! * 6. mym_condensation * -! * determines the liquid water content and the cloud fraction * -! * diagnostically. * -! * * -! * call mym_initialize * -! * | * -! * |<----------------+ * -! * | | * -! * call mym_condensation | * -! * call mym_turbulence | * -! * call mym_predict | * -! * | | * -! * |-----------------+ * -! * | * -! * end * -! * * -! * Variables worthy of special mention: * -! * tref : Reference temperature * -! * thl : Liquid water potential temperature * -! * qw : Total water (water vapor+liquid water) content * -! * ql : Liquid water content * -! * vt, vq : Functions for computing the buoyancy flux * -! * * -! * If the water contents are unnecessary, e.g., in the case of * -! * ocean models, thl is the potential temperature and qw, ql, vt * -! * and vq are all zero. * -! * * -! * Grid arrangement: * -! * k+1 +---------+ * -! * | | i = 1 - nx * -! * (k) | * | j = 1 - ny * -! * | | k = 1 - nz * -! * k +---------+ * -! * i (i) i+1 * -! * * -! * All the predicted variables are defined at the center (*) of * -! * the grid boxes. The diffusivity coefficients are, however, * -! * defined on the walls of the grid boxes. * -! * # Upper boundary values are given at k=nz. * -! * * -! * References: * -! * 1. Nakanishi, M., 2001: * -! * Boundary-Layer Meteor., 99, 349-378. * -! * 2. Nakanishi, M. and H. Niino, 2004: * -! * Boundary-Layer Meteor., 112, 1-31. * -! * 3. Nakanishi, M. and H. Niino, 2006: * -! * Boundary-Layer Meteor., (in press). * -! * 4. Nakanishi, M. and H. Niino, 2009: * -! * Jour. Meteor. Soc. Japan, 87, 895-912. * -! ********************************************************************** -! -! SUBROUTINE mym_initialize: -! -! Input variables: -! iniflag : <>0; turbulent quantities will be initialized -! = 0; turbulent quantities have been already -! given, i.e., they will not be initialized -! mx, my : Maximum numbers of grid boxes -! in the x and y directions, respectively -! nx, ny, nz : Numbers of the actual grid boxes -! in the x, y and z directions, respectively -! tref : Reference temperature (K) -! dz(nz) : Vertical grid spacings (m) -! # dz(nz)=dz(nz-1) -! zw(nz+1) : Heights of the walls of the grid boxes (m) -! # zw(1)=0.0 and zw(k)=zw(k-1)+dz(k-1) -! h(mx,ny) : G^(1/2) in the terrain-following coordinate -! # h=1-zg/zt, where zg is the height of the -! terrain and zt the top of the model domain -! pi0(mx,my,nz) : Exner function at zw*h+zg (J/kg K) -! defined by c_p*( p_basic/1000hPa )^kappa -! This is usually computed by integrating -! d(pi0)/dz = -h*g/tref. -! rmo(mx,ny) : Inverse of the Obukhov length (m^(-1)) -! flt, flq(mx,ny) : Turbulent fluxes of sensible and latent heat, -! respectively, e.g., flt=-u_*Theta_* (K m/s) -!! flt - liquid water potential temperature surface flux -!! flq - total water flux surface flux -! ust(mx,ny) : Friction velocity (m/s) -! pmz(mx,ny) : phi_m-zeta at z1*h+z0, where z1 (=0.5*dz(1)) -! is the first grid point above the surafce, z0 -! the roughness length and zeta=(z1*h+z0)*rmo -! phh(mx,ny) : phi_h at z1*h+z0 -! u, v(mx,my,nz): Components of the horizontal wind (m/s) -! thl(mx,my,nz) : Liquid water potential temperature -! (K) -! qw(mx,my,nz) : Total water content Q_w (kg/kg) -! -! Output variables: -! ql(mx,my,nz) : Liquid water content (kg/kg) -! v?(mx,my,nz) : Functions for computing the buoyancy flux -! qke(mx,my,nz) : Twice the turbulent kinetic energy q^2 -! (m^2/s^2) -! tsq(mx,my,nz) : Variance of Theta_l (K^2) -! qsq(mx,my,nz) : Variance of Q_w -! cov(mx,my,nz) : Covariance of Theta_l and Q_w (K) -! el(mx,my,nz) : Master length scale L (m) -! defined on the walls of the grid boxes -! bsh : no longer used -! via common : Closure constants -! -! Work arrays: see subroutine mym_level2 -! pd?(mx,my,nz) : Half of the production terms at Level 2 -! defined on the walls of the grid boxes -! qkw(mx,my,nz) : q on the walls of the grid boxes (m/s) -! -! # As to dtl, ...gh, see subroutine mym_turbulence. -! -!------------------------------------------------------------------- - SUBROUTINE mym_initialize ( kts,kte,& - & dz, zw, & - & u, v, thl, qw, & -! & ust, rmo, pmz, phh, flt, flq,& -!JOE-BouLac/PBLH mod - & zi,theta,& - & sh,& -!JOE-end - & ust, rmo, el,& - & Qke, Tsq, Qsq, Cov) -! -!------------------------------------------------------------------- - - INTEGER, INTENT(IN) :: kts,kte -! REAL, INTENT(IN) :: ust, rmo, pmz, phh, flt, flq - REAL, INTENT(IN) :: ust, rmo - REAL, DIMENSION(kts:kte), INTENT(in) :: dz - REAL, DIMENSION(kts:kte+1), INTENT(in) :: zw - REAL, DIMENSION(kts:kte), INTENT(in) :: u,v,thl,qw - - REAL, DIMENSION(kts:kte), INTENT(out) :: tsq,qsq,cov - REAL, DIMENSION(kts:kte), INTENT(inout) :: el,qke - - REAL, DIMENSION(kts:kte) :: & - &ql,pdk,pdt,pdq,pdc,dtl,dqw,dtv,& - &gm,gh,sm,sh,qkw,vt,vq - INTEGER :: k,l,lmax - REAL :: phm,vkz,elq,elv,b1l,b2l,pmz=1.,phh=1.,flt=0.,flq=0.,tmpq -!JOE-BouLac and PBLH mod - REAL :: zi - REAL, DIMENSION(kts:kte) :: theta -!JOE-end - - -! ** At first ql, vt and vq are set to zero. ** - DO k = kts,kte - ql(k) = 0.0 - vt(k) = 0.0 - vq(k) = 0.0 - END DO -! - CALL mym_level2 ( kts,kte,& - & dz, & - & u, v, thl, qw, & - & ql, vt, vq, & - & dtl, dqw, dtv, gm, gh, sm, sh ) -! -! ** Preliminary setting ** - - el (kts) = 0.0 - qke(kts) = ust**2 * ( b1*pmz )**(2.0/3.0) -! - phm = phh*b2 / ( b1*pmz )**(1.0/3.0) - tsq(kts) = phm*( flt/ust )**2 - qsq(kts) = phm*( flq/ust )**2 - cov(kts) = phm*( flt/ust )*( flq/ust ) -! - DO k = kts+1,kte - vkz = vk*zw(k) - el (k) = vkz/( 1.0 + vkz/100.0 ) - qke(k) = 0.0 -! - tsq(k) = 0.0 - qsq(k) = 0.0 - cov(k) = 0.0 - END DO -! -! ** Initialization with an iterative manner ** -! ** lmax is the iteration count. This is arbitrary. ** - lmax = 5 -! - DO l = 1,lmax -! - CALL mym_length ( kts,kte,& - & dz, zw, & - & rmo, flt, flq, & - & vt, vq, & - & qke, & - & dtv, & - & el, & -!JOE-added for BouLac/PBHL - & zi,theta,& -!JOE-end - & qkw) -! - DO k = kts+1,kte - elq = el(k)*qkw(k) - pdk(k) = elq*( sm(k)*gm (k)+& - &sh(k)*gh (k) ) - pdt(k) = elq* sh(k)*dtl(k)**2 - pdq(k) = elq* sh(k)*dqw(k)**2 - pdc(k) = elq* sh(k)*dtl(k)*dqw(k) - END DO -! -! ** Strictly, vkz*h(i,j) -> vk*( 0.5*dz(1)*h(i,j)+z0 ) ** - vkz = vk*0.5*dz(kts) -! - elv = 0.5*( el(kts+1)+el(kts) ) / vkz - qke(kts) = ust**2 * ( b1*pmz*elv )**(2.0/3.0) -! - phm = phh*b2 / ( b1*pmz/elv**2 )**(1.0/3.0) - tsq(kts) = phm*( flt/ust )**2 - qsq(kts) = phm*( flq/ust )**2 - cov(kts) = phm*( flt/ust )*( flq/ust ) -! - DO k = kts+1,kte-1 - b1l = b1*0.25*( el(k+1)+el(k) ) - tmpq=MAX(b1l*( pdk(k+1)+pdk(k) ),qkemin) -! PRINT *,'tmpqqqqq',tmpq,pdk(k+1),pdk(k) - qke(k) = tmpq**(2.0/3.0) - -! - IF ( qke(k) .LE. 0.0 ) THEN - b2l = 0.0 - ELSE - b2l = b2*( b1l/b1 ) / SQRT( qke(k) ) - END IF -! - tsq(k) = b2l*( pdt(k+1)+pdt(k) ) - qsq(k) = b2l*( pdq(k+1)+pdq(k) ) - cov(k) = b2l*( pdc(k+1)+pdc(k) ) - END DO - -! - END DO - -!! qke(kts)=qke(kts+1) -!! tsq(kts)=tsq(kts+1) -!! qsq(kts)=qsq(kts+1) -!! cov(kts)=cov(kts+1) - - qke(kte)=qke(kte-1) - tsq(kte)=tsq(kte-1) - qsq(kte)=qsq(kte-1) - cov(kte)=cov(kte-1) - -! -! RETURN - - END SUBROUTINE mym_initialize - -! -! ================================================================== -! SUBROUTINE mym_level2: -! -! Input variables: see subroutine mym_initialize -! -! Output variables: -! dtl(mx,my,nz) : Vertical gradient of Theta_l (K/m) -! dqw(mx,my,nz) : Vertical gradient of Q_w -! dtv(mx,my,nz) : Vertical gradient of Theta_V (K/m) -! gm (mx,my,nz) : G_M divided by L^2/q^2 (s^(-2)) -! gh (mx,my,nz) : G_H divided by L^2/q^2 (s^(-2)) -! sm (mx,my,nz) : Stability function for momentum, at Level 2 -! sh (mx,my,nz) : Stability function for heat, at Level 2 -! -! These are defined on the walls of the grid boxes. -! - SUBROUTINE mym_level2 (kts,kte,& - & dz, & - & u, v, thl, qw, & - & ql, vt, vq, & - & dtl, dqw, dtv, gm, gh, sm, sh ) -! -!------------------------------------------------------------------- - - INTEGER, INTENT(IN) :: kts,kte - REAL, DIMENSION(kts:kte), INTENT(in) :: dz - REAL, DIMENSION(kts:kte), INTENT(in) :: u,v,thl,qw,ql,vt,vq - - REAL, DIMENSION(kts:kte), INTENT(out) :: & - &dtl,dqw,dtv,gm,gh,sm,sh - - INTEGER :: k - - REAL :: rfc,f1,f2,rf1,rf2,smc,shc,& - &ri1,ri2,ri3,ri4,duz,dtz,dqz,vtt,vqq,dtq,dzk,afk,abk,ri,rf - -!JOE-Canuto/Kitamura mod - REAL :: a2den -!JOE-end - -! ev = 2.5e6 -! tv0 = 0.61*tref -! tv1 = 1.61*tref -! gtr = 9.81/tref -! - rfc = g1/( g1+g2 ) - f1 = b1*( g1-c1 ) +3.0*a2*( 1.0 -c2 )*( 1.0-c5 ) & - & +2.0*a1*( 3.0-2.0*c2 ) - f2 = b1*( g1+g2 ) -3.0*a1*( 1.0 -c2 ) - rf1 = b1*( g1-c1 )/f1 - rf2 = b1* g1 /f2 - smc = a1 /a2* f1/f2 - shc = 3.0*a2*( g1+g2 ) -! - ri1 = 0.5/smc - ri2 = rf1*smc - ri3 = 4.0*rf2*smc -2.0*ri2 - ri4 = ri2**2 -! - DO k = kts+1,kte - dzk = 0.5 *( dz(k)+dz(k-1) ) - afk = dz(k)/( dz(k)+dz(k-1) ) - abk = 1.0 -afk - duz = ( u(k)-u(k-1) )**2 +( v(k)-v(k-1) )**2 - duz = duz /dzk**2 - dtz = ( thl(k)-thl(k-1) )/( dzk ) - dqz = ( qw(k)-qw(k-1) )/( dzk ) -! - vtt = 1.0 +vt(k)*abk +vt(k-1)*afk - vqq = tv0 +vq(k)*abk +vq(k-1)*afk - dtq = vtt*dtz +vqq*dqz -! - dtl(k) = dtz - dqw(k) = dqz - dtv(k) = dtq -!? dtv(i,j,k) = dtz +tv0*dqz -!? : +( ev/pi0(i,j,k)-tv1 ) -!? : *( ql(i,j,k)-ql(i,j,k-1) )/( dzk*h(i,j) ) -! - gm (k) = duz - gh (k) = -dtq*gtr -! -! ** Gradient Richardson number ** - ri = -gh(k)/MAX( duz, 1.0e-10 ) - -!JOE-Canuto/Kitamura mod - IF (CKmod .eq. 1) THEN - a2den = 1. + MAX(ri,0.0) - ELSE - a2den = 1. + 0.0 - ENDIF - - rfc = g1/( g1+g2 ) - f1 = b1*( g1-c1 ) +3.0*(a2/a2den)*( 1.0 -c2 )*( 1.0-c5 ) & - & +2.0*a1*( 3.0-2.0*c2 ) - f2 = b1*( g1+g2 ) -3.0*a1*( 1.0 -c2 ) - rf1 = b1*( g1-c1 )/f1 - rf2 = b1* g1 /f2 - smc = a1 /(a2/a2den)* f1/f2 - shc = 3.0*(a2/a2den)*( g1+g2 ) - - ri1 = 0.5/smc - ri2 = rf1*smc - ri3 = 4.0*rf2*smc -2.0*ri2 - ri4 = ri2**2 -!JOE-end - -! ** Flux Richardson number ** - rf = MIN( ri1*( ri+ri2-SQRT(ri**2-ri3*ri+ri4) ), rfc ) -! - sh (k) = shc*( rfc-rf )/( 1.0-rf ) - sm (k) = smc*( rf1-rf )/( rf2-rf ) * sh(k) - END DO -! - RETURN - - END SUBROUTINE mym_level2 - -! ================================================================== -! SUBROUTINE mym_length: -! -! Input variables: see subroutine mym_initialize -! -! Output variables: see subroutine mym_initialize -! -! Work arrays: -! elt(mx,ny) : Length scale depending on the PBL depth (m) -! vsc(mx,ny) : Velocity scale q_c (m/s) -! at first, used for computing elt -! -! NOTE: the mixing lengths are meant to be calculated at the full- -! sigmal levels (or interfaces beween the model layers). -! - SUBROUTINE mym_length ( kts,kte,& - & dz, zw, & - & rmo, flt, flq, & - & vt, vq, & - & qke, & - & dtv, & - & el, & - & zi,theta,& !JOE-BouLac mod - & qkw) - -!------------------------------------------------------------------- - - INTEGER, INTENT(IN) :: kts,kte - REAL, DIMENSION(kts:kte), INTENT(in) :: dz - REAL, DIMENSION(kts:kte+1), INTENT(in) :: zw - REAL, INTENT(in) :: rmo,flt,flq - REAL, DIMENSION(kts:kte), INTENT(IN) :: qke,vt,vq - - REAL, DIMENSION(kts:kte), INTENT(out) :: qkw, el - REAL, DIMENSION(kts:kte), INTENT(in) :: dtv - - REAL :: elt,vsc -!JOE-added for BouLac ML - REAL, DIMENSION(kts:kte), INTENT(IN) :: theta - REAL, DIMENSION(kts:kte) :: qtke,elBLmin,elBLavg,thetaw - REAL :: wt,zi,zi2,h1,h2 - - !THE FOLLOWING LIMITS DO NOT DIRECTLY AFFECT THE ACTUAL PBLH. - !THEY ONLY IMPOSE LIMITS ON THE CALCULATION OF THE MIXING LENGTH - !SCALES SO THAT THE BOULAC MIXING LENGTH (IN FREE ATMOS) DOES - !NOT ENCROACH UPON THE BOUNDARY LAYER MIXING LENGTH (els, elb & elt). - REAL, PARAMETER :: minzi = 300. !min mixed-layer height - REAL, PARAMETER :: maxdz = 750. !max (half) transition layer depth - !=0.3*2500 m PBLH, so the transition - !layer stops growing for PBLHs > 2.5 km. - REAL, PARAMETER :: mindz = 300. !min (half) transition layer depth - - !SURFACE LAYER LENGTH SCALE MODS TO REDUCE IMPACT IN UPPER BOUNDARY LAYER - REAL, PARAMETER :: ZSLH = 100. ! Max height correlated to surface conditions (m) - REAL, PARAMETER :: CSL = 2. ! CSL = constant of proportionality to L O(1) - REAL :: z_m - -!Joe-end - - INTEGER :: i,j,k - REAL :: afk,abk,zwk,dzk,qdz,vflx,bv,elb,els,elf - -! tv0 = 0.61*tref -! gtr = 9.81/tref -! -!JOE-added to impose limits on the height integration for elt as well -! as the transition layer depth - IF ( BLmod .EQ. 0. ) THEN - zi2=5000. !originally integrated to model top, not just 5000 m. - ELSE - zi2=MAX(zi,minzi) - ENDIF - h1=MAX(0.3*zi2,mindz) - h1=MIN(h1,maxdz) ! 1/2 transition layer depth - h2=h1/2.0 ! 1/4 transition layer depth - - qtke(kts)=MAX(qke(kts)/2.,0.01) !tke at full sigma levels - thetaw(kts)=theta(kts) !theta at full-sigma levels -!JOE-end - qkw(kts) = SQRT(MAX(qke(kts),1.0e-10)) - - DO k = kts+1,kte - afk = dz(k)/( dz(k)+dz(k-1) ) - abk = 1.0 -afk - qkw(k) = SQRT(MAX(qke(k)*abk+qke(k-1)*afk,1.0e-3)) - -!JOE- BouLac Start - qtke(k) = (qkw(k)**2.)/2. ! q -> TKE - thetaw(k)= theta(k)*abk + theta(k-1)*afk -!JOE- BouLac End - - END DO -! - elt = 1.0e-5 - vsc = 1.0e-5 -! -! ** Strictly, zwk*h(i,j) -> ( zwk*h(i,j)+z0 ) ** -!JOE-Lt mod: only integrate to top of PBL (+ transition/entrainment -! layer), since TKE aloft is not relevant. Make WHILE loop, so it -! exits after looping through the boundary layer. -! - k = kts+1 - zwk = zw(k) - DO WHILE (zwk .LE. MIN((zi2+h1), 4000.)) !JOE: 20130523 reduce too high diffusivity over mts - dzk = 0.5*( dz(k)+dz(k-1) ) - qdz = MAX( qkw(k)-qmin, 0.03 )*dzk - elt = elt +qdz*zwk - vsc = vsc +qdz - k = k+1 - zwk = zw(k) - END DO -! - elt = alp1*elt/vsc - vflx = ( vt(kts)+1.0 )*flt +( vq(kts)+tv0 )*flq - vsc = ( gtr*elt*MAX( vflx, 0.0 ) )**(1.0/3.0) -! -! ** Strictly, el(i,j,1) is not zero. ** - el(kts) = 0.0 -! -!JOE- BouLac Start - IF ( BLmod .GT. 0. ) THEN - ! COMPUTE BouLac mixing length - CALL boulac_length(kts,kte,zw,dz,qtke,thetaw,elBLmin,elBLavg) - ENDIF -!JOE- BouLac END - - DO k = kts+1,kte - zwk = zw(k) !full-sigma levels - -! ** Length scale limited by the buoyancy effect ** - IF ( dtv(k) .GT. 0.0 ) THEN - bv = SQRT( gtr*dtv(k) ) - elb = alp2*qkw(k) / bv & - & *( 1.0 + alp3/alp2*& - &SQRT( vsc/( bv*elt ) ) ) - - elf = alp2 * qkw(k)/bv - ELSE - elb = 1.0e10 - elf = elb - END IF -! - z_m = MAX(ZSLH,CSL*zwk*rmo) - -! ** Length scale in the surface layer ** - IF ( rmo .GT. 0.0 ) THEN - ! IF ( zwk <= z_m ) THEN ! use original cns - els = vk*zwk/(1.0+cns*MIN( zwk*rmo, zmax )) - !els = vk*zwk/(1.0+cns*MIN( 0.5*zw(kts+1)*rmo, zmax )) - ! ELSE - ! !blend to neutral values (kz) above z_m - ! els = vk*z_m/(1.0+cns*MIN( zwk*rmo, zmax )) + vk*(zwk - z_m) - ! ENDIF - ELSE - els = vk*zwk*( 1.0 - alp4* zwk*rmo )**0.2 - END IF -! -! ** HARMONC AVERGING OF MIXING LENGTH SCALES: -! el(k) = MIN(elb/( elb/elt+elb/els+1.0 ),elf) -! el(k) = elb/( elb/elt+elb/els+1.0 ) -!JOE- BouLac Start - IF ( BLmod .EQ. 0. ) THEN - el(k) = MIN(elb/( elb/elt+elb/els+1.0 ),elf) - ELSE - !add blending to use BouLac mixing length in free atmos; - !defined relative to the PBLH (zi) + transition layer (h1) - el(k) = MIN(elb/( elb/elt+elb/els+1.0 ),elf) - wt=.5*TANH((zwk - (zi2+h1))/h2) + .5 - el(k) = el(k)*(1.-wt) + alp5*elBLmin(k)*wt - ENDIF -!JOE- BouLac End - - !IF (el(k) > 1000.) THEN - ! print*,"SUSPICIOUSLY LARGE Lm:",el(k),k - !ENDIF - END DO -! - RETURN - - END SUBROUTINE mym_length - -!JOE- BouLac Code Start - -! ================================================================== - SUBROUTINE boulac_length(kts,kte,zw,dz,qtke,theta,lb1,lb2) -! -! NOTE: This subroutine was taken from the BouLac scheme in WRF-ARW -! and modified for integration into the MYNN PBL scheme. -! WHILE loops were added to reduce the computational expense. -! This subroutine computes the length scales up and down -! and then computes the min, average of the up/down -! length scales, and also considers the distance to the -! surface. -! -! dlu = the distance a parcel can be lifted upwards give a finite -! amount of TKE. -! dld = the distance a parcel can be displaced downwards given a -! finite amount of TKE. -! lb1 = the minimum of the length up and length down -! lb2 = the average of the length up and length down -!------------------------------------------------------------------- - - INTEGER, INTENT(IN) :: kts,kte - REAL, DIMENSION(kts:kte), INTENT(IN) :: qtke,dz,theta - REAL, DIMENSION(kts:kte), INTENT(OUT) :: lb1,lb2 - REAL, DIMENSION(kts:kte+1), INTENT(IN) :: zw - - !LOCAL VARS - INTEGER :: iz, izz, found - REAL, DIMENSION(kts:kte) :: dlu,dld - REAL, PARAMETER :: Lmax=2000. !soft limit - REAL :: dzt, zup, beta, zup_inf, bbb, tl, zdo, zdo_sup, zzz - - !print*,"IN MYNN-BouLac",kts, kte - - do iz=kts,kte - - !---------------------------------- - ! FIND DISTANCE UPWARD - !---------------------------------- - zup=0. - dlu(iz)=zw(kte+1)-zw(iz)-dz(iz)/2. - zzz=0. - zup_inf=0. - beta=g/theta(iz) !Buoyancy coefficient - - !print*,"FINDING Dup, k=",iz," zw=",zw(iz) - - if (iz .lt. kte) then !cant integrate upwards from highest level - - found = 0 - izz=iz - DO WHILE (found .EQ. 0) - - if (izz .lt. kte) then - dzt=dz(izz) ! layer depth above - zup=zup-beta*theta(iz)*dzt ! initial PE the parcel has at iz - !print*," ",iz,izz,theta(izz),dz(izz) - zup=zup+beta*(theta(izz+1)+theta(izz))*dzt/2. ! PE gained by lifting a parcel to izz+1 - zzz=zzz+dzt ! depth of layer iz to izz+1 - !print*," PE=",zup," TKE=",qtke(iz)," z=",zw(izz) - if (qtke(iz).lt.zup .and. qtke(iz).ge.zup_inf) then - bbb=(theta(izz+1)-theta(izz))/dzt - if (bbb .ne. 0.) then - !fractional distance up into the layer where TKE becomes < PE - tl=(-beta*(theta(izz)-theta(iz)) + & - & sqrt( max(0.,(beta*(theta(izz)-theta(iz)))**2. + & - & 2.*bbb*beta*(qtke(iz)-zup_inf))))/bbb/beta - else - if (theta(izz) .ne. theta(iz))then - tl=(qtke(iz)-zup_inf)/(beta*(theta(izz)-theta(iz))) - else - tl=0. - endif - endif - dlu(iz)=zzz-dzt+tl - !print*," FOUND Dup:",dlu(iz)," z=",zw(izz)," tl=",tl - found =1 - endif - zup_inf=zup - izz=izz+1 - ELSE - found = 1 - ENDIF - - ENDDO - - endif - - !---------------------------------- - ! FIND DISTANCE DOWN - !---------------------------------- - zdo=0. - zdo_sup=0. - dld(iz)=zw(iz) - zzz=0. - - !print*,"FINDING Ddown, k=",iz," zwk=",zw(iz) - if (iz .gt. kts) then !cant integrate downwards from lowest level - - found = 0 - izz=iz - DO WHILE (found .EQ. 0) - - if (izz .gt. kts) then - dzt=dz(izz-1) - zdo=zdo+beta*theta(iz)*dzt - !print*," ",iz,izz,theta(izz),dz(izz-1) - zdo=zdo-beta*(theta(izz-1)+theta(izz))*dzt/2. - zzz=zzz+dzt - !print*," PE=",zdo," TKE=",qtke(iz)," z=",zw(izz) - if (qtke(iz).lt.zdo .and. qtke(iz).ge.zdo_sup) then - bbb=(theta(izz)-theta(izz-1))/dzt - if (bbb .ne. 0.) then - tl=(beta*(theta(izz)-theta(iz))+ & - & sqrt( max(0.,(beta*(theta(izz)-theta(iz)))**2. + & - & 2.*bbb*beta*(qtke(iz)-zdo_sup))))/bbb/beta - else - if (theta(izz) .ne. theta(iz)) then - tl=(qtke(iz)-zdo_sup)/(beta*(theta(izz)-theta(iz))) - else - tl=0. - endif - endif - dld(iz)=zzz-dzt+tl - !print*," FOUND Ddown:",dld(iz)," z=",zw(izz)," tl=",tl - found = 1 - endif - zdo_sup=zdo - izz=izz-1 - ELSE - found = 1 - ENDIF - ENDDO - - endif - - !---------------------------------- - ! GET MINIMUM (OR AVERAGE) - !---------------------------------- - !The surface layer length scale can exceed z for large z/L, - !so keep maximum distance down > z. - dld(iz) = min(dld(iz),zw(iz+1))!not used in PBL anyway, only free atmos - lb1(iz) = min(dlu(iz),dld(iz)) !minimum - lb2(iz) = sqrt(dlu(iz)*dld(iz)) !average - biased towards smallest - !lb2(iz) = 0.5*(dlu(iz)+dld(iz)) !average - - !Apply soft limit (only impacts very large lb; lb=100 by 5%, lb=500 by 20%). - lb1(iz) = lb1(iz)/(1. + (lb1(iz)/Lmax)) - lb2(iz) = lb2(iz)/(1. + (lb2(iz)/Lmax)) - - if (iz .eq. kte) then - lb1(kte) = lb1(kte-1) - lb2(kte) = lb2(kte-1) - endif - !print*,"IN MYNN-BouLac",kts, kte,lb1(iz) - !print*,"IN MYNN-BouLac",iz,dld(iz),dlu(iz) - - ENDDO - - END SUBROUTINE boulac_length -! -!JOE-END BOULAC CODE - -! ================================================================== -! SUBROUTINE mym_turbulence: -! -! Input variables: see subroutine mym_initialize -! levflag : <>3; Level 2.5 -! = 3; Level 3 -! -! # ql, vt, vq, qke, tsq, qsq and cov are changed to input variables. -! -! Output variables: see subroutine mym_initialize -! dfm(mx,my,nz) : Diffusivity coefficient for momentum, -! divided by dz (not dz*h(i,j)) (m/s) -! dfh(mx,my,nz) : Diffusivity coefficient for heat, -! divided by dz (not dz*h(i,j)) (m/s) -! dfq(mx,my,nz) : Diffusivity coefficient for q^2, -! divided by dz (not dz*h(i,j)) (m/s) -! tcd(mx,my,nz) : Countergradient diffusion term for Theta_l -! (K/s) -! qcd(mx,my,nz) : Countergradient diffusion term for Q_w -! (kg/kg s) -! pd?(mx,my,nz) : Half of the production terms -! -! Only tcd and qcd are defined at the center of the grid boxes -! -! # DO NOT forget that tcd and qcd are added on the right-hand side -! of the equations for Theta_l and Q_w, respectively. -! -! Work arrays: see subroutine mym_initialize and level2 -! -! # dtl, dqw, dtv, gm and gh are allowed to share storage units with -! dfm, dfh, dfq, tcd and qcd, respectively, for saving memory. -! - SUBROUTINE mym_turbulence ( kts,kte,& - & levflag, & - & dz, zw, & - & u, v, thl, ql, qw, & - & qke, tsq, qsq, cov, & - & vt, vq,& - & rmo, flt, flq, & -!JOE-BouLac/PBLH test - & zi,theta,& - & sh,& -!JOE-end - & El,& - & Dfm, Dfh, Dfq, Tcd, Qcd, Pdk, Pdt, Pdq, Pdc & -!JOE-TKE BUDGET - & ,qWT1D,qSHEAR1D,qBUOY1D,qDISS1D & - & ,bl_mynn_tkebudget & -!JOE-end - &) - -!------------------------------------------------------------------- -! - INTEGER, INTENT(IN) :: kts,kte - INTEGER, INTENT(IN) :: levflag - REAL, DIMENSION(kts:kte), INTENT(in) :: dz - REAL, DIMENSION(kts:kte+1), INTENT(in) :: zw - REAL, INTENT(in) :: rmo,flt,flq - REAL, DIMENSION(kts:kte), INTENT(in) :: u,v,thl,qw,& - &ql,vt,vq,qke,tsq,qsq,cov - - REAL, DIMENSION(kts:kte), INTENT(out) :: dfm,dfh,dfq,& - &pdk,pdt,pdq,pdc,tcd,qcd,el - -!JOE-TKE BUDGET - REAL, DIMENSION(kts:kte), INTENT(inout) :: & - qWT1D,qSHEAR1D,qBUOY1D,qDISS1D - REAL :: q3sq_old,dlsq1,qWTP_old,qWTP_new - REAL :: dudz,dvdz,dTdz,& - upwp,vpwp,Tpwp - INTEGER, INTENT(in) :: bl_mynn_tkebudget -!JOE-end - - REAL, DIMENSION(kts:kte) :: qkw,dtl,dqw,dtv,gm,gh,sm,sh - - INTEGER :: k -! REAL :: cc2,cc3,e1c,e2c,e3c,e4c,e5c - REAL :: e6c,dzk,afk,abk,vtt,vqq,& - &cw25,clow,cupp,gamt,gamq,smd,gamv,elq,elh - -!JOE-added for BouLac/PBLH test - REAL :: zi - REAL, DIMENSION(kts:kte), INTENT(in) :: theta -!JOE-end - - REAL :: a2den, duz, ri, HLmod !JOE-Canuto/Kitamura mod - - DOUBLE PRECISION q2sq, t2sq, r2sq, c2sq, elsq, gmel, ghel - DOUBLE PRECISION q3sq, t3sq, r3sq, c3sq, dlsq, qdiv - DOUBLE PRECISION e1, e2, e3, e4, enum, eden, wden -! -! tv0 = 0.61*tref -! gtr = 9.81/tref -! -! cc2 = 1.0-c2 -! cc3 = 1.0-c3 -! e1c = 3.0*a2*b2*cc3 -! e2c = 9.0*a1*a2*cc2 -! e3c = 9.0*a2*a2*cc2*( 1.0-c5 ) -! e4c = 12.0*a1*a2*cc2 -! e5c = 6.0*a1*a1 -! - - CALL mym_level2 (kts,kte,& - & dz, & - & u, v, thl, qw, & - & ql, vt, vq, & - & dtl, dqw, dtv, gm, gh, sm, sh ) -! - CALL mym_length (kts,kte, & - & dz, zw, & - & rmo, flt, flq, & - & vt, vq, & - & qke, & - & dtv, & - & el, & - & zi,theta,& !JOE-hybrid PBLH - & qkw) -! - - DO k = kts+1,kte - dzk = 0.5 *( dz(k)+dz(k-1) ) - afk = dz(k)/( dz(k)+dz(k-1) ) - abk = 1.0 -afk - elsq = el (k)**2 - q2sq = b1*elsq*( sm(k)*gm(k)+sh(k)*gh(k) ) - q3sq = qkw(k)**2 - -!JOE-Canuto/Kitamura mod - duz = ( u(k)-u(k-1) )**2 +( v(k)-v(k-1) )**2 - duz = duz /dzk**2 - ! ** Gradient Richardson number ** - ri = -gh(k)/MAX( duz, 1.0e-10 ) - IF (CKmod .eq. 1) THEN - a2den = 1. + MAX(ri,0.0) - ELSE - a2den = 1. + 0.0 - ENDIF -!JOE-end -! -! Modified: Dec/22/2005, from here, (dlsq -> elsq) - gmel = gm (k)*elsq - ghel = gh (k)*elsq -! Modified: Dec/22/2005, up to here -! -!JOE-add prints - IF (sh(k)<0.0 .OR. sm(k)<0.0) THEN - PRINT*,"MYM_TURBULENCE2.0: k=",k," sh=",sh(k) - PRINT*," gm=",gm(k)," gh=",gh(k)," sm=",sm(k) - PRINT*," q2sq=",q2sq," q3sq=",q3sq," q3/q2=",q3sq/q2sq - PRINT*," qke=",qke(k)," el=",el(k)," ri=",ri - PRINT*," PBLH=",zi," u=",u(k)," v=",v(k) - ENDIF -!JOE-Apply Helfand & Labraga stability check for all Ric -! when CKmod == 1. Suggested by Kitamura. Not applied below. - IF (CKmod .eq. 1) THEN - HLmod = q2sq -1. - ELSE - HLmod = q3sq - ENDIF -! ** Since qkw is set to more than 0.0, q3sq > 0.0. ** - IF ( q3sq .LT. q2sq ) THEN -! IF ( HLmod .LT. q2sq ) THEN -!JOE-END - qdiv = SQRT( q3sq/q2sq ) !HL89: (1-alfa) - sm(k) = sm(k) * qdiv - sh(k) = sh(k) * qdiv -! -!JOE-Canuto/Kitamura mod -! e1 = q3sq - e1c*ghel * qdiv**2 -! e2 = q3sq - e2c*ghel * qdiv**2 -! e3 = e1 + e3c*ghel * qdiv**2 -! e4 = e1 - e4c*ghel * qdiv**2 - e1 = q3sq - e1c*ghel/a2den * qdiv**2 - e2 = q3sq - e2c*ghel/a2den * qdiv**2 - e3 = e1 + e3c*ghel/(a2den**2) * qdiv**2 - e4 = e1 - e4c*ghel/a2den * qdiv**2 -!JOE-end - eden = e2*e4 + e3*e5c*gmel * qdiv**2 - eden = MAX( eden, 1.0d-20 ) - ELSE -!JOE-Canuto/Kitamura mod -! e1 = q3sq - e1c*ghel -! e2 = q3sq - e2c*ghel -! e3 = e1 + e3c*ghel -! e4 = e1 - e4c*ghel - e1 = q3sq - e1c*ghel/a2den - e2 = q3sq - e2c*ghel/a2den - e3 = e1 + e3c*ghel/(a2den**2) - e4 = e1 - e4c*ghel/a2den -!JOE-end - eden = e2*e4 + e3*e5c*gmel - eden = MAX( eden, 1.0d-20 ) -! - qdiv = 1.0 - sm(k) = q3sq*a1*( e3-3.0*c1*e4 )/eden -!JOE-Canuto/Kitamura mod -! sh(k) = q3sq*a2*( e2+3.0*c1*e5c*gmel )/eden - sh(k) = q3sq*(a2/a2den)*( e2+3.0*c1*e5c*gmel )/eden -!JOE-end - END IF -! -! HL88 , lev2.5 criteria from eqs. 3.17, 3.19, & 3.20 - IF (sh(k)<0.0 .OR. sm(k)<0.0 .OR. & - sh(k) > 0.76*b2 .or. (sm(k)**2*gm(k) .gt. .44**2)) THEN - PRINT*,"MYM_TURBULENCE2.5: k=",k," sh=",sh(k) - PRINT*," gm=",gm(k)," gh=",gh(k)," sm=",sm(k) - PRINT*," q2sq=",q2sq," q3sq=",q3sq," q3/q2=",q3sq/q2sq - PRINT*," qke=",qke(k)," el=",el(k)," ri=",ri - PRINT*," PBLH=",zi," u=",u(k)," v=",v(k) - ENDIF - -! ** Level 3 : start ** - IF ( levflag .EQ. 3 ) THEN - t2sq = qdiv*b2*elsq*sh(k)*dtl(k)**2 - r2sq = qdiv*b2*elsq*sh(k)*dqw(k)**2 - c2sq = qdiv*b2*elsq*sh(k)*dtl(k)*dqw(k) - t3sq = MAX( tsq(k)*abk+tsq(k-1)*afk, 0.0 ) - r3sq = MAX( qsq(k)*abk+qsq(k-1)*afk, 0.0 ) - c3sq = cov(k)*abk+cov(k-1)*afk -! -! Modified: Dec/22/2005, from here - c3sq = SIGN( MIN( ABS(c3sq), SQRT(t3sq*r3sq) ), c3sq ) -! - vtt = 1.0 +vt(k)*abk +vt(k-1)*afk - vqq = tv0 +vq(k)*abk +vq(k-1)*afk - t2sq = vtt*t2sq +vqq*c2sq - r2sq = vtt*c2sq +vqq*r2sq - c2sq = MAX( vtt*t2sq+vqq*r2sq, 0.0d0 ) - t3sq = vtt*t3sq +vqq*c3sq - r3sq = vtt*c3sq +vqq*r3sq - c3sq = MAX( vtt*t3sq+vqq*r3sq, 0.0d0 ) -! - cw25 = e1*( e2 + 3.0*c1*e5c*gmel*qdiv**2 )/( 3.0*eden ) -! -! ** Limitation on q, instead of L/q ** - dlsq = elsq - IF ( q3sq/dlsq .LT. -gh(k) ) q3sq = -dlsq*gh(k) -! -! ** Limitation on c3sq (0.12 =< cw =< 0.76) ** -!JOE-Canuto/Kitamura mod -! e2 = q3sq - e2c*ghel * qdiv**2 -! e3 = q3sq + e3c*ghel * qdiv**2 -! e4 = q3sq - e4c*ghel * qdiv**2 - e2 = q3sq - e2c*ghel/a2den * qdiv**2 - e3 = q3sq + e3c*ghel/(a2den**2) * qdiv**2 - e4 = q3sq - e4c*ghel/a2den * qdiv**2 -!JOE-end - eden = e2*e4 + e3 *e5c*gmel * qdiv**2 -! -!JOE-Canuto/Kitamura mod -! wden = cc3*gtr**2 * dlsq**2/elsq * qdiv**2 & -! & *( e2*e4c - e3c*e5c*gmel * qdiv**2 ) - wden = cc3*gtr**2 * dlsq**2/elsq * qdiv**2 & - & *( e2*e4c/a2den - e3c*e5c*gmel/(a2den**2) * qdiv**2 ) -!JOE-end -! - IF ( wden .NE. 0.0 ) THEN - clow = q3sq*( 0.12-cw25 )*eden/wden - cupp = q3sq*( 0.76-cw25 )*eden/wden -! - IF ( wden .GT. 0.0 ) THEN - c3sq = MIN( MAX( c3sq, c2sq+clow ), c2sq+cupp ) - ELSE - c3sq = MAX( MIN( c3sq, c2sq+clow ), c2sq+cupp ) - END IF - END IF -! - e1 = e2 + e5c*gmel * qdiv**2 - eden = MAX( eden, 1.0d-20 ) -! Modified: Dec/22/2005, up to here -! -!JOE-Canuto/Kitamura mod -! e6c = 3.0*a2*cc3*gtr * dlsq/elsq - e6c = 3.0*(a2/a2den)*cc3*gtr * dlsq/elsq -!JOE-end -! -! ** for Gamma_theta ** -!! enum = qdiv*e6c*( t3sq-t2sq ) - IF ( t2sq .GE. 0.0 ) THEN - enum = MAX( qdiv*e6c*( t3sq-t2sq ), 0.0d0 ) - ELSE - enum = MIN( qdiv*e6c*( t3sq-t2sq ), 0.0d0 ) - ENDIF - - gamt =-e1 *enum /eden -! -! ** for Gamma_q ** -!! enum = qdiv*e6c*( r3sq-r2sq ) - IF ( r2sq .GE. 0.0 ) THEN - enum = MAX( qdiv*e6c*( r3sq-r2sq ), 0.0d0 ) - ELSE - enum = MIN( qdiv*e6c*( r3sq-r2sq ), 0.0d0 ) - ENDIF - - gamq =-e1 *enum /eden -! -! ** for Sm' and Sh'd(Theta_V)/dz ** -!! enum = qdiv*e6c*( c3sq-c2sq ) - enum = MAX( qdiv*e6c*( c3sq-c2sq ), 0.0d0) - -!JOE-Canuto/Kitamura mod -! smd = dlsq*enum*gtr/eden * qdiv**2 * (e3c+e4c)*a1/a2 - smd = dlsq*enum*gtr/eden * qdiv**2 * (e3c/(a2den**2) + & - & e4c/a2den)*a1/(a2/a2den) -!JOE-end - gamv = e1 *enum*gtr/eden -! - sm(k) = sm(k) +smd -! -! ** For elh (see below), qdiv at Level 3 is reset to 1.0. ** - qdiv = 1.0 -! ** Level 3 : end ** -! - IF (sh(k)<0.0 .OR. sm(k)<0.0) THEN - PRINT*,"MYM_TURBULENCE3.0: k=",k," sh=",sh(k) - PRINT*," gm=",gm(k)," gh=",gh(k)," sm=",sm(k) - PRINT*," q2sq=",q2sq," q3sq=",q3sq," q3/q2=",q3sq/q2sq - PRINT*," qke=",qke(k)," el=",el(k)," ri=",ri - PRINT*," PBLH=",zi," u=",u(k)," v=",v(k) - ENDIF - - ELSE -! ** At Level 2.5, qdiv is not reset. ** - gamt = 0.0 - gamq = 0.0 - gamv = 0.0 - END IF -! - elq = el(k)*qkw(k) - elh = elq*qdiv -! - pdk(k) = elq*( sm(k)*gm(k) & - & +sh(k)*gh(k)+gamv ) - pdt(k) = elh*( sh(k)*dtl(k)+gamt )*dtl(k) - pdq(k) = elh*( sh(k)*dqw(k)+gamq )*dqw(k) - pdc(k) = elh*( sh(k)*dtl(k)+gamt )& - &*dqw(k)*0.5 & - &+elh*( sh(k)*dqw(k)+gamq )*dtl(k)*0.5 -! - tcd(k) = elq*gamt - qcd(k) = elq*gamq -! - dfm(k) = elq*sm (k) / dzk - dfh(k) = elq*sh (k) / dzk -! Modified: Dec/22/2005, from here -! ** In sub.mym_predict, dfq for the TKE and scalar variance ** -! ** are set to 3.0*dfm and 1.0*dfm, respectively. (Sqfac) ** - dfq(k) = dfm(k) -! Modified: Dec/22/2005, up to here - - IF ( bl_mynn_tkebudget == 1) THEN - !TKE BUDGET - dudz = ( u(k)-u(k-1) )/dzk - dvdz = ( v(k)-v(k-1) )/dzk - dTdz = ( thl(k)-thl(k-1) )/dzk - - upwp = -elq*sm(k)*dudz - vpwp = -elq*sm(k)*dvdz - Tpwp = -elq*sh(k)*dTdz - Tpwp = SIGN(MAX(ABS(Tpwp),1.E-6),Tpwp) - - IF ( k .EQ. kts+1 ) THEN - qWT1D(kts)=0. - q3sq_old =0. - qWTP_old =0. - !** Limitation on q, instead of L/q ** - dlsq1 = MAX(el(kts)**2,1.0) - IF ( q3sq_old/dlsq1 .LT. -gh(k) ) q3sq_old = -dlsq1*gh(k) - ENDIF - - !!!Vertical Transport Term - qWTP_new = elq*Sqfac*sm(k)*(q3sq - q3sq_old)/dzk - qWT1D(k) = 0.5*(qWTP_new - qWTP_old)/dzk - qWTP_old = elq*Sqfac*sm(k)*(q3sq - q3sq_old)/dzk - q3sq_old = q3sq - - !!!Shear Term - !!!qSHEAR1D(k)=-(upwp*dudz + vpwp*dvdz) - qSHEAR1D(k) = elq*sm(k)*gm(k) - - !!!Buoyancy Term - !!!qBUOY1D(k)=g*Tpwp/thl(k) - !qBUOY1D(k)= elq*(sh(k)*gh(k) + gamv) - qBUOY1D(k) = elq*(sh(k)*(-dTdz*g/thl(k)) + gamv) - - !!!Dissipation Term - qDISS1D(k) = (q3sq**(3./2.))/(b1*MAX(el(k),1.)) - ENDIF - - END DO -! - - dfm(kts) = 0.0 - dfh(kts) = 0.0 - dfq(kts) = 0.0 - tcd(kts) = 0.0 - qcd(kts) = 0.0 - - tcd(kte) = 0.0 - qcd(kte) = 0.0 - -! - DO k = kts,kte-1 - dzk = dz(k) - tcd(k) = ( tcd(k+1)-tcd(k) )/( dzk ) - qcd(k) = ( qcd(k+1)-qcd(k) )/( dzk ) - END DO -! - - IF ( bl_mynn_tkebudget == 1) THEN - !JOE-TKE BUDGET - qWT1D(kts)=0. - qSHEAR1D(kts)=qSHEAR1D(kts+1) - qBUOY1D(kts)=qBUOY1D(kts+1) - qDISS1D(kts)=qDISS1D(kts+1) - ENDIF - - RETURN - - END SUBROUTINE mym_turbulence - -! ================================================================== -! SUBROUTINE mym_predict: -! -! Input variables: see subroutine mym_initialize and turbulence -! qke(mx,my,nz) : qke at (n)th time level -! tsq, ...cov : ditto -! -! Output variables: -! qke(mx,my,nz) : qke at (n+1)th time level -! tsq, ...cov : ditto -! -! Work arrays: -! qkw(mx,my,nz) : q at the center of the grid boxes (m/s) -! bp (mx,my,nz) : = 1/2*F, see below -! rp (mx,my,nz) : = P-1/2*F*Q, see below -! -! # The equation for a turbulent quantity Q can be expressed as -! dQ/dt + Ah + Av = Dh + Dv + P - F*Q, (1) -! where A is the advection, D the diffusion, P the production, -! F*Q the dissipation and h and v denote horizontal and vertical, -! respectively. If Q is q^2, F is 2q/B_1L. -! Using the Crank-Nicholson scheme for Av, Dv and F*Q, a finite -! difference equation is written as -! Q{n+1} - Q{n} = dt *( Dh{n} - Ah{n} + P{n} ) -! + dt/2*( Dv{n} - Av{n} - F*Q{n} ) -! + dt/2*( Dv{n+1} - Av{n+1} - F*Q{n+1} ), (2) -! where n denotes the time level. -! When the advection and diffusion terms are discretized as -! dt/2*( Dv - Av ) = a(k)Q(k+1) - b(k)Q(k) + c(k)Q(k-1), (3) -! Eq.(2) can be rewritten as -! - a(k)Q(k+1) + [ 1 + b(k) + dt/2*F ]Q(k) - c(k)Q(k-1) -! = Q{n} + dt *( Dh{n} - Ah{n} + P{n} ) -! + dt/2*( Dv{n} - Av{n} - F*Q{n} ), (4) -! where Q on the left-hand side is at (n+1)th time level. -! -! In this subroutine, a(k), b(k) and c(k) are obtained from -! subprogram coefvu and are passed to subprogram tinteg via -! common. 1/2*F and P-1/2*F*Q are stored in bp and rp, -! respectively. Subprogram tinteg solves Eq.(4). -! -! Modify this subroutine according to your numerical integration -! scheme (program). -! -!------------------------------------------------------------------- - SUBROUTINE mym_predict (kts,kte,& - & levflag, & - & delt,& - & dz, & - & ust, flt, flq, pmz, phh, & - & el, dfq, & - & pdk, pdt, pdq, pdc,& - & qke, tsq, qsq, cov & - &) - -!------------------------------------------------------------------- - INTEGER, INTENT(IN) :: kts,kte - INTEGER, INTENT(IN) :: levflag - REAL, INTENT(IN) :: delt - REAL, DIMENSION(kts:kte), INTENT(IN) :: dz, dfq,el - REAL, DIMENSION(kts:kte), INTENT(INOUT) :: pdk, pdt, pdq, pdc - REAL, INTENT(IN) :: flt, flq, ust, pmz, phh - REAL, DIMENSION(kts:kte), INTENT(INOUT) :: qke,tsq, qsq, cov - - INTEGER :: k,nz - REAL, DIMENSION(kts:kte) :: qkw, bp, rp, df3q - REAL :: vkz,pdk1,phm,pdt1,pdq1,pdc1,b1l,b2l - REAL, DIMENSION(kts:kte) :: dtz - REAL, DIMENSION(1:kte-kts+1) :: a,b,c,d - - nz=kte-kts+1 - -! ** Strictly, vkz*h(i,j) -> vk*( 0.5*dz(1)*h(i,j)+z0 ) ** - vkz = vk*0.5*dz(kts) -! -! Modified: Dec/22/2005, from here -! ** dfq for the TKE is 3.0*dfm. ** -! CALL coefvu ( dfq, 3.0 ) ! make change here -! Modified: Dec/22/2005, up to here -! - DO k = kts,kte -!! qke(k) = MAX(qke(k), 0.0) - qkw(k) = SQRT( MAX( qke(k), 0.0 ) ) - !df3q(k)=3.*dfq(k) - df3q(k)=Sqfac*dfq(k) - dtz(k)=delt/dz(k) - END DO -! - pdk1 = 2.0*ust**3*pmz/( vkz ) - phm = 2.0/ust *phh/( vkz ) - pdt1 = phm*flt**2 - pdq1 = phm*flq**2 - pdc1 = phm*flt*flq -! -! ** pdk(i,j,1)+pdk(i,j,2) corresponds to pdk1. ** - pdk(kts) = pdk1 -pdk(kts+1) - -!! pdt(kts) = pdt1 -pdt(kts+1) -!! pdq(kts) = pdq1 -pdq(kts+1) -!! pdc(kts) = pdc1 -pdc(kts+1) - pdt(kts) = pdt(kts+1) - pdq(kts) = pdq(kts+1) - pdc(kts) = pdc(kts+1) -! -! ** Prediction of twice the turbulent kinetic energy ** -!! DO k = kts+1,kte-1 - DO k = kts,kte-1 - b1l = b1*0.5*( el(k+1)+el(k) ) - bp(k) = 2.*qkw(k) / b1l - rp(k) = pdk(k+1) + pdk(k) - END DO - -!! a(1)=0. -!! b(1)=1. -!! c(1)=-1. -!! d(1)=0. - -! Since df3q(kts)=0.0, a(1)=0.0 and b(1)=1.+dtz(k)*df3q(k+1)+bp(k)*delt. - DO k=kts,kte-1 - a(k-kts+1)=-dtz(k)*df3q(k) - b(k-kts+1)=1.+dtz(k)*(df3q(k)+df3q(k+1))+bp(k)*delt - c(k-kts+1)=-dtz(k)*df3q(k+1) - d(k-kts+1)=rp(k)*delt + qke(k) - ENDDO - -!! DO k=kts+1,kte-1 -!! a(k-kts+1)=-dtz(k)*df3q(k) -!! b(k-kts+1)=1.+dtz(k)*(df3q(k)+df3q(k+1)) -!! c(k-kts+1)=-dtz(k)*df3q(k+1) -!! d(k-kts+1)=rp(k)*delt + qke(k) - qke(k)*bp(k)*delt -!! ENDDO - - a(nz)=-1. !0. - b(nz)=1. - c(nz)=0. - d(nz)=0. - - CALL tridiag(nz,a,b,c,d) - - DO k=kts,kte - qke(k)=d(k-kts+1) - ENDDO - - - IF ( levflag .EQ. 3 ) THEN -! -! Modified: Dec/22/2005, from here -! ** dfq for the scalar variance is 1.0*dfm. ** -! CALL coefvu ( dfq, 1.0 ) make change here -! Modified: Dec/22/2005, up to here -! -! ** Prediction of the temperature variance ** -!! DO k = kts+1,kte-1 - DO k = kts,kte-1 - b2l = b2*0.5*( el(k+1)+el(k) ) - bp(k) = 2.*qkw(k) / b2l - rp(k) = pdt(k+1) + pdt(k) - END DO - -!zero gradient for tsq at bottom and top - -!! a(1)=0. -!! b(1)=1. -!! c(1)=-1. -!! d(1)=0. - -! Since dfq(kts)=0.0, a(1)=0.0 and b(1)=1.+dtz(k)*dfq(k+1)+bp(k)*delt. - DO k=kts,kte-1 - a(k-kts+1)=-dtz(k)*dfq(k) - b(k-kts+1)=1.+dtz(k)*(dfq(k)+dfq(k+1))+bp(k)*delt - c(k-kts+1)=-dtz(k)*dfq(k+1) - d(k-kts+1)=rp(k)*delt + tsq(k) - ENDDO - -!! DO k=kts+1,kte-1 -!! a(k-kts+1)=-dtz(k)*dfq(k) -!! b(k-kts+1)=1.+dtz(k)*(dfq(k)+dfq(k+1)) -!! c(k-kts+1)=-dtz(k)*dfq(k+1) -!! d(k-kts+1)=rp(k)*delt + tsq(k) - tsq(k)*bp(k)*delt -!! ENDDO - - a(nz)=-1. !0. - b(nz)=1. - c(nz)=0. - d(nz)=0. - - CALL tridiag(nz,a,b,c,d) - - DO k=kts,kte - tsq(k)=d(k-kts+1) - ENDDO - -! ** Prediction of the moisture variance ** -!! DO k = kts+1,kte-1 - DO k = kts,kte-1 - b2l = b2*0.5*( el(k+1)+el(k) ) - bp(k) = 2.*qkw(k) / b2l - rp(k) = pdq(k+1) +pdq(k) - END DO - -!zero gradient for qsq at bottom and top - -!! a(1)=0. -!! b(1)=1. -!! c(1)=-1. -!! d(1)=0. - -! Since dfq(kts)=0.0, a(1)=0.0 and b(1)=1.+dtz(k)*dfq(k+1)+bp(k)*delt. - DO k=kts,kte-1 - a(k-kts+1)=-dtz(k)*dfq(k) - b(k-kts+1)=1.+dtz(k)*(dfq(k)+dfq(k+1))+bp(k)*delt - c(k-kts+1)=-dtz(k)*dfq(k+1) - d(k-kts+1)=rp(k)*delt + qsq(k) - ENDDO - -!! DO k=kts+1,kte-1 -!! a(k-kts+1)=-dtz(k)*dfq(k) -!! b(k-kts+1)=1.+dtz(k)*(dfq(k)+dfq(k+1)) -!! c(k-kts+1)=-dtz(k)*dfq(k+1) -!! d(k-kts+1)=rp(k)*delt + qsq(k) -qsq(k)*bp(k)*delt -!! ENDDO - - a(nz)=-1. !0. - b(nz)=1. - c(nz)=0. - d(nz)=0. - - CALL tridiag(nz,a,b,c,d) - - DO k=kts,kte - qsq(k)=d(k-kts+1) - ENDDO - -! ** Prediction of the temperature-moisture covariance ** -!! DO k = kts+1,kte-1 - DO k = kts,kte-1 - b2l = b2*0.5*( el(k+1)+el(k) ) - bp(k) = 2.*qkw(k) / b2l - rp(k) = pdc(k+1) + pdc(k) - END DO - -!zero gradient for tqcov at bottom and top - -!! a(1)=0. -!! b(1)=1. -!! c(1)=-1. -!! d(1)=0. - -! Since dfq(kts)=0.0, a(1)=0.0 and b(1)=1.+dtz(k)*dfq(k+1)+bp(k)*delt. - DO k=kts,kte-1 - a(k-kts+1)=-dtz(k)*dfq(k) - b(k-kts+1)=1.+dtz(k)*(dfq(k)+dfq(k+1))+bp(k)*delt - c(k-kts+1)=-dtz(k)*dfq(k+1) - d(k-kts+1)=rp(k)*delt + cov(k) - ENDDO - -!! DO k=kts+1,kte-1 -!! a(k-kts+1)=-dtz(k)*dfq(k) -!! b(k-kts+1)=1.+dtz(k)*(dfq(k)+dfq(k+1)) -!! c(k-kts+1)=-dtz(k)*dfq(k+1) -!! d(k-kts+1)=rp(k)*delt + cov(k) - cov(k)*bp(k)*delt -!! ENDDO - - a(nz)=-1. !0. - b(nz)=1. - c(nz)=0. - d(nz)=0. - - CALL tridiag(nz,a,b,c,d) - - DO k=kts,kte - cov(k)=d(k-kts+1) - ENDDO - - ELSE -!! DO k = kts+1,kte-1 - DO k = kts,kte-1 - IF ( qkw(k) .LE. 0.0 ) THEN - b2l = 0.0 - ELSE - b2l = b2*0.25*( el(k+1)+el(k) )/qkw(k) - END IF -! - tsq(k) = b2l*( pdt(k+1)+pdt(k) ) - qsq(k) = b2l*( pdq(k+1)+pdq(k) ) - cov(k) = b2l*( pdc(k+1)+pdc(k) ) - END DO - -!! tsq(kts)=tsq(kts+1) -!! qsq(kts)=qsq(kts+1) -!! cov(kts)=cov(kts+1) - - tsq(kte)=tsq(kte-1) - qsq(kte)=qsq(kte-1) - cov(kte)=cov(kte-1) - - END IF - - END SUBROUTINE mym_predict - -! ================================================================== -! SUBROUTINE mym_condensation: -! -! Input variables: see subroutine mym_initialize and turbulence -! exner(nz) : Perturbation of the Exner function (J/kg K) -! defined on the walls of the grid boxes -! This is usually computed by integrating -! d(pi)/dz = h*g*tv/tref**2 -! from the upper boundary, where tv is the -! virtual potential temperature minus tref. -! -! Output variables: see subroutine mym_initialize -! cld(mx,my,nz) : Cloud fraction -! -! Work arrays: -! qmq(mx,my,nz) : Q_w-Q_{sl}, where Q_{sl} is the saturation -! specific humidity at T=Tl -! alp(mx,my,nz) : Functions in the condensation process -! bet(mx,my,nz) : ditto -! sgm(mx,my,nz) : Combined standard deviation sigma_s -! multiplied by 2/alp -! -! # qmq, alp, bet and sgm are allowed to share storage units with -! any four of other work arrays for saving memory. -! -! # Results are sensitive particularly to values of cp and rd. -! Set these values to those adopted by you. -! -!------------------------------------------------------------------- - SUBROUTINE mym_condensation (kts,kte, & - & dz, & - & thl, qw, & - & p,exner, & - & tsq, qsq, cov, & - & Sh, el, bl_mynn_cloudpdf,& !JOE - cloud PDF testing - & Vt, Vq) - -!------------------------------------------------------------------- - INTEGER, INTENT(IN) :: kts,kte, bl_mynn_cloudpdf - - REAL, DIMENSION(kts:kte), INTENT(IN) :: dz - REAL, DIMENSION(kts:kte), INTENT(IN) :: p,exner, thl, qw, & - &tsq, qsq, cov - - REAL, DIMENSION(kts:kte), INTENT(OUT) :: vt,vq - - REAL, DIMENSION(kts:kte) :: qmq,alp,bet,sgm,ql,cld - - DOUBLE PRECISION :: t3sq, r3sq, c3sq -! - - REAL :: p2a,t,esl,qsl,dqsl,q1,cld0,eq1,qll,& - &q2p,pt,rac,qt - INTEGER :: i,j,k - - REAL :: erf - - !JOE: NEW VARIABLES FOR ALTERNATE SIGMA - REAL::dth,dqw,dzk - REAL, DIMENSION(kts:kte), INTENT(IN) :: Sh,el - -! Note: kte needs to be larger than kts, i.e., kte >= kts+1. - - DO k = kts,kte-1 - p2a = exner(k) - t = thl(k)*p2a - -!x if ( ct .gt. 0.0 ) then -! a = 17.27 -! b = 237.3 -!x else -!x a = 21.87 -!x b = 265.5 -!x end if -! -! ** 3.8 = 0.622*6.11 (hPa) ** - !SATURATED VAPOR PRESSURE - esl=svp11*EXP(svp2*(t-svpt0)/(t-svp3)) - !SATURATED SPECIFIC HUMIDITY - qsl=ep_2*esl/(p(k)-ep_3*esl) - !dqw/dT: Clausius-Clapeyron - dqsl = qsl*ep_2*ev/( rd*t**2 ) - !DEFICIT/EXCESS WATER CONTENT - qmq(k) = qw(k) -qsl - - alp(k) = 1.0/( 1.0+dqsl*xlvcp ) - bet(k) = dqsl*p2a -! - t3sq = MAX( tsq(k), 0.0 ) - r3sq = MAX( qsq(k), 0.0 ) - c3sq = cov(k) - c3sq = SIGN( MIN( ABS(c3sq), SQRT(t3sq*r3sq) ), c3sq ) -! - r3sq = r3sq +bet(k)**2*t3sq -2.0*bet(k)*c3sq - IF (bl_mynn_cloudpdf == 0) THEN - !ORIGINAL STANDARD DEVIATION: limit e-6 produces ~10% more BL clouds than e-10 - sgm(k) = SQRT( MAX( r3sq, 1.0d-10 )) - ELSE - !ALTERNATIVE FORM (Nakanishi & Niino 2004 BLM, eq. B6, and - ! Kuwano-Yoshida et al. 2010 QJRMS, eq. 7): - if (k .eq. kts) then - dzk = 0.5*dz(k) - else - dzk = 0.5*( dz(k) + dz(k-1) ) - end if - dth = 0.5*(thl(k+1)+thl(k)) - 0.5*(thl(k)+thl(MAX(k-1,kts))) - dqw = 0.5*(qw(k+1) + qw(k)) - 0.5*(qw(k) + qw(MAX(k-1,kts))) - sgm(k) = SQRT( MAX( (alp(k)**2 * MAX(el(k)**2,1.) * & - b2 * MAX(Sh(k),0.03))/4. * & - (dqw/dzk - bet(k)*(dth/dzk ))**2 , 1.0e-10) ) - ENDIF - END DO -! - DO k = kts,kte-1 - !NORMALIZED DEPARTURE FROM SATURATION - q1 = qmq(k) / sgm(k) - !CLOUD FRACTION. rr2 = 1/SQRT(2) = 0.707 - cld(k) = 0.5*( 1.0+erf( q1*rr2 ) ) -! IF (cld(k) < 0. .OR. cld(k) > 1.) THEN -! PRINT*,"MYM_CONDENSATION, k=",k," cld=",cld(k) -! PRINT*," r3sq=",r3sq," t3sq=",t3sq," c3sq=",c3sq -! ENDIF -! q1=0. -! cld(k)=0. - - !qll IS THE NORMALIZED LIQUID WATER CONTENT (Sommeria and - !Deardorff (1977, eq 29a). rrp = 1/(sqrt(2*pi)) = 0.3989 - eq1 = rrp*EXP( -0.5*q1*q1 ) - qll = MAX( cld(k)*q1 + eq1, 0.0 ) - !ESTIMATED LIQUID WATER CONTENT (UNNORMALIZED) - ql (k) = alp(k)*sgm(k)*qll -! - q2p = xlvcp/exner(k) - !POTENTIAL TEMPERATURE - pt = thl(k) +q2p*ql(k) - !qt is a THETA-V CONVERSION FOR TOTAL WATER (i.e., THETA-V = qt*THETA) - qt = 1.0 +p608*qw(k) -(1.+p608)*ql(k) - rac = alp(k)*( cld(k)-qll*eq1 )*( q2p*qt-(1.+p608)*pt ) - - !BUOYANCY FACTORS: wherever vt and vq are used, there is a - !"+1" and "+tv0", respectively, so these are subtracted out here. - !vt is unitless and vq has units of K. - vt (k) = qt-1.0 -rac*bet(k) - vq (k) = p608*pt-tv0 +rac - END DO -! - - cld(kte) = cld(kte-1) - ql(kte) = ql(kte-1) - vt(kte) = vt(kte-1) - vq(kte) = vq(kte-1) - - RETURN - - END SUBROUTINE mym_condensation - -! ================================================================== - SUBROUTINE mynn_tendencies(kts,kte,& - &levflag,grav_settling,& - &delt,& - &dz,& - &u,v,th,qv,qc,qi,qni,& !qnc,& - &p,exner,& - &thl,sqv,sqc,sqi,sqw,& - &ust,flt,flq,flqv,flqc,wspd,qcg,& - &uoce,voce,& - &tsq,qsq,cov,& - &tcd,qcd,& - &dfm,dfh,dfq,& - &Du,Dv,Dth,Dqv,Dqc,Dqi,Dqni&!,Dqnc& - &,vdfg1& !Katata/JOE-fogdes - &,FLAG_QI,FLAG_QNI,FLAG_QC,FLAG_QNC & - &) - -!------------------------------------------------------------------- - INTEGER, INTENT(in) :: kts,kte - INTEGER, INTENT(in) :: grav_settling,levflag - LOGICAL, INTENT(IN) :: FLAG_QI,FLAG_QNI,FLAG_QC,FLAG_QNC - -!! grav_settling = 1 or 2 for gravitational settling of droplets -!! grav_settling = 0 otherwise -! thl - liquid water potential temperature -! qw - total water -! dfm,dfh,dfq - as above -! flt - surface flux of thl -! flq - surface flux of qw - - REAL, DIMENSION(kts:kte), INTENT(in) :: u,v,th,qv,qc,qi,qni,&!qnc,& - &p,exner,dfm,dfh,dfq,dz,tsq,qsq,cov,tcd,qcd - REAL, DIMENSION(kts:kte), INTENT(inout) :: thl,sqw,sqv,sqc,sqi - REAL, DIMENSION(kts:kte), INTENT(inout) :: du,dv,dth,dqv,dqc,dqi,& - &dqni!,dqnc - REAL, INTENT(IN) :: delt,ust,flt,flq,flqv,flqc,wspd,uoce,voce,qcg - -! REAL, INTENT(IN) :: delt,ust,flt,flq,qcg,& -! &gradu_top,gradv_top,gradth_top,gradqv_top - -!local vars - - REAL, DIMENSION(kts:kte) :: dtz,vt,vq,qni2!,qnc2 - - REAL, DIMENSION(1:kte-kts+1) :: a,b,c,d - - REAL :: rhs,gfluxm,gfluxp,dztop - - REAL :: grav_settling2,vdfg1 !Katata-fogdes - - INTEGER :: k,kk,nz - - nz=kte-kts+1 - - dztop=.5*(dz(kte)+dz(kte-1)) - - DO k=kts,kte - dtz(k)=delt/dz(k) - ENDDO - -!!============================================ -!! u -!!============================================ - - k=kts - - a(1)=0. - b(1)=1.+dtz(k)*(dfm(k+1)+ust**2/wspd) - c(1)=-dtz(k)*dfm(k+1) -! d(1)=u(k) - d(1)=u(k)+dtz(k)*uoce*ust**2/wspd - -!! a(1)=0. -!! b(1)=1.+dtz(k)*dfm(k+1) -!! c(1)=-dtz(k)*dfm(k+1) -!! d(1)=u(k)*(1.-ust**2/wspd*dtz(k)) - - DO k=kts+1,kte-1 - kk=k-kts+1 - a(kk)=-dtz(k)*dfm(k) - b(kk)=1.+dtz(k)*(dfm(k)+dfm(k+1)) - c(kk)=-dtz(k)*dfm(k+1) - d(kk)=u(k) - ENDDO - -!! no flux at the top - -! a(nz)=-1. -! b(nz)=1. -! c(nz)=0. -! d(nz)=0. - -!! specified gradient at the top - -! a(nz)=-1. -! b(nz)=1. -! c(nz)=0. -! d(nz)=gradu_top*dztop - -!! prescribed value - - a(nz)=0 - b(nz)=1. - c(nz)=0. - d(nz)=u(kte) - - CALL tridiag(nz,a,b,c,d) - - DO k=kts,kte - du(k)=(d(k-kts+1)-u(k))/delt - ENDDO - -!!============================================ -!! v -!!============================================ - - k=kts - - a(1)=0. - b(1)=1.+dtz(k)*(dfm(k+1)+ust**2/wspd) - c(1)=-dtz(k)*dfm(k+1) -! d(1)=v(k) - d(1)=v(k)+dtz(k)*voce*ust**2/wspd - -!! a(1)=0. -!! b(1)=1.+dtz(k)*dfm(k+1) -!! c(1)=-dtz(k)*dfm(k+1) -!! d(1)=v(k)*(1.-ust**2/wspd*dtz(k)) - - DO k=kts+1,kte-1 - kk=k-kts+1 - a(kk)=-dtz(k)*dfm(k) - b(kk)=1.+dtz(k)*(dfm(k)+dfm(k+1)) - c(kk)=-dtz(k)*dfm(k+1) - d(kk)=v(k) - ENDDO - -!! no flux at the top - -! a(nz)=-1. -! b(nz)=1. -! c(nz)=0. -! d(nz)=0. - - -!! specified gradient at the top - -! a(nz)=-1. -! b(nz)=1. -! c(nz)=0. -! d(nz)=gradv_top*dztop - -!! prescribed value - - a(nz)=0 - b(nz)=1. - c(nz)=0. - d(nz)=v(kte) - - CALL tridiag(nz,a,b,c,d) - - DO k=kts,kte - dv(k)=(d(k-kts+1)-v(k))/delt - ENDDO - -!!============================================ -!! thl -!! NOTE: currently, gravitational settling is removed -!!============================================ - k=kts - - a(1)=0. - b(1)=1.+dtz(k)*dfh(k+1) - c(1)=-dtz(k)*dfh(k+1) - -!Katata - added -! grav_settling2 = MIN(REAL(grav_settling),1.) -!Katata - end -! -! if qcg not used then assume constant flux in the surface layer -!JOE-remove original code -! IF (qcg < qcgmin) THEN -! IF (sqc(k) > qcgmin) THEN -! gfluxm=grav_settling2*gno*sqc(k)**gpw -! ELSE -! gfluxm=0. -! ENDIF -! ELSE -! gfluxm=grav_settling2*gno*(qcg/(1.+qcg))**gpw -! ENDIF -!and replace with vdfg1 is computed in module_sf_fogdes.F. -! IF (sqc(k) > qcgmin) THEN -! !gfluxm=grav_settling2*gno*sqc(k)**gpw -! gfluxm=grav_settling2*sqc(k)*vdfg1 -! ELSE -! gfluxm=0. -! ENDIF -!JOE-end -! -! IF (.5*(sqc(k+1)+sqc(k)) > qcgmin) THEN -! gfluxp=grav_settling2*gno*(.5*(sqc(k+1)+sqc(k)))**gpw -! ELSE -! gfluxp=0. -! ENDIF - - rhs= tcd(k) !-xlvcp/exner(k)*& -! ((gfluxp - gfluxm)/dz(k)) - - d(1)=thl(k) + dtz(k)*flt + rhs*delt - - DO k=kts+1,kte-1 - kk=k-kts+1 - a(kk)=-dtz(k)*dfh(k) - b(kk)=1.+dtz(k)*(dfh(k)+dfh(k+1)) - c(kk)=-dtz(k)*dfh(k+1) - -! IF (.5*(sqc(k+1)+sqc(k)) > qcgmin) THEN -! gfluxp=grav_settling2*gno*(.5*(sqc(k+1)+sqc(k)))**gpw -! ELSE -! gfluxp=0. -! ENDIF -! -! IF (.5*(sqc(k-1)+sqc(k)) > qcgmin) THEN -! gfluxm=grav_settling2*gno*(.5*(sqc(k-1)+sqc(k)))**gpw -! ELSE -! gfluxm=0. -! ENDIF - - rhs= tcd(k) !-xlvcp/exner(k)*& -! &((gfluxp - gfluxm)/dz(k)) - - d(kk)=thl(k) + rhs*delt - ENDDO - -!! no flux at the top - -! a(nz)=-1. -! b(nz)=1. -! c(nz)=0. -! d(nz)=0. + ) + +!================================================================================================================= + +!--- input arguments: + logical,intent(in):: & + f_qc, &! if true,the physics package includes the cloud liquid water mixing ratio. + f_qi, &! if true,the physics package includes the cloud ice mixing ratio. + f_qs, &! if true,the physics package includes the snow mixing ratio. + f_qoz, &! if true,the physics package includes the ozone mixing ratio. + f_nc, &! if true,the physics package includes the cloud liquid water number concentration. + f_ni, &! if true,the physics package includes the cloud ice number concentration. + f_nifa, &! if true,the physics package includes the "ice-friendly" aerosol number concentration. + f_nwfa, &! if true,the physics package includes the "water-friendly" aerosol number concentration. + f_nbca ! if true,the physics package includes the number concentration of black carbon. + + logical,intent(in):: & + bl_mynn_tkeadvect ! + + logical,intent(in):: & + do_restart, &! + do_DAcycling ! + + integer,intent(in):: & + ids,ide,jds,jde,kds,kde, & + ims,ime,jms,jme,kms,kme, & + its,ite,jts,jte,kts,kte + + integer,intent(in):: & + bl_mynn_cloudpdf, &! + bl_mynn_mixlength, &! + bl_mynn_stfunc, &! + bl_mynn_topdown, &! + bl_mynn_scaleaware, &! + bl_mynn_dheat_opt, &! + bl_mynn_edmf, &! + bl_mynn_edmf_dd, &! + bl_mynn_edmf_mom, &! + bl_mynn_edmf_tke, &! + bl_mynn_output, &! + bl_mynn_mixscalars, &! + bl_mynn_cloudmix, &! + bl_mynn_mixqt, &! + bl_mynn_tkebudget ! -!! specified gradient at the top - -!assume gradthl_top=gradth_top - -! a(nz)=-1. -! b(nz)=1. -! c(nz)=0. -! d(nz)=gradth_top*dztop - -!! prescribed value - - a(nz)=0. - b(nz)=1. - c(nz)=0. - d(nz)=thl(kte) - - CALL tridiag(nz,a,b,c,d) - - DO k=kts,kte - thl(k)=d(k-kts+1) - ENDDO - -!!============================================ -!! NO LONGER MIX total water (sqw = sqc + sqv) -!! NOTE: no total water tendency is output -!!============================================ -! -! k=kts -! -! a(1)=0. -! b(1)=1.+dtz(k)*dfh(k+1) -! c(1)=-dtz(k)*dfh(k+1) -! -!JOE: replace orig code with fogdep -! IF (qcg < qcgmin) THEN -! IF (sqc(k) > qcgmin) THEN -! gfluxm=grav_settling2*gno*sqc(k)**gpw -! ELSE -! gfluxm=0. -! ENDIF -! ELSE -! gfluxm=grav_settling2*gno*(qcg/(1.+qcg))**gpw -! ENDIF -!and replace with fogdes code + remove use of qcg: -! IF (sqc(k) > qcgmin) THEN -! !gfluxm=grav_settling2*gno*(.5*(sqc(k)+sqc(k)))**gpw -! gfluxm=grav_settling2*sqc(k)*vdfg1 -! ELSE -! gfluxm=0. -! ENDIF -!JOE-end -! -! IF (.5*(sqc(k+1)+sqc(k)) > qcgmin) THEN -! gfluxp=grav_settling2*gno*(.5*(sqc(k+1)+sqc(k)))**gpw -! ELSE -! gfluxp=0. -! ENDIF -! -! rhs= qcd(k) !+ (gfluxp - gfluxm)/dz(k)& -! -! d(1)=sqw(k) + dtz(k)*flq + rhs*delt -! -! DO k=kts+1,kte-1 -! kk=k-kts+1 -! a(kk)=-dtz(k)*dfh(k) -! b(kk)=1.+dtz(k)*(dfh(k)+dfh(k+1)) -! c(kk)=-dtz(k)*dfh(k+1) -! -! IF (.5*(sqc(k+1)+sqc(k)) > qcgmin) THEN -! gfluxp=grav_settling2*gno*(.5*(sqc(k+1)+sqc(k)))**gpw -! ELSE -! gfluxp=0. -! ENDIF -! -! IF (.5*(sqc(k-1)+sqc(k)) > qcgmin) THEN -! gfluxm=grav_settling2*gno*(.5*(sqc(k-1)+sqc(k)))**gpw -! ELSE -! gfluxm=0. -! ENDIF -! -! rhs= qcd(k) !+ (gfluxp - gfluxm)/dz(k)& -! -! d(kk)=sqw(k) + rhs*delt -! ENDDO - - -!! no flux at the top - -! a(nz)=-1. -! b(nz)=1. -! c(nz)=0. -! d(nz)=0. - -!! specified gradient at the top -!assume gradqw_top=gradqv_top - -! a(nz)=-1. -! b(nz)=1. -! c(nz)=0. -! d(nz)=gradqv_top*dztop - -!! prescribed value - -! a(nz)=0. -! b(nz)=1. -! c(nz)=0. -! d(nz)=sqw(kte) -! -! CALL tridiag(nz,a,b,c,d) -! -! DO k=kts,kte -! sqw(k)=d(k-kts+1) -! ENDDO - -!!============================================ -!! cloud water ( sqc ) -!!============================================ -IF (Cloudmix > 0.5 .AND. FLAG_QC) THEN - - k=kts - - a(1)=0. - b(1)=1.+dtz(k)*dfh(k+1) - c(1)=-dtz(k)*dfh(k+1) - - rhs = qcd(k) - d(1)=sqc(k) + dtz(k)*flqc + rhs*delt - - DO k=kts+1,kte-1 - kk=k-kts+1 - a(kk)=-dtz(k)*dfh(k) - b(kk)=1.+dtz(k)*(dfh(k)+dfh(k+1)) - c(kk)=-dtz(k)*dfh(k+1) - - rhs = qcd(k) - d(kk)=sqc(k) + rhs*delt - ENDDO - -!! prescribed value - a(nz)=0. - b(nz)=1. - c(nz)=0. - d(nz)=sqc(kte) - - CALL tridiag(nz,a,b,c,d) - - DO k=kts,kte - sqc(k)=d(k-kts+1) - ENDDO - -ENDIF - -!!============================================ -!! cloud water number concentration ( qnc ) -!!============================================ -!IF (Cloudmix > 0.5 .AND. FLAG_QNC) THEN -! -! k=kts -! -! a(1)=0. -! b(1)=1.+dtz(k)*dfh(k+1) -! c(1)=-dtz(k)*dfh(k+1) -! -! rhs =qcd(k) -! d(1)=qnc(k) !+ dtz(k)*flqc + rhs*delt -! -! DO k=kts+1,kte-1 -! kk=k-kts+1 -! a(kk)=-dtz(k)*dfh(k) -! b(kk)=1.+dtz(k)*(dfh(k)+dfh(k+1)) -! c(kk)=-dtz(k)*dfh(k+1) -! -! rhs = qcd(k) -! d(kk)=qnc(k) + rhs*delt -! ENDDO -! -!! prescribed value -! a(nz)=0. -! b(nz)=1. -! c(nz)=0. -! d(nz)=qnc(kte) -! -! CALL tridiag(nz,a,b,c,d) -! -! DO k=kts,kte -! qnc2(k)=d(k-kts+1) -! ENDDO -! -!ELSE -! qnc2=qnc -!ENDIF - -!!============================================ -!! MIX WATER VAPOR ONLY ( sqv ) -!!============================================ - - k=kts - - a(1)=0. - b(1)=1.+dtz(k)*dfh(k+1) - c(1)=-dtz(k)*dfh(k+1) - d(1)=sqv(k) + dtz(k)*flqv + qcd(k)*delt - - DO k=kts+1,kte-1 - kk=k-kts+1 - a(kk)=-dtz(k)*dfh(k) - b(kk)=1.+dtz(k)*(dfh(k)+dfh(k+1)) - c(kk)=-dtz(k)*dfh(k+1) - d(kk)=sqv(k) + qcd(k)*delt - ENDDO - -!! no flux at the top -! a(nz)=-1. -! b(nz)=1. -! c(nz)=0. -! d(nz)=0. - -!! specified gradient at the top -!assume gradqw_top=gradqv_top -! a(nz)=-1. -! b(nz)=1. -! c(nz)=0. -! d(nz)=gradqv_top*dztop - -!! prescribed value - a(nz)=0. - b(nz)=1. - c(nz)=0. - d(nz)=sqv(kte) - - CALL tridiag(nz,a,b,c,d) - - DO k=kts,kte - sqv(k)=d(k-kts+1) - ENDDO - -!!============================================ -!! MIX CLOUD ICE ( sqi ) -!!============================================ -IF (Cloudmix > 0.5 .AND. FLAG_QI) THEN - - k=kts - - a(1)=0. - b(1)=1.+dtz(k)*dfh(k+1) - c(1)=-dtz(k)*dfh(k+1) - d(1)=sqi(k) + qcd(k)*delt !should we have qcd for ice??? - - DO k=kts+1,kte-1 - kk=k-kts+1 - a(kk)=-dtz(k)*dfh(k) - b(kk)=1.+dtz(k)*(dfh(k)+dfh(k+1)) - c(kk)=-dtz(k)*dfh(k+1) - d(kk)=sqi(k) + qcd(k)*delt - ENDDO - -!! no flux at the top -! a(nz)=-1. -! b(nz)=1. -! c(nz)=0. -! d(nz)=0. - -!! specified gradient at the top -!assume gradqw_top=gradqv_top -! a(nz)=-1. -! b(nz)=1. -! c(nz)=0. -! d(nz)=gradqv_top*dztop - -!! prescribed value - a(nz)=0. - b(nz)=1. - c(nz)=0. - d(nz)=sqi(kte) - - CALL tridiag(nz,a,b,c,d) - - DO k=kts,kte - sqi(k)=d(k-kts+1) - ENDDO - -ENDIF - -!!============================================ -!! ice water number concentration (qni) -!!============================================ -IF (Cloudmix > 0.5 .AND. FLAG_QNI) THEN - - k=kts - - a(1)=0. - b(1)=1.+dtz(k)*dfh(k+1) - c(1)=-dtz(k)*dfh(k+1) - - rhs = qcd(k) - - d(1)=qni(k) !+ dtz(k)*flqc + rhs*delt - - DO k=kts+1,kte-1 - kk=k-kts+1 - a(kk)=-dtz(k)*dfh(k) - b(kk)=1.+dtz(k)*(dfh(k)+dfh(k+1)) - c(kk)=-dtz(k)*dfh(k+1) - - rhs = qcd(k) - d(kk)=qni(k) + rhs*delt - - ENDDO - -!! prescribed value - a(nz)=0. - b(nz)=1. - c(nz)=0. - d(nz)=qni(kte) - - CALL tridiag(nz,a,b,c,d) - - DO k=kts,kte - qni2(k)=d(k-kts+1) - ENDDO -ELSE - qni2=qni -ENDIF - -!!============================================ -!! convert to mixing ratios for wrf -!!============================================ -!!NOTE: added number conc tendencies for double moment schemes - - DO k=kts,kte - !sqw(k)=d(k-kts+1) - Dqv(k)=(sqv(k)/(1.-sqv(k))-qv(k))/delt - !qc settling tendency is now computed in module_bl_fogdes.F, so - !sqc should only be changed by turbulent mixing. - Dqc(k)=(sqc(k)/(1.-sqc(k))-qc(k))/delt - Dqi(k)=(sqi(k)/(1.-sqi(k))-qi(k))/delt - ! Dqnc(k)=(qnc2(k)-qnc(k))/delt - Dqni(k)=(qni2(k)-qni(k))/delt - Dth(k)=(thl(k) + xlvcp/exner(k)*sqc(k) & - & + xlscp/exner(k)*sqi(k) & - & - th(k))/delt - !Dth(k)=(thl(k)+xlvcp/exner(k)*sqc(k)-th(k))/delt - ENDDO - - END SUBROUTINE mynn_tendencies - -! ================================================================== - SUBROUTINE retrieve_exchange_coeffs(kts,kte,& - &dfm,dfh,dfq,dz,& - &K_m,K_h,K_q) - -!------------------------------------------------------------------- - - INTEGER , INTENT(in) :: kts,kte - - REAL, DIMENSION(KtS:KtE), INTENT(in) :: dz,dfm,dfh,dfq - - REAL, DIMENSION(KtS:KtE), INTENT(out) :: & - &K_m, K_h, K_q - - - INTEGER :: k - REAL :: dzk - - K_m(kts)=0. - K_h(kts)=0. - K_q(kts)=0. - - DO k=kts+1,kte - dzk = 0.5 *( dz(k)+dz(k-1) ) - K_m(k)=dfm(k)*dzk - K_h(k)=dfh(k)*dzk - K_q(k)=dfq(k)*dzk - ENDDO - - END SUBROUTINE retrieve_exchange_coeffs - -! ================================================================== - SUBROUTINE tridiag(n,a,b,c,d) - -!! to solve system of linear eqs on tridiagonal matrix n times n -!! after Peaceman and Rachford, 1955 -!! a,b,c,d - are vectors of order n -!! a,b,c - are coefficients on the LHS -!! d - is initially RHS on the output becomes a solution vector - -!------------------------------------------------------------------- - - INTEGER, INTENT(in):: n - REAL, DIMENSION(n), INTENT(in) :: a,b - REAL, DIMENSION(n), INTENT(inout) :: c,d - - INTEGER :: i - REAL :: p - REAL, DIMENSION(n) :: q - - c(n)=0. - q(1)=-c(1)/b(1) - d(1)=d(1)/b(1) - - DO i=2,n - p=1./(b(i)+a(i)*q(i-1)) - q(i)=-c(i)*p - d(i)=(d(i)-a(i)*d(i-1))*p - ENDDO - - DO i=n-1,1,-1 - d(i)=d(i)+q(i)*d(i+1) - ENDDO - - END SUBROUTINE tridiag - -! ================================================================== - SUBROUTINE mynn_bl_driver(& - &initflag,& - &grav_settling,& - &delt,& - &dz,& - &u,v,th,qv,qc,qi,qni,&! qnc& !JOE: ice & num conc mixing - &p,exner,rho,& - &xland,ts,qsfc,qcg,ps,& - &ust,ch,hfx,qfx,rmol,wspd,& - &uoce,voce,& !ocean current - &vdfg,& !Katata-added for fog dep - &Qke,tke_pbl,& !JOE: add TKE for coupling - &qke_adv,bl_mynn_tkeadvect,& !ACF for QKE advection - &Tsq,Qsq,Cov,& - &Du,Dv,Dth,& - &Dqv,Dqc,Dqi,Dqni,& !Dqnc,& !JOE: ice & nim conc mixing - &K_m,K_h,K_q,& -! &K_h,k_m,& - &Pblh,kpbl& !JOE-added kpbl for coupling - &,el_pbl& - &,dqke,qWT,qSHEAR,qBUOY,qDISS & !JOE-TKE BUDGET - &,wstar,delta & !JOE-added for grims - &,bl_mynn_tkebudget & !JOE-TKE BUDGET - &,bl_mynn_cloudpdf,Sh3D & !JOE-cloudPDF testing - ! optional arguments - &,FLAG_QI,FLAG_QNI,FLAG_QC,FLAG_QNC & - &,IDS,IDE,JDS,JDE,KDS,KDE & - &,IMS,IME,JMS,JME,KMS,KME & - &,ITS,ITE,JTS,JTE,KTS,KTE) - -!------------------------------------------------------------------- - - INTEGER, INTENT(in) :: initflag - !INPUT NAMELIST OPTIONS: - INTEGER, INTENT(in) :: grav_settling - INTEGER, INTENT(in) :: bl_mynn_tkebudget - INTEGER, INTENT(in) :: bl_mynn_cloudpdf - LOGICAL, INTENT(IN) :: bl_mynn_tkeadvect - - LOGICAL, INTENT(IN) :: FLAG_QI,FLAG_QNI,FLAG_QC,FLAG_QNC - - INTEGER,INTENT(IN) :: & - & IDS,IDE,JDS,JDE,KDS,KDE & - &,IMS,IME,JMS,JME,KMS,KME & - &,ITS,ITE,JTS,JTE,KTS,KTE - - -! initflag > 0 for TRUE -! else for FALSE -! levflag : <>3; Level 2.5 -! = 3; Level 3 -! grav_settling = 1 when gravitational settling accounted for -! grav_settling = 0 when gravitational settling NOT accounted for - - REAL, INTENT(in) :: delt - REAL, DIMENSION(IMS:IME,KMS:KME,JMS:JME), INTENT(in) :: dz,& - &u,v,th,qv,qc,p,exner,rho - REAL, DIMENSION(IMS:IME,KMS:KME,JMS:JME), OPTIONAL, INTENT(in)::& - &qi,qni! ,qnc - REAL, DIMENSION(IMS:IME,JMS:JME), INTENT(in) :: xland,ust,& -! &ch,rmol,ts,qsfc,qcg,ps,hfx,qfx, wspd,uoce,voce -!Katata-added for extra in-output - &ch,rmol,ts,qsfc,qcg,ps,hfx,qfx, wspd,uoce,voce, vdfg -!Katata-end - - REAL, DIMENSION(IMS:IME,KMS:KME,JMS:JME), INTENT(inout) :: & - &Qke,Tsq,Qsq,Cov, & - &tke_pbl, & !JOE-added for coupling (TKE_PBL = QKE/2) - &qke_adv !ACF for QKE advection - - REAL, DIMENSION(IMS:IME,KMS:KME,JMS:JME), INTENT(inout) :: & - &Du,Dv,Dth,Dqv,Dqc,Dqi,Dqni!,Dqnc - - REAL, DIMENSION(IMS:IME,KMS:KME,JMS:JME), INTENT(out) :: & - &K_h,K_m - - REAL, DIMENSION(IMS:IME,JMS:JME), INTENT(inout) :: & - &Pblh,wstar,delta !JOE-added for GRIMS - INTEGER,DIMENSION(IMS:IME,JMS:JME),INTENT(INOUT) :: & - &KPBL - - REAL, DIMENSION(IMS:IME,KMS:KME,JMS:JME), INTENT(inout) :: & - &el_pbl - -!JOE-TKE BUDGET - REAL, DIMENSION(IMS:IME,KMS:KME,JMS:JME), INTENT(out) :: & - &qWT,qSHEAR,qBUOY,qDISS,dqke - ! 3D budget arrays are not allocated when bl_mynn_tkebudget == 0. - ! 1D (local) budget arrays are used for passing between subroutines. - REAL, DIMENSION(KTS:KTE) :: qWT1,qSHEAR1,qBUOY1,qDISS1,dqke1 -!JOE-end - REAL, DIMENSION(IMS:IME,KMS:KME,JMS:JME) :: K_q,Sh3D - -!local vars - INTEGER :: ITF,JTF,KTF, IMD,JMD - INTEGER :: i,j,k - REAL, DIMENSION(KTS:KTE) :: thl,sqv,sqc,sqi,sqw,& - &El, Dfm, Dfh, Dfq, Tcd, Qcd, Pdk, Pdt, Pdq, Pdc, Vt, Vq - - REAL, DIMENSION(KTS:KTE) :: thetav,sh,u1,v1,p1,ex1,dz1,th1,qke1, & - & tsq1,qsq1,cov1,qv1,qi1,qc1,du1,dv1,dth1,dqv1,dqc1,dqi1, & - & k_m1,k_h1,k_q1,qni1,dqni1!,qnc1,dqnc1 - - REAL, DIMENSION(KTS:KTE+1) :: zw - - REAL :: cpm,sqcg,flt,flq,flqv,flqc,pmz,phh,exnerg,zet,& - &afk,abk -!JOE-add GRIMS parameters & variables - real,parameter :: d1 = 0.02, d2 = 0.05, d3 = 0.001 - real,parameter :: h1 = 0.33333335, h2 = 0.6666667 - REAL :: govrth, sflux, bfx0, wstar3, wm2, wm3, delb -!JOE-end GRIMS - INTEGER, SAVE :: levflag - -!*** Begin debugging - IMD=(IMS+IME)/2 - JMD=(JMS+JME)/2 -!*** End debugging - - JTF=MIN0(JTE,JDE-1) - ITF=MIN0(ITE,IDE-1) - KTF=MIN0(KTE,KDE-1) - - levflag=mynn_level - - IF (initflag > 0) THEN -! write(0,*) -! write(0,*) '--- bl_mynn initflag = ', initflag -! write(0,*) '--- bl_mynn mynn_level = ', levflag -! write(0,*) '--- initialize sh3d, el_pbl, tsq, qsq, cov' -! write(0,*) - Sh3D(its:ite,kts:kte,jts:jte)=0. - el_pbl(its:ite,kts:kte,jts:jte)=0. - tsq(its:ite,kts:kte,jts:jte)=0. - qsq(its:ite,kts:kte,jts:jte)=0. - cov(its:ite,kts:kte,jts:jte)=0. - - DO j=JTS,JTF - DO i=ITS,ITF - DO k=KTS,KTF - dz1(k)=dz(i,k,j) - u1(k) = u(i,k,j) - v1(k) = v(i,k,j) - th1(k)=th(i,k,j) - sqc(k)=qc(i,k,j)/(1.+qc(i,k,j)) - sqv(k)=qv(i,k,j)/(1.+qv(i,k,j)) - thetav(k)=th(i,k,j)*(1.+0.61*sqv(k)) - IF (PRESENT(qi) .AND. FLAG_QI ) THEN - sqi(k)=qi(i,k,j)/(1.+qi(i,k,j)) - sqw(k)=sqv(k)+sqc(k)+sqi(k) - thl(k)=th(i,k,j)- xlvcp/exner(i,k,j)*sqc(k) & - & - xlscp/exner(i,k,j)*sqi(k) - ELSE - sqi(k)=0.0 - sqw(k)=sqv(k)+sqc(k) - thl(k)=th(i,k,j)-xlvcp/exner(i,k,j)*sqc(k) - ENDIF - - IF (k==kts) THEN - zw(k)=0. - ELSE - zw(k)=zw(k-1)+dz(i,k-1,j) - ENDIF - - k_m(i,k,j)=0. - k_h(i,k,j)=0. - k_q(i,k,j)=0. - qke(i,k,j)=0.1-MIN(zw(k)*0.001, 0.0) - qke1(k)=qke(i,k,j) - el(k)=el_pbl(i,k,j) - sh(k)=Sh3D(i,k,j) - tsq1(k)=tsq(i,k,j) - qsq1(k)=qsq(i,k,j) - cov1(k)=cov(i,k,j) - - IF ( bl_mynn_tkebudget == 1) THEN - !TKE BUDGET VARIABLES - qWT(i,k,j)=0. - qSHEAR(i,k,j)=0. - qBUOY(i,k,j)=0. - qDISS(i,k,j)=0. - dqke(i,k,j)=0. - ENDIF - ENDDO - - zw(kte+1)=zw(kte)+dz(i,kte,j) - - CALL GET_PBLH(KTS,KTE,PBLH(i,j),thetav,& - & Qke1,zw,dz1,xland(i,j),KPBL(i,j)) - - CALL mym_initialize ( kts,kte,& - &dz1, zw, u1, v1, thl, sqv,& - &PBLH(i,j),th1,& !JOE-BouLac mod - &sh,& !JOE-cloudPDF mod - &ust(i,j), rmol(i,j),& - &el, Qke1, Tsq1, Qsq1, Cov1) - - !UPDATE 3D VARIABLES - DO k=KTS,KTE !KTF - el_pbl(i,k,j)=el(k) - sh3d(i,k,j)=sh(k) - qke(i,k,j)=qke1(k) - tsq(i,k,j)=tsq1(k) - qsq(i,k,j)=qsq1(k) - cov(i,k,j)=cov1(k) -!ACF,JOE- initialize qke_adv array if using advection - IF (bl_mynn_tkeadvect) THEN - qke_adv(i,k,j)=qke1(k) - ENDIF -!ACF,JOE-end - ENDDO - -!*** Begin debugging -! k=kdebug -! IF(I==IMD .AND. J==JMD)THEN -! PRINT*,"MYNN DRIVER INIT: k=",1," sh=",sh(k) -! PRINT*," sqw=",sqw(k)," thl=",thl(k)," k_m=",k_m(i,k,j) -! PRINT*," xland=",xland(i,j)," rmol=",rmol(i,j)," ust=",ust(i,j) -! PRINT*," qke=",qke(i,k,j)," el=",el_pbl(i,k,j)," tsq=",Tsq(i,k,j) -! PRINT*," PBLH=",PBLH(i,j)," u=",u(i,k,j)," v=",v(i,k,j) -! ENDIF -!*** End debugging - - ENDDO - ENDDO - - ENDIF ! end initflag - -!ACF copy qke_adv array into qke if using advection - IF (bl_mynn_tkeadvect) THEN - qke=qke_adv - ENDIF -!ACF-end - - DO j=JTS,JTF - DO i=ITS,ITF - DO k=KTS,KTF - !JOE-TKE BUDGET - IF ( bl_mynn_tkebudget == 1) THEN - dqke(i,k,j)=qke(i,k,j) - END IF - dz1(k)= dz(i,k,j) - u1(k) = u(i,k,j) - v1(k) = v(i,k,j) - th1(k)= th(i,k,j) - qv1(k)= qv(i,k,j) - qc1(k)= qc(i,k,j) - sqv(k)= qv(i,k,j)/(1.+qv(i,k,j)) - sqc(k)= qc(i,k,j)/(1.+qc(i,k,j)) - IF(PRESENT(qi) .AND. FLAG_QI)THEN - qi1(k)= qi(i,k,j) - sqi(k)= qi(i,k,j)/(1.+qi(i,k,j)) - sqw(k)= sqv(k)+sqc(k)+sqi(k) - thl(k)= th(i,k,j) - xlvcp/exner(i,k,j)*sqc(k) & - & - xlscp/exner(i,k,j)*sqi(k) - !print*,"MYNN: Flag_qi=",FLAG_QI,qi(i,k,j) - ELSE - qi1(k)=0.0 - sqi(k)=0.0 - sqw(k)= sqv(k)+sqc(k) - thl(k)= th(i,k,j)-xlvcp/exner(i,k,j)*sqc(k) - ENDIF - IF (PRESENT(qni) .AND. FLAG_QNI ) THEN - qni1(k)=qni(i,k,j) - !print*,"MYNN: Flag_qni=",FLAG_QNI,qni(i,k,j) - ELSE - qni1(k)=0.0 - ENDIF - !IF (PRESENT(qnc) .AND. FLAG_QNC ) THEN - ! qnc1(k)=qnc(i,k,j) - ! !print*,"MYNN: Flag_qnc=",FLAG_QNC,qnc(i,k,j) - !ELSE - ! qnc1(k)=0.0 - !ENDIF - thetav(k)=th(i,k,j)*(1.+0.608*sqv(k)) - p1(k) = p(i,k,j) - ex1(k)= exner(i,k,j) - el(k) = el_pbl(i,k,j) - qke1(k)=qke(i,k,j) - sh(k) = sh3d(i,k,j) - tsq1(k)=tsq(i,k,j) - qsq1(k)=qsq(i,k,j) - cov1(k)=cov(i,k,j) - - IF (k==kts) THEN - zw(k)=0. - ELSE - zw(k)=zw(k-1)+dz(i,k-1,j) - ENDIF - ENDDO - - zw(kte+1)=zw(kte)+dz(i,kte,j) - - CALL GET_PBLH(KTS,KTE,PBLH(i,j),thetav,& - & Qke1,zw,dz1,xland(i,j),KPBL(i,j)) - - sqcg= 0.0 !JOE, it was: qcg(i,j)/(1.+qcg(i,j)) - cpm=cp*(1.+0.84*qv(i,kts,j)) - exnerg=(ps(i,j)/p1000mb)**rcp - - !----------------------------------------------------- - !ORIGINAL CODE - !flt = hfx(i,j)/( rho(i,kts,j)*cpm ) & - ! +xlvcp*ch(i,j)*(sqc(kts)/exner(i,kts,j) -sqcg/exnerg) - !flq = qfx(i,j)/ rho(i,kts,j) & - ! -ch(i,j)*(sqc(kts) -sqcg ) - !----------------------------------------------------- - ! Katata-added - The deposition velocity of cloud (fog) - ! water is used instead of CH. - flt = hfx(i,j)/( rho(i,kts,j)*cpm ) & - & +xlvcp*vdfg(i,j)*(sqc(kts)/exner(i,kts,j)- sqcg/exnerg) - flq = qfx(i,j)/ rho(i,kts,j) & - & -vdfg(i,j)*(sqc(kts) - sqcg ) - flqv = qfx(i,j)/rho(i,kts,j) - flqc = -vdfg(i,j)*(sqc(kts) - sqcg ) - - zet = 0.5*dz(i,kts,j)*rmol(i,j) - if ( zet >= 0.0 ) then - pmz = 1.0 + (cphm_st-1.0) * zet - phh = 1.0 + cphh_st * zet - else - pmz = 1.0/ (1.0-cphm_unst*zet)**0.25 - zet - phh = 1.0/SQRT(1.0-cphh_unst*zet) - end if - -!!!!! estimate wstar & delta for GRIMS shallow-cu - govrth = g/th1(kts) - sflux = hfx(i,j)/rho(i,kts,j)/cpm + & - qfx(i,j)/rho(i,kts,j)*ep_1*th1(kts) - bfx0 = max(sflux,0.) - wstar3 = (govrth*bfx0*pblh(i,j)) - wstar(i,j) = wstar3**h1 - wm3 = wstar3 + 5.*ust(i,j)**3. - wm2 = wm3**h2 - delb = govrth*d3*pblh(i,j) - delta(i,j) = min(d1*pblh(i,j) + d2*wm2/delb, 100.) -!!!!! end GRIMS - - CALL mym_condensation ( kts,kte,& - &dz1,thl,sqw,p1,ex1, & - &tsq1, qsq1, cov1, & - &Sh,el,bl_mynn_cloudpdf, & !JOE-added for cloud PDF testing (from Kuwano-Yoshida et al. 2010) - &Vt, Vq) - - CALL mym_turbulence ( kts,kte,levflag, & - &dz1, zw, u1, v1, thl, sqc, sqw, & - &qke1, tsq1, qsq1, cov1, & - &vt, vq,& - &rmol(i,j), flt, flq, & - &PBLH(i,j),th1,& !JOE-BouLac mod - &Sh,& !JOE-cloudPDF mod - &el,& - &Dfm,Dfh,Dfq, & - &Tcd,Qcd,Pdk, & - &Pdt,Pdq,Pdc & - &,qWT1,qSHEAR1,qBUOY1,qDISS1 & !JOE-TKE BUDGET - &,bl_mynn_tkebudget & !JOE-TKE BUDGET - &) - - CALL mym_predict (kts,kte,levflag, & - &delt, dz1, & - &ust(i,j), flt, flq, pmz, phh, & - &el, dfq, pdk, pdt, pdq, pdc, & - &Qke1, Tsq1, Qsq1, Cov1) - - CALL mynn_tendencies(kts,kte,& - &levflag,grav_settling,& - &delt, dz1,& - &u1, v1, th1, qv1, qc1, qi1, qni1,&! qnc1,& - &p1, ex1, thl, sqv, sqc, sqi, sqw,& - &ust(i,j),flt,flq,flqv,flqc,wspd(i,j),qcg(i,j),& - &uoce(i,j),voce(i,j),& - &tsq1, qsq1, cov1,& - &tcd, qcd, & - &dfm, dfh, dfq,& - &Du1, Dv1, Dth1, Dqv1, Dqc1, Dqi1, Dqni1& !, Dqnc1& - &,vdfg(i,j)& !JOE/Katata- fog deposition - &,FLAG_QI,FLAG_QNI,FLAG_QC,FLAG_QNC & - &) - - !print*,"MYNN: qi_ten, qni_ten=",Dqi1(4),Dqni1(4) - !print*,"MYNN: qc_ten, qnc_ten=",Dqc1(4),Dqnc1(4) - - CALL retrieve_exchange_coeffs(kts,kte,& - &dfm, dfh, dfq, dz1,& - &K_m1, K_h1, K_q1) - - !UPDATE 3D ARRAYS - DO k=KTS,KTF - K_m(i,k,j)=K_m1(k) - K_h(i,k,j)=K_h1(k) - K_q(i,k,j)=K_q1(k) - du(i,k,j)=du1(k) - dv(i,k,j)=dv1(k) - dth(i,k,j)=dth1(k) - dqv(i,k,j)=dqv1(k) - dqc(i,k,j)=dqc1(k) - IF (PRESENT(qi) .AND. FLAG_QI) dqi(i,k,j)=dqi1(k) - !IF (PRESENT(qnc) .AND. FLAG_QNC) dqnc(i,k,j)=dqnc1(k) - IF (PRESENT(qni) .AND. FLAG_QNI) dqni(i,k,j)=dqni1(k) - el_pbl(i,k,j)=el(k) - qke(i,k,j)=qke1(k) - tsq(i,k,j)=tsq1(k) - qsq(i,k,j)=qsq1(k) - cov(i,k,j)=cov1(k) - sh3d(i,k,j)=sh(k) - IF ( bl_mynn_tkebudget == 1) THEN - dqke(i,k,j) = (qke1(k)-dqke(i,k,j))*0.5 !qke->tke - qWT(i,k,j) = qWT1(k)*delt - qSHEAR(i,k,j)= qSHEAR1(k)*delt - qBUOY(i,k,j) = qBUOY1(k)*delt - qDISS(i,k,j) = qDISS1(k)*delt - ENDIF - !*** Begin debugging -! IF ( sh(k) < 0. .OR. sh(k)> 200. .OR. & -! & qke(i,k,j) < -5. .OR. qke(i,k,j)> 200. .OR. & -! & el_pbl(i,k,j) < 0. .OR. el_pbl(i,k,j)> 2000. .OR. & -! & ABS(vt(k)) > 0.8 .OR. ABS(vq(k)) > 1100. .OR. & -! & k_m(i,k,j) < 0. .OR. k_m(i,k,j)> 2000. .OR. & -! & vdfg(i,j) < 0. .OR. vdfg(i,j)>5. ) THEN -! PRINT*,"SUSPICIOUS VALUES AT: k=",k," sh=",sh(k) -! PRINT*," sqw=",sqw(k)," thl=",thl(k)," k_m=",k_m(i,k,j) -! PRINT*," xland=",xland(i,j)," rmol=",rmol(i,j)," ust=",ust(i,j) -! PRINT*," qke=",qke(i,k,j)," el=",el_pbl(i,k,j)," tsq=",tsq(i,k,j) -! PRINT*," PBLH=",PBLH(i,j)," u=",u(i,k,j)," v=",v(i,k,j) -! PRINT*," vq=",vq(k)," vt=",vt(k)," vdfg=",vdfg(i,j) -! ENDIF - !*** End debugging - ENDDO -!JOE-add tke_pbl for coupling w/shallow-cu schemes (TKE_PBL = QKE/2.) -! TKE_PBL is defined on interfaces, while QKE is at middle of layer. - tke_pbl(i,kts,j) = 0.5*MAX(qke(i,kts,j),1.0e-10) - DO k = kts+1,kte - afk = dz1(k)/( dz1(k)+dz1(k-1) ) - abk = 1.0 -afk - tke_pbl(i,k,j) = 0.5*MAX(qke(i,k,j)*abk+qke(i,k-1,j)*afk,1.0e-3) - ENDDO -!JOE-end tke_pbl -!JOE-end addition - -!*** Begin debugging -! IF(I==IMD .AND. J==JMD)THEN -! k=kdebug -! PRINT*,"MYNN DRIVER END: k=",1," sh=",sh(k) -! PRINT*," sqw=",sqw(k)," thl=",thl(k)," k_m=",k_m(i,k,j) -! PRINT*," xland=",xland(i,j)," rmol=",rmol(i,j)," ust=",ust(i,j) -! PRINT*," qke=",qke(i,k,j)," el=",el_pbl(i,k,j)," tsq=",tsq(i,k,j) -! PRINT*," PBLH=",PBLH(i,j)," u=",u(i,k,j)," v=",v(i,k,j) -! PRINT*," vq=",vq(k)," vt=",vt(k)," vdfg=",vdfg(i,j) -! ENDIF -!*** End debugging - - ENDDO - ENDDO - -!ACF copy qke into qke_adv if using advection - IF (bl_mynn_tkeadvect) THEN - qke_adv=qke - ENDIF -!ACF-end - - END SUBROUTINE mynn_bl_driver - -#if !defined(mpas) -! ================================================================== - SUBROUTINE mynn_bl_init_driver(& - &Du,Dv,Dth,Dqv,Dqc,Dqi & - !&,Dqnc,Dqni & - &,QKE,TKE_PBL,EXCH_H & - &,RESTART,ALLOWED_TO_READ,LEVEL & - &,IDS,IDE,JDS,JDE,KDS,KDE & - &,IMS,IME,JMS,JME,KMS,KME & - &,ITS,ITE,JTS,JTE,KTS,KTE) - - !--------------------------------------------------------------- - LOGICAL,INTENT(IN) :: ALLOWED_TO_READ,RESTART - INTEGER,INTENT(IN) :: LEVEL - - INTEGER,INTENT(IN) :: IDS,IDE,JDS,JDE,KDS,KDE, & - & IMS,IME,JMS,JME,KMS,KME, & - & ITS,ITE,JTS,JTE,KTS,KTE - - - REAL,DIMENSION(IMS:IME,KMS:KME,JMS:JME),INTENT(INOUT) :: & - &Du,Dv,Dth,Dqv,Dqc,Dqi, & !Dqnc,Dqni, - &QKE,TKE_PBL,EXCH_H - - INTEGER :: I,J,K,ITF,JTF,KTF - - JTF=MIN0(JTE,JDE-1) - KTF=MIN0(KTE,KDE-1) - ITF=MIN0(ITE,IDE-1) - - IF(.NOT.RESTART)THEN - DO J=JTS,JTF - DO K=KTS,KTF - DO I=ITS,ITF - Du(i,k,j)=0. - Dv(i,k,j)=0. - Dth(i,k,j)=0. - Dqv(i,k,j)=0. - if( p_qc >= param_first_scalar ) Dqc(i,k,j)=0. - if( p_qi >= param_first_scalar ) Dqi(i,k,j)=0. - !if( p_qnc >= param_first_scalar ) Dqnc(i,k,j)=0. - !if( p_qni >= param_first_scalar ) Dqni(i,k,j)=0. - QKE(i,k,j)=0. - TKE_PBL(i,k,j)=0. - EXCH_H(i,k,j)=0. - ENDDO - ENDDO - ENDDO - ENDIF - - mynn_level=level - - END SUBROUTINE mynn_bl_init_driver + integer,intent(in):: & + initflag, &! + icloud_bl, &! + spp_pbl ! + + real(kind=kind_phys),intent(in):: & + bl_mynn_closure + + real(kind=kind_phys),intent(in):: & + delt ! + + real(kind=kind_phys),intent(in),dimension(ims:ime,jms:jme):: & + dx, &! + xland, &! + ps, &! + ts, &! + qsfc, &! + ust, &! + ch, &! + hfx, &! + qfx, &! + rmol, &! + wspd, &! + uoce, &! + voce, &! + znt ! + + real(kind=kind_phys),intent(in),dimension(ims:ime,kms:kme,jms:jme):: & + dz, &! + u, &! + w, &! + v, &! + th, &! + tt, &! + p, &! + exner, &! + rho, &! + qv, &! + rthraten ! + + real(kind=kind_phys),intent(in),dimension(ims:ime,kms:kme,jms:jme),optional:: & + qc, &! + qi, &! + qs, &! + qoz, &! + nc, &! + ni, &! + nifa, &! + nwfa, &! + nbca + + real(kind=kind_phys),intent(in),dimension(ims:ime,kms:kme,jms:jme),optional:: & + pattern_spp ! + + +!--- inout arguments: + integer,intent(inout),dimension(ims:ime,jms:jme):: & + kpbl, &! + ktop_plume ! + + real(kind=kind_phys),intent(inout),dimension(ims:ime,jms:jme):: & + pblh ! + + real(kind=kind_phys),intent(inout),dimension(ims:ime,kms:kme,jms:jme):: & + cldfra_bl, &! + qc_bl, &! + qi_bl ! + + real(kind=kind_phys),intent(inout),dimension(ims:ime,kms:kme,jms:jme):: & + el_pbl, &! + qke, &! + qke_adv, &! + cov, &! + qsq, &! + tsq, &! + sh3d, &! + sm3d + + real(kind=kind_phys),intent(inout),dimension(ims:ime,kms:kme,jms:jme):: & + rublten, &! + rvblten, &! + rthblten, &! + rqvblten ! + + real(kind=kind_phys),intent(inout),dimension(ims:ime,kms:kme,jms:jme),optional:: & + rqcblten, &! + rqiblten, &! + rqsblten, &! + rqozblten, &! + rncblten, &! + rniblten, &! + rnifablten, &! + rnwfablten, &! + rnbcablten ! + + real(kind=kind_phys),intent(inout),dimension(ims:ime,kms:kme,jms:jme),optional:: & + edmf_a, &! + edmf_w, &! + edmf_qt, &! + edmf_thl, &! + edmf_ent, &! + edmf_qc, &! + sub_thl, &! + sub_sqv, &! + det_thl, &! + det_sqv ! + + +!--- output arguments: + character(len=*),intent(out):: & + errmsg ! output error message (-). + + integer,intent(out):: & + errflg ! output error flag (-). + + real(kind=kind_phys),intent(out),dimension(ims:ime,jms:jme):: & + maxwidth, &! + maxmf, &! + ztop_plume + + real(kind=kind_phys),intent(out),dimension(ims:ime,kms:kme,jms:jme):: & + exch_h, &! + exch_m ! + + real(kind=kind_phys),intent(out),dimension(ims:ime,kms:kme,jms:jme),optional:: & + dqke, &! + qwt, &! + qshear, &! + qbuoy, &! + qdiss ! + +#if(WRF_CHEM == 1) +!--- input arguments for PBL and free-tropospheric mixing of chemical species: + logical,intent(in):: mix_chem + integer,intent(in):: kdvel,nchem,ndvel + + real(kind=kind_phys),intent(in),dimension(ims:ime,jms:jme):: frp_mean,ems_ant_no + real(kind=kind_phys),intent(in),dimension(ims:ime,kdvel,jms:jme,ndvel):: vd3d + real(kind=kind_phys),intent(inout),dimension(ims:ime,kms:kme,jms:jme,nchem):: chem3 + + real(kind=RKIND),dimension(its:ite):: frp_mean_hv,emsant_no_hv + real(kind=RKIND),dimension(its:ite,kdvel,ndvel):: vd_hv + real(kind=RKIND),dimension(its:ite,kts:kte,nchem):: chem_hv +#endif + +!local variables and arrays: + logical:: mynn_edmf_l,mynn_edmf_dd_l,mynn_edmf_mom_l,mynn_edmf_tke_l + logical:: mynn_mixscalars_l,mynn_mixclouds_l,mynn_mixqt_l + logical:: mynn_tkebudget_l + logical:: mynn_output_l,mynn_dheatopt_l,mynn_scaleaware_l,mynn_topdown_l + + integer:: i,k,j + + integer:: dheat_opt + integer,dimension(its:ite):: & + kpbl_hv,ktopplume_hv + + real(kind=kind_phys):: denom + + real(kind=kind_phys),dimension(its:ite):: & + dx_hv,xland_hv,ps_hv,ts_hv,qsfc_hv,ust_hv,ch_hv,hfx_hv,qfx_hv, & + rmol_hv,wspd_hv,uoce_hv,voce_hv,znt_hv + + real(kind=kind_phys),dimension(its:ite,kts:kte):: & + dz_hv,u_hv,v_hv,th_hv,tt_hv,p_hv,exner_hv,rho_hv,qv_hv,rthraten_hv + + real(kind=kind_phys),dimension(its:ite,kts:kme):: & + w_hv + + real(kind=kind_phys),dimension(its:ite,kts:kte):: & + qc_hv,qi_hv,qs_hv,nc_hv,ni_hv,nifa_hv,nwfa_hv,nbca_hv,qoz_hv + + real(kind=kind_phys),dimension(its:ite,kts:kte):: & + pattern_spp_hv + + real(kind=kind_phys),dimension(its:ite):: & + pblh_hv + + real(kind=kind_phys),dimension(its:ite,kts:kte):: & + cldfrabl_hv,qcbl_hv,qibl_hv,elpbl_hv,qke_hv,qkeadv_hv,cov_hv,qsq_hv,tsq_hv,sh3d_hv,sm3d_hv + + real(kind=kind_phys),dimension(its:ite,kts:kte):: & + rublten_hv,rvblten_hv,rthblten_hv,rqvblten_hv,rqcblten_hv,rqiblten_hv,rqsblten_hv, & + rncblten_hv,rniblten_hv,rnifablten_hv,rnwfablten_hv,rnbcablten_hv,rqozblten_hv + + real(kind=kind_phys),dimension(its:ite,kts:kte):: & + edmfa_hv,edmfw_hv,edmfqt_hv,edmfthl_hv,edmfent_hv,edmfqc_hv, & + subthl_hv,subsqv_hv,detthl_hv,detsqv_hv + + real(kind=kind_phys),dimension(its:ite):: & + maxwidth_hv,maxmf_hv,ztopplume_hv + + real(kind=kind_phys),dimension(its:ite,kts:kte):: & + exchh_hv,exchm_hv,dqke_hv,qwt_hv,qshear_hv,qbuoy_hv,qdiss_hv + + real(kind=kind_phys),dimension(its:ite,kts:kte):: & + sqv_hv,sqc_hv,sqi_hv,sqs_hv + +!----------------------------------------------------------------------------------------------------------------- +!call mpas_log_write(' ') +!call mpas_log_write('--- enter subroutine mynn_bl_driver:') + + errmsg = " " + errflg = 0 + + mynn_edmf_l = .false. + mynn_edmf_dd_l = .false. + mynn_edmf_mom_l = .false. + mynn_edmf_tke_l = .false. + if(bl_mynn_edmf == 1) mynn_edmf_l = .true. + if(bl_mynn_edmf_dd == 1) mynn_edmf_dd_l = .true. + if(bl_mynn_edmf_mom == 1) mynn_edmf_mom_l = .true. + if(bl_mynn_edmf_tke == 1) mynn_edmf_tke_l = .true. + + mynn_mixscalars_l = .false. + mynn_mixclouds_l = .false. + mynn_mixqt_l = .false. + if(bl_mynn_mixscalars == 1) mynn_mixscalars_l = .true. + if(bl_mynn_cloudmix == 1) mynn_mixclouds_l = .true. + if(bl_mynn_mixqt == 1) mynn_mixqt_l = .true. + + mynn_tkebudget_l = .false. + if(bl_mynn_tkebudget == 1) mynn_tkebudget_l = .true. + + mynn_output_l = .false. + mynn_dheatopt_l = .false. + mynn_scaleaware_l = .false. + mynn_topdown_l = .false. + if(bl_mynn_output == 1) mynn_output_l = .true. + if(bl_mynn_dheat_opt == 1) mynn_dheatopt_l = .true. + if(bl_mynn_scaleaware == 1) mynn_scaleaware_l = .true. + if(bl_mynn_topdown == 1) mynn_topdown_l = .true. + + dheat_opt = bl_mynn_dheat_opt + + do j = jts,jte + + !--- input arguments + do i = its,ite + dx_hv(i) = dx(i,j) + xland_hv(i) = xland(i,j) + ps_hv(i) = ps(i,j) + ts_hv(i) = ts(i,j) + qsfc_hv(i) = qsfc(i,j) + ust_hv(i) = ust(i,j) + ch_hv(i) = ch(i,j) + hfx_hv(i) = hfx(i,j) + qfx_hv(i) = qfx(i,j) + rmol_hv(i) = rmol(i,j) + wspd_hv(i) = wspd(i,j) + uoce_hv(i) = uoce(i,j) + voce_hv(i) = voce(i,j) + znt_hv(i) = znt(i,j) + enddo + do k = kts,kte + do i = its,ite + dz_hv(i,k) = dz(i,k,j) + u_hv(i,k) = u(i,k,j) + v_hv(i,k) = v(i,k,j) + w_hv(i,k) = w(i,k,j) + th_hv(i,k) = th(i,k,j) + tt_hv(i,k) = tt(i,k,j) + p_hv(i,k) = p(i,k,j) + exner_hv(i,k) = exner(i,k,j) + rho_hv(i,k) = rho(i,k,j) + qv_hv(i,k) = qv(i,k,j) + rthraten_hv(i,k) = rthraten(i,k,j) + enddo + enddo + do i = its,ite + w_hv(i,kte+1) = w(i,kte+1,j) + enddo + + !--- input arguments for cloud mixing ratios and number concentrations; input argument + ! for the ozone mixing ratio; input arguments for aerosols from the aerosol-aware + ! Thompson cloud microphysics: + do k = kts,kte + do i = its,ite + qc_hv(i,k) = 0._kind_phys + qi_hv(i,k) = 0._kind_phys + qs_hv(i,k) = 0._kind_phys + qoz_hv(i,k) = 0._kind_phys + nc_hv(i,k) = 0._kind_phys + ni_hv(i,k) = 0._kind_phys + nifa_hv(i,k) = 0._kind_phys + nwfa_hv(i,k) = 0._kind_phys + nbca_hv(i,k) = 0._kind_phys + enddo + enddo + if(f_qc .and. present(qc)) then + do k = kts,kte + do i = its,ite + qc_hv(i,k) = qc(i,k,j) + enddo + enddo + endif + if(f_qi .and. present(qi)) then + do k = kts,kte + do i = its,ite + qi_hv(i,k) = qi(i,k,j) + enddo + enddo + endif + if(f_qs .and. present(qs)) then + do k = kts,kte + do i = its,ite + qs_hv(i,k) = qs(i,k,j) + enddo + enddo + endif + if(f_nc .and. present(nc)) then + do k = kts,kte + do i = its,ite + nc_hv(i,k) = nc(i,k,j) + enddo + enddo + endif + if(f_ni .and. present(ni)) then + do k = kts,kte + do i = its,ite + ni_hv(i,k) = ni(i,k,j) + enddo + enddo + endif + if(f_nifa .and. present(nifa)) then + do k = kts,kte + do i = its,ite + nifa_hv(i,k) = nifa(i,k,j) + enddo + enddo + endif + if(f_nwfa .and. present(nwfa)) then + do k = kts,kte + do i = its,ite + nwfa_hv(i,k) = nwfa(i,k,j) + enddo + enddo + endif + if(f_nbca .and. present(nbca)) then + do k = kts,kte + do i = its,ite + nbca_hv(i,k) = nbca(i,k,j) + enddo + enddo + endif + if(f_qoz .and. present(qoz)) then + do k = kts,kte + do i = its,ite + qoz_hv(i,k) = qoz(i,k,j) + enddo + enddo + endif + + !--- conversion from mixing ratios to specific contents: + call bl_mynn_pre_run(its,ite,kte,f_qc,f_qi,f_qs,qv_hv,qc_hv,qi_hv,qs_hv,sqv_hv,sqc_hv, & + sqi_hv,sqs_hv,errmsg,errflg) + + !--- initialization of the stochastic forcing in the PBL: + if(spp_pbl > 0 .and. present(pattern_spp)) then + do k = kts,kte + do i = its,ite + pattern_spp_hv(i,k) = pattern_spp(i,k,j) + enddo + enddo + else + do k = kts,kte + do i = its,ite + pattern_spp_hv(i,k) = 0._kind_phys + enddo + enddo + endif + + !--- inout arguments: + do i = its,ite + pblh_hv(i) = pblh(i,j) + kpbl_hv(i) = kpbl(i,j) + ktopplume_hv(i) = ktop_plume(i,j) + enddo + + do k = kts,kte + do i = its,ite + cldfrabl_hv(i,k) = cldfra_bl(i,k,j) + qcbl_hv(i,k) = qc_bl(i,k,j) + qibl_hv(i,k) = qi_bl(i,k,j) + enddo + enddo + + do k = kts,kte + do i = its,ite + elpbl_hv(i,k) = el_pbl(i,k,j) + qke_hv(i,k) = qke(i,k,j) + qkeadv_hv(i,k) = qke_adv(i,k,j) + cov_hv(i,k) = cov(i,k,j) + tsq_hv(i,k) = tsq(i,k,j) + qsq_hv(i,k) = qsq(i,k,j) + sh3d_hv(i,k) = sh3d(i,k,j) + sm3d_hv(i,k) = sm3d(i,k,j) + enddo + enddo + +#if(WRF_CHEM == 1) + do i = its,ite + do ic = 1,nchem + do k = kts,kte + chem_hv(i,k,ic) = chem3d(i,k,j,ic) + enddo + enddo + do ic = 1,ndvel + do k = 1,kdvel + vd_hv(i,k,ic) = vd3d(i,k,j,ic) + enddo + enddo + + frp_mean_hv(i) = frp_mean(i,j) + emisant_no_hv(i) = emis_ant_no(i,j) + enddo +#endif + + do k = kts,kte + do i = its,ite + rqcblten_hv(i,k) = 0._kind_phys + rqiblten_hv(i,k) = 0._kind_phys + rqsblten_hv(i,k) = 0._kind_phys + rqozblten_hv(i,k) = 0._kind_phys + rncblten_hv(i,k) = 0._kind_phys + rniblten_hv(i,k) = 0._kind_phys + rnifablten_hv(i,k) = 0._kind_phys + rnwfablten_hv(i,k) = 0._kind_phys + rnbcablten_hv(i,k) = 0._kind_phys + enddo + enddo + + call bl_mynn_run ( & + initflag = initflag , restart = do_restart , cycling = do_DAcycling , & + delt = delt , dz = dz_hv , dx = dx_hv , & + znt = znt_hv , u = u_hv , v = v_hv , & + w = w_hv , th = th_hv , sqv = sqv_hv , & + sqc = sqc_hv , sqi = sqi_hv , sqs = sqs_hv , & + qnc = nc_hv , qni = ni_hv , qnwfa = nwfa_hv , & + qnifa = nifa_hv , qnbca = nbca_hv , qozone = qoz_hv , & + p = p_hv , exner = exner_hv , rho = rho_hv , & + tt = tt_hv , xland = xland_hv , ts = ts_hv , & + qsfc = qsfc_hv , ps = ps_hv , ust = ust_hv , & + ch = ch_hv , hfx = hfx_hv , qfx = qfx_hv , & + rmol = rmol_hv , wspd = wspd_hv , uoce = uoce_hv , & + voce = voce_hv , qke = qke_hv , qke_adv = qkeadv_hv , & + tsq = tsq_hv , qsq = qsq_hv , cov = cov_hv , & + rthraten = rthraten_hv , rublten = rublten_hv , rvblten = rvblten_hv , & + rthblten = rthblten_hv , rqvblten = rqvblten_hv , rqcblten = rqcblten_hv , & + rqiblten = rqiblten_hv , rqsblten = rqsblten_hv , rqncblten = rncblten_hv , & + rqniblten = rniblten_hv , rqnwfablten = rnwfablten_hv , rqnifablten = rnifablten_hv , & + rqnbcablten = rnbcablten_hv , rqozblten = rqozblten_hv , exch_h = exchh_hv , & + exch_m = exchm_hv , pblh = pblh_hv , kpbl = kpbl_hv , & + el_pbl = elpbl_hv , dqke = dqke_hv , qwt = qwt_hv , & + qshear = qshear_hv , qbuoy = qbuoy_hv , qdiss = qdiss_hv , & + sh = sh3d_hv , sm = sm3d_hv , qc_bl = qcbl_hv , & + qi_bl = qibl_hv , cldfra_bl = cldfrabl_hv , icloud_bl = icloud_bl , & + edmf_a = edmfa_hv , edmf_w = edmfw_hv , edmf_qt = edmfqt_hv , & + edmf_thl = edmfthl_hv , edmf_ent = edmfent_hv , edmf_qc = edmfqc_hv , & + sub_thl = subthl_hv , sub_sqv = subsqv_hv , det_thl = detthl_hv , & + det_sqv = detsqv_hv , maxwidth = maxwidth_hv , maxmf = maxmf_hv , & + ktop_plume = ktopplume_hv , ztop_plume = ztopplume_hv , spp_pbl = spp_pbl , & + flag_qc = f_qc , flag_qi = f_qi , flag_qs = f_qs , & + flag_qoz = f_qoz , flag_qnc = f_nc , flag_qni = f_ni , & + flag_qnwfa = f_nwfa , flag_qnifa = f_nifa , flag_qnbca = f_nbca , & + pattern_spp_pbl = pattern_spp_hv & +#if(WRF_CHEM == 1) + ,mix_chem = mix_chem , enh_mix = enh_mix , rrfs_sd = rrfs_sd , & + smoke_dbg = smoke_dbg , nchem = nchem , kdvel = kdvel , & + ndvel = ndvel , chem = chem_hv , emis_ant_no = emisant_no_hv , & + frp = frp_hv , vdep = vd_hv & #endif -! ================================================================== - - SUBROUTINE GET_PBLH(KTS,KTE,zi,thetav1D,qke1D,zw1D,dz1D,landsea,kzi) - - !--------------------------------------------------------------- - ! NOTES ON THE PBLH FORMULATION - ! - !The 1.5-theta-increase method defines PBL heights as the level at - !which the potential temperature first exceeds the minimum potential - !temperature within the boundary layer by 1.5 K. When applied to - !observed temperatures, this method has been shown to produce PBL- - !height estimates that are unbiased relative to profiler-based - !estimates (Nielsen-Gammon et al. 2008). However, their study did not - !include LLJs. Banta and Pichugina (2008) show that a TKE-based - !threshold is a good estimate of the PBL height in LLJs. Therefore, - !a hybrid definition is implemented that uses both methods, weighting - !the TKE-method more during stable conditions (PBLH < 400 m). - !A variable tke threshold (TKEeps) is used since no hard-wired - !value could be found to work best in all conditions. - !--------------------------------------------------------------- - - INTEGER,INTENT(IN) :: KTS,KTE - REAL, INTENT(OUT) :: zi - REAL, INTENT(IN) :: landsea - REAL, DIMENSION(KTS:KTE), INTENT(IN) :: thetav1D, qke1D, dz1D - REAL, DIMENSION(KTS:KTE+1), INTENT(IN) :: zw1D - !LOCAL VARS - REAL :: PBLH_TKE,qtke,qtkem1,wt,maxqke,TKEeps,minthv - REAL :: delt_thv !delta theta-v; dependent on land/sea point - REAL, PARAMETER :: sbl_lim = 200. !typical scale of stable BL (m). - REAL, PARAMETER :: sbl_damp = 400. !transition length for blending (m). - INTEGER :: I,J,K,kthv,ktke,kzi,kzi2 - - !ADD KPBL (kzi) for coupling to some Cu schemes, initialize at k=2 - !kzi2 is the TKE-based part of the hybrid KPBL - kzi = 1 - kzi2= 1 - - !FIND MAX TKE AND MIN THETAV IN THE LOWEST 500 M - k = kts+1 - kthv = 1 - ktke = 1 - maxqke = 0. - minthv = 9.E9 - DO WHILE (zw1D(k) .LE. 500.) - qtke =MAX(Qke1D(k),0.) ! maximum QKE - IF (maxqke < qtke) then - maxqke = qtke - ktke = k - ENDIF - IF (minthv > thetav1D(k)) then - minthv = thetav1D(k) - kthv = k - ENDIF - k = k+1 - ENDDO - !TKEeps = maxtke/20. = maxqke/40. - TKEeps = maxqke/40. - TKEeps = MAX(TKEeps,0.025) - - !FIND THETAV-BASED PBLH (BEST FOR DAYTIME). - zi=0. - k = kthv+1 - IF((landsea-1.5).GE.0)THEN - ! WATER - delt_thv = 0.75 - ELSE - ! LAND - delt_thv = 1.25 - ENDIF - - zi=0. - k = kthv+1 - DO WHILE (zi .EQ. 0.) - IF (thetav1D(k) .GE. (minthv + delt_thv))THEN - kzi = MAX(k-1,1) - zi = zw1D(k) - dz1D(k-1)* & - & MIN((thetav1D(k)-(minthv + delt_thv))/ & - & MAX(thetav1D(k)-thetav1D(k-1),1E-6),1.0) - ENDIF - k = k+1 - IF (k .EQ. kte-1) zi = zw1D(kts+1) !EXIT SAFEGUARD - ENDDO - !print*,"IN GET_PBLH:",thsfc,zi - - !FOR STABLE BOUNDARY LAYERS, USE TKE METHOD TO COMPLEMENT THE - !THETAV-BASED DEFINITION (WHEN THE THETA-V BASED PBLH IS BELOW ~0.5 KM). - !THE TANH WEIGHTING FUNCTION WILL MAKE THE TKE-BASED DEFINITION NEGLIGIBLE - !WHEN THE THETA-V-BASED DEFINITION IS ABOVE ~1 KM. - - PBLH_TKE=0. - k = ktke+1 - DO WHILE (PBLH_TKE .EQ. 0.) - !QKE CAN BE NEGATIVE (IF CKmod == 0)... MAKE TKE NON-NEGATIVE. - qtke =MAX(Qke1D(k)/2.,0.) ! maximum TKE - qtkem1=MAX(Qke1D(k-1)/2.,0.) - IF (qtke .LE. TKEeps) THEN - kzi2 = MAX(k-1,1) - PBLH_TKE = zw1D(k) - dz1D(k-1)* & - & MIN((TKEeps-qtke)/MAX(qtkem1-qtke, 1E-6), 1.0) - !IN CASE OF NEAR ZERO TKE, SET PBLH = LOWEST LEVEL. - PBLH_TKE = MAX(PBLH_TKE,zw1D(kts+1)) - !print *,"PBLH_TKE:",i,j,PBLH_TKE, Qke1D(k)/2., zw1D(kts+1) - ENDIF - k = k+1 - IF (k .EQ. kte-1) PBLH_TKE = zw1D(kts+1) !EXIT SAFEGUARD - ENDDO - - !With TKE advection turned on, the TKE-based PBLH can be very large - !in grid points with convective precipitation (> 8 km!), - !so an artificial limit is imposed to not let PBLH_TKE exceed 4km. - !This has no impact on 98-99% of the domain, but is the simplest patch - !that adequately addresses these extremely large PBLHs. - !PBLH_TKE = MIN(PBLH_TKE,4000.) - PBLH_TKE = MIN(PBLH_TKE,zi+500.) - - !BLEND THE TWO PBLH TYPES HERE: - wt=.5*TANH((zi - sbl_lim)/sbl_damp) + .5 - zi=PBLH_TKE*(1.-wt) + zi*wt - - !ADD KPBL (kzi) for coupling to some Cu schemes - kzi = INT(kzi2*(1.-wt) + kzi*wt) - - END SUBROUTINE GET_PBLH - -! ================================================================== - -END MODULE module_bl_mynn + ,bl_mynn_tkeadvect = bl_mynn_tkeadvect , & + bl_mynn_tkebudget = mynn_tkebudget_l , & + bl_mynn_cloudpdf = bl_mynn_cloudpdf , & + bl_mynn_mixlength = bl_mynn_mixlength , & + bl_mynn_stfunc = bl_mynn_stfunc , & + bl_mynn_dheatopt = mynn_dheatopt_l , & + bl_mynn_scaleaware = mynn_scaleaware_l , & + bl_mynn_topdown = mynn_topdown_l , & + bl_mynn_closure = bl_mynn_closure , & + bl_mynn_edmf = mynn_edmf_l , & + bl_mynn_edmf_dd = mynn_edmf_dd_l , & + bl_mynn_edmf_mom = mynn_edmf_mom_l , & + bl_mynn_edmf_tke = mynn_edmf_tke_l , & + bl_mynn_mixscalars = mynn_mixscalars_l , & + bl_mynn_output = mynn_output_l , & + bl_mynn_cloudmix = mynn_mixclouds_l , & + bl_mynn_mixqt = mynn_mixqt_l , & + its = its , ite = ite , kts = kts , kte = kte , kme = kme , errmsg = errmsg , errflg = errflg ) + + + !--- conversion of tendencies in terms of specific contents to in terms of mixing ratios: + call bl_mynn_post_run(its,ite,kte,f_qc,f_qi,f_qs,delt,qv_hv,qc_hv,qi_hv,qs_hv,rqvblten_hv,rqcblten_hv, & + rqiblten_hv,rqsblten_hv,errmsg,errflg) + + !--- inout arguments: + do i = its,ite + pblh(i,j) = pblh_hv(i) + kpbl(i,j) = kpbl_hv(i) + ktop_plume(i,j) = ktopplume_hv(i) + enddo + do k = kts,kte + do i = its,ite + cldfra_bl(i,k,j) = cldfrabl_hv(i,k) + qc_bl(i,k,j) = qcbl_hv(i,k) + qi_bl(i,k,j) = qibl_hv(i,k) + enddo + enddo + + do k = kts,kte + do i = its,ite + el_pbl(i,k,j) = elpbl_hv(i,k) + qke(i,k,j) = qke_hv(i,k) + qke_adv(i,k,j) = qkeadv_hv(i,k) + cov(i,k,j) = cov_hv(i,k) + tsq(i,k,j) = tsq_hv(i,k) + qsq(i,k,j) = qsq_hv(i,k) + sh3d(i,k,j) = sh3d_hv(i,k) + sm3d(i,k,j) = sm3d_hv(i,k) + enddo + enddo + + !--- inout tendencies: + do k = kts,kte + do i = its,ite + rublten(i,k,j) = rublten_hv(i,k) + rvblten(i,k,j) = rvblten_hv(i,k) + rthblten(i,k,j) = rthblten_hv(i,k) + rqvblten(i,k,j) = rqvblten_hv(i,k) + enddo + enddo + if(f_qc .and. present(rqcblten)) then + do k = kts,kte + do i = its,ite + rqcblten(i,k,j) = rqcblten_hv(i,k) + enddo + enddo + endif + if(f_qi .and. present(rqiblten)) then + do k = kts,kte + do i = its,ite + rqiblten(i,k,j) = rqiblten_hv(i,k) + enddo + enddo + endif + if(f_qs .and. present(rqsblten)) then + do k = kts,kte + do i = its,ite + rqsblten(i,k,j) = rqsblten_hv(i,k) + enddo + enddo + endif + if(f_qoz .and. present(rqozblten)) then + do k = kts,kte + do i = its,ite + rqozblten(i,k,j) = rqozblten_hv(i,k) + enddo + enddo + endif + if(f_nc .and. present(rncblten)) then + do k = kts,kte + do i = its,ite + rncblten(i,k,j) = rncblten_hv(i,k) + enddo + enddo + endif + if(f_ni .and. present(rniblten)) then + do k = kts,kte + do i = its,ite + rniblten(i,k,j) = rniblten_hv(i,k) + enddo + enddo + endif + if(f_nifa .and. present(rnifablten)) then + do k = kts,kte + do i = its,ite + rnifablten(i,k,j) = rnifablten_hv(i,k) + enddo + enddo + endif + if(f_nwfa .and. present(rnwfablten)) then + do k = kts,kte + do i = its,ite + rnwfablten(i,k,j) = rnwfablten_hv(i,k) + enddo + enddo + endif + if(f_nbca .and. present(rnbcablten)) then + do k = kts,kte + do i = its,ite + rnbcablten(i,k,j) = rnbcablten_hv(i,k) + enddo + enddo + endif + + do k = kts,kte + do i = its,ite + edmf_a(i,k,j) = edmfa_hv(i,k) + edmf_w(i,k,j) = edmfw_hv(i,k) + edmf_qt(i,k,j) = edmfqt_hv(i,k) + edmf_thl(i,k,j) = edmfthl_hv(i,k) + edmf_ent(i,k,j) = edmfent_hv(i,k) + edmf_qc(i,k,j) = edmfqc_hv(i,k) + sub_thl(i,k,j) = subthl_hv(i,k) + sub_sqv(i,k,j) = subsqv_hv(i,k) + det_thl(i,k,j) = detthl_hv(i,k) + det_sqv(i,k,j) = detsqv_hv(i,k) + enddo + enddo + + !--- output arguments: + do i = its,ite + maxwidth(i,j) = maxwidth_hv(i) + maxmf(i,j) = maxmf_hv(i) + ztop_plume(i,j) = ztopplume_hv(i) + enddo + + do k = kts,kte + do i = its,ite + exch_h(i,k,j) = exchh_hv(i,k) + exch_m(i,k,j) = exchm_hv(i,k) + enddo + enddo + + if(present(qwt) .and. present(qbuoy) .and. present(qshear) .and. & + present(qdiss) .and. present(dqke)) then + do k = kts,kte + do i = its,ite + dqke(i,k,j) = dqke_hv(i,k) + qwt(i,k,j) = qwt_hv(i,k) + qshear(i,k,j) = qshear_hv(i,k) + qbuoy(i,k,j) = qbuoy_hv(i,k) + qdiss(i,k,j) = qdiss_hv(i,k) + enddo + enddo + endif + + enddo + +!call mpas_log_write('--- end subroutine mynn_bl_driver:') + + end subroutine mynn_bl_driver + +!================================================================================================================= + end module module_bl_mynn +!================================================================================================================= + diff --git a/src/core_atmosphere/physics/physics_wrf/module_cu_kfeta.F b/src/core_atmosphere/physics/physics_wrf/module_cu_kfeta.F index 82ea37b2ec..ecf0d82adf 100644 --- a/src/core_atmosphere/physics/physics_wrf/module_cu_kfeta.F +++ b/src/core_atmosphere/physics/physics_wrf/module_cu_kfeta.F @@ -28,7 +28,7 @@ SUBROUTINE KF_eta_CPS( & ,STEPCU,CU_ACT_FLAG,warm_rain,CUTOP,CUBOT & ,QV & ! optionals - ,F_QV ,F_QC ,F_QR ,F_QI ,F_QS & + ,F_QR ,F_QI ,F_QS & ,RTHCUTEN,RQVCUTEN,RQCCUTEN,RQRCUTEN & ,RQICUTEN,RQSCUTEN & ) @@ -45,7 +45,7 @@ SUBROUTINE KF_eta_CPS( & ,STEPCU,CU_ACT_FLAG,warm_rain,CUTOP,CUBOT & ,QV & ! optionals - ,F_QV ,F_QC ,F_QR ,F_QI ,F_QS & + ,F_QR ,F_QI ,F_QS & ,RTHCUTEN,RQVCUTEN,RQCCUTEN,RQRCUTEN & ,RQICUTEN,RQSCUTEN & ) @@ -138,9 +138,7 @@ SUBROUTINE KF_eta_CPS( & ! use or not. ! LOGICAL, OPTIONAL :: & - F_QV & - ,F_QC & - ,F_QR & + F_QR & ,F_QI & ,F_QS diff --git a/src/core_atmosphere/physics/physics_wrf/module_cu_ntiedtke.F b/src/core_atmosphere/physics/physics_wrf/module_cu_ntiedtke.F index 9f45378d9c..b36cb5e610 100644 --- a/src/core_atmosphere/physics/physics_wrf/module_cu_ntiedtke.F +++ b/src/core_atmosphere/physics/physics_wrf/module_cu_ntiedtke.F @@ -24,7 +24,7 @@ subroutine cu_ntiedtke_driver( & ,u3d,v3d,w,t3d,qv3d,qc3d,qi3d,pi3d,rho3d & ,qvften,thften & ,dz8w,pcps,p8w,xland,cu_act_flag,dx & - ,f_qv,f_qc,f_qr,f_qi,f_qs & + ,f_qc,f_qi & ,grav,xlf,xls,xlv,rd,rv,cp & ,rthcuten,rqvcuten,rqccuten,rqicuten & ,rucuten,rvcuten & @@ -86,7 +86,7 @@ subroutine cu_ntiedtke_driver( & !----------------------------------------------------------------------------------------------------------------- !--- input arguments: - logical,intent(in),optional:: f_qv,f_qc,f_qr,f_qi,f_qs + logical,intent(in),optional:: f_qc,f_qi integer,intent(in):: ids,ide,jds,jde,kds,kde, & ims,ime,jms,jme,kms,kme, & @@ -159,7 +159,6 @@ subroutine cu_ntiedtke_driver( & errmsg = ' ' errflg = 0 -!call cu_ntiedtke_init(cp,rd,rv,xlv,xls,xlf,grav,errmsg,errflg) call cu_ntiedtke_init( & con_cp = cp , con_rd = rd , con_rv = rv , con_xlv = xlv , & con_xls = xls , con_xlf = xlf , con_grav = grav , errmsg = errmsg , & diff --git a/src/core_atmosphere/physics/physics_wrf/module_cu_tiedtke.F b/src/core_atmosphere/physics/physics_wrf/module_cu_tiedtke.F index 33e2842ad2..a4372dc848 100644 --- a/src/core_atmosphere/physics/physics_wrf/module_cu_tiedtke.F +++ b/src/core_atmosphere/physics/physics_wrf/module_cu_tiedtke.F @@ -142,7 +142,7 @@ subroutine cu_tiedtke( & ,its,ite, jts,jte, kts,kte & ,rthcuten,rqvcuten,rqccuten,rqicuten & ,rucuten, rvcuten & - ,f_qv ,f_qc ,f_qr ,f_qi ,f_qs & + ,f_qc ,f_qi & ) !------------------------------------------------------------------- @@ -254,12 +254,9 @@ subroutine cu_tiedtke( & ! to determine at run-time whether a particular tracer is in ! use or not. ! - logical, optional :: & - f_qv & - ,f_qc & - ,f_qr & - ,f_qi & - ,f_qs + logical, optional :: & + f_qc & + ,f_qi !--------------------------- local vars ------------------------------ diff --git a/src/core_atmosphere/physics/physics_wrf/module_ra_cam.F b/src/core_atmosphere/physics/physics_wrf/module_ra_cam.F index f30bc03d34..89309850b1 100644 --- a/src/core_atmosphere/physics/physics_wrf/module_ra_cam.F +++ b/src/core_atmosphere/physics/physics_wrf/module_ra_cam.F @@ -204,7 +204,7 @@ subroutine camrad(RTHRATENLW,RTHRATENSW, & GSW,GLW,XLAT,XLONG, & ALBEDO,t_phy,TSK,EMISS, & QV3D,QC3D,QR3D,QI3D,QS3D,QG3D, & - F_QV,F_QC,F_QR,F_QI,F_QS,F_QG, & + F_QC,F_QR,F_QI,F_QS, & f_ice_phy,f_rain_phy, & p_phy,p8w,z,pi_phy,rho_phy,dz8w, & CLDFRA,XLAND,XICE,SNOW, & @@ -233,7 +233,7 @@ subroutine camrad(RTHRATENLW,RTHRATENSW, & INTEGER, INTENT(IN ) :: ids,ide, jds,jde, kds,kde, & ims,ime, jms,jme, kms,kme, & its,ite, jts,jte, kts,kte - LOGICAL, INTENT(IN ) :: F_QV,F_QC,F_QR,F_QI,F_QS,F_QG + LOGICAL, INTENT(IN ) :: F_QC,F_QR,F_QI,F_QS LOGICAL, INTENT(INout) :: doabsems LOGICAL, INTENT(IN ) :: dolw,dosw diff --git a/src/core_atmosphere/physics/physics_wrf/module_sf_mynn.F b/src/core_atmosphere/physics/physics_wrf/module_sf_mynn.F index 1584f3c2e1..ed41320ac7 100644 --- a/src/core_atmosphere/physics/physics_wrf/module_sf_mynn.F +++ b/src/core_atmosphere/physics/physics_wrf/module_sf_mynn.F @@ -1,205 +1,106 @@ !================================================================================================================= -! copied for implementation in MPAS from WRF version 3.6.1. - -! modifications made to sourcecode: -! * used preprocessing option to replace module_model_constants with mpas_atmphys_constants. -! Laura D. Fowler (laura@ucar.edu / 2014-09-25). -! * used preprocessing option to include the actual mean distance between cell centers. -! Laura D. Fowler (laura@ucar.edu / 2015-01-06). -! * used "dummy" variables in the call to mym_condensation. -! Laura D. Fowler (laura@ucar.edu / 2016-10-28). - + module module_sf_mynn !================================================================================================================= + use mpas_kind_types,only: RKIND,StrKIND -MODULE module_sf_mynn + use sf_mynn,only : sf_mynn_run + use sf_mynn_pre,only: sf_mynn_pre_run -!------------------------------------------------------------------- -!Modifications implemented by Joseph Olson NOAA/GSD/AMB - CU/CIRES -!for WRFv3.4 and WRFv3.4.1: -! -! BOTH LAND AND WATER: -!1) Calculation of stability parameter (z/L) taken from Li et al. (2010 BLM) -! for first iteration of first time step; afterwards, exact calculation. -!2) Fixed isflux=0 option to turn off scalar fluxes, but keep momentum -! fluxes for idealized studies (credit: Anna Fitch). -!3) Kinematic viscosity now varies with temperature -!4) Uses Monin-Obukhov flux-profile relationships more consistent with -! those used in the MYNN PBL code. -!5) Allows negative QFX, similar to MYJ scheme -! -! LAND only: -!1) iz0tlnd option is now available with the following options: -! (default) =0: Zilitinkevich (1995) -! =1: Czil_new (modified according to Chen & Zhang 2008) -! =2: Modified Yang et al (2002, 2008) - generalized for all landuse -! =3: constant zt = z0/7.4 (original form; Garratt 1992) -! =4: Pan et al. (1994) with RUC mods for z_q, zili for z_t -!2) Relaxed u* minimum from 0.1 to 0.01 -! -! WATER only: -!1) isftcflx option is now available with the following options: -! (default) =0: z0, zt, and zq from COARE3.0 (Fairall et al 2003) -! =1: z0 from Davis et al (2008), zt & zq from COARE3.0 -! =2: z0 from Davis et al (2008), zt & zq from Garratt (1992) -! =3: z0 from Taylor and Yelland (2004), zt and zq from COARE3.0 -! =4: z0 from Zilitinkevich (2001), zt & zq from COARE3.0 -! -! SNOW/ICE only: -!1) Added Andreas (2002) snow/ice parameterization for thermal and -! moisture roughness to help reduce the cool/moist bias in the arctic -! region. -! -!NOTE: This code was primarily tested in combination with the RUC LSM. -! Performance with the Noah (or other) LSM is relatively unknown. -!------------------------------------------------------------------- - -#if defined(mpas) - use mpas_atmphys_constants,only: p1000mb => P0,cp,xlv,ep_2 - use module_bl_mynn,only: tv0,mym_condensation - use module_sf_sfclay,only: sfclayinit implicit none private - public:: mynn_sf_init_driver, & - sfclay_mynn - -#else - USE module_model_constants, only: & - &p1000mb, cp, xlv, ep_2 - - USE module_sf_sfclay, ONLY: sfclayinit - USE module_bl_mynn, only: tv0, mym_condensation - USE module_wrf_error -!------------------------------------------------------------------- - IMPLICIT NONE -!------------------------------------------------------------------- -#endif - - REAL, PARAMETER :: xlvcp=xlv/cp, ep_3=1.-ep_2 - - REAL, PARAMETER :: wmin=0.1 ! Minimum wind speed - REAL, PARAMETER :: VCONVC=1.0 - REAL, PARAMETER :: SNOWZ0=0.012 + public:: sfclay_mynn - REAL, DIMENSION(0:1000 ),SAVE :: PSIMTB,PSIHTB -CONTAINS - -!------------------------------------------------------------------- - SUBROUTINE mynn_sf_init_driver(allowed_to_read) + contains - LOGICAL, INTENT(in) :: allowed_to_read - !Fill the PSIM and PSIH tables. The subroutine "sfclayinit" - !can be found in module_sf_sfclay.F. This subroutine returns - !the forms from Dyer and Hicks (1974). - - CALL sfclayinit(allowed_to_read) - - END SUBROUTINE mynn_sf_init_driver - -!------------------------------------------------------------------- - SUBROUTINE SFCLAY_mynn(U3D,V3D,T3D,QV3D,P3D,dz8w, & - CP,G,ROVCP,R,XLV,PSFCPA,CHS,CHS2,CQS2,CPM, & - ZNT,UST,PBLH,MAVAIL,ZOL,MOL,REGIME,PSIM,PSIH, & - XLAND,HFX,QFX,LH,TSK,FLHC,FLQC,QGH,QSFC,RMOL, & - U10,V10,TH2,T2,Q2,SNOWH, & - GZ1OZ0,WSPD,BR,ISFFLX,DX, & - SVP1,SVP2,SVP3,SVPT0,EP1,EP2, & - KARMAN,itimestep,ch,th3d,pi3d,qc3d,rho3d, & - tsq,qsq,cov,sh3d,el_pbl,qcg, & -!JOE-add output -! z0zt_ratio,BulkRi,wstar,qstar,resist,logres, & -!JOE-end - ids,ide, jds,jde, kds,kde, & - ims,ime, jms,jme, kms,kme, & - its,ite, jts,jte, kts,kte, & - ustm,ck,cka,cd,cda,isftcflx,iz0tlnd, & - bl_mynn_cloudpdf & -#if defined(mpas) - ,dxCell & -#endif - ) -!------------------------------------------------------------------- - IMPLICIT NONE +!================================================================================================================= + subroutine sfclay_mynn( & + u3d,v3d,t3d,qv3d,p3d,dz8w, & + cp,g,rovcp,r,xlv,psfcpa,chs,chs2,cqs2,cpm, & + znt,ust,pblh,mavail,zol,mol,regime,psim,psih, & + xland,hfx,qfx,lh,tsk,flhc,flqc,qgh,qsfc,rmol, & + u10,v10,th2,t2,q2,snowh, & + gz1oz0,wspd,br,isfflx,dx, & + svp1,svp2,svp3,svpt0,ep1,ep2, & + karman,itimestep,ch,th3d,pi3d,qc3d,rho3d,qcg, & + spp_pbl,pattern_spp_pbl, & + ustm,ck,cka,cd,cda,isftcflx,iz0tlnd, & + ids,ide,jds,jde,kds,kde, & + ims,ime,jms,jme,kms,kme, & + its,ite,jts,jte,kts,kte, & + errmsg,errflg & + ) !------------------------------------------------------------------- -!-- U3D 3D u-velocity interpolated to theta points (m/s) -!-- V3D 3D v-velocity interpolated to theta points (m/s) -!-- T3D 3D temperature (K) -!-- QV3D 3D water vapor mixing ratio (Kg/Kg) -!-- P3D 3D pressure (Pa) -!-- RHO3D 3D density (kg/m3) -!-- dz8w 3D dz between full levels (m) -!-- CP heat capacity at constant pressure for dry air (J/kg/K) -!-- G acceleration due to gravity (m/s^2) -!-- ROVCP R/CP -!-- R gas constant for dry air (J/kg/K) -!-- XLV latent heat of vaporization for water (J/kg) -!-- PSFCPA surface pressure (Pa) -!-- ZNT roughness length (m) -!-- UST u* in similarity theory (m/s) -!-- USTM u* in similarity theory (m/s) w* added to WSPD. This is -! used to couple with TKE scheme but not in MYNN. -! (as of now, USTM = UST in this version) -!-- PBLH PBL height from previous time (m) -!-- MAVAIL surface moisture availability (between 0 and 1) -!-- ZOL z/L height over Monin-Obukhov length -!-- MOL T* (similarity theory) (K) -!-- RMOL Reciprocal of M-O length (/m) -!-- REGIME flag indicating PBL regime (stable, unstable, etc.) -!-- PSIM similarity stability function for momentum -!-- PSIH similarity stability function for heat -!-- XLAND land mask (1 for land, 2 for water) -!-- HFX upward heat flux at the surface (W/m^2) -!-- QFX upward moisture flux at the surface (kg/m^2/s) -!-- LH net upward latent heat flux at surface (W/m^2) -!-- TSK surface temperature (K) -!-- FLHC exchange coefficient for heat (W/m^2/K) -!-- FLQC exchange coefficient for moisture (kg/m^2/s) -!-- CHS heat/moisture exchange coefficient for LSM (m/s) -!-- QGH lowest-level saturated mixing ratio -!-- QSFC qv (specific humidity) at the surface -!-- QSFCMR qv (mixing ratio) at the surface -!-- U10 diagnostic 10m u wind -!-- V10 diagnostic 10m v wind -!-- TH2 diagnostic 2m theta (K) -!-- T2 diagnostic 2m temperature (K) -!-- Q2 diagnostic 2m mixing ratio (kg/kg) -!-- SNOWH Snow height (m) -!-- GZ1OZ0 log((z1+ZNT)/ZNT) where ZNT is roughness length -!-- WSPD wind speed at lowest model level (m/s) -!-- BR bulk Richardson number in surface layer -!-- ISFFLX isfflx=1 for surface heat and moisture fluxes -!-- DX horizontal grid size (m) -!-- SVP1 constant for saturation vapor pressure (=0.6112 kPa) -!-- SVP2 constant for saturation vapor pressure (=17.67 dimensionless) -!-- SVP3 constant for saturation vapor pressure (=29.65 K) -!-- SVPT0 constant for saturation vapor pressure (=273.15 K) -!-- EP1 constant for virtual temperature (Rv/Rd - 1) (dimensionless) -!-- EP2 constant for spec. hum. calc (Rd/Rv = 0.622) (dimensionless) -!-- EP3 constant for spec. hum. calc (1 - Rd/Rv = 0.378 ) (dimensionless) -!-- KARMAN Von Karman constant -!-- ck enthalpy exchange coeff at 10 meters -!-- cd momentum exchange coeff at 10 meters -!-- cka enthalpy exchange coeff at the lowest model level -!-- cda momentum exchange coeff at the lowest model level -!-- isftcflx =0: z0, zt, and zq from COARE3.0 (Fairall et al 2003) -! (water =1: z0 from Davis et al (2008), zt & zq from COARE3.0 -! only) =2: z0 from Davis et al (2008), zt & zq from Garratt (1992) -! =3: z0 from Taylor and Yelland (2004), zt and zq from COARE3.0 -! =4: z0 from Zilitinkevich (2001), zt & zq from COARE3.0 -!-- iz0tlnd =0: Zilitinkevich (1995) with Czil=0.14, -! (land =1: Czil_new (modified according to Chen & Zhang 2008) -! only) =2: Modified Yang et al (2002, 2008) - generalized for all landuse -! =3: constant zt = z0/7.4 (Garratt 1992) -! =4: Pan et al (1994) for zq; ZIlitintevich for zt -!-- bl_mynn_cloudpdf =0: Mellor & Yamada -! =1: Kuwano et al. -!-- el_pbl = mixing length from PBL scheme (meters) -!-- Sh3d = Stability finction for heat (unitless) -!-- cov = T'q' from PBL scheme -!-- tsq = T'T' from PBL scheme -!-- qsq = q'q' from PBL scheme +!-- u3d 3d u-velocity interpolated to theta points (m/s) +!-- v3d 3d v-velocity interpolated to theta points (m/s) +!-- t3d 3d temperature (k) +!-- qv3d 3d water vapor mixing ratio (kg/kg) +!-- p3d 3d pressure (pa) +!-- rho3d 3d density (kg/m3) +!-- dz8w 3d dz between full levels (m) +!-- cp heat capacity at constant pressure for dry air (j/kg/k) +!-- g acceleration due to gravity (m/s^2) +!-- rovcp r/cp +!-- r gas constant for dry air (j/kg/k) +!-- xlv latent heat of vaporization for water (j/kg) +!-- psfcpa surface pressure (pa) +!-- znt roughness length (m) +!-- ust u* in similarity theory (m/s) +!-- ustm u* in similarity theory (m/s) w* added to wspd. this is +! used to couple with tke scheme but not in mynn. +! (as of now, ustm = ust in this version) +!-- pblh pbl height from previous time (m) +!-- mavail surface moisture availability (between 0 and 1) +!-- zol z/l height over monin-obukhov length +!-- mol t* (similarity theory) (k) +!-- rmol reciprocal of m-o length (/m) +!-- regime flag indicating pbl regime (stable, unstable, etc.) +!-- psim similarity stability function for momentum +!-- psih similarity stability function for heat +!-- xland land mask (1 for land, 2 for water) +!-- hfx upward heat flux at the surface (w/m^2) +!-- qfx upward moisture flux at the surface (kg/m^2/s) +!-- lh net upward latent heat flux at surface (w/m^2) +!-- tsk surface temperature (k) +!-- flhc exchange coefficient for heat (w/m^2/k) +!-- flqc exchange coefficient for moisture (kg/m^2/s) +!-- chs heat/moisture exchange coefficient for lsm (m/s) +!-- qgh lowest-level saturated mixing ratio +!-- qsfc qv (specific humidity) at the surface +!-- qsfcmr qv (mixing ratio) at the surface +!-- u10 diagnostic 10m u wind +!-- v10 diagnostic 10m v wind +!-- th2 diagnostic 2m theta (k) +!-- t2 diagnostic 2m temperature (k) +!-- q2 diagnostic 2m mixing ratio (kg/kg) +!-- snowh snow height (m) +!-- gz1oz0 log((z1+znt)/znt) where znt is roughness length +!-- wspd wind speed at lowest model level (m/s) +!-- br bulk richardson number in surface layer +!-- isfflx isfflx=1 for surface heat and moisture fluxes +!-- dx horizontal grid size (m) +!-- svp1 constant for saturation vapor pressure (=0.6112 kpa) +!-- svp2 constant for saturation vapor pressure (=17.67 dimensionless) +!-- svp3 constant for saturation vapor pressure (=29.65 k) +!-- svpt0 constant for saturation vapor pressure (=273.15 k) +!-- ep1 constant for virtual temperature (rv/rd - 1) (dimensionless) +!-- ep2 constant for spec. hum. calc (rd/rv = 0.622) (dimensionless) +!-- ep3 constant for spec. hum. calc (1 - rd/rv = 0.378 ) (dimensionless) +!-- karman von karman constant +!-- ck enthalpy exchange coeff at 10 meters +!-- cd momentum exchange coeff at 10 meters +!-- cka enthalpy exchange coeff at the lowest model level +!-- cda momentum exchange coeff at the lowest model level +!-- isftcflx =0: z0, zt, and zq from coare3.0/3.5 (fairall et al 2003/edson et al 2013) +! (water =1: z0 from davis et al (2008), zt & zq from coare3.0/3.5 +! only) =2: z0 from davis et al (2008), zt & zq from garratt (1992) +! =3: z0 from taylor and yelland (2004), zt and zq from coare 3.0/3.5 +!-- iz0tlnd =0: zilitinkevich (1995) with czil=0.085, +! (land =1: czil_new (modified according to chen & zhang 2008) +! only) =2: modified yang et al (2002, 2008) - generalized for all landuse +! =3: constant zt = z0/7.4 (garratt 1992) ! !-- ids start index for i in domain !-- ide end index for i in domain @@ -219,1630 +120,274 @@ SUBROUTINE SFCLAY_mynn(U3D,V3D,T3D,QV3D,P3D,dz8w, & !-- jte end index for j in tile !-- kts start index for k in tile !-- kte end index for k in tile -!================================================================= -! SCALARS -!=================================== - INTEGER, INTENT(IN) :: ids,ide, jds,jde, kds,kde, & - ims,ime, jms,jme, kms,kme, & - its,ite, jts,jte, kts,kte - INTEGER, INTENT(IN) :: itimestep - REAL, INTENT(IN) :: SVP1,SVP2,SVP3,SVPT0 - REAL, INTENT(IN) :: EP1,EP2,KARMAN - REAL, INTENT(IN) :: CP,G,ROVCP,R,XLV,DX -!NAMELIST OPTIONS: - INTEGER, INTENT(IN) :: ISFFLX - INTEGER, OPTIONAL, INTENT(IN) :: ISFTCFLX, IZ0TLND,& - bl_mynn_cloudpdf -!=================================== -! 3D VARIABLES -!=================================== - REAL, DIMENSION( ims:ime, kms:kme, jms:jme ) , & - INTENT(IN ) :: dz8w, & - QV3D, & - P3D, & - T3D, & - QC3D, & - U3D,V3D, & - RHO3D,th3d,pi3d,tsq,qsq,cov,sh3d,el_pbl -!=================================== -! 2D VARIABLES -!=================================== - REAL, DIMENSION( ims:ime, jms:jme ) , & - INTENT(IN ) :: MAVAIL, & - PBLH, & - XLAND, & - TSK, & - QCG, & - PSFCPA , & - SNOWH - -#if defined(mpas) -!MPAS specific (Laura D. Fowler - 2014-12-02): - real,intent(in),dimension(ims:ime,jms:jme),optional:: dxCell -!MPAS specific end. -#endif - - REAL, DIMENSION( ims:ime, jms:jme ) , & - INTENT(OUT ) :: U10,V10, & - TH2,T2,Q2 - - REAL, OPTIONAL, DIMENSION( ims:ime, jms:jme ) , & - INTENT(OUT) :: ck,cka,cd,cda,ustm -! - REAL, DIMENSION( ims:ime, jms:jme ) , & - INTENT(INOUT) :: REGIME, & - HFX, & - QFX, & - LH, & - MOL,RMOL, & - QSFC, QGH, & - ZNT, & - ZOL, & - UST, & - CPM, & - CHS2, & - CQS2, & - CHS, & - CH, & - FLHC,FLQC, & - GZ1OZ0,WSPD,BR, & - PSIM,PSIH - -!ADDITIONAL OUTPUT -!JOE-begin - REAL, DIMENSION( ims:ime, jms:jme ) :: z0zt_ratio, & - BulkRi,wstar,qstar,resist,logres -!JOE-end -!=================================== -! 1D LOCAL ARRAYS -!=================================== - REAL, DIMENSION( its:ite ) :: U1D, & - V1D, & - QV1D, & - P1D, & - T1D,QC1D, & - RHO1D, & - dz8w1d - - ! VARIABLE FOR PASSING TO MYM_CONDENSATION - REAL, DIMENSION(kts:kts+1 ) :: dummy1,dummy2,dummy3,dummy4, & - dummy5,dummy6,dummy7,dummy8, & - dummy9,dummy10 - - REAL, DIMENSION( its:ite ) :: vt1,vq1 - REAL, DIMENSION(kts:kts+1) :: thl, qw, vt, vq - REAL :: ql - - INTEGER :: I,J,K,itf,jtf,ktf -!----------------------------------------------------------- - - itf=MIN0(ite,ide-1) - jtf=MIN0(jte,jde-1) - ktf=MIN0(kte,kde-1) - - DO J=jts,jte - DO i=its,ite - dz8w1d(I) = dz8w(i,kts,j) - U1D(i) =U3D(i,kts,j) - V1D(i) =V3D(i,kts,j) - QV1D(i)=QV3D(i,kts,j) - QC1D(i)=QC3D(i,kts,j) - P1D(i) =P3D(i,kts,j) - T1D(i) =T3D(i,kts,j) - RHO1D(i)=RHO3D(i,kts,j) - ENDDO - - IF (itimestep==1) THEN -! write(0,*) -! write(0,*) '--- sfc_mynn itimestep = ', itimestep -! write(0,*) '--- initialize vt1, vq1, ust, mol, qsfc, qstar' -! write(0,*) - DO i=its,ite - vt1(i)=0. - vq1(i)=0. - UST(i,j)=MAX(0.025*SQRT(U1D(i)*U1D(i) + V1D(i)*V1D(i)),0.001) - MOL(i,j)=0. ! Tstar - QSFC(i,j)=QV3D(i,kts,j)/(1.+QV3D(i,kts,j)) - qstar(i,j)=0.0 - ENDDO - ELSE -! write(0,*) -! write(0,*) '--- sfc_mynn itimestep = ', itimestep -! write(0,*) '--- call mym_condensation:' -! write(0,*) - DO i=its,ite - do k = kts,kts+1 - ql = qc3d(i,k,j)/(1.+qc3d(i,k,j)) - qw(k) = qv3d(i,k,j)/(1.+qv3d(i,k,j)) + ql - thl(k) = th3d(i,k,j)-xlvcp*ql/pi3d(i,k,j) - dummy1(k) = dz8w(i,k,j) - dummy2(k) = thl(k) - dummy3(k) = qw(k) - dummy4(k) = p3d(i,k,j) - dummy5(k) = pi3d(i,k,j) - dummy6(k) = tsq(i,k,j) - dummy7(k) = qsq(i,k,j) - dummy8(k) = cov(i,k,j) - dummy9(k) = Sh3d(i,k,j) - dummy10(k) = el_pbl(i,k,j) - end do - - ! NOTE: The last grid number is kts+1 instead of kte. - CALL mym_condensation (kts,kts+1, & - & dummy1,dummy2,dummy3, & - & dummy4,dummy5,dummy6, & - & dummy7,dummy8,dummy9, & - & dummy10, & - & bl_mynn_cloudpdf, & - & vt(kts:kts+1), vq(kts:kts+1)) - vt1(i) = vt(kts) - vq1(i) = vq(kts) - ENDDO - ENDIF - - CALL SFCLAY1D_mynn(J,U1D,V1D,T1D,QV1D,P1D,dz8w1d,rho1d, & - CP,G,ROVCP,R,XLV,PSFCPA(ims,j),CHS(ims,j),CHS2(ims,j),& - CQS2(ims,j),CPM(ims,j),PBLH(ims,j), RMOL(ims,j), & - ZNT(ims,j),UST(ims,j),MAVAIL(ims,j),ZOL(ims,j), & - MOL(ims,j),REGIME(ims,j),PSIM(ims,j),PSIH(ims,j), & - XLAND(ims,j),HFX(ims,j),QFX(ims,j),TSK(ims,j), & - U10(ims,j),V10(ims,j),TH2(ims,j),T2(ims,j), & - Q2(ims,j),FLHC(ims,j),FLQC(ims,j),SNOWH(ims,j), & - QGH(ims,j),QSFC(ims,j),LH(ims,j), & - GZ1OZ0(ims,j),WSPD(ims,j),BR(ims,j),ISFFLX,DX, & - SVP1,SVP2,SVP3,SVPT0,EP1,EP2,KARMAN, & - ch(ims,j),vt1,vq1,qc1d,qcg(ims,j),itimestep, & -!JOE-begin additional output - z0zt_ratio(ims,j),BulkRi(ims,j),wstar(ims,j), & - qstar(ims,j),resist(ims,j),logres(ims,j), & -!JOE-end - ids,ide, jds,jde, kds,kde, & - ims,ime, jms,jme, kms,kme, & - its,ite, jts,jte, kts,kte & -#if defined(mpas) -!MPAS specific (Laura D. Fowler - 2014-12-02): - ,isftcflx,iz0tlnd, & - USTM(ims,j),CK(ims,j),CKA(ims,j), & - CD(ims,j),CDA(ims,j),dxCell(ims,j) & -#else - ,isftcflx,iz0tlnd, & - USTM(ims,j),CK(ims,j),CKA(ims,j), & - CD(ims,j),CDA(ims,j) & -#endif - ) - - ENDDO - - END SUBROUTINE SFCLAY_MYNN - -!------------------------------------------------------------------- - SUBROUTINE SFCLAY1D_mynn(J,U1D,V1D,T1D,QV1D,P1D,dz8w1d,rho1d, & - CP,G,ROVCP,R,XLV,PSFCPA,CHS,CHS2,CQS2,CPM, & - PBLH,RMOL,ZNT,UST,MAVAIL,ZOL,MOL,REGIME, & - PSIM,PSIH,XLAND,HFX,QFX,TSK, & - U10,V10,TH2,T2,Q2,FLHC,FLQC,SNOWH,QGH, & - QSFC,LH,GZ1OZ0,WSPD,BR,ISFFLX,DX, & - SVP1,SVP2,SVP3,SVPT0,EP1,EP2, & - KARMAN,ch,vt1,vq1,qc1d,qcg,itimestep, & -!JOE-additional output - zratio,BRi,wstar,qstar,resist,logres, & -!JOE-end - ids,ide, jds,jde, kds,kde, & - ims,ime, jms,jme, kms,kme, & - its,ite, jts,jte, kts,kte & - ,isftcflx, iz0tlnd, & -#if defined(mpas) -!MPAS specific (Laura D. Fowler - 2014-12-02): - ustm,ck,cka,cd,cda,dxCell & -#else - ustm,ck,cka,cd,cda & -#endif - ) - -!------------------------------------------------------------------- - IMPLICIT NONE -!------------------------------------------------------------------- -! SCALARS -!----------------------------- - INTEGER, INTENT(IN) :: ids,ide, jds,jde, kds,kde, & - ims,ime, jms,jme, kms,kme, & - its,ite, jts,jte, kts,kte, & - J, itimestep - - REAL, PARAMETER :: XKA=2.4E-5 !molecular diffusivity - REAL, PARAMETER :: PRT=1. !prandlt number - REAL, INTENT(IN) :: SVP1,SVP2,SVP3,SVPT0,EP1,EP2 - REAL, INTENT(IN) :: KARMAN,CP,G,ROVCP,R,XLV,DX - -!----------------------------- -! NAMELIST OPTIONS -!----------------------------- - INTEGER, INTENT(IN) :: ISFFLX - INTEGER, OPTIONAL, INTENT(IN ) :: ISFTCFLX, IZ0TLND - -!----------------------------- -! 1D ARRAYS -!----------------------------- - REAL, DIMENSION( ims:ime ), INTENT(IN) :: MAVAIL, & - PBLH, & - XLAND, & - TSK, & - PSFCPA, & - QCG, & - SNOWH - - REAL, DIMENSION( its:ite ), INTENT(IN) :: U1D,V1D, & - QV1D,P1D, & - T1D,QC1d, & - dz8w1d, & - RHO1D, & - vt1,vq1 - - REAL, DIMENSION( ims:ime ), INTENT(INOUT) :: REGIME, & - HFX,QFX,LH, & - MOL,RMOL, & - QGH,QSFC, & - ZNT, & - ZOL, & - UST, & - CPM, & - CHS2,CQS2, & - CHS,CH, & - FLHC,FLQC, & - GZ1OZ0, & - WSPD, & - BR, & - PSIM,PSIH - - ! DIAGNOSTIC OUTPUT - REAL, DIMENSION( ims:ime ), INTENT(OUT) :: U10,V10, & - TH2,T2,Q2 - - REAL, OPTIONAL, DIMENSION( ims:ime ) , & - INTENT(OUT) :: ck,cka,cd,cda,ustm -!-------------------------------------------- -!JOE-additinal output - REAL, DIMENSION( ims:ime ) :: zratio,BRi,wstar,qstar, & - resist,logres -!JOE-end -!---------------------------------------------------------------- -! LOCAL VARS -!---------------------------------------------------------------- - REAL :: thl1,sqv1,sqc1,exner1,sqvg,sqcg,vv,ww - - REAL, DIMENSION(its:ite) :: & - ZA, & !Height of lowest 1/2 sigma level(m) - THV1D, & !Theta-v at lowest 1/2 sigma (K) - TH1D, & !Theta at lowest 1/2 sigma (K) - TC1D, & !T at lowest 1/2 sigma (Celsius) - TV1D, & !Tv at lowest 1/2 sigma (K) - QVSH, & !qv at lowest 1/2 sigma (spec humidity) - PSIH2,PSIM2, & !M-O stability functions at z=2 m - PSIH10,PSIM10, & !M-O stability functions at z=10 m - WSPDI, & - z_t,z_q, & !thermal & moisture roughness lengths - GOVRTH, & !g/theta - THGB, & !theta at ground - THVGB, & !theta-v at ground - PSFC, & !press at surface (Pa/1000) - QSFCMR, & !qv at surface (mixing ratio, kg/kg) - GZ2OZ0, & !LOG((2.0+ZNT(I))/ZNT(I)) - GZ10OZ0, & !LOG((10.+ZNT(I))/ZNT(I)) - GZ2OZt, & !LOG((2.0+z_t(i))/z_t(i)) - GZ10OZt, & !LOG((10.+z_t(i))/z_t(i)) - GZ1OZt !LOG((ZA(I)+z_t(i))/z_t(i)) - - INTEGER :: N,I,K,L,NZOL,NK,NZOL2,NZOL10, ITER - INTEGER, PARAMETER :: ITMAX=5 - - REAL :: PL,THCON,TVCON,E1 - REAL :: DTHVDZ,DTHVM,VCONV,RZOL,RZOL2,RZOL10,ZOL2,ZOL10 - REAL :: DTG,PSIX,DTTHX,DTHDZ,PSIX10,PSIT,PSIT2,PSIT10, & - PSIQ,PSIQ2,PSIQ10 - REAL :: FLUXC,VSGD - REAL :: restar,VISC,DQG,OLDUST,OLDTST - REAL, PARAMETER :: psilim = -10. ! ONLY AFFECTS z/L > 2.0 - -#if defined(mpas) -!MPAS specific (Laura D. Fowler - 2014-12-02): - real,intent(in),dimension(ims:ime),optional:: dxCell -!MPAS specific end. -#endif - -!------------------------------------------------------------------- - - DO I=its,ite - ! CONVERT GROUND & LOWEST LAYER TEMPERATURE TO POTENTIAL TEMPERATURE: - ! PSFC cmb - PSFC(I)=PSFCPA(I)/1000. - THGB(I)=TSK(I)*(100./PSFC(I))**ROVCP !(K) - ! PL cmb - PL=P1D(I)/1000. - THCON=(100./PL)**ROVCP - TH1D(I)=T1D(I)*THCON !(Theta, K) - TC1D(I)=T1D(I)-273.15 !(T, Celsius) - - ! CONVERT TO VIRTUAL TEMPERATURE - QVSH(I)=QV1D(I)/(1.+QV1D(I)) !CONVERT TO SPEC HUM (kg/kg) - TVCON=(1.+EP1*QVSH(I)) - THV1D(I)=TH1D(I)*TVCON !(K) - TV1D(I)=T1D(I)*TVCON !(K) - - !RHO1D(I)=PSFCPA(I)/(R*TV1D(I)) !now using value calculated in sfc driver - ZA(I)=0.5*dz8w1d(I) !height of first half-sigma level - GOVRTH(I)=G/TH1D(I) - ENDDO - - DO I=its,ite - IF (TSK(I) .LT. 273.15) THEN - !SATURATION VAPOR PRESSURE WRT ICE (SVP1=.6112; 10*mb) - E1=SVP1*EXP(4648*(1./273.15 - 1./TSK(I)) - & - & 11.64*LOG(273.15/TSK(I)) + 0.02265*(273.15 - TSK(I))) - ELSE - !SATURATION VAPOR PRESSURE WRT WATER (Bolton 1980) - E1=SVP1*EXP(SVP2*(TSK(I)-SVPT0)/(TSK(I)-SVP3)) - ENDIF - !FOR LAND POINTS, QSFC can come from LSM, ONLY RECOMPUTE OVER WATER - IF (xland(i).gt.1.5 .or. QSFC(i).le.0.0) THEN !WATER - QSFC(I)=EP2*E1/(PSFC(I)-ep_3*E1) !specific humidity - QSFCMR(I)=EP2*E1/(PSFC(I)-E1) !mixing ratio - ELSE !LAND - QSFCMR(I)=QSFC(I)/(1.-QSFC(I)) - ENDIF - - ! QGH CHANGED TO USE LOWEST-LEVEL AIR TEMP CONSISTENT WITH MYJSFC CHANGE - ! Q2SAT = QGH IN LSM - IF (TSK(I) .LT. 273.15) THEN - !SATURATION VAPOR PRESSURE WRT ICE - E1=SVP1*EXP(4648*(1./273.15 - 1./T1D(I)) - & - & 11.64*LOG(273.15/T1D(I)) + 0.02265*(273.15 - T1D(I))) - ELSE - !SATURATION VAPOR PRESSURE WRT WATER (Bolton 1980) - E1=SVP1*EXP(SVP2*(T1D(I)-SVPT0)/(T1D(I)-SVP3)) - ENDIF - PL=P1D(I)/1000. - !QGH(I)=EP2*E1/(PL-ep_3*E1) !specific humidity - QGH(I)=EP2*E1/(PL-E1) !mixing ratio - CPM(I)=CP*(1.+0.84*QV1D(I)) - ENDDO - - DO I=its,ite - WSPD(I)=SQRT(U1D(I)*U1D(I)+V1D(I)*V1D(I)) - - !account for partial condensation - exner1=(p1d(I)/p1000mb)**ROVCP - sqc1=qc1d(I)/(1.+qc1d(I)) !lowest mod level cloud water spec hum - sqv1=QVSH(I) !lowest mod level water vapor spec hum - thl1=TH1D(I)-xlvcp/exner1*sqc1 - sqvg=qsfc(I) !sfc water vapor spec hum - sqcg=qcg(I)/(1.+qcg(I)) !sfc cloud water spec hum - - vv = thl1-THGB(I) - !TGS:ww = mavail(I)*(sqv1-sqvg) + (sqc1-sqcg) - ww = (sqv1-sqvg) + (sqc1-sqcg) - - !TGS:THVGB(I)=THGB(I)*(1.+EP1*QSFC(I)*MAVAIL(I)) - THVGB(I)=THGB(I)*(1.+EP1*QSFC(I)) - - DTHDZ=(TH1D(I)-THGB(I)) - DTHVDZ=(THV1D(I)-THVGB(I)) - !DTHVDZ= (vt1(i) + 1.0)*vv + (vq1(i) + tv0)*ww - - !-------------------------------------------------------- - ! Calculate the convective velocity scale (WSTAR) and - ! subgrid-scale velocity (VSGD) following Beljaars (1995, QJRMS) - ! and Mahrt and Sun (1995, MWR), respectively - !------------------------------------------------------- - ! VCONV = 0.25*sqrt(g/THVGB(I)*pblh(i)*dthvm) - ! Use Beljaars over land, old MM5 (Wyngaard) formula over water - IF (xland(i).lt.1.5) then !LAND (xland == 1) - - fluxc = max(hfx(i)/RHO1D(i)/cp & - & + ep1*THVGB(I)*qfx(i)/RHO1D(i),0.) - WSTAR(I) = vconvc*(g/TSK(i)*pblh(i)*fluxc)**.33 - - ELSE !WATER (xland == 2) - - !JOE-the Wyngaard formula is ~3 times larger than the Beljaars - !formula, so switch to Beljaars for water, but use VCONVC = 1.25, - !as in the COARE3.0 bulk parameterizations. - !IF(-DTHVDZ.GE.0)THEN - ! DTHVM=-DTHVDZ - !ELSE - ! DTHVM=0. - !ENDIF - !WSTAR(I) = 2.*SQRT(DTHVM) - fluxc = max(hfx(i)/RHO1D(i)/cp & - & + ep1*THVGB(I)*qfx(i)/RHO1D(i),0.) - WSTAR(I) = 1.25*(g/TSK(i)*pblh(i)*fluxc)**.33 - - ENDIF - - !-------------------------------------------------------- - ! Mahrt and Sun low-res correction - ! (for 13 km ~ 0.37 m/s; for 3 km == 0 m/s) - !-------------------------------------------------------- -!MPAS specific (Laura D. Fowler): We take into accound the actual size of individual -!grid-boxes: - if(present(dxCell)) then - VSGD = 0.32 * (max(dxCell(i)/5000.-1.,0.))**.33 - else - VSGD = 0.32 * (max(dx/5000.-1.,0.))**.33 - endif - WSPD(I)=SQRT(WSPD(I)*WSPD(I)+WSTAR(I)*WSTAR(I)+vsgd*vsgd) - WSPD(I)=MAX(WSPD(I),wmin) - - !-------------------------------------------------------- - ! CALCULATE THE BULK RICHARDSON NUMBER OF SURFACE LAYER, - ! ACCORDING TO AKB(1976), EQ(12). - !-------------------------------------------------------- - BR(I)=GOVRTH(I)*ZA(I)*DTHVDZ/(WSPD(I)*WSPD(I)) - !SET LIMITS ACCORDING TO Li et al. (2010) Boundary-Layer Meteorol (p.158) - !JOE: defying limits: BR(I)=MAX(BR(I),-2.0) - BR(I)=MAX(BR(I),-20.0) - BR(I)=MIN(BR(I),2.0) - BRi(I)=BR(I) !new variable for output - BR is not a "state" variable. - - ! IF PREVIOUSLY UNSTABLE, DO NOT LET INTO REGIMES 1 AND 2 (STABLE) - !if (itimestep .GT. 1) THEN - ! IF(MOL(I).LT.0.)BR(I)=MIN(BR(I),0.0) - !ENDIF - - !IF(I .eq. 2)THEN - ! write(*,1006)"BR:",BR(I)," fluxc:",fluxc," vt1:",vt1(i)," vq1:",vq1(i) - ! write(*,1007)"XLAND:",XLAND(I)," WSPD:",WSPD(I)," DTHVDZ:",DTHVDZ," WSTAR:",WSTAR(I) - !ENDIF - - ENDDO - - 1006 format(A,F7.3,A,f9.4,A,f9.5,A,f9.4) - 1007 format(A,F2.0,A,f6.2,A,f7.3,A,f7.2) - -!-------------------------------------------------------------------- -!-------------------------------------------------------------------- -!--- BEGIN ITERATION LOOP (ITMAX=5); USUALLY CONVERGES IN TWO PASSES -!-------------------------------------------------------------------- -!-------------------------------------------------------------------- - - DO I=its,ite - - ITER = 1 - DO WHILE (ITER .LE. ITMAX) - - !COMPUTE KINEMATIC VISCOSITY (m2/s) Andreas (1989) CRREL Rep. 89-11 - !valid between -173 and 277 degrees C. - VISC=1.326e-5*(1. + 6.542e-3*TC1D(I) + 8.301e-6*TC1D(I)*TC1D(I) & - - 4.84e-9*TC1D(I)*TC1D(I)*TC1D(I)) - - IF((XLAND(I)-1.5).GE.0)THEN - !-------------------------------------- - ! WATER - !-------------------------------------- - ! CALCULATE z0 (znt) - !-------------------------------------- - IF ( PRESENT(ISFTCFLX) ) THEN - IF ( ISFTCFLX .EQ. 0 ) THEN - !NAME OF SUBROUTINE IS MISLEADING - ACTUALLY VARIABLE CHARNOCK - !PARAMETER FROM COARE3.0: - CALL charnock_1955(ZNT(i),UST(i),WSPD(i),visc) - ELSEIF ( ISFTCFLX .EQ. 1 .OR. ISFTCFLX .EQ. 2 ) THEN - CALL davis_etal_2008(ZNT(i),UST(i)) - ELSEIF ( ISFTCFLX .EQ. 3 ) THEN - CALL Taylor_Yelland_2001(ZNT(i),UST(i),WSPD(i)) - ELSEIF ( ISFTCFLX .EQ. 4 ) THEN - CALL charnock_1955(ZNT(i),UST(i),WSPD(i),visc) - ENDIF - ELSE - !DEFAULT TO COARE 3.0 - CALL charnock_1955(ZNT(i),UST(i),WSPD(i),visc) - ENDIF - - !COMPUTE ROUGHNESS REYNOLDS NUMBER (restar) USING NEW ZNT - ! AHW: Garrattt formula: Calculate roughness Reynolds number - ! Kinematic viscosity of air (linear approx to - ! temp dependence at sea level) - restar=MAX(ust(i)*ZNT(i)/visc, 0.1) - - !-------------------------------------- - !CALCULATE z_t and z_q - !-------------------------------------- - IF ( PRESENT(ISFTCFLX) ) THEN - IF ( ISFTCFLX .EQ. 0 ) THEN - CALL fairall_2001(z_t(i),z_q(i),restar,UST(i),visc) - ELSEIF ( ISFTCFLX .EQ. 1 ) THEN - CALL fairall_2001(z_t(i),z_q(i),restar,UST(i),visc) - ELSEIF ( ISFTCFLX .EQ. 2 ) THEN - CALL garratt_1992(z_t(i),z_q(i),ZNT(i),restar,XLAND(I)) - ELSEIF ( ISFTCFLX .EQ. 3 ) THEN - CALL fairall_2001(z_t(i),z_q(i),restar,UST(i),visc) - ELSEIF ( ISFTCFLX .EQ. 4 ) THEN - CALL zilitinkevich_1995(ZNT(i),z_t(i),z_q(i),restar,& - UST(I),KARMAN,XLAND(I),IZ0TLND) - ENDIF - ELSE - !DEFAULT TO COARE 3.0 - CALL fairall_2001(z_t(i),z_q(i),restar,UST(i),visc) - ENDIF - - ELSE - - !-------------------------------------- - ! LAND - !-------------------------------------- - !COMPUTE ROUGHNESS REYNOLDS NUMBER (restar) USING DEFAULT ZNT - restar=MAX(ust(i)*ZNT(i)/visc, 0.1) - - !-------------------------------------- - !GET z_t and z_q - !-------------------------------------- - !CHECK FOR SNOW/ICE POINTS OVER LAND - !IF ( ZNT(i) .LE. SNOWZ0 .AND. TSK(I) .LE. 273.15 ) THEN - IF ( SNOWH(i) .GE. 0.1) THEN - CALL Andreas_2002(ZNT(i),restar,z_t(i),z_q(i)) - ELSE - IF ( PRESENT(IZ0TLND) ) THEN - IF ( IZ0TLND .LE. 1 .OR. IZ0TLND .EQ. 4) THEN - !IF IZ0TLND==4, THEN PSIQ WILL BE RECALCULATED USING - !PAN ET AL (1994), but PSIT FROM ZILI WILL BE USED. - CALL zilitinkevich_1995(ZNT(i),z_t(i),z_q(i),restar,& - UST(I),KARMAN,XLAND(I),IZ0TLND) - ELSEIF ( IZ0TLND .EQ. 2 ) THEN - CALL Yang_2008(ZNT(i),z_t(i),z_q(i),UST(i),MOL(I),& - qstar(I),restar,visc,XLAND(I)) - ELSEIF ( IZ0TLND .EQ. 3 ) THEN - !Original MYNN in WRF-ARW used this form: - CALL garratt_1992(z_t(i),z_q(i),ZNT(i),restar,XLAND(I)) - ENDIF - ELSE - !DEFAULT TO ZILITINKEVICH - CALL zilitinkevich_1995(ZNT(i),z_t(i),z_q(i),restar,& - UST(I),KARMAN,XLAND(I),0) - ENDIF - ENDIF - - ENDIF - zratio(i)=znt(i)/z_t(i) - - !ADD RESISTANCE (SOMEWHAT FOLLOWING JIMENEZ ET AL. (2012)) TO PROTECT AGAINST - !EXCESSIVE FLUXES WHEN USING A LOW FIRST MODEL LEVEL (ZA < 10 m). - !Formerly: GZ1OZ0(I)= LOG(ZA(I)/ZNT(I)) - GZ1OZ0(I)= LOG((ZA(I)+ZNT(I))/ZNT(I)) - GZ1OZt(I)= LOG((ZA(I)+z_t(i))/z_t(i)) - GZ2OZ0(I)= LOG((2.0+ZNT(I))/ZNT(I)) - GZ2OZt(I)= LOG((2.0+z_t(i))/z_t(i)) - GZ10OZ0(I)=LOG((10.+ZNT(I))/ZNT(I)) - GZ10OZt(I)=LOG((10.+z_t(i))/z_t(i)) - - !-------------------------------------------------------------------- - !--- DIAGNOSE BASIC PARAMETERS FOR THE APPROPRIATE STABILITY CLASS: - ! - ! THE STABILITY CLASSES ARE DETERMINED BY BR (BULK RICHARDSON NO.). - ! - ! CRITERIA FOR THE CLASSES ARE AS FOLLOWS: - ! - ! 1. BR .GE. 0.2; - ! REPRESENTS NIGHTTIME STABLE CONDITIONS (REGIME=1), - ! - ! 2. BR .LT. 0.2 .AND. BR .GT. 0.0; - ! REPRESENTS DAMPED MECHANICAL TURBULENT CONDITIONS - ! (REGIME=2), - ! - ! 3. BR .EQ. 0.0 - ! REPRESENTS FORCED CONVECTION CONDITIONS (REGIME=3), - ! - ! 4. BR .LT. 0.0 - ! REPRESENTS FREE CONVECTION CONDITIONS (REGIME=4). - ! - !-------------------------------------------------------------------- - IF (BR(I) .GT. 0.0) THEN - IF (BR(I) .GT. 0.2) THEN - !---CLASS 1; STABLE (NIGHTTIME) CONDITIONS: - REGIME(I)=1. - ELSE - !---CLASS 2; DAMPED MECHANICAL TURBULENCE: - REGIME(I)=2. - ENDIF - - !COMPUTE z/L - !CALL Li_etal_2010(ZOL(I),BR(I),ZA(I)/ZNT(I),zratio(I)) - IF (ITER .EQ. 1 .AND. itimestep .LE. 1) THEN - CALL Li_etal_2010(ZOL(I),BR(I),ZA(I)/ZNT(I),zratio(I)) - ELSE - ZOL(I)=ZA(I)*KARMAN*G*MOL(I)/(TH1D(I)*MAX(UST(I),0.001)**2) - ZOL(I)=MAX(ZOL(I),0.0) - ZOL(I)=MIN(ZOL(I),2.) - ENDIF - - !COMPUTE PSIM and PSIH - IF((XLAND(I)-1.5).GE.0)THEN - ! WATER - !CALL PSI_Suselj_Sood_2010(PSIM(I),PSIH(I),ZOL(I)) - !CALL PSI_Beljaars_Holtslag_1991(PSIM(I),PSIH(I),ZOL(I)) - !CALL PSI_Businger_1971(PSIM(I),PSIH(I),ZOL(I)) - CALL PSI_DyerHicks(PSIM(I),PSIH(I),ZOL(I),z_t(I),ZNT(I),ZA(I)) - ELSE - ! LAND - !CALL PSI_Beljaars_Holtslag_1991(PSIM(I),PSIH(I),ZOL(I)) - !CALL PSI_Businger_1971(PSIM(I),PSIH(I),ZOL(I)) - !CALL PSI_Zilitinkevich_Esau_2007(PSIM(I),PSIH(I),ZOL(I)) - CALL PSI_DyerHicks(PSIM(I),PSIH(I),ZOL(I),z_t(I),ZNT(I),ZA(I)) - ENDIF - - ! LOWER LIMIT ON PSI IN STABLE CONDITIONS - PSIM(I)=MAX(PSIM(I),psilim) - PSIH(I)=MAX(PSIH(I),psilim) - PSIM10(I)=MAX(10./ZA(I)*PSIM(I), psilim) - PSIH10(I)=MAX(10./ZA(I)*PSIH(I), psilim) - PSIM2(I)=MAX(2./ZA(I)*PSIM(I), psilim) - PSIH2(I)=MAX(2./ZA(I)*PSIH(I), psilim) - ! 1.0 over Monin-Obukhov length - RMOL(I)= ZOL(I)/ZA(I) - - ELSEIF(BR(I) .EQ. 0.) THEN - !========================================================= - !-----CLASS 3; FORCED CONVECTION/NEUTRAL: - !========================================================= - REGIME(I)=3. - - PSIM(I)=0.0 - PSIH(I)=PSIM(I) - PSIM10(I)=0. - PSIH10(I)=PSIM10(I) - PSIM2(I)=0. - PSIH2(I)=PSIM2(I) - - !ZOL(I)=0. - IF(UST(I) .LT. 0.01)THEN - ZOL(I)=BR(I)*GZ1OZ0(I) - ELSE - ZOL(I)=KARMAN*GOVRTH(I)*ZA(I)*MOL(I)/(UST(I)*UST(I)) - ENDIF - RMOL(I) = ZOL(I)/ZA(I) - - ELSEIF(BR(I) .LT. 0.)THEN - !========================================================== - !-----CLASS 4; FREE CONVECTION: - !========================================================== - REGIME(I)=4. - - !COMPUTE z/L - !CALL Li_etal_2010(ZOL(I),BR(I),ZA(I)/ZNT(I),zratio(I)) - IF (ITER .EQ. 1 .AND. itimestep .LE. 1) THEN - CALL Li_etal_2010(ZOL(I),BR(I),ZA(I)/ZNT(I),zratio(I)) - ELSE - ZOL(I)=ZA(I)*KARMAN*G*MOL(I)/(TH1D(I)*MAX(UST(I),0.001)**2) - ZOL(I)=MAX(ZOL(I),-9.999) - ZOL(I)=MIN(ZOL(I),0.0) - ENDIF - - ZOL10=10./ZA(I)*ZOL(I) - ZOL2=2./ZA(I)*ZOL(I) - ZOL(I)=MIN(ZOL(I),0.) - ZOL(I)=MAX(ZOL(I),-9.9999) - ZOL10=MIN(ZOL10,0.) - ZOL10=MAX(ZOL10,-9.9999) - ZOL2=MIN(ZOL2,0.) - ZOL2=MAX(ZOL2,-9.9999) - NZOL=INT(-ZOL(I)*100.) - RZOL=-ZOL(I)*100.-NZOL - NZOL10=INT(-ZOL10*100.) - RZOL10=-ZOL10*100.-NZOL10 - NZOL2=INT(-ZOL2*100.) - RZOL2=-ZOL2*100.-NZOL2 - - !COMPUTE PSIM and PSIH - IF((XLAND(I)-1.5).GE.0)THEN - ! WATER - !CALL PSI_Suselj_Sood_2010(PSIM(I),PSIH(I),ZOL(I)) - !CALL PSI_Hogstrom_1996(PSIM(I),PSIH(I),ZOL(I), z_t(I), ZNT(I), ZA(I)) - !CALL PSI_Businger_1971(PSIM(I),PSIH(I),ZOL(I)) - CALL PSI_DyerHicks(PSIM(I),PSIH(I),ZOL(I),z_t(I),ZNT(I),ZA(I)) - ELSE - ! LAND - !CALL PSI_Hogstrom_1996(PSIM(I),PSIH(I),ZOL(I), z_t(I), ZNT(I), ZA(I)) - !CALL PSI_Businger_1971(PSIM(I),PSIH(I),ZOL(I)) - CALL PSI_DyerHicks(PSIM(I),PSIH(I),ZOL(I),z_t(I),ZNT(I),ZA(I)) - ENDIF - -!!!!!JOE-test:avoid using psi tables in entirety -! PSIM10(I)=PSIMTB(NZOL10)+RZOL10*(PSIMTB(NZOL10+1)-PSIMTB(NZOL10)) -! PSIH10(I)=PSIHTB(NZOL10)+RZOL10*(PSIHTB(NZOL10+1)-PSIHTB(NZOL10)) -! PSIM2(I)=PSIMTB(NZOL2)+RZOL2*(PSIMTB(NZOL2+1)-PSIMTB(NZOL2)) -! PSIH2(I)=PSIHTB(NZOL2)+RZOL2*(PSIHTB(NZOL2+1)-PSIHTB(NZOL2)) - PSIM10(I)=10./ZA(I)*PSIM(I) - PSIH10(I)=10./ZA(I)*PSIH(I) - PSIM2(I)=2./ZA(I)*PSIM(I) - PSIH2(I)=2./ZA(I)*PSIH(I) - - !---LIMIT PSIH AND PSIM IN THE CASE OF THIN LAYERS AND - !---HIGH ROUGHNESS. THIS PREVENTS DENOMINATOR IN FLUXES - !---FROM GETTING TOO SMALL - !PSIH(I)=MIN(PSIH(I),0.9*GZ1OZt(I)) !JOE: less restricitive over forest/urban. - PSIH(I)=MIN(PSIH(I),0.9*GZ1OZ0(I)) - PSIM(I)=MIN(PSIM(I),0.9*GZ1OZ0(I)) - !PSIH2(I)=MIN(PSIH2(I),0.9*GZ2OZt(I)) !JOE: less restricitive over forest/urban. - PSIH2(I)=MIN(PSIH2(I),0.9*GZ2OZ0(I)) - PSIM2(I)=MIN(PSIM2(I),0.9*GZ2OZ0(I)) - PSIM10(I)=MIN(PSIM10(I),0.9*GZ10OZ0(I)) - PSIH10(I)=MIN(PSIH10(I),0.9*GZ10OZ0(I)) - - RMOL(I) = ZOL(I)/ZA(I) - - ENDIF - - !------------------------------------------------------------ - !-----COMPUTE THE FRICTIONAL VELOCITY: - !------------------------------------------------------------ - ! ZA(1982) EQS(2.60),(2.61). - GZ1OZ0(I) =LOG((ZA(I)+ZNT(I))/ZNT(I)) - GZ10OZ0(I)=LOG((10.+ZNT(I))/ZNT(I)) - PSIX=GZ1OZ0(I)-PSIM(I) - PSIX10=GZ10OZ0(I)-PSIM10(I) - ! TO PREVENT OSCILLATIONS AVERAGE WITH OLD VALUE - OLDUST = UST(I) - UST(I)=0.5*UST(I)+0.5*KARMAN*WSPD(I)/PSIX - !NON-AVERAGED: UST(I)=KARMAN*WSPD(I)/PSIX - - ! Compute u* without vconv for use in HFX calc when isftcflx > 0 - WSPDI(I)=MAX(SQRT(U1D(I)*U1D(I)+V1D(I)*V1D(I)), wmin) - IF ( PRESENT(USTM) ) THEN - USTM(I)=0.5*USTM(I)+0.5*KARMAN*WSPDI(I)/PSIX - ENDIF - - IF ((XLAND(I)-1.5).LT.0.) THEN !LAND - UST(I)=MAX(UST(I),0.01) !JOE:Relaxing this limit - !Keep ustm = ust over land. - IF ( PRESENT(USTM) ) USTM(I)=UST(I) - ENDIF - - !------------------------------------------------------------ - !-----COMPUTE THE THERMAL AND MOISTURE RESISTANCE (PSIQ AND PSIT): - !------------------------------------------------------------ - ! LOWER LIMIT ADDED TO PREVENT LARGE FLHC IN SOIL MODEL - ! ACTIVATES IN UNSTABLE CONDITIONS WITH THIN LAYERS OR HIGH Z0 - GZ1OZt(I)= LOG((ZA(I)+z_t(i))/z_t(i)) - GZ2OZt(I)= LOG((2.0+z_t(i))/z_t(i)) - - !PSIT=MAX(GZ1OZ0(I)-PSIH(I),2.) - PSIT=MAX(LOG((ZA(I)+z_t(i))/z_t(i))-PSIH(I) ,2.0) - PSIT2=MAX(LOG((2.0+z_t(i))/z_t(i))-PSIH2(I) ,2.0) - resist(I)=PSIT - logres(I)=GZ1OZt(I) - - PSIQ=MAX(LOG((za(i)+z_q(i))/z_q(I))-PSIH(I) ,2.0) - PSIQ2=MAX(LOG((2.0+z_q(i))/z_q(I))-PSIH2(I) ,2.0) - - IF((XLAND(I)-1.5).LT.0)THEN !Land only - IF ( IZ0TLND .EQ. 4 ) THEN - CALL Pan_etal_1994(PSIQ,PSIQ2,UST(I),PSIH(I),PSIH2(I),& - & KARMAN,ZA(I)) - ENDIF - ENDIF - - !---------------------------------------------------- - !COMPUTE THE TEMPERATURE SCALE (or FRICTION TEMPERATURE, T*) - !---------------------------------------------------- - DTG=TH1D(I)-THGB(I) - OLDTST=MOL(I) - MOL(I)=KARMAN*DTG/PSIT/PRT - !t_star(I) = -HFX(I)/(UST(I)*CPM(I)*RHO1D(I)) - !t_star(I) = MOL(I) - !---------------------------------------------------- - !COMPUTE THE MOISTURE SCALE (or q*) - DQG=(QVSH(i)-qsfc(i))*1000. !(kg/kg -> g/kg) - qstar(I)=KARMAN*DQG/PSIQ/PRT - - !----------------------------------------------------- - !COMPUTE DIAGNOSTICS - !----------------------------------------------------- - !COMPUTE 10 M WNDS - !----------------------------------------------------- - ! If the lowest model level is close to 10-m, use it - ! instead of the flux-based diagnostic formula. - if (ZA(i) .gt. 7.0 .and. ZA(i) .lt. 13.0) then - U10(I)=U1D(I) - V10(I)=V1D(I) - else - U10(I)=U1D(I)*PSIX10/PSIX - V10(I)=V1D(I)*PSIX10/PSIX - endif - - !----------------------------------------------------- - !COMPUTE 2m T, TH, AND Q - !THESE WILL BE OVERWRITTEN FOR LAND POINTS IN THE LSM - !----------------------------------------------------- - TH2(I)=THGB(I)+DTG*PSIT2/PSIT - !*** BE CERTAIN THAT THE 2-M THETA IS BRACKETED BY - !*** THE VALUES AT THE SURFACE AND LOWEST MODEL LEVEL. -! IF ((TH1D(I)>THGB(I) .AND. (TH2(I)TH1D(I))) .OR. & -! (TH1D(I)THGB(I) .OR. TH2(I)QSFCMR(I) .AND. (Q2(I)QV1D(I))) .OR. & - (QV1D(I)QSFCMR(I) .OR. Q2(I) 1200. .OR. HFX(I) < -500. .OR. & -! &LH(I) > 1200. .OR. LH(I) < -500. .OR. & -! &UST(I) < 0.0 .OR. UST(I) > 4.0 .OR. & -! &WSTAR(I)<0.0 .OR. WSTAR(I) > 6.0 .OR. & -! &RHO1D(I)<0.0 .OR. RHO1D(I) > 1.6 .OR. & -! &QSFC(I)*1000. <0.0 .OR. QSFC(I)*1000. >38. .OR. & -! &PBLH(I)>6000.) THEN -! print*,"SUSPICIOUS VALUES IN MYNN SFCLAYER",& -! ITER-ITMAX," ITERATIONS",I,J -! write(*,1000)"HFX: ",HFX(I)," LH:",LH(I)," CH:",CH(I),& -! " PBLH:",PBLH(I) -! write(*,1001)"REGIME:",REGIME(I)," z/L:",ZOL(I)," U*:",UST(I),& -! " Tstar:",MOL(I) -! write(*,1002)"PSIM:",PSIM(I)," PSIH:",PSIH(I)," W*:",WSTAR(I),& -! " DTHV:",THV1D(I)-THVGB(I) -! write(*,1003)"CPM:",CPM(I)," RHO1D:",RHO1D(I)," L:",& -! ZOL(I)/ZA(I)," DTH:",TH1D(I)-THGB(I) -! write(*,1004)"Z0/Zt:",zratio(I)," Z0:",ZNT(I)," Zt:",z_t(I),& -! " za:",za(I) -! write(*,1005)"Re:",restar," MAVAIL:",MAVAIL(I)," QSFC(I):",& -! QSFC(I)," QVSH(I):",QVSH(I) -! print*,"PSIX=",PSIX," Z0:",ZNT(I)," T1D(i):",T1D(i) -! write(*,*)"=============================================" -! ENDIF -! ENDIF - - ENDDO !end i-loop - -END SUBROUTINE SFCLAY1D_mynn -!------------------------------------------------------------------- - SUBROUTINE zilitinkevich_1995(Z_0,Zt,Zq,restar,ustar,KARMAN,& - & landsea,IZ0TLND2) - - ! This subroutine returns the thermal and moisture roughness lengths - ! from Zilitinkevich (1995) and Zilitinkevich et al. (2001) over - ! land and water, respectively. - ! - ! MODS: - ! 20120705 : added IZ0TLND option. Note: This option was designed - ! to work with the Noah LSM and may be specific for that - ! LSM only. Tests with RUC LSM showed no improvements. - - IMPLICIT NONE - REAL, INTENT(IN) :: Z_0,restar,ustar,KARMAN,landsea - INTEGER, OPTIONAL, INTENT(IN):: IZ0TLND2 - REAL, INTENT(OUT) :: Zt,Zq - REAL :: CZIL !=0.100 in Chen et al. (1997) - !=0.075 in Zilitinkevich (1995) - !=0.500 in Lemone et al. (2008) - - IF (landsea-1.5 .GT. 0) THEN !WATER - - !THIS IS BASED ON Zilitinkevich, Grachev, and Fairall (2001; - !Their equations 15 and 16). - IF (restar .LT. 0.1) THEN - Zt = Z_0*EXP(KARMAN*2.0) - Zt = MIN( Zt, 6.0e-5) - Zt = MAX( Zt, 2.0e-9) - Zq = Z_0*EXP(KARMAN*3.0) - Zq = MIN( Zq, 6.0e-5) - Zq = MAX( Zq, 2.0e-9) - ELSE - Zt = Z_0*EXP(-KARMAN*(4.0*SQRT(restar)-3.2)) - Zt = MIN( Zt, 6.0e-5) - Zt = MAX( Zt, 2.0e-9) - Zq = Z_0*EXP(-KARMAN*(4.0*SQRT(restar)-4.2)) - Zq = MIN( Zt, 6.0e-5) - Zq = MAX( Zt, 2.0e-9) - ENDIF - - ELSE !LAND - - !Option to modify CZIL according to Chen & Zhang, 2009 - IF ( IZ0TLND2 .EQ. 1 ) THEN - CZIL = 10.0 ** ( -0.40 * ( Z_0 / 0.07 ) ) - ELSE - CZIL = 0.10 - END IF - - Zt = Z_0*EXP(-KARMAN*CZIL*SQRT(restar)) - Zt = MIN( Zt, Z_0/2.) - - Zq = Z_0*EXP(-KARMAN*CZIL*SQRT(restar)) - Zq = MIN( Zq, Z_0/2.) - - !Zq = Zt - ENDIF - - return - - END SUBROUTINE zilitinkevich_1995 -!-------------------------------------------------------------------- - SUBROUTINE Pan_etal_1994(PSIQ,PSIQ2,ustar,psih,psih2,KARMAN,Z1) - - ! This subroutine returns the resistance (PSIQ) for moisture - ! exchange. This is a modified form originating from Pan et al. - ! (1994) but modified according to tests in both the RUC model - ! and WRF-ARW. Note that it is very similar to Carlson and - ! Boland (1978) model (include below in comments) but has an - ! extra molecular layer (a third layer) instead of two layers. - - IMPLICIT NONE - REAL, INTENT(IN) :: Z1,ustar,KARMAN,psih,psih2 - REAL, INTENT(OUT) :: psiq,psiq2 - REAL, PARAMETER :: Cpan=1.0 !was 20.8 in Pan et al 1994 - REAL, PARAMETER :: ZL=0.01 - REAL, PARAMETER :: ZMUs=0.2E-3 - REAL, PARAMETER :: XKA = 2.4E-5 - - !PAN et al. (1994): 3-layer model, as in paper: - !ZMU = Cpan*XKA/(KARMAN*UST(I)) - !PSIQ =MAX(KARMAN*ustar*ZMU/XKA + LOG((KARMAN*ustar*ZL + XKA)/XKA + & - ! & Z1/ZL) - PSIH,2.0) - !PSIQ2=MAX(KARMAN*ustar*ZMU/XKA + LOG((KARMAN*ustar*ZL + XKA)/XKA + & - ! & 2./ZL) - PSIH2,2.0) - !MODIFIED FORM: - PSIQ =MAX(KARMAN*ustar*ZMUs/XKA + LOG((KARMAN*ustar*Z1)/XKA + & - & Z1/ZL) - PSIH,2.0) - PSIQ2=MAX(KARMAN*ustar*ZMUs/XKA + LOG((KARMAN*ustar*2.0)/XKA + & - & 2./ZL) - PSIH2,2.0) - - !CARLSON AND BOLAND (1978): 2-layer model - !PSIQ =MAX(LOG(KARMAN*ustar*Z1/XKA + Z1/ZL)-PSIH ,2.0) - !PSIQ2=MAX(LOG(KARMAN*ustar*2./XKA + 2./ZL)-PSIH2 ,2.0) - - END SUBROUTINE Pan_etal_1994 -!-------------------------------------------------------------- - SUBROUTINE davis_etal_2008(Z_0,ustar) - - !This formulation for roughness length was designed to match - !the labratory experiments of Donelan et al. (2004). - !This is an update version from Davis et al. 2008, which - !corrects a small-bias in Z_0 (AHW real-time 2012). - - IMPLICIT NONE - REAL, INTENT(IN) :: ustar - REAL, INTENT(OUT) :: Z_0 - REAL :: ZW, ZN1, ZN2 - REAL, PARAMETER :: G=9.81, OZO=1.59E-5 - - !OLD FORM: Z_0 = 10.*EXP(-10./(ustar**(1./3.))) - !NEW FORM: - - ZW = MIN((ustar/1.06)**(0.3),1.0) - ZN1 = 0.011*ustar*ustar/G + OZO - ZN2 = 10.*exp(-9.5*ustar**(-.3333)) + & - 0.11*1.5E-5/AMAX1(ustar,0.01) - Z_0 = (1.0-ZW) * ZN1 + ZW * ZN2 - - Z_0 = MAX( Z_0, 1.27e-7) !These max/mins were suggested by - Z_0 = MIN( Z_0, 2.85e-3) !Davis et al. (2008) - - return - - END SUBROUTINE davis_etal_2008 -!-------------------------------------------------------------------- - SUBROUTINE Taylor_Yelland_2001(Z_0,ustar,wsp10) - - !This formulation for roughness length was designed account for - !wave steepness. - - IMPLICIT NONE - REAL, INTENT(IN) :: ustar,wsp10 - REAL, INTENT(OUT) :: Z_0 - REAL, parameter :: g=9.81, pi=3.14159265 - REAL :: hs, Tp, Lp - - !hs is the significant wave height - hs = 0.0248*(wsp10**2.) - !Tp dominant wave period - Tp = 0.729*MAX(wsp10,0.1) - !Lp is the wavelength of the dominant wave - Lp = g*Tp**2/(2*pi) - - Z_0 = 1200.*hs*(hs/Lp)**4.5 - Z_0 = MAX( Z_0, 1.27e-7) !These max/mins were suggested by - Z_0 = MIN( Z_0, 2.85e-3) !Davis et al. (2008) - - return - - END SUBROUTINE Taylor_Yelland_2001 -!-------------------------------------------------------------------- - SUBROUTINE charnock_1955(Z_0,ustar,wsp10,visc) - - !This version of Charnock's relation employs a varying - !Charnock parameter, similar to COARE3.0 [Fairall et al. (2003)]. - !The Charnock parameter CZC is varied from .011 to .018 - !between 10-m wsp = 10 and 18. - - IMPLICIT NONE - REAL, INTENT(IN) :: ustar, visc, wsp10 - REAL, INTENT(OUT) :: Z_0 - REAL, PARAMETER :: G=9.81, CZO2=0.011 - REAL :: CZC !variable charnock "constant" - - CZC = CZO2 + 0.007*MIN(MAX((wsp10-10.)/8., 0.), 1.0) - Z_0 = CZC*ustar*ustar/G + (0.11*visc/MAX(ustar,0.1)) - Z_0 = MAX( Z_0, 1.27e-7) !These max/mins were suggested by - Z_0 = MIN( Z_0, 2.85e-3) !Davis et al. (2008) - - return - - END SUBROUTINE charnock_1955 -!-------------------------------------------------------------------- - SUBROUTINE garratt_1992(Zt,Zq,Z_0,Ren,landsea) - - !This formulation for the thermal and moisture roughness lengths - !(Zt and Zq) relates them to Z0 via the roughness Reynolds number (Ren). - !This formula comes from Fairall et al. (2003). It is modified from - !the original Garratt-Brutsaert model to better fit the COARE/HEXMAX - !data. The formula for land uses a constant ratio (Z_0/7.4) taken - !from Garratt (1992). - - IMPLICIT NONE - REAL, INTENT(IN) :: Ren, Z_0,landsea - REAL, INTENT(OUT) :: Zt,Zq - REAL :: Rq - REAL, PARAMETER :: e=2.71828183 - - IF (landsea-1.5 .GT. 0) THEN !WATER - - Zt = Z_0*EXP(2.0 - (2.48*(Ren**0.25))) - Zq = Z_0*EXP(2.0 - (2.28*(Ren**0.25))) - - Zq = MIN( Zq, 5.5e-5) - Zq = MAX( Zq, 2.0e-9) - Zt = MIN( Zt, 5.5e-5) - Zt = MAX( Zt, 2.0e-9) !same lower limit as ECMWF - ELSE !LAND - Zq = Z_0/(e**2.) !taken from Garratt (1980,1992) - Zt = Zq - ENDIF - - return - - END SUBROUTINE garratt_1992 -!-------------------------------------------------------------------- - SUBROUTINE fairall_2001(Zt,Zq,Ren,ustar,visc) - - !This formulation for thermal and moisture roughness length (Zt and Zq) - !as a function of the roughness Reynolds number (Ren) comes from the - !COARE3.0 formulation, empirically derived from COARE and HEXMAX data - ![Fairall et al. (2003)]. Edson et al. (2004; JGR) suspected that this - !relationship overestimated roughness lengths for low Reynolds number - !flows, so a smooth flow relationship, taken from Garrattt (1992, p. 102), - !is used for flows with Ren < 2. - ! - !Note that this formulation should not be used with the Davis et al. - !(2008) formulation for Zo, because that formulation produces much - !smaller u* (Ren), resulting in a large Zt and Zq. It works best with - !the Charnock or the Taylor and Yelland relationships. - ! - !This is for use over water only. - - IMPLICIT NONE - REAL, INTENT(IN) :: Ren,ustar,visc - REAL, INTENT(OUT) :: Zt,Zq - - IF (Ren .le. 2.) then - - Zt = (5.5e-5)*(Ren**(-0.60)) - Zq = Zt - !FOR SMOOTH SEAS, USE GARRATT - !Zq = 0.2*visc/MAX(ustar,0.1) - !Zq = 0.3*visc/MAX(ustar,0.1) - - ELSE - - !FOR ROUGH SEAS, USE FAIRALL - Zt = (5.5e-5)*(Ren**(-0.60)) - Zq = Zt - - ENDIF - - Zt = MIN(Zt,1.0e-4) - Zt = MAX(Zt,2.0e-9) - - Zq = MIN(Zt,1.0e-4) - Zq = MAX(Zt,2.0e-9) - - return - - END SUBROUTINE fairall_2001 -!-------------------------------------------------------------------- - SUBROUTINE Yang_2008(Z_0,Zt,Zq,ustar,tstar,qst,Ren,visc,landsea) - - !This is a modified version of Yang et al (2002 QJRMS, 2008 JAMC) - !and Chen et al (2010, J of Hydromet). Although it was originally - !designed for arid regions with bare soil, it is modified - !here to perform over a broader spectrum of vegetation. - ! - !The original formulation relates the thermal roughness length (Zt) - !to u* and T*: - ! - ! Zt = ht * EXP(-beta*(ustar**0.5)*(ABS(tstar)**0.25)) - ! - !where ht = Renc*visc/ustar and the critical Reynolds number - !(Renc) = 70. Beta was originally = 10 (2002 paper) but was revised - !to 7.2 (in 2008 paper). Their form typically varies the - !ratio Z0/Zt by a few orders of magnitude (1-1E4). - ! - !This modified form uses beta = 0.5 and Renc = 350, so zt generally - !varies similarly to the Zilitinkevich form for small/moderate heat - !fluxes but can become ~O(1/2 Zilitinkevich) for very large negative T*. - !Also, the exponent (0.25) on tstar was changed to 1.0, since we found - !Zt was reduced too much for low-moderate positive heat fluxes. - ! - !This should only be used over land! - - IMPLICIT NONE - REAL, INTENT(IN) :: Z_0, Ren, ustar, tstar, qst, visc, landsea - REAL :: ht, tstar2 - REAL, INTENT(OUT) :: Zt,Zq - REAL, PARAMETER :: Renc=350., beta=0.5, e=2.71828183 - - ht = Renc*visc/MAX(ustar,0.01) - tstar2 = MIN(tstar, 0.0) - - Zt = ht * EXP(-beta*(ustar**0.5)*(ABS(tstar2)**1.0)) - !Zq = ht * EXP(-beta*(ustar**0.5)*(ABS(qst)**1.0)) - Zq = Zt - - Zt = MIN(Zt, Z_0/2.0) !(e**2.)) !limit from Garratt (1980,1992) - Zq = MIN(Zq, Z_0/2.0) !(e**2.)) !limit from Garratt (1980,1992) - - return - - END SUBROUTINE Yang_2008 -!-------------------------------------------------------------------- - SUBROUTINE Andreas_2002(Z_0,Ren,Zt,Zq) - - !This is taken from Andreas (2002; J. of Hydromet). - ! - !This should only be used over snow/ice! - - IMPLICIT NONE - REAL, INTENT(IN) :: Z_0, Ren - REAL, INTENT(OUT) :: Zt, Zq - REAL :: Ren2 - - REAL, PARAMETER :: bt0_s=1.25, bt0_t=0.149, bt0_r=0.317, & - bt1_s=0.0, bt1_t=-0.55, bt1_r=-0.565, & - bt2_s=0.0, bt2_t=0.0, bt2_r=-0.183 - - REAL, PARAMETER :: bq0_s=1.61, bq0_t=0.351, bq0_r=0.396, & - bq1_s=0.0, bq1_t=-0.628, bq1_r=-0.512, & - bq2_s=0.0, bq2_t=0.0, bq2_r=-0.180 - - Ren2 = Ren - ! Make sure that Re is not outside of the range of validity - ! for using their equations - IF (Ren2 .gt. 1000.) Ren2 = 1000. - - IF (Ren2 .le. 0.135) then - - Zt = Z_0*EXP(bt0_s + bt1_s*LOG(Ren2) + bt2_s*LOG(Ren2)**2) - Zq = Z_0*EXP(bq0_s + bq1_s*LOG(Ren2) + bq2_s*LOG(Ren2)**2) - - ELSE IF (Ren2 .gt. 0.135 .AND. Ren2 .lt. 2.5) then - - Zt = Z_0*EXP(bt0_t + bt1_t*LOG(Ren2) + bt2_t*LOG(Ren2)**2) - Zq = Z_0*EXP(bq0_t + bq1_t*LOG(Ren2) + bq2_t*LOG(Ren2)**2) - - ELSE - - Zt = Z_0*EXP(bt0_r + bt1_r*LOG(Ren2) + bt2_r*LOG(Ren2)**2) - Zq = Z_0*EXP(bq0_r + bq1_r*LOG(Ren2) + bq2_r*LOG(Ren2)**2) - - ENDIF - - return - - END SUBROUTINE Andreas_2002 -!-------------------------------------------------------------------- - SUBROUTINE PSI_Hogstrom_1996(psi_m, psi_h, zL, Zt, Z_0, Za) - - ! This subroutine returns the stability functions based off - ! of Hogstrom (1996). - - IMPLICIT NONE - REAL, INTENT(IN) :: zL, Zt, Z_0, Za - REAL, INTENT(OUT) :: psi_m, psi_h - REAL :: x, x0, y, y0, zmL, zhL - - zmL = Z_0*zL/Za - zhL = Zt*zL/Za - - IF (zL .gt. 0.) THEN !STABLE (not well tested - seem large) - - psi_m = -5.3*(zL - zmL) - psi_h = -8.0*(zL - zhL) - - ELSE !UNSTABLE - - x = (1.-19.0*zL)**0.25 - x0= (1.-19.0*zmL)**0.25 - y = (1.-11.6*zL)**0.5 - y0= (1.-11.6*zhL)**0.5 - - psi_m = 2.*LOG((1.+x)/(1.+x0)) + & - &LOG((1.+x**2.)/(1.+x0**2.)) - & - &2.0*ATAN(x) + 2.0*ATAN(x0) - psi_h = 2.*LOG((1.+y)/(1.+y0)) - - ENDIF - - return - - END SUBROUTINE PSI_Hogstrom_1996 -!-------------------------------------------------------------------- - SUBROUTINE PSI_DyerHicks(psi_m, psi_h, zL, Zt, Z_0, Za) - - ! This subroutine returns the stability functions based off - ! of Hogstrom (1996), but with different constants compatible - ! with Dyer and Hicks (1970/74?). This formulation is used for - ! testing/development by Nakanishi (personal communication). - - IMPLICIT NONE - REAL, INTENT(IN) :: zL, Zt, Z_0, Za - REAL, INTENT(OUT) :: psi_m, psi_h - REAL :: x, x0, y, y0, zmL, zhL - - zmL = Z_0*zL/Za !Zo/L - zhL = Zt*zL/Za !Zt/L - - IF (zL .gt. 0.) THEN !STABLE - - psi_m = -5.0*(zL - zmL) - psi_h = -5.0*(zL - zhL) - - ELSE !UNSTABLE - - x = (1.-16.*zL)**0.25 - x0= (1.-16.*zmL)**0.25 - - y = (1.-16.*zL)**0.5 - y0= (1.-16.*zhL)**0.5 - - psi_m = 2.*LOG((1.+x)/(1.+x0)) + & - &LOG((1.+x**2.)/(1.+x0**2.)) - & - &2.0*ATAN(x) + 2.0*ATAN(x0) - psi_h = 2.*LOG((1.+y)/(1.+y0)) - - ENDIF - - return - - END SUBROUTINE PSI_DyerHicks -!-------------------------------------------------------------------- - SUBROUTINE PSI_Beljaars_Holtslag_1991(psi_m, psi_h, zL) - - ! This subroutine returns the stability functions based off - ! of Beljaar and Holtslag 1991, which is an extension of Holtslag - ! and Debruin 1989. - - IMPLICIT NONE - REAL, INTENT(IN) :: zL - REAL, INTENT(OUT) :: psi_m, psi_h - REAL, PARAMETER :: a=1., b=0.666, c=5., d=0.35 - - IF (zL .lt. 0.) THEN !UNSTABLE - - WRITE(*,*)"WARNING: Universal stability functions from" - WRITE(*,*)" Beljaars and Holtslag (1991) should only" - WRITE(*,*)" be used in the stable regime!" - psi_m = 0. - psi_h = 0. - - ELSE !STABLE - - psi_m = -(a*zL + b*(zL -(c/d))*exp(-d*zL) + (b*c/d)) - psi_h = -((1.+.666*a*zL)**1.5 + & - b*(zL - (c/d))*exp(-d*zL) + (b*c/d) -1.) - - ENDIF - - return - - END SUBROUTINE PSI_Beljaars_Holtslag_1991 -!-------------------------------------------------------------------- - SUBROUTINE PSI_Zilitinkevich_Esau_2007(psi_m, psi_h, zL) - - ! This subroutine returns the stability functions come from - ! Zilitinkevich and Esau (2007, BM), which are formulatioed from the - ! "generalized similarity theory" and tuned to the LES DATABASE64 - ! to determine their dependence on z/L. - - IMPLICIT NONE - REAL, INTENT(IN) :: zL - REAL, INTENT(OUT) :: psi_m, psi_h - REAL, PARAMETER :: Cm=3.0, Ct=2.5 - - IF (zL .lt. 0.) THEN !UNSTABLE - - WRITE(*,*)"WARNING: Universal stability function from" - WRITE(*,*)" Zilitinkevich and Esau (2007) should only" - WRITE(*,*)" be used in the stable regime!" - psi_m = 0. - psi_h = 0. - - ELSE !STABLE - - psi_m = -Cm*(zL**(5./6.)) - psi_h = -Ct*(zL**(4./5.)) - - ENDIF - - return - - END SUBROUTINE PSI_Zilitinkevich_Esau_2007 -!-------------------------------------------------------------------- - SUBROUTINE PSI_Businger_1971(psi_m, psi_h, zL) - - ! This subroutine returns the flux-profile relationships - ! of Businger el al. 1971. - - IMPLICIT NONE - REAL, INTENT(IN) :: zL - REAL, INTENT(OUT) :: psi_m, psi_h - REAL :: x, y - REAL, PARAMETER :: Pi180 = 3.14159265/180. - - IF (zL .lt. 0.) THEN !UNSTABLE - - x = (1. - 15.0*zL)**0.25 - y = (1. - 9.0*zL)**0.5 - - psi_m = LOG(((1.+x)/2.)**2.) + & - &LOG((1.+x**2.)/2.) - & - &2.0*ATAN(x) + Pi180*90. - psi_h = 2.*LOG((1.+y)/2.) - - ELSE !STABLE - - psi_m = -4.7*zL - psi_h = -(4.7/0.74)*zL - - ENDIF - - return - - END SUBROUTINE PSI_Businger_1971 -!-------------------------------------------------------------------- - SUBROUTINE PSI_Suselj_Sood_2010(psi_m, psi_h, zL) - - !This subroutine returns flux-profile relatioships based off - !of Lobocki (1993), which is derived from the MY-level 2 model. - !Suselj and Sood (2010) applied the surface layer length scales - !from Nakanishi (2001) to get this new relationship. These functions - !are more agressive (larger magnitude) than most formulations. They - !showed improvement over water, but untested over land. - - IMPLICIT NONE - REAL, INTENT(IN) :: zL - REAL, INTENT(OUT) :: psi_m, psi_h - REAL, PARAMETER :: Rfc=0.19, Ric=0.183, PHIT=0.8 - - IF (zL .gt. 0.) THEN !STABLE - - psi_m = -(zL/Rfc + 1.1223*EXP(1.-1.6666/zL)) - !psi_h = -zL*Ric/((Rfc**2.)*PHIT) + 8.209*(zL**1.1091) - !THEIR EQ FOR PSI_H CRASHES THE MODEL AND DOES NOT MATCH - !THEIR FIG 1. THIS EQ (BELOW) MATCHES THEIR FIG 1 BETTER: - psi_h = -(zL*Ric/((Rfc**2.)*5.) + 7.09*(zL**1.1091)) - - ELSE !UNSTABLE - - psi_m = 0.9904*LOG(1. - 14.264*zL) - psi_h = 1.0103*LOG(1. - 16.3066*zL) - - ENDIF - - return - - END SUBROUTINE PSI_Suselj_Sood_2010 -!-------------------------------------------------------------------- - SUBROUTINE Li_etal_2010(zL, Rib, zaz0, z0zt) - - !This subroutine returns a more robust z/L that best matches - !the z/L from Hogstrom (1996) for unstable conditions and Beljaars - !and Holtslag (1991) for stable conditions. - - IMPLICIT NONE - REAL, INTENT(OUT) :: zL - REAL, INTENT(IN) :: Rib, zaz0, z0zt - REAL :: alfa, beta, zaz02, z0zt2 - REAL, PARAMETER :: au11=0.045, bu11=0.003, bu12=0.0059, & - &bu21=-0.0828, bu22=0.8845, bu31=0.1739, & - &bu32=-0.9213, bu33=-0.1057 - REAL, PARAMETER :: aw11=0.5738, aw12=-0.4399, aw21=-4.901,& - &aw22=52.50, bw11=-0.0539, bw12=1.540, & - &bw21=-0.669, bw22=-3.282 - REAL, PARAMETER :: as11=0.7529, as21=14.94, bs11=0.1569,& - &bs21=-0.3091, bs22=-1.303 - - !set limits according to Li et al (2010), p 157. - zaz02=zaz0 - IF (zaz0 .lt. 100.0) zaz02=100. - IF (zaz0 .gt. 100000.0) zaz02=100000. - - !set more limits according to Li et al (2010) - z0zt2=z0zt - IF (z0zt .lt. 0.5) z0zt2=0.5 - IF (z0zt .gt. 100.0) z0zt2=100. - - alfa = LOG(zaz02) - beta = LOG(z0zt2) - - IF (Rib .le. 0.0) THEN - zL = au11*alfa*Rib**2 + ( & - & (bu11*beta + bu12)*alfa**2 + & - & (bu21*beta + bu22)*alfa + & - & (bu31*beta**2 + bu32*beta + bu33))*Rib - !if(zL .LT. -15 .OR. zl .GT. 0.)print*,"VIOLATION Rib<0:",zL - zL = MAX(zL,-15.) !LIMITS SET ACCORDING TO Li et al (2010) - zL = MIN(zL,0.) !Figure 1. - ELSEIF (Rib .gt. 0.0 .AND. Rib .le. 0.2) THEN - zL = ((aw11*beta + aw12)*alfa + & - & (aw21*beta + aw22))*Rib**2 + & - & ((bw11*beta + bw12)*alfa + & - & (bw21*beta + bw22))*Rib - !if(zL .LT. 0 .OR. zl .GT. 4)print*,"VIOLATION 00.2:",zL - zL = MIN(zL,20.) !LIMITS ACCORDING TO Li et al (2010), THIER - !FIGUE 1C. - zL = MAX(zL,1.) - ENDIF - - return +!================================================================================================================= - END SUBROUTINE Li_etal_2010 -!-------------------------------------------------------------------- +!--- input arguments: + integer,intent(in):: ids,ide,jds,jde,kds,kde, & + ims,ime,jms,jme,kms,kme, & + its,ite,jts,jte,kts,kte + integer,intent(in):: itimestep + integer,intent(in):: isfflx + integer,intent(in),optional:: isftcflx, iz0tlnd + integer,intent(in),optional:: spp_pbl + + real(kind=RKIND),intent(in):: svp1,svp2,svp3,svpt0 + real(kind=RKIND),intent(in):: ep1,ep2,karman + real(kind=RKIND),intent(in):: cp,g,rovcp,r,xlv + + real(kind=RKIND),intent(in),dimension(ims:ime,kms:kme,jms:jme):: & + dz8w, & + qv3d, & + p3d, & + t3d, & + qc3d, & + u3d, & + v3d, & + rho3d, & + th3d, & + pi3d + + real(kind=RKIND),intent(in),dimension(ims:ime,kms:kme,jms:jme),optional:: & + pattern_spp_pbl + + real(kind=RKIND),intent(in),dimension(ims:ime,jms:jme):: & + mavail, & + pblh, & + xland, & + tsk, & + qcg, & + psfcpa, & + snowh, & + dx + +!--- output arguments: + character(len=StrKIND),intent(out):: errmsg + integer,intent(out):: errflg + + real(kind=RKIND),intent(out),dimension(ims:ime,jms:jme):: & + u10, & + v10, & + th2, & + t2, & + q2 + + real(kind=RKIND),intent(out),dimension(ims:ime,jms:jme),optional:: & + ck, & + cka, & + cd, & + cda, & + ustm + +!--- inout arguments: + real(kind=RKIND),intent(inout),dimension(ims:ime,jms:jme):: & + regime, & + hfx, & + qfx, & + lh, & + mol, & + rmol, & + qsfc, & + qgh, & + znt, & + zol, & + ust, & + cpm, & + chs2, & + cqs2, & + chs, & + ch, & + flhc, & + flqc, & + gz1oz0, & + wspd, & + br, & + psim, & + psih + +!--- local variables and arrays: + integer:: i,j,k + + real(kind=RKIND),dimension(its:ite):: & + u1d,v1d,u1d2,v1d2,qv1d,p1d,t1d,qc1d,rho1d,dz8w1d,dz2w1d + + real(kind=RKIND),dimension(its:ite):: rstoch1d + + real(kind=RKIND),dimension(ims:ime,jms:jme):: qstar,wstar + +!intermediate variables and arrays to accomodate the CCPP-compliant sourcecode: + logical:: f_spp + + real(kind=RKIND),dimension(its:ite):: mavail_hv,pblh_hv,xland_hv,tsk_hv,psfcpa_hv, & + qcg_hv,snowh_hv,dx_hv + real(kind=RKIND),dimension(its:ite):: regime_hv,hfx_hv,qfx_hv,lh_hv,mol_hv,rmol_hv, & + qgh_hv,qsfc_hv,znt_hv,zol_hv,ust_hv,cpm_hv,chs2_hv, & + cqs2_hv,chs_hv,ch_hv,flhc_hv,flqc_hv,gz1oz0_hv,wspd_hv, & + br_hv,psim_hv,psih_hv + real(kind=RKIND),dimension(its:ite):: u10_hv,v10_hv,th2_hv,t2_hv,q2_hv,wstar_hv,qstar_hv + real(kind=RKIND),dimension(its:ite):: cd_hv,cda_hv,ck_hv,cka_hv,ustm_hv + +!----------------------------------------------------------------------------------------------------------------- + + f_spp = .false. + if(spp_pbl==1 .and. present(pattern_spp_pbl)) f_spp = .true. + + errmsg = ' ' + errflg = 0 + + do j = jts,jte + + !initialization of arrays ust,mol,qsfc,and qstar that are initialized if itimestep equals 1: + do i = its,ite + ust_hv(i) = ust(i,j) + mol_hv(i) = mol(i,j) + qsfc_hv(i) = qsfc(i,j) + qstar_hv(i) = qstar(i,j) + enddo + + call sf_mynn_pre_run(its,ite,kte,itimestep,dz8w,u3d,v3d,p3d,t3d,rho3d,qv3d,qc3d,f_spp, & + pattern_spp_pbl,ust_hv,mol_hv,qsfc_hv,qstar_hv,dz8w1d,u1d,v1d,p1d,t1d,rho1d, & + qv1d,qc1d,rstoch1d,dz2w1d,u1d2,v1d2,errmsg,errflg) + + !input arguments: + do i = its,ite + mavail_hv(i) = mavail(i,j) + pblh_hv(i) = pblh(i,j) + xland_hv(i) = xland(i,j) + tsk_hv(i) = tsk(i,j) + psfcpa_hv(i) = psfcpa(i,j) + qcg_hv(i) = qcg(i,j) + snowh_hv(i) = snowh(i,j) + dx_hv(i) = dx(i,j) + enddo + + !inout arguments: + do i = its,ite + regime_hv(i) = regime(i,j) + hfx_hv(i) = hfx(i,j) + qfx_hv(i) = qfx(i,j) + lh_hv(i) = lh(i,j) + rmol_hv(i) = rmol(i,j) + qgh_hv(i) = qgh(i,j) + znt_hv(i) = znt(i,j) + zol_hv(i) = zol(i,j) + cpm_hv(i) = cpm(i,j) + chs2_hv(i) = chs2(i,j) + cqs2_hv(i) = cqs2(i,j) + chs_hv(i) = chs(i,j) + ch_hv(i) = ch(i,j) + flhc_hv(i) = flhc(i,j) + flqc_hv(i) = flqc(i,j) + gz1oz0_hv(i) = gz1oz0(i,j) + wspd_hv(i) = wspd(i,j) + br_hv(i) = br(i,j) + psim_hv(i) = psim(i,j) + psih_hv(i) = psih(i,j) + enddo + + !output arguments: + do i = its,ite + u10_hv(i) = 0. + v10_hv(i) = 0. + th2_hv(i) = 0. + t2_hv(i) = 0. + q2_hv(i) = 0. + wstar_hv(i) = 0. + enddo + + !optional output arguments: + if(present(ck) .and. present(cka) .and. present(cd) .and. present(cda)) then + do i = its,ite + ck_hv(i) = 0. + cka_hv(i) = 0. + cd_hv(i) = 0. + cda_hv(i) = 0. + enddo + endif + if(present(ustm)) then + do i = its,ite + ustm_hv(i) = ustm(i,j) + enddo + endif + + call sf_mynn_run( & + u1d = u1d , v1d = v1d , t1d = t1d , qv1d = qv1d , & + p1d = p1d , dz8w1d = dz8w1d , rho1d = rho1d , u1d2 = u1d2 , & + v1d2 = v1d2 , dz2w1d = dz2w1d , cp = cp , g = g , & + rovcp = rovcp , r = r , xlv = xlv , psfcpa = psfcpa_hv , & + chs = chs_hv , chs2 = chs2_hv , cqs2 = cqs2_hv , cpm = cpm_hv , & + pblh = pblh_hv , rmol = rmol_hv , znt = znt_hv , ust = ust_hv , & + mavail = mavail_hv , zol = zol_hv , mol = mol_hv , regime = regime_hv , & + psim = psim_hv , psih = psih_hv , xland = xland_hv , hfx = hfx_hv , & + qfx = qfx_hv , tsk = tsk_hv , u10 = u10_hv , v10 = v10_hv , & + th2 = th2_hv , t2 = t2_hv , q2 = q2_hv , flhc = flhc_hv , & + flqc = flqc_hv , snowh = snowh_hv , qgh = qgh_hv , qsfc = qsfc_hv , & + lh = lh_hv , gz1oz0 = gz1oz0_hv , wspd = wspd_hv , br = br_hv , & + isfflx = isfflx , dx = dx_hv , svp1 = svp1 , svp2 = svp2 , & + svp3 = svp3 , svpt0 = svpt0 , ep1 = ep1 , ep2 = ep2 , & + karman = karman , ch = ch_hv , qcg = qcg_hv , itimestep = itimestep , & + wstar = wstar_hv , qstar = qstar_hv , ustm = ustm_hv , ck = ck_hv , & + cka = cka_hv , cd = cd_hv , cda = cda_hv , spp_pbl = f_spp , & + rstoch1d = rstoch1d , isftcflx = isftcflx , iz0tlnd = iz0tlnd , & + its = its , ite = ite , errmsg = errmsg , errflg = errflg & + ) + + !inout arguments: + do i = its,ite + regime(i,j) = regime_hv(i) + hfx(i,j) = hfx_hv(i) + qfx(i,j) = qfx_hv(i) + lh(i,j) = lh_hv(i) + mol(i,j) = mol_hv(i) + rmol(i,j) = rmol_hv(i) + qgh(i,j) = qgh_hv(i) + qsfc(i,j) = qsfc_hv(i) + znt(i,j) = znt_hv(i) + zol(i,j) = zol_hv(i) + ust(i,j) = ust_hv(i) + cpm(i,j) = cpm_hv(i) + chs2(i,j) = chs2_hv(i) + cqs2(i,j) = cqs2_hv(i) + chs(i,j) = chs_hv(i) + ch(i,j) = ch_hv(i) + flhc(i,j) = flhc_hv(i) + flqc(i,j) = flqc_hv(i) + gz1oz0(i,j) = gz1oz0_hv(i) + wspd(i,j) = wspd_hv(i) + br(i,j) = br_hv(i) + psim(i,j) = psim_hv(i) + psih(i,j) = psih_hv(i) + enddo + + !output arguments: + do i = its,ite + u10(i,j) = u10_hv(i) + v10(i,j) = v10_hv(i) + th2(i,j) = th2_hv(i) + t2(i,j) = t2_hv(i) + q2(i,j) = q2_hv(i) + wstar(i,j) = wstar_hv(i) + qstar(i,j) = qstar_hv(i) + enddo + + !optional output arguments: + if(present(ck) .and. present(cka) .and. present(cd) .and. present(cda)) then + do i = its,ite + ck(i,j) = ck_hv(i) + cka(i,j) = cka_hv(i) + cd(i,j) = cd_hv(i) + cda(i,j) = cda_hv(i) + enddo + endif + if(present(ustm)) then + do i = its,ite + ustm(i,j) = ustm_hv(i) + enddo + endif + + enddo + + end subroutine sfclay_mynn -END MODULE module_sf_mynn +!================================================================================================================= + end module module_sf_mynn +!================================================================================================================= diff --git a/src/core_atmosphere/physics/physics_wrf/sf_mynn_pre.F b/src/core_atmosphere/physics/physics_wrf/sf_mynn_pre.F new file mode 100644 index 0000000000..e4d07a85d4 --- /dev/null +++ b/src/core_atmosphere/physics/physics_wrf/sf_mynn_pre.F @@ -0,0 +1,169 @@ +!================================================================================================================= + module sf_mynn_pre + use ccpp_kinds,only: kind_phys + + implicit none + private + public:: sf_mynn_pre_init, & + sf_mynn_pre_finalize, & + sf_mynn_pre_run + + + contains + +!================================================================================================================= +!>\section arg_table_sf_mynn_pre_init +!!\html\include sf_mynn_pre_init.html +!! + subroutine sf_mynn_pre_init(errmsg,errflg) +!================================================================================================================= + +!--- output arguments: + character(len=*),intent(out):: & + errmsg ! output error message (-). + + integer,intent(out):: & + errflg ! output error flag (-). + +!----------------------------------------------------------------------------------------------------------------- + +!--- output error flag and message: + errflg = 0 + errmsg = " " + + end subroutine sf_mynn_pre_init + +!================================================================================================================= +!>\section arg_table_sf_mynn_pre_finalize +!!\html\include sf_mynn_pre_finalize.html +!! + subroutine sf_mynn_pre_finalize(errmsg,errflg) +!================================================================================================================= + +!--- output arguments: + character(len=*),intent(out):: & + errmsg ! output error message (-). + + integer,intent(out):: & + errflg ! output error flag (-). + +!----------------------------------------------------------------------------------------------------------------- + +!--- output error flag and message: + errflg = 0 + errmsg = " " + + end subroutine sf_mynn_pre_finalize + +!================================================================================================================= +!>\section arg_table_sf_mynn_pre_run +!!\html\include sf_mynn_pre_run.html +!! + subroutine sf_mynn_pre_run(its,ite,kte,itimestep,dz3d,u3d,v3d,p3d,t3d,rho3d,qv3d,qc3d,f_spp,pattern_spp, & + ust,mol,qsfc,qstar,dz8w1d,u1d,v1d,p1d,t1d,rho1d,qv1d,qc1d,rstoch1d,dz2w1d,u1d2, & + v1d2,errmsg,errflg) +!================================================================================================================= + +!--- input arguments: + logical,intent(in):: f_spp + + integer,intent(in):: its,ite + integer,intent(in):: kte + integer,intent(in):: itimestep + + real(kind=kind_phys),intent(in),dimension(its:ite,1:kte):: & + dz3d, &! + u3d, &! + v3d, &! + qv3d, &! + qc3d, &! + p3d, &! + t3d, &! + rho3d ! + + real(kind=kind_phys),intent(in),dimension(its:ite,1:kte):: & + pattern_spp ! + + +!--- inout arguments: + real(kind=kind_phys),intent(inout),dimension(its:ite):: & + ust, &! + mol, &! + qsfc, &! + qstar ! + + +!--- output arguments: + character(len=*),intent(out):: & + errmsg ! output error message (-). + + integer,intent(out):: & + errflg ! output error flag (-). + + real(kind=kind_phys),intent(out),dimension(its:ite):: & + dz8w1d, &! + u1d, &! + v1d, &! + qv1d, &! + qc1d, &! + p1d, &! + t1d, &! + rho1d, &! + rstoch1d ! + + real(kind=kind_phys),intent(out),dimension(its:ite):: & + dz2w1d, &! + u1d2, &! + v1d2 ! + + +!--- local variables: + integer:: i,kts + +!----------------------------------------------------------------------------------------------------------------- + + kts = 1 + + do i = its,ite + dz8w1d(i) = dz3d(i,kts) + u1d(i) = u3d(i,kts) + v1d(i) = v3d(i,kts) + qv1d(i) = qv3d(i,kts) + qc1d(i) = qc3d(i,kts) + p1d(i) = p3d(i,kts) + t1d(i) = t3d(i,kts) + rho1d(i) = rho3d(i,kts) + !--- 2nd model level winds - for diags with high-resolution grids: + dz2w1d(i) = dz3d(i,kts+1) + u1d2(i) = u3d(i,kts+1) + v1d2(i) = v3d(i,kts+1) + enddo + + if(f_spp) then + do i = its,ite + rstoch1d(i) = pattern_spp(i,kts) + enddo + else + do i = its,ite + rstoch1d(i)=0._kind_phys + enddo + endif + + if(itimestep == 1) then + do i = its,ite + ust(i) = max(0.04*sqrt(u1d(i)*u1d(i) + v1d(i)*v1d(i)),0.001) + mol(i) = 0._kind_phys + qsfc(i) = qv1d(i)/(1.+qv1d(i)) + qstar(i) = 0._kind_phys + enddo + endif + +!--- output message and error flags: + errmsg = 'sf_mynn_mpas_run OK' + errflg = 0 + + end subroutine sf_mynn_pre_run + +!================================================================================================================= + end module sf_mynn_pre +!================================================================================================================= diff --git a/src/core_init_atmosphere/Registry.xml b/src/core_init_atmosphere/Registry.xml index 9f5abc147e..1773a80e54 100644 --- a/src/core_init_atmosphere/Registry.xml +++ b/src/core_init_atmosphere/Registry.xml @@ -1,5 +1,5 @@ - + @@ -182,6 +182,11 @@ description="The supersampling factor to be used for MODIS maximum snow albedo and monthly albedo datasets (case 7 only)" possible_values="Positive integer values"/> + + + @@ -588,6 +594,7 @@ immutable="true"> + @@ -601,6 +608,7 @@ immutable="true"> + @@ -940,6 +948,9 @@ + + diff --git a/src/core_init_atmosphere/mpas_init_atm_cases.F b/src/core_init_atmosphere/mpas_init_atm_cases.F index e3e1ba56ea..afc18f1135 100644 --- a/src/core_init_atmosphere/mpas_init_atm_cases.F +++ b/src/core_init_atmosphere/mpas_init_atm_cases.F @@ -72,9 +72,12 @@ subroutine init_atm_setup_case(domain, stream_manager) character(len=StrKIND), pointer :: mminlu character(len=StrKIND), pointer :: xtime + real (kind=RKIND) :: dt + real (kind=RKIND), pointer :: Time - type (MPAS_Time_type) :: curr_time, stop_time + type (MPAS_Time_type) :: curr_time, stop_time, start_time type (MPAS_TimeInterval_type) :: clock_interval, lbc_stream_interval, surface_stream_interval + type (MPAS_TimeInterval_type) :: time_since_start character(len=StrKIND) :: timeString integer, pointer :: nCells @@ -297,6 +300,7 @@ subroutine init_atm_setup_case(domain, stream_manager) curr_time = mpas_get_clock_time(domain % clock, MPAS_NOW) stop_time = mpas_get_clock_time(domain % clock, MPAS_STOP_TIME) + start_time = mpas_get_clock_time(domain % clock, MPAS_START_TIME) do while (curr_time <= stop_time) @@ -309,6 +313,7 @@ subroutine init_atm_setup_case(domain, stream_manager) call mpas_pool_get_subpool(block_ptr % structs, 'lbc_state', lbc_state) call mpas_pool_get_array(state, 'xtime', xtime) + call mpas_pool_get_array(state, 'Time', Time) call mpas_pool_get_dimension(block_ptr % dimensions, 'nCells', nCells) call mpas_pool_get_dimension(block_ptr % dimensions, 'nEdges', nEdges) @@ -316,6 +321,9 @@ subroutine init_atm_setup_case(domain, stream_manager) call mpas_get_time(curr_time, dateTimeString=timeString) xtime = timeString ! Set field valid time, xtime, to the current time in the time loop + time_since_start = curr_time - start_time + call mpas_get_TimeInterval(time_since_start, dt=dt) + Time = dt call init_atm_case_lbc(timeString, block_ptr, mesh, nCells, nEdges, nVertLevels, fg, state, & diag, lbc_state, block_ptr % dimensions, block_ptr % configs) diff --git a/src/core_init_atmosphere/mpas_init_atm_core.F b/src/core_init_atmosphere/mpas_init_atm_core.F index ee0d52ed76..b899cf83cd 100644 --- a/src/core_init_atmosphere/mpas_init_atm_core.F +++ b/src/core_init_atmosphere/mpas_init_atm_core.F @@ -16,6 +16,8 @@ function init_atm_core_init(domain, startTimeStamp) result(ierr) use mpas_derived_types use mpas_stream_manager use mpas_io_streams, only : MPAS_STREAM_NEAREST + use mpas_attlist, only : mpas_modify_att + use mpas_string_utils, only : mpas_string_replace use init_atm_cases implicit none @@ -25,6 +27,7 @@ function init_atm_core_init(domain, startTimeStamp) result(ierr) type (block_type), pointer :: block type (mpas_pool_type), pointer :: state, mesh + type (field0DReal), pointer :: Time_field character (len=StrKIND), pointer :: xtime character (len=StrKIND), pointer :: initial_time character (len=StrKIND), pointer :: config_start_time @@ -38,6 +41,7 @@ function init_atm_core_init(domain, startTimeStamp) result(ierr) do while (associated(block)) call mpas_pool_get_subpool(block % structs, 'state', state) call mpas_pool_get_subpool(block % structs, 'mesh', mesh) + call mpas_pool_get_field(state, 'Time', Time_field) call mpas_pool_get_array(state, 'xtime', xtime) call mpas_pool_get_array(state, 'initial_time', initial_time) call mpas_pool_get_config(mesh, 'sphere_radius', sphere_radius) @@ -49,6 +53,10 @@ function init_atm_core_init(domain, startTimeStamp) result(ierr) domain % sphere_radius = a ! Appears in output files sphere_radius = a ! Used in setting up test cases + ! Set Time units to be cf compliant 'seconds since ' + call mpas_modify_att(Time_field % attLists(1) % attlist, 'units', & + 'seconds since ' // mpas_string_replace(initial_time, '_', ' ')) + block => block % next end do diff --git a/src/core_init_atmosphere/mpas_init_atm_core_interface.F b/src/core_init_atmosphere/mpas_init_atm_core_interface.F index ba68bd2a21..6fca9a737b 100644 --- a/src/core_init_atmosphere/mpas_init_atm_core_interface.F +++ b/src/core_init_atmosphere/mpas_init_atm_core_interface.F @@ -100,14 +100,15 @@ end subroutine init_atm_setup_domain !> not allocated until after this routine has been called. ! !----------------------------------------------------------------------- - function init_atm_setup_packages(configs, packages, iocontext) result(ierr) + function init_atm_setup_packages(configs, streamInfo, packages, iocontext) result(ierr) - use mpas_derived_types, only : mpas_pool_type, mpas_io_context_type + use mpas_derived_types, only : mpas_pool_type, mpas_io_context_type, MPAS_streamInfo_type use mpas_pool_routines, only : mpas_pool_get_config, mpas_pool_get_package implicit none type (mpas_pool_type), intent(inout) :: configs + type (MPAS_streamInfo_type), intent(inout) :: streamInfo type (mpas_pool_type), intent(inout) :: packages type (mpas_io_context_type), intent(inout) :: iocontext integer :: ierr @@ -420,15 +421,16 @@ end function init_atm_setup_log!}}} !> are available. ! !----------------------------------------------------------------------- - function init_atm_get_mesh_stream(configs, stream) result(ierr) + function init_atm_get_mesh_stream(configs, streamInfo, stream) result(ierr) use mpas_kind_types, only : StrKIND - use mpas_derived_types, only : mpas_pool_type + use mpas_derived_types, only : mpas_pool_type, MPAS_streamInfo_type use mpas_pool_routines, only : mpas_pool_get_config implicit none type (mpas_pool_type), intent(inout) :: configs + type (MPAS_streamInfo_type), intent(inout) :: streamInfo character(len=StrKIND), intent(out) :: stream integer :: ierr diff --git a/src/core_init_atmosphere/mpas_init_atm_static.F b/src/core_init_atmosphere/mpas_init_atm_static.F index 92a5613881..a4686f7ce6 100644 --- a/src/core_init_atmosphere/mpas_init_atm_static.F +++ b/src/core_init_atmosphere/mpas_init_atm_static.F @@ -140,6 +140,7 @@ subroutine init_atm_static(mesh, dims, configs) type(c_ptr) :: rarray_ptr integer, pointer :: supersample_fac + integer, pointer :: supersample_fac_30s real(kind=RKIND):: lat,lon,x,y real(kind=RKIND):: lat_pt,lon_pt @@ -214,6 +215,7 @@ subroutine init_atm_static(mesh, dims, configs) call mpas_pool_get_config(configs, 'config_albedo_data', config_albedo_data) call mpas_pool_get_config(configs, 'config_maxsnowalbedo_data', config_maxsnowalbedo_data) call mpas_pool_get_config(configs, 'config_supersample_factor', supersample_fac) + call mpas_pool_get_config(configs, 'config_30s_supersample_factor', supersample_fac_30s) write(geog_data_path, '(a)') config_geog_data_path i = len_trim(geog_data_path) @@ -374,7 +376,8 @@ subroutine init_atm_static(mesh, dims, configs) end select call mpas_log_write('--- start interpolate TER') - call interp_terrain(mesh, tree, trim(geog_data_path)//trim(geog_sub_path)) + call interp_terrain(mesh, tree, trim(geog_data_path)//trim(geog_sub_path), & + supersample_fac=supersample_fac_30s) call mpas_log_write('--- end interpolate TER') @@ -398,7 +401,8 @@ subroutine init_atm_static(mesh, dims, configs) end select surface_input_select1 call mpas_log_write('--- start interpolate LU_INDEX') - call interp_landuse(mesh, tree, trim(geog_data_path)//trim(geog_sub_path), isice_lu, iswater_lu) + call interp_landuse(mesh, tree, trim(geog_data_path)//trim(geog_sub_path), isice_lu, iswater_lu, & + supersample_fac=supersample_fac_30s) call mpas_log_write('--- end interpolate LU_INDEX') ! @@ -407,7 +411,8 @@ subroutine init_atm_static(mesh, dims, configs) geog_sub_path = 'soiltype_top_30s/' call mpas_log_write('--- start interpolate SOILCAT_TOP') - call interp_soilcat(mesh, tree, trim(geog_data_path)//trim(geog_sub_path), iswater_soil) + call interp_soilcat(mesh, tree, trim(geog_data_path)//trim(geog_sub_path), iswater_soil, & + supersample_fac=supersample_fac_30s) call mpas_log_write('--- end interpolate SOILCAT_TOP') !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! @@ -704,6 +709,10 @@ subroutine init_atm_static(mesh, dims, configs) call mpas_log_write('Using MODIS FPAR 30-arc-second data for climatological monthly vegetation fraction') + if (supersample_fac_30s > 1) then + call mpas_log_write(' Dataset will be supersampled by a factor of $i', intArgs=(/supersample_fac_30s/)) + end if + geog_sub_path = 'greenfrac_fpar_modis/' ierr = mgr % init(trim(geog_data_path)//trim(geog_sub_path)) @@ -750,10 +759,13 @@ subroutine init_atm_static(mesh, dims, configs) all_pixels_mapped_to_halo_cells = .true. - do j = tile_bdr + 1, tile_ny + tile_bdr, 1 - do i = tile_bdr + 1, tile_nx + tile_bdr, 1 + do j = supersample_fac_30s * tile_bdr + 1, supersample_fac_30s * (tile_ny + tile_bdr), 1 + do i = supersample_fac_30s * tile_bdr + 1, supersample_fac_30s * (tile_nx + tile_bdr), 1 + + ii = (i - 1) / supersample_fac_30s + 1 + jj = (j - 1) / supersample_fac_30s + 1 - call mgr % tile_to_latlon(tile, j, i, lat_pt, lon_pt) + call mgr % tile_to_latlon(tile, j, i, lat_pt, lon_pt, supersample_fac_30s) call mpas_latlon_to_xyz(xPixel, yPixel, zPixel, sphere_radius, lat_pt, lon_pt) call mpas_kd_search(tree, (/xPixel, yPixel, zPixel/), res, max_distance=max_kdtree_distance2) @@ -766,10 +778,10 @@ subroutine init_atm_static(mesh, dims, configs) ! if (landMask(res % id) == 1 .and. bdyMaskCell(res % id) < nBdyLayers) then do k = 1, tile_nz - if (tile % tile(i, j, k) == missing_value) then + if (tile % tile(ii, jj, k) == missing_value) then i8val = int(fillval, kind=I8KIND) else - i8val = int(tile % tile(i,j,k), kind=I8KIND) + i8val = int(tile % tile(ii, jj, k), kind=I8KIND) end if greenfrac_int(k, res % id) = greenfrac_int(k, res % id) + i8val end do @@ -785,10 +797,10 @@ subroutine init_atm_static(mesh, dims, configs) if (mpas_in_cell(xPixel, yPixel, zPixel, xCell(res % id), yCell(res % id), zCell(res % id), & nEdgesOnCell(res % id), verticesOnCell(:,res % id), xVertex, yVertex, zVertex)) then do k = 1, tile_nz - if (tile % tile(i, j, k) == missing_value) then + if (tile % tile(ii, jj, k) == missing_value) then i8val = int(fillval, kind=I8KIND) else - i8val = int(tile % tile(i,j,k), kind=I8KIND) + i8val = int(tile % tile(ii, jj, k), kind=I8KIND) end if greenfrac_int(k, res % id) = greenfrac_int(k, res % id) + i8val end do @@ -1435,7 +1447,7 @@ end subroutine terrain_interp_accumulation !> should be the path to the terrain dataset. ! !----------------------------------------------------------------------- - subroutine interp_terrain(mesh, kdtree, geog_data_path) + subroutine interp_terrain(mesh, kdtree, geog_data_path, supersample_fac) implicit none @@ -1443,6 +1455,7 @@ subroutine interp_terrain(mesh, kdtree, geog_data_path) type (mpas_pool_type), intent(inout) :: mesh type (mpas_kd_type), pointer, intent(in) :: kdtree character (len=*), intent(in) :: geog_data_path + integer, intent(in), optional :: supersample_fac ! Local variables type (mpas_geotile_mgr_type) :: mgr @@ -1478,7 +1491,8 @@ subroutine interp_terrain(mesh, kdtree, geog_data_path) ter_integer(:) = 0 nhs(:) = 0 - call init_atm_map_static_data(mesh, mgr, kdtree, continuous_interp_criteria, terrain_interp_accumulation) + call init_atm_map_static_data(mesh, mgr, kdtree, continuous_interp_criteria, terrain_interp_accumulation, & + supersample_fac=supersample_fac) do iCell = 1, nCells ter(iCell) = real(real(ter_integer(iCell), kind=R8KIND) / real(nhs(iCell), kind=R8KIND), kind=RKIND) @@ -1571,7 +1585,7 @@ end subroutine categorical_interp_accumulation !> that isice and iswater are in the dataset's index file. ! !----------------------------------------------------------------------- - subroutine interp_landuse(mesh, kdtree, geog_data_path, isice_lu, iswater_lu) + subroutine interp_landuse(mesh, kdtree, geog_data_path, isice_lu, iswater_lu, supersample_fac) implicit none @@ -1581,6 +1595,7 @@ subroutine interp_landuse(mesh, kdtree, geog_data_path, isice_lu, iswater_lu) character (len=*), intent(in) :: geog_data_path integer, intent(out) :: isice_lu integer, intent(out) :: iswater_lu + integer, intent(in), optional :: supersample_fac ! Local variables type (mpas_geotile_mgr_type) :: mgr @@ -1613,7 +1628,8 @@ subroutine interp_landuse(mesh, kdtree, geog_data_path, isice_lu, iswater_lu) allocate(ncat(category_min:category_max, nCells)) ncat(:,:) = 0 - call init_atm_map_static_data(mesh, mgr, kdtree, categorical_interp_criteria, categorical_interp_accumulation) + call init_atm_map_static_data(mesh, mgr, kdtree, categorical_interp_criteria, categorical_interp_accumulation, & + supersample_fac=supersample_fac) do iCell = 1, nCells ! Because maxloc returns the location of the maximum value of an array as if the @@ -1652,7 +1668,7 @@ end subroutine interp_landuse !> iswater is present in the dataset's index file. !> !----------------------------------------------------------------------- - subroutine interp_soilcat(mesh, kdtree, geog_data_path, iswater_soil) + subroutine interp_soilcat(mesh, kdtree, geog_data_path, iswater_soil, supersample_fac) implicit none @@ -1661,6 +1677,7 @@ subroutine interp_soilcat(mesh, kdtree, geog_data_path, iswater_soil) type (mpas_kd_type), pointer, intent(in) :: kdtree character (len=*), intent(in) :: geog_data_path integer, intent(out) :: iswater_soil + integer, intent(in), optional :: supersample_fac ! Local variables type (mpas_geotile_mgr_type) :: mgr @@ -1690,7 +1707,8 @@ subroutine interp_soilcat(mesh, kdtree, geog_data_path, iswater_soil) allocate(ncat(category_min:category_max, nCells)) ncat(:,:) = 0 - call init_atm_map_static_data(mesh, mgr, kdtree, categorical_interp_criteria, categorical_interp_accumulation) + call init_atm_map_static_data(mesh, mgr, kdtree, categorical_interp_criteria, categorical_interp_accumulation, & + supersample_fac=supersample_fac) do iCell = 1, nCells ! Because maxloc returns the location of the maximum value of an array as if the diff --git a/src/core_init_atmosphere/mpas_init_atm_surface.F b/src/core_init_atmosphere/mpas_init_atm_surface.F index 962ccb282c..bb68b6942e 100644 --- a/src/core_init_atmosphere/mpas_init_atm_surface.F +++ b/src/core_init_atmosphere/mpas_init_atm_surface.F @@ -44,13 +44,16 @@ subroutine init_atm_case_sfc(domain, dminfo, stream_manager, mesh, fg, state, di type (mpas_pool_type), intent(in) :: configs !local variables: - type (MPAS_Time_type) :: curr_time, stop_time + type (MPAS_Time_type) :: curr_time, stop_time, start_time + type (MPAS_TimeInterval_type) :: time_since_start character(len=StrKIND) :: timeString + real (kind=RKIND) :: dt character(len=StrKIND), pointer :: config_sfc_prefix character(len=StrKIND), pointer :: xtime + real (kind=RKIND), pointer :: Time integer :: ierr - + !================================================================================================== @@ -58,15 +61,21 @@ subroutine init_atm_case_sfc(domain, dminfo, stream_manager, mesh, fg, state, di call mpas_pool_get_config(configs, 'config_sfc_prefix', config_sfc_prefix) call mpas_pool_get_array(state, 'xtime', xtime) + call mpas_pool_get_array(state, 'Time', Time) !loop over all times: curr_time = mpas_get_clock_time(domain % clock, MPAS_NOW) stop_time = mpas_get_clock_time(domain % clock, MPAS_STOP_TIME) + start_time = mpas_get_clock_time(domain % clock, MPAS_START_TIME) do while (curr_time <= stop_time) call mpas_get_time(curr_time, dateTimeString=timeString) xtime = timeString + time_since_start = curr_time - start_time + call mpas_get_timeInterval(time_since_start, dt=dt) + Time = dt + ! call mpas_log_write('Processing '//trim(config_sfc_prefix)//':'//timeString(1:13)) !read the sea-surface temperature and sea-ice data from the surface file, and interpolate the diff --git a/src/core_landice/Registry.xml b/src/core_landice/Registry.xml index 91db32ee9a..115d29024b 100644 --- a/src/core_landice/Registry.xml +++ b/src/core_landice/Registry.xml @@ -1,5 +1,5 @@ - + diff --git a/src/core_landice/landice.cmake b/src/core_landice/landice.cmake deleted file mode 100644 index 0d580d7800..0000000000 --- a/src/core_landice/landice.cmake +++ /dev/null @@ -1,79 +0,0 @@ - -# build_options.mk stuff handled here -list(APPEND CPPDEFS "-DCORE_LANDICE") -list(APPEND INCLUDES "${CMAKE_BINARY_DIR}/core_landice/shared" "${CMAKE_BINARY_DIR}/core_landice/analysis_members" "${CMAKE_BINARY_DIR}/core_landice/mode_forward") - -# -# Check if building with LifeV, Albany, and/or PHG external libraries -# - -if (LIFEV) - # LifeV can solve L1L2 or FO - list(APPEND CPPDEFS "-DLIFEV" "-DUSE_EXTERNAL_L1L2" "-DUSE_EXTERNAL_FIRSTORDER" "-DMPAS_LI_BUILD_INTERFACE") -endif() - -# Albany can only solve FO at present -if (ALBANY) - list(APPEND CPPDEFS "-DUSE_EXTERNAL_FIRSTORDER" "-DMPAS_LI_BUILD_INTERFACE") -endif() - -if (LIFEV AND ALBANY) - message(FATAL "Compiling with both LifeV and Albany is not allowed at this time.") -endif() - -# PHG currently requires LifeV -if (PHG AND NOT LIFEV) - message(FATAL "Compiling with PHG requires LifeV at this time.") -endif() - -# PHG can only Stokes at present -if (PHG) - list(APPEND CPPDEFS "-DUSE_EXTERNAL_STOKES" "-DMPAS_LI_BUILD_INTERFACE") -endif() - -# driver (files live in E3SM) -list(APPEND RAW_SOURCES - ../../mpas-albany-landice/driver/glc_comp_mct.F - ../../mpas-albany-landice/driver/glc_cpl_indices.F - ../../mpas-albany-landice/driver/glc_mct_vars.F -) - -# shared -list(APPEND RAW_SOURCES - core_landice/shared/mpas_li_constants.F - core_landice/shared/mpas_li_mask.F - core_landice/shared/mpas_li_setup.F -) - -# analysis members -list(APPEND RAW_SOURCES - core_landice/analysis_members/mpas_li_analysis_driver.F - core_landice/analysis_members/mpas_li_global_stats.F - core_landice/analysis_members/mpas_li_regional_stats.F -) - -# mode forward -list(APPEND RAW_SOURCES - core_landice/mode_forward/mpas_li_core.F - core_landice/mode_forward/mpas_li_core_interface.F - core_landice/mode_forward/mpas_li_time_integration.F - core_landice/mode_forward/mpas_li_time_integration_fe.F - core_landice/mode_forward/mpas_li_diagnostic_vars.F - core_landice/mode_forward/mpas_li_advection.F - core_landice/mode_forward/mpas_li_calving.F - core_landice/mode_forward/mpas_li_statistics.F - core_landice/mode_forward/mpas_li_velocity.F - core_landice/mode_forward/mpas_li_thermal.F - core_landice/mode_forward/mpas_li_iceshelf_melt.F - core_landice/mode_forward/mpas_li_sia.F - core_landice/mode_forward/mpas_li_velocity_simple.F - core_landice/mode_forward/mpas_li_velocity_external.F - core_landice/mode_forward/mpas_li_subglacial_hydro.F -) - -if (CPPDEFS MATCHES ".*MPAS_LI_BUILD_INTERFACE.*") - list(APPEND RAW_SOURCES core_landice/mode_forward/Interface_velocity_solver.cpp) -endif() - -# Generate core input -handle_st_nl_gen("namelist.landice" "streams.landice stream_list.landice. listed" ${CORE_INPUT_DIR} ${CORE_BLDDIR}) diff --git a/src/core_landice/mode_forward/mpas_li_core_interface.F b/src/core_landice/mode_forward/mpas_li_core_interface.F index db27f38305..e003bceb21 100644 --- a/src/core_landice/mode_forward/mpas_li_core_interface.F +++ b/src/core_landice/mode_forward/mpas_li_core_interface.F @@ -90,10 +90,11 @@ end subroutine li_setup_domain!}}} !> *not* allocated until after this routine is called. ! !----------------------------------------------------------------------- - function li_setup_packages(configPool, packagePool, iocontext) result(ierr) + function li_setup_packages(configPool, streamInfo, packagePool, iocontext) result(ierr) implicit none type (mpas_pool_type), intent(inout) :: configPool + type (MPAS_streamInfo_type), intent(inout) :: streamInfo type (mpas_pool_type), intent(inout) :: packagePool type (mpas_io_context_type), intent(inout) :: iocontext integer :: ierr @@ -236,11 +237,12 @@ end function li_setup_log!}}} !> are available. ! !----------------------------------------------------------------------- - function li_get_mesh_stream(configs, stream) result(ierr) + function li_get_mesh_stream(configs, streamInfo, stream) result(ierr) implicit none type (mpas_pool_type), intent(inout) :: configs + type (MPAS_streamInfo_type), intent(inout) :: streamInfo character(len=StrKIND), intent(out) :: stream integer :: ierr diff --git a/src/core_ocean/Registry.xml b/src/core_ocean/Registry.xml index a5f42e4d4a..97345172c3 100644 --- a/src/core_ocean/Registry.xml +++ b/src/core_ocean/Registry.xml @@ -1,5 +1,5 @@ - + *not* allocated until after this routine is called. ! !----------------------------------------------------------------------- - function ocn_setup_packages(configPool, packagePool, iocontext) result(ierr)!{{{ + function ocn_setup_packages(configPool, streamInfo, packagePool, iocontext) result(ierr)!{{{ use ocn_analysis_driver type (mpas_pool_type), intent(inout) :: configPool + type (MPAS_streamInfo_type), intent(inout) :: streamInfo type (mpas_pool_type), intent(inout) :: packagePool type (mpas_io_context_type), intent(inout) :: iocontext @@ -529,7 +530,7 @@ end function ocn_setup_log!}}} !> are available. ! !----------------------------------------------------------------------- - function ocn_get_mesh_stream(configs, stream) result(ierr)!{{{ + function ocn_get_mesh_stream(configs, streamInfo, stream) result(ierr)!{{{ use mpas_derived_types use mpas_pool_routines @@ -537,6 +538,7 @@ function ocn_get_mesh_stream(configs, stream) result(ierr)!{{{ implicit none type (mpas_pool_type), intent(inout) :: configs + type (MPAS_streamInfo_type), intent(inout) :: streamInfo character(len=StrKIND), intent(out) :: stream integer :: ierr diff --git a/src/core_ocean/ocean.cmake b/src/core_ocean/ocean.cmake deleted file mode 100644 index 287dbb523b..0000000000 --- a/src/core_ocean/ocean.cmake +++ /dev/null @@ -1,207 +0,0 @@ - -# build_options.mk stuff handled here -list(APPEND CPPDEFS "-DCORE_OCEAN") -list(APPEND INCLUDES "${CMAKE_BINARY_DIR}/core_ocean/BGC" "${CMAKE_BINARY_DIR}/core_ocean/shared" "${CMAKE_BINARY_DIR}/core_ocean/analysis_members" "${CMAKE_BINARY_DIR}/core_ocean/cvmix" "${CMAKE_BINARY_DIR}/core_ocean/mode_forward" "${CMAKE_BINARY_DIR}/core_ocean/mode_analysis" "${CMAKE_BINARY_DIR}/core_ocean/mode_init") - -# driver (files live in E3SM) -list(APPEND RAW_SOURCES - ../../mpas-ocean/driver/ocn_comp_mct.F - ../../mpas-ocean/driver/mpaso_cpl_indices.F - ../../mpas-ocean/driver/mpaso_mct_vars.F -) - -# dycore -list(APPEND RAW_SOURCES - core_ocean/mode_forward/mpas_ocn_forward_mode.F - core_ocean/mode_forward/mpas_ocn_time_integration.F - core_ocean/mode_forward/mpas_ocn_time_integration_rk4.F - core_ocean/mode_forward/mpas_ocn_time_integration_split.F - - core_ocean/mode_analysis/mpas_ocn_analysis_mode.F - - core_ocean/mode_init/mpas_ocn_init_mode.F - core_ocean/mode_init/mpas_ocn_init_spherical_utils.F - core_ocean/mode_init/mpas_ocn_init_vertical_grids.F - core_ocean/mode_init/mpas_ocn_init_cell_markers.F - core_ocean/mode_init/mpas_ocn_init_interpolation.F - core_ocean/mode_init/mpas_ocn_init_ssh_and_landIcePressure.F - core_ocean/mode_init/mpas_ocn_init_baroclinic_channel.F - core_ocean/mode_init/mpas_ocn_init_lock_exchange.F - core_ocean/mode_init/mpas_ocn_init_dam_break.F - core_ocean/mode_init/mpas_ocn_init_internal_waves.F - core_ocean/mode_init/mpas_ocn_init_overflow.F - core_ocean/mode_init/mpas_ocn_init_cvmix_WSwSBF.F - core_ocean/mode_init/mpas_ocn_init_iso.F - core_ocean/mode_init/mpas_ocn_init_soma.F - core_ocean/mode_init/mpas_ocn_init_ziso.F - core_ocean/mode_init/mpas_ocn_init_sub_ice_shelf_2D.F - core_ocean/mode_init/mpas_ocn_init_periodic_planar.F - core_ocean/mode_init/mpas_ocn_init_ecosys_column.F - core_ocean/mode_init/mpas_ocn_init_sea_mount.F - core_ocean/mode_init/mpas_ocn_init_global_ocean.F - core_ocean/mode_init/mpas_ocn_init_isomip.F - core_ocean/mode_init/mpas_ocn_init_hurricane.F - core_ocean/mode_init/mpas_ocn_init_isomip_plus.F - core_ocean/mode_init/mpas_ocn_init_tidal_boundary.F - - core_ocean/shared/mpas_ocn_init_routines.F - core_ocean/shared/mpas_ocn_gm.F - core_ocean/shared/mpas_ocn_diagnostics.F - core_ocean/shared/mpas_ocn_diagnostics_routines.F - core_ocean/shared/mpas_ocn_thick_ale.F - core_ocean/shared/mpas_ocn_equation_of_state.F - core_ocean/shared/mpas_ocn_equation_of_state_jm.F - core_ocean/shared/mpas_ocn_equation_of_state_linear.F - core_ocean/shared/mpas_ocn_thick_hadv.F - core_ocean/shared/mpas_ocn_thick_vadv.F - core_ocean/shared/mpas_ocn_thick_surface_flux.F - core_ocean/shared/mpas_ocn_vel_hadv_coriolis.F - core_ocean/shared/mpas_ocn_vel_vadv.F - core_ocean/shared/mpas_ocn_vel_hmix.F - core_ocean/shared/mpas_ocn_vel_hmix_del2.F - core_ocean/shared/mpas_ocn_vel_hmix_leith.F - core_ocean/shared/mpas_ocn_vel_hmix_del4.F - core_ocean/shared/mpas_ocn_vel_forcing.F - core_ocean/shared/mpas_ocn_vel_forcing_surface_stress.F - core_ocean/shared/mpas_ocn_vel_forcing_explicit_bottom_drag.F - core_ocean/shared/mpas_ocn_vel_pressure_grad.F - core_ocean/shared/mpas_ocn_vmix.F - core_ocean/shared/mpas_ocn_vmix_coefs_const.F - core_ocean/shared/mpas_ocn_vmix_coefs_rich.F - core_ocean/shared/mpas_ocn_vmix_coefs_tanh.F - core_ocean/shared/mpas_ocn_vmix_coefs_redi.F - core_ocean/shared/mpas_ocn_vmix_cvmix.F - core_ocean/shared/mpas_ocn_tendency.F - core_ocean/shared/mpas_ocn_tracer_hmix.F - core_ocean/shared/mpas_ocn_tracer_hmix_del2.F - core_ocean/shared/mpas_ocn_tracer_hmix_del4.F - core_ocean/shared/mpas_ocn_tracer_hmix_redi.F - core_ocean/shared/mpas_ocn_tracer_advection.F - core_ocean/shared/mpas_ocn_tracer_advection_mono.F - core_ocean/shared/mpas_ocn_tracer_advection_std.F - core_ocean/shared/mpas_ocn_tracer_nonlocalflux.F - core_ocean/shared/mpas_ocn_tracer_short_wave_absorption.F - core_ocean/shared/mpas_ocn_tracer_short_wave_absorption_jerlov.F - core_ocean/shared/mpas_ocn_tracer_short_wave_absorption_variable.F - core_ocean/shared/mpas_ocn_tracer_surface_restoring.F - core_ocean/shared/mpas_ocn_tracer_interior_restoring.F - core_ocean/shared/mpas_ocn_tracer_exponential_decay.F - core_ocean/shared/mpas_ocn_tracer_ideal_age.F - core_ocean/shared/mpas_ocn_tracer_TTD.F - core_ocean/shared/mpas_ocn_tracer_ecosys.F - core_ocean/shared/mpas_ocn_tracer_DMS.F - core_ocean/shared/mpas_ocn_tracer_MacroMolecules.F - core_ocean/shared/mpas_ocn_high_freq_thickness_hmix_del2.F - core_ocean/shared/mpas_ocn_tracer_surface_flux_to_tend.F - core_ocean/shared/mpas_ocn_test.F - core_ocean/shared/mpas_ocn_constants.F - core_ocean/shared/mpas_ocn_forcing.F - core_ocean/shared/mpas_ocn_surface_bulk_forcing.F - core_ocean/shared/mpas_ocn_surface_land_ice_fluxes.F - core_ocean/shared/mpas_ocn_effective_density_in_land_ice.F - core_ocean/shared/mpas_ocn_frazil_forcing.F - core_ocean/shared/mpas_ocn_tidal_forcing.F - core_ocean/shared/mpas_ocn_time_average_coupled.F - core_ocean/shared/mpas_ocn_sea_ice.F - core_ocean/shared/mpas_ocn_framework_forcing.F - core_ocean/shared/mpas_ocn_time_varying_forcing.F - core_ocean/shared/mpas_ocn_wetting_drying.F - core_ocean/shared/mpas_ocn_tidal_potential_forcing.F -) - -set(OCEAN_DRIVER - core_ocean/driver/mpas_ocn_core.F - core_ocean/driver/mpas_ocn_core_interface.F -) -list(APPEND RAW_SOURCES ${OCEAN_DRIVER}) -list(APPEND DISABLE_QSMP ${OCEAN_DRIVER}) - -# Get CVMix -execute_process(COMMAND ${CMAKE_CURRENT_SOURCE_DIR}/core_ocean/get_cvmix.sh - WORKING_DIRECTORY ${CORE_BLDDIR}) - -# Get BGC -execute_process(COMMAND ${CMAKE_CURRENT_SOURCE_DIR}/core_ocean/get_BGC.sh - WORKING_DIRECTORY ${CORE_BLDDIR}) - -# Add CVMix -set(CVMIX_FILES - ${CORE_BLDDIR}/cvmix/cvmix_kinds_and_types.F90 - ${CORE_BLDDIR}/cvmix/cvmix_background.F90 - ${CORE_BLDDIR}/cvmix/cvmix_convection.F90 - ${CORE_BLDDIR}/cvmix/cvmix_ddiff.F90 - ${CORE_BLDDIR}/cvmix/cvmix_kpp.F90 - ${CORE_BLDDIR}/cvmix/cvmix_math.F90 - ${CORE_BLDDIR}/cvmix/cvmix_put_get.F90 - ${CORE_BLDDIR}/cvmix/cvmix_shear.F90 - ${CORE_BLDDIR}/cvmix/cvmix_tidal.F90 - ${CORE_BLDDIR}/cvmix/cvmix_utils.F90 -) - -# Add BGC -set(BGC_FILES - ${CORE_BLDDIR}/BGC/BGC_mod.F90 - ${CORE_BLDDIR}/BGC/BGC_parms.F90 - ${CORE_BLDDIR}/BGC/DMS_mod.F90 - ${CORE_BLDDIR}/BGC/DMS_parms.F90 - ${CORE_BLDDIR}/BGC/MACROS_mod.F90 - ${CORE_BLDDIR}/BGC/MACROS_parms.F90 - ${CORE_BLDDIR}/BGC/co2calc.F90 -) - -list(APPEND RAW_SOURCES ${CVMIX_FILES} ${BGC_FILES}) -list(APPEND NO_PREPROCESS ${CVMIX_FILES} ${BGC_FILES}) - -# Add analysis members -list(APPEND RAW_SOURCES - core_ocean/analysis_members/mpas_ocn_global_stats.F - core_ocean/analysis_members/mpas_ocn_okubo_weiss.F - core_ocean/analysis_members/mpas_ocn_okubo_weiss_eigenvalues.c - core_ocean/analysis_members/mpas_ocn_layer_volume_weighted_averages.F - core_ocean/analysis_members/mpas_ocn_surface_area_weighted_averages.F - core_ocean/analysis_members/mpas_ocn_water_mass_census.F - core_ocean/analysis_members/mpas_ocn_meridional_heat_transport.F - core_ocean/analysis_members/mpas_ocn_test_compute_interval.F - core_ocean/analysis_members/mpas_ocn_high_frequency_output.F - core_ocean/analysis_members/mpas_ocn_zonal_mean.F - core_ocean/analysis_members/mpas_ocn_lagrangian_particle_tracking_interpolations.F - core_ocean/analysis_members/mpas_ocn_particle_list.F - core_ocean/analysis_members/mpas_ocn_lagrangian_particle_tracking_reset.F - core_ocean/analysis_members/mpas_ocn_lagrangian_particle_tracking.F - core_ocean/analysis_members/mpas_ocn_eliassen_palm.F - core_ocean/analysis_members/mpas_ocn_time_filters.F - core_ocean/analysis_members/mpas_ocn_mixed_layer_depths.F - core_ocean/analysis_members/mpas_ocn_pointwise_stats.F - core_ocean/analysis_members/mpas_ocn_debug_diagnostics.F - core_ocean/analysis_members/mpas_ocn_time_series_stats.F - core_ocean/analysis_members/mpas_ocn_regional_stats.F - core_ocean/analysis_members/mpas_ocn_rpn_calculator.F - core_ocean/analysis_members/mpas_ocn_transect_transport.F - core_ocean/analysis_members/mpas_ocn_eddy_product_variables.F - core_ocean/analysis_members/mpas_ocn_moc_streamfunction.F - core_ocean/analysis_members/mpas_ocn_analysis_driver.F -) - -# add accelerator/gpu flags -list(APPEND ADD_ACC_FLAGS - core_ocean/shared/mpas_ocn_equation_of_state_jm.f90 - core_ocean/shared/mpas_ocn_mesh.f90 - core_ocean/shared/mpas_ocn_surface_bulk_forcing.f90 - core_ocean/shared/mpas_ocn_surface_land_ice_fluxes.f90 - core_ocean/shared/mpas_ocn_tendency.f90 - core_ocean/shared/mpas_ocn_vel_forcing_explicit_bottom_drag.f90 - core_ocean/shared/mpas_ocn_vel_forcing_surface_stress.f90 - core_ocean/shared/mpas_ocn_vel_hadv_coriolis.f90 - core_ocean/shared/mpas_ocn_vel_hmix_del2.f90 - core_ocean/shared/mpas_ocn_vel_hmix_del4.f90 - core_ocean/shared/mpas_ocn_vel_hmix_leith.f90 - core_ocean/shared/mpas_ocn_vel_pressure_grad.f90 - core_ocean/shared/mpas_ocn_vel_vadv.f90 -) - -# Generate core input -handle_st_nl_gen( - "namelist.ocean;namelist.ocean.forward mode=forward;namelist.ocean.analysis mode=analysis;namelist.ocean.init mode=init" - "streams.ocean stream_list.ocean. mutable;streams.ocean.forward stream_list.ocean.forward. mutable mode=forward;streams.ocean.analysis stream_list.ocean.analysis. mutable mode=analysis;streams.ocean.init stream_list.ocean.init. mutable mode=init" - ${CORE_INPUT_DIR} ${CORE_BLDDIR} -) diff --git a/src/core_seaice/Registry.xml b/src/core_seaice/Registry.xml index a649c2b623..22a3dd2ca0 100644 --- a/src/core_seaice/Registry.xml +++ b/src/core_seaice/Registry.xml @@ -1,5 +1,5 @@ - + *not* allocated until after this routine is called. ! !----------------------------------------------------------------------- - function seaice_setup_packages(configPool, packagePool, iocontext) result(ierr)!{{{ + function seaice_setup_packages(configPool, streamInfo, packagePool, iocontext) result(ierr)!{{{ use mpas_derived_types implicit none type (mpas_pool_type), intent(inout) :: configPool + type (MPAS_streamInfo_type), intent(inout) :: streamInfo type (mpas_pool_type), intent(inout) :: packagePool type (mpas_io_context_type), intent(inout) :: iocontext @@ -718,7 +719,7 @@ end function seaice_setup_log!}}} !> are available. ! !----------------------------------------------------------------------- - function seaice_get_mesh_stream(configs, stream) result(ierr)!{{{ + function seaice_get_mesh_stream(configs, streamInfo, stream) result(ierr)!{{{ use mpas_derived_types use mpas_pool_routines @@ -726,6 +727,7 @@ function seaice_get_mesh_stream(configs, stream) result(ierr)!{{{ implicit none type (mpas_pool_type), intent(inout) :: configs + type (MPAS_streamInfo_type), intent(inout) :: streamInfo character(len=StrKIND), intent(out) :: stream integer :: ierr diff --git a/src/core_seaice/seaice.cmake b/src/core_seaice/seaice.cmake deleted file mode 100644 index 0ac2b0dd49..0000000000 --- a/src/core_seaice/seaice.cmake +++ /dev/null @@ -1,108 +0,0 @@ - -# build_options.mk stuff handled here -list(APPEND CPPDEFS "-DCORE_SEAICE" "-Dcoupled" "-DCCSMCOUPLED") -list(APPEND INCLUDES "${CMAKE_BINARY_DIR}/core_seaice/column" "${CMAKE_BINARY_DIR}/core_seaice/shared" "${CMAKE_BINARY_DIR}/core_seaice/analysis_members" "${CMAKE_BINARY_DIR}/core_seaice/model_forward") - - -# driver (files live in E3SM) -list(APPEND RAW_SOURCES - ../../mpas-seaice/driver/ice_comp_mct.F - ../../mpas-seaice/driver/mpassi_cpl_indices.F - ../../mpas-seaice/driver/mpassi_mct_vars.F -) - -# column -list(APPEND RAW_SOURCES - core_seaice/column/ice_colpkg.F90 - core_seaice/column/ice_kinds_mod.F90 - core_seaice/column/ice_warnings.F90 - core_seaice/column/ice_colpkg_shared.F90 - core_seaice/column/constants/cesm/ice_constants_colpkg.F90 - core_seaice/column/ice_therm_shared.F90 - core_seaice/column/ice_orbital.F90 - core_seaice/column/ice_mushy_physics.F90 - core_seaice/column/ice_therm_mushy.F90 - core_seaice/column/ice_atmo.F90 - core_seaice/column/ice_age.F90 - core_seaice/column/ice_firstyear.F90 - core_seaice/column/ice_flux_colpkg.F90 - core_seaice/column/ice_meltpond_cesm.F90 - core_seaice/column/ice_meltpond_lvl.F90 - core_seaice/column/ice_meltpond_topo.F90 - core_seaice/column/ice_therm_vertical.F90 - core_seaice/column/ice_therm_bl99.F90 - core_seaice/column/ice_therm_0layer.F90 - core_seaice/column/ice_itd.F90 - core_seaice/column/ice_colpkg_tracers.F90 - core_seaice/column/ice_therm_itd.F90 - core_seaice/column/ice_shortwave.F90 - core_seaice/column/ice_mechred.F90 - core_seaice/column/ice_aerosol.F90 - core_seaice/column/ice_brine.F90 - core_seaice/column/ice_algae.F90 - core_seaice/column/ice_zbgc.F90 - core_seaice/column/ice_zbgc_shared.F90 - core_seaice/column/ice_zsalinity.F90 - core_seaice/column/ice_snow.F90 -) - -# shared -list(APPEND RAW_SOURCES - core_seaice/shared/mpas_seaice_time_integration.F - core_seaice/shared/mpas_seaice_advection_incremental_remap_tracers.F - core_seaice/shared/mpas_seaice_advection_incremental_remap.F - core_seaice/shared/mpas_seaice_advection_upwind.F - core_seaice/shared/mpas_seaice_advection.F - core_seaice/shared/mpas_seaice_velocity_solver_unit_tests.F - core_seaice/shared/mpas_seaice_velocity_solver.F - core_seaice/shared/mpas_seaice_velocity_solver_weak.F - core_seaice/shared/mpas_seaice_velocity_solver_variational.F - core_seaice/shared/mpas_seaice_velocity_solver_wachspress.F - core_seaice/shared/mpas_seaice_velocity_solver_pwl.F - core_seaice/shared/mpas_seaice_velocity_solver_variational_shared.F - core_seaice/shared/mpas_seaice_velocity_solver_constitutive_relation.F - core_seaice/shared/mpas_seaice_forcing.F - core_seaice/shared/mpas_seaice_initialize.F - core_seaice/shared/mpas_seaice_testing.F - core_seaice/shared/mpas_seaice_unit_test.F - core_seaice/shared/mpas_seaice_mesh.F - core_seaice/shared/mpas_seaice_diagnostics.F - core_seaice/shared/mpas_seaice_numerics.F - core_seaice/shared/mpas_seaice_constants.F - core_seaice/shared/mpas_seaice_column.F - core_seaice/shared/mpas_seaice_diagnostics.F - core_seaice/shared/mpas_seaice_error.F -) - -# analysis members -list(APPEND RAW_SOURCES - core_seaice/analysis_members/mpas_seaice_analysis_driver.F - core_seaice/analysis_members/mpas_seaice_high_frequency_output.F - core_seaice/analysis_members/mpas_seaice_temperatures.F - core_seaice/analysis_members/mpas_seaice_regional_statistics.F - core_seaice/analysis_members/mpas_seaice_ridging_diagnostics.F - core_seaice/analysis_members/mpas_seaice_conservation_check.F - core_seaice/analysis_members/mpas_seaice_geographical_vectors.F - core_seaice/analysis_members/mpas_seaice_ice_present.F - core_seaice/analysis_members/mpas_seaice_time_series_stats.F - core_seaice/analysis_members/mpas_seaice_load_balance.F - core_seaice/analysis_members/mpas_seaice_maximum_ice_presence.F - core_seaice/analysis_members/mpas_seaice_miscellaneous.F - core_seaice/analysis_members/mpas_seaice_area_variables.F - core_seaice/analysis_members/mpas_seaice_pond_diagnostics.F - core_seaice/analysis_members/mpas_seaice_deactivate_unneeded_fields.F - core_seaice/analysis_members/mpas_seaice_pointwise_stats.F - core_seaice/analysis_members/mpas_seaice_unit_conversion.F - core_seaice/analysis_members/mpas_seaice_ice_shelves.F -) - -# model_forward (DISABLE qsmp for these) -set(SEAICE_MODEL_FORWARD - core_seaice/model_forward/mpas_seaice_core.F - core_seaice/model_forward/mpas_seaice_core_interface.F -) -list(APPEND RAW_SOURCES ${SEAICE_MODEL_FORWARD}) -list(APPEND DISABLE_QSMP ${SEAICE_MODEL_FORWARD}) - -# Generate core input -handle_st_nl_gen("namelist.seaice" "streams.seaice stream_list.seaice. listed" ${CORE_INPUT_DIR} ${CORE_BLDDIR}) diff --git a/src/core_sw/Registry.xml b/src/core_sw/Registry.xml index 868918cf3b..2ffebc0dfe 100644 --- a/src/core_sw/Registry.xml +++ b/src/core_sw/Registry.xml @@ -1,5 +1,5 @@ - + diff --git a/src/core_sw/mpas_sw_core_interface.F b/src/core_sw/mpas_sw_core_interface.F index 7596acf82a..04df23f19d 100644 --- a/src/core_sw/mpas_sw_core_interface.F +++ b/src/core_sw/mpas_sw_core_interface.F @@ -89,13 +89,14 @@ end subroutine sw_setup_domain!}}} !> *not* allocated until after this routine is called. ! !----------------------------------------------------------------------- - function sw_setup_packages(configPool, packagePool, iocontext) result(ierr)!{{{ + function sw_setup_packages(configPool, streamInfo, packagePool, iocontext) result(ierr)!{{{ use mpas_derived_types implicit none type (mpas_pool_type), intent(inout) :: configPool + type (MPAS_streamInfo_type), intent(inout) :: streamInfo type (mpas_pool_type), intent(inout) :: packagePool type (mpas_io_context_type), intent(inout) :: iocontext integer :: ierr @@ -234,7 +235,7 @@ end function sw_setup_log!}}} !> are available. ! !----------------------------------------------------------------------- - function sw_get_mesh_stream(configs, stream) result(ierr)!{{{ + function sw_get_mesh_stream(configs, streamInfo, stream) result(ierr)!{{{ use mpas_derived_types use mpas_pool_routines @@ -242,6 +243,7 @@ function sw_get_mesh_stream(configs, stream) result(ierr)!{{{ implicit none type (mpas_pool_type), intent(inout) :: configs + type (MPAS_streamInfo_type), intent(inout) :: streamInfo character(len=StrKIND), intent(out) :: stream integer :: ierr diff --git a/src/core_test/Makefile b/src/core_test/Makefile index d47059490c..556992262a 100644 --- a/src/core_test/Makefile +++ b/src/core_test/Makefile @@ -7,7 +7,10 @@ OBJS = mpas_test_core.o \ mpas_test_core_field_tests.o \ mpas_test_core_timekeeping_tests.o \ mpas_test_core_sorting.o \ - mpas_halo_testing.o + mpas_halo_testing.o \ + mpas_test_core_string_utils.o \ + mpas_test_core_dmpar.o \ + mpas_test_core_stream_inquiry.o all: core_test @@ -36,7 +39,9 @@ mpas_test_core_interface.o: mpas_test_core.o mpas_test_core.o: mpas_test_core_halo_exch.o mpas_test_core_streams.o \ mpas_test_core_field_tests.o mpas_test_core_timekeeping_tests.o \ - mpas_test_core_sorting.o mpas_halo_testing.o + mpas_test_core_sorting.o mpas_halo_testing.o \ + mpas_test_core_string_utils.o mpas_test_core_dmpar.o \ + mpas_test_core_stream_inquiry.o mpas_test_core_halo_exch.o: diff --git a/src/core_test/Registry.xml b/src/core_test/Registry.xml index 102cce6de3..f9e4d90e1c 100644 --- a/src/core_test/Registry.xml +++ b/src/core_test/Registry.xml @@ -1,5 +1,5 @@ - + @@ -71,6 +71,19 @@ + + + + + + + diff --git a/src/core_test/mpas_test_core.F b/src/core_test/mpas_test_core.F index fc746aba48..d51974cdf3 100644 --- a/src/core_test/mpas_test_core.F +++ b/src/core_test/mpas_test_core.F @@ -93,7 +93,10 @@ function test_core_run(domain) result(iErr)!{{{ use test_core_streams, only : test_core_streams_test use test_core_sorting, only : test_core_test_sorting use mpas_halo_testing, only : mpas_halo_tests - + use test_core_string_utils, only : mpas_test_string_utils + use mpas_test_core_dmpar, only : mpas_test_dmpar + use mpas_test_core_stream_inquiry, only : mpas_test_stream_inquiry + implicit none type (domain_type), intent(inout) :: domain @@ -167,6 +170,34 @@ function test_core_run(domain) result(iErr)!{{{ call mpas_log_write('Stream I/O tests: FAILURE', MPAS_LOG_ERR) end if + ! Run string util tests + call mpas_log_write('') + call mpas_test_string_utils(iErr) + call mpas_log_write('') + + ! + ! Run mpas_dmpar tests + ! + call mpas_log_write('') + iErr = mpas_test_dmpar(domain % dminfo) + if (iErr == 0) then + call mpas_log_write('All tests PASSED') + else + call mpas_log_write('$i tests FAILED', intArgs=[iErr]) + end if + call mpas_log_write('') + + ! + ! Run mpas_stream_inquiry tests + ! + call mpas_log_write('') + iErr = mpas_test_stream_inquiry(domain % dminfo) + if (iErr == 0) then + call mpas_log_write('All tests PASSED') + else + call mpas_log_write('$i tests FAILED', intArgs=[iErr]) + end if + call mpas_log_write('') call test_core_test_intervals(domain, threadErrs, iErr) diff --git a/src/core_test/mpas_test_core_dmpar.F b/src/core_test/mpas_test_core_dmpar.F new file mode 100644 index 0000000000..dde2e40c96 --- /dev/null +++ b/src/core_test/mpas_test_core_dmpar.F @@ -0,0 +1,160 @@ +! Copyright (c) 2023 The University Corporation for Atmospheric Research (UCAR). +! +! Unless noted otherwise source code is licensed under the BSD license. +! Additional copyright and license information can be found in the LICENSE file +! distributed with this code, or at https://mpas-dev.github.io/license.html . +! +module mpas_test_core_dmpar + + use mpas_derived_types, only : dm_info + use mpas_log, only : mpas_log_write + + private + + public :: mpas_test_dmpar + + + contains + + + !----------------------------------------------------------------------- + ! routine mpas_test_dmpar + ! + !> \brief Main driver for tests of the mpas_dmpar module + !> \author Michael Duda + !> \date 14 November 2023 + !> \details + !> This routine invokes tests for individual routines in the mpas_dmpar + !> module, and reports PASSED/FAILED for each of those tests. + !> + !> Return value: The total number of test that failed on any MPI rank. + ! + !----------------------------------------------------------------------- + function mpas_test_dmpar(dminfo) result(ierr_count) + + use mpas_dmpar, only : mpas_dmpar_max_int + use mpas_kind_types, only : StrKIND + + implicit none + + ! Arguments + type (dm_info), intent(inout) :: dminfo + + ! Return value + integer :: ierr_count + + ! Local variables + integer :: ierr, ierr_global + character(len=StrKIND) :: routine_name + + + ierr_count = 0 + + call mpas_log_write('--- Begin dmpar tests') + + ! + ! Test mpas_dmpar_sum_int8 routine + ! + routine_name = 'mpas_dmpar_sum_int8' + ierr = test_sum_int8(dminfo) + call mpas_dmpar_max_int(dminfo, ierr, ierr_global) + if (ierr_global == 0) then + call mpas_log_write(' '//trim(routine_name)//' - PASSED') + else + ierr_count = ierr_count + 1 + call mpas_log_write(' '//trim(routine_name)//' - FAILED') + end if + + end function mpas_test_dmpar + + + !----------------------------------------------------------------------- + ! routine test_sum_int8 + ! + !> \brief Tests the mpas_dmpar_sum_int8 routine + !> \author Michael Duda + !> \date 14 November 2023 + !> \details + !> This routine tests the mpas_dmpar_sum_int8 routine. + !> + !> Return value: The total number of test that failed on the calling rank. + ! + !----------------------------------------------------------------------- + function test_sum_int8(dminfo) result(ierr_count) + + use mpas_dmpar, only : mpas_dmpar_sum_int8 + use mpas_kind_types, only : I8KIND + + implicit none + + ! Arguments + type (dm_info), intent(inout) :: dminfo + + ! Return value + integer :: ierr_count + + ! Local variables + integer(kind=I8KIND) :: ival, ival_sum + integer :: nranks, myrank + + ierr_count = 0 + + myrank = dminfo % my_proc_id + nranks = dminfo % nprocs + + ! + ! Compute sum(huge(ival) / nranks) + ! Correct result should be at least (huge(ival) - nranks) when accounting + ! for truncation in the integer division operation + ! + ival = huge(ival) / nranks + call mpas_dmpar_sum_int8(dminfo, ival, ival_sum) + if (ival_sum >= huge(ival) - nranks) then + call mpas_log_write(' int8 sum to HUGE() - PASSED') + else + call mpas_log_write(' int8 sum to HUGE() - FAILED') + ierr_count = 1 + end if + + ! + ! Compute sum(-huge(ival) / nranks) + ! Correct result should be at most (-huge(ival) + nranks) when accounting + ! for truncation in the integer division operation + ! + ival = -huge(ival) / nranks + call mpas_dmpar_sum_int8(dminfo, ival, ival_sum) + if (ival_sum <= -huge(ival) + nranks) then + call mpas_log_write(' int8 sum to -HUGE() - PASSED') + else + call mpas_log_write(' int8 sum to -HUGE() - FAILED') + ierr_count = 1 + end if + + ! + ! Compute sum of N alternating positive and negative values, where N is + ! the largest even number not greater than the number of ranks. + ! The magnitude of the values to be summed is (huge(ival) / nranks) to + ! avoid overflow for any order of summation. + ! + ival = huge(ival) / nranks + if (mod(myrank, 2) == 1) then + ival = -ival + end if + + ! If we have an odd number of ranks, set value on rank 0 to zero + if (mod(nranks, 2) /= 0) then + if (myrank == 0) then + ival = 0 + end if + end if + call mpas_dmpar_sum_int8(dminfo, ival, ival_sum) + if (ival_sum == 0_I8KIND) then + call mpas_log_write(' int8 sum to zero - PASSED') + else + call mpas_log_write(' int8 sum to zero - FAILED') + ierr_count = 1 + end if + + end function test_sum_int8 + +end module mpas_test_core_dmpar diff --git a/src/core_test/mpas_test_core_field_tests.F b/src/core_test/mpas_test_core_field_tests.F index 54493fc39c..50114398c6 100644 --- a/src/core_test/mpas_test_core_field_tests.F +++ b/src/core_test/mpas_test_core_field_tests.F @@ -82,19 +82,21 @@ subroutine test_core_attribute_list_test(domain, threadErrs, ierr)!{{{ integer, intent(out) :: ierr type ( att_list_type ), pointer :: srcList, destList - integer :: srcInt, destInt - integer, dimension(:), pointer :: srcIntA, destIntA - real (kind=RKIND) :: srcReal, destReal + integer :: srcInt, destInt, modifyInt + integer, dimension(:), pointer :: srcIntA, destIntA, modifyIntA + real (kind=RKIND) :: srcReal, destReal, modifyReal real (kind=RKIND), dimension(:), pointer :: srcRealA, destRealA - character (len=StrKIND) :: srcText, destText + real (kind=RKIND), dimension(:), pointer :: modifyRealA + character (len=StrKIND) :: srcText, destText, modifyText integer :: threadNum iErr = 0 + threadErrs = 0 - threadNum = mpas_threading_get_thread_num() + threadNum = mpas_threading_get_thread_num() + 1 - if ( threadNum == 0 ) then + if ( threadNum == 1 ) then allocate(srcList) nullify(destList) @@ -153,9 +155,61 @@ subroutine test_core_attribute_list_test(domain, threadErrs, ierr)!{{{ call mpas_log_write(' Duplicate string does not match', MPAS_LOG_ERR) end if + deallocate(destIntA) + deallocate(destRealA) + allocate(modifyIntA(3)) + allocate(modifyRealA(5)) + + modifyInt = 2 + modifyIntA(:) = 2 + modifyReal = 2.0_RKIND + modifyRealA(:) = 2.0_RKIND + modifyText = 'Modified' + + call mpas_modify_att(srcList, 'testInt', modifyInt) + call mpas_modify_att(srcList, 'testIntA', modifyIntA) + call mpas_modify_att(srcList, 'testReal', modifyReal) + call mpas_modify_att(srcList, 'testRealA', modifyRealA) + call mpas_modify_att(srcList, 'testText', modifyText) + + call mpas_get_att(srcList, 'testInt', destInt) + call mpas_get_att(srcList, 'testIntA', destIntA) + call mpas_get_att(srcList, 'testReal', destReal) + call mpas_get_att(srcList, 'testRealA', destRealA) + call mpas_get_att(srcList, 'testText', destText) + + if ( destInt /= modifyInt ) then + threadErrs( threadNum ) = 1 + call mpas_log_write(' Int not modified correctly', MPAS_LOG_ERR) + end if + + if (sum(destIntA) /= sum(modifyIntA)) then + threadErrs( threadNum ) = 1 + call mpas_log_write(' IntA not modified correctly', MPAS_LOG_ERR) + end if + + if ( destReal /= modifyReal ) then + threadErrs( threadNum ) = 1 + call mpas_log_write(' Real not modified correctly', MPAS_LOG_ERR) + end if + + if ( sum(destRealA) /= sum(modifyRealA) ) then + threadErrs( threadNum ) = 1 + call mpas_log_write(' RealA not modified correctly', MPAS_LOG_ERR) + end if + + if ( trim(destText) /= trim(modifyText) ) then + threadErrs( threadNum ) = 1 + call mpas_log_write(' Text not modified correctly', MPAS_LOG_ERR) + end if + call mpas_deallocate_attlist(srcList) call mpas_deallocate_attlist(destList) - + + deallocate(destIntA) + deallocate(destRealA) + deallocate(modifyRealA) + deallocate(modifyIntA) deallocate(srcIntA) deallocate(srcRealA) end if diff --git a/src/core_test/mpas_test_core_halo_exch.F b/src/core_test/mpas_test_core_halo_exch.F index 88f41b1ab2..f3979f74ac 100644 --- a/src/core_test/mpas_test_core_halo_exch.F +++ b/src/core_test/mpas_test_core_halo_exch.F @@ -104,8 +104,7 @@ subroutine test_core_halo_exch_full_test(domain, threadErrs, err)!{{{ integer, dimension(:), intent(out) :: threadErrs integer, intent(out) :: err - type (block_type), pointer :: block - type (mpas_pool_type), pointer :: meshPool, haloExchTestPool + type (mpas_pool_type), pointer :: haloExchTestPool type (field5DReal), pointer :: real5DField type (field4DReal), pointer :: real4DField @@ -116,27 +115,6 @@ subroutine test_core_halo_exch_full_test(domain, threadErrs, err)!{{{ type (field2DInteger), pointer :: int2DField type (field1DInteger), pointer :: int1DField - real (kind=RKIND), dimension(:, :, :, :, :), pointer :: real5D - real (kind=RKIND), dimension(:, :, :, :), pointer :: real4D - real (kind=RKIND), dimension(:, :, :), pointer :: real3D - real (kind=RKIND), dimension(:, :), pointer :: real2D - real (kind=RKIND), dimension(:), pointer :: real1D - - real (kind=RKIND) :: realValue - integer :: integerValue - - integer, dimension(:, :, :), pointer :: int3D - integer, dimension(:, :), pointer :: int2D - integer, dimension(:), pointer :: int1D - - integer :: i, j, k, l, m - integer :: iDim1, iDim2, iDim3, iDim4, iDim5 - integer, pointer :: nCells, nEdges, nVertices - integer, pointer :: nCellsSolve, nEdgesSolve, nVerticesSolve - integer, dimension(:), pointer :: indexToCellID - integer, dimension(:), pointer :: indexToEdgeID - integer, dimension(:), pointer :: indexToVertexID - integer :: threadNum threadNum = mpas_threading_get_thread_num() + 1 @@ -992,6 +970,130 @@ subroutine test_core_halo_exch_setup_fields(domain, threadErrs, err)!{{{ end subroutine test_core_halo_exch_setup_fields!}}} + !*********************************************************************** + ! routine computeErrors + ! + !> \brief compare the provided array elements with the provided + !> expected values + !> \details + !> Goes through the provided data arrays, comparing data elements with corresponding + !> values in an array of expected values. + !> Return non-zero if any elements don't match their expected value, + !> else return zero + !----------------------------------------------------------------------- + function computeErrors(nColumns, expectedValues, real5D, real4D, real3D, real2D, real1D, & + int3d, int2d, int1d) result(errorCode) + integer, intent(in) :: nColumns !< the outermost dimension size to be checked + integer, dimension(:), pointer, intent(in) :: expectedValues !< an array of expected values + !< the following are multi-dimension arrays whose elements are checked + real (kind=RKIND), dimension(:, :, :, :, :), pointer, intent(inout) :: real5D + real (kind=RKIND), dimension(:, :, :, :), pointer, intent(inout) :: real4D + real (kind=RKIND), dimension(:, :, :), pointer, intent(inout) :: real3D + real (kind=RKIND), dimension(:, :), pointer, intent(inout) :: real2D + real (kind=RKIND), dimension(:), pointer, intent(inout) :: real1D + integer, dimension(:, :, :), pointer, intent(inout) :: int3D + integer, dimension(:, :), pointer, intent(inout) :: int2D + integer, dimension(:), pointer, intent(inout) :: int1D + + integer :: iDim2, iDim3, iDim4, iDim5 + integer :: i, j, k, l, m + integer integerValue + real (kind=RKIND) realValue + integer errorCode + + iDim2 = size(real5D, dim=4) + iDim3 = size(real5D, dim=3) + iDim4 = size(real5D, dim=2) + iDim5 = size(real5D, dim=1) + + errorCode = 0 + !$omp do schedule(runtime) private(j, k, l, m, realValue, integerValue) + do i = 1, nColumns + realValue = real(expectedValues(i), kind=RKIND) + integerValue = expectedValues(i) + do j = 1, iDim2 + do k = 1, iDim3 + do l = 1, iDim4 + do m = 1, iDim5 + if (real5D(m, l, k, j, i) - realValue /= 0.0_RKIND) then + errorCode = 1 +#ifdef HALO_EXCH_DEBUG + call mpas_log_write(' real5D($i, $i, $i, $i, $i) - realValue:$r', & + intArgs=(/m, l, k, j, i/), realArgs=(/real5D(m, l, k, j, i) - realValue/)) +#else + return +#endif + end if + end do + if (real4D(l, k, j, i) - realValue /= 0.0_RKIND) then + errorCode = 1 +#ifdef HALO_EXCH_DEBUG + call mpas_log_write(' real4D($i, $i, $i, $i) - realValue:$r', & + intArgs=(/l, k, j, i/), realArgs=(/real4D(l, k, j, i) - realValue/)) +#else + return +#endif + end if + end do + if (real3D(k, j, i) - realValue /= 0.0_RKIND) then + errorCode = 1 +#ifdef HALO_EXCH_DEBUG + call mpas_log_write(' real3D($i, $i, $i) - realValue:$r', & + intArgs=(/k, j, i/), realArgs=(/real3D(k, j, i) - realValue/)) +#else + return +#endif + endif + if (int3D(k, j, i) - integerValue /= 0) then + errorCode = 1 +#ifdef HALO_EXCH_DEBUG + call mpas_log_write(' int3D($i, $i, $i, $i, $i) - intValue:$i', & + intArgs=(/k, j, i, int3D(k, j, i) - integerValue/)) +#else + return +#endif + end if + end do + if (real2D(j, i) - realValue /= 0.0_RKIND) then + errorCode = 1 +#ifdef HALO_EXCH_DEBUG + call mpas_log_write(' real2D($i, $i) - realValue:$r', & + intArgs=(/j, i/), realArgs=(/real2D(j, i) - realValue/)) +#else + return +#endif + end if + if (int2D(j, i) - integerValue /= 0) then + errorCode = 1 +#ifdef HALO_EXCH_DEBUG + call mpas_log_write(' int2D($i, $i) - integerValue:$i', & + intArgs=(/j, i, int2D(j, i) - integerValue/)) +#else + return +#endif + end if + end do + if (real1D(i) - realValue /= 0.0_RKIND) then + errorCode = 1 +#ifdef HALO_EXCH_DEBUG + call mpas_log_write(' real1D($i) - realValue:$r', & + intArgs=(/i/), realArgs=(/real1D(i) - realValue/)) +#else + return +#endif + end if + if (int1D(i) - integerValue /= 0) then + errorCode = 1 +#ifdef HALO_EXCH_DEBUG + call mpas_log_write(' int1D($i) - integerValue:$i', & + intArgs=(/i, int1D(i) - integerValue/)) +#else + return +#endif + endif + end do + end function computeErrors + !*********************************************************************** ! ! routine test_core_halo_exch_validate_fields @@ -1031,15 +1133,10 @@ subroutine test_core_halo_exch_validate_fields(domain, threadErrs, err)!{{{ real (kind=RKIND), dimension(:, :), pointer :: real2D real (kind=RKIND), dimension(:), pointer :: real1D - real (kind=RKIND) :: realValue - integer :: integerValue - integer, dimension(:, :, :), pointer :: int3D integer, dimension(:, :), pointer :: int2D integer, dimension(:), pointer :: int1D - integer :: i, j, k, l, m - integer :: iDim1, iDim2, iDim3, iDim4, iDim5 integer, pointer :: nCells, nEdges, nVertices integer, pointer :: nCellsSolve, nEdgesSolve, nVerticesSolve integer, dimension(:), pointer :: indexToCellID @@ -1083,71 +1180,13 @@ subroutine test_core_halo_exch_validate_fields(domain, threadErrs, err)!{{{ call mpas_pool_get_array(haloExchTestPool, 'cellPersistInt2D', int2D) call mpas_pool_get_array(haloExchTestPool, 'cellPersistInt1D', int1D) - ! Subtract index from all peristent cell fields - iDim1 = size(real5D, dim=5) - iDim2 = size(real5D, dim=4) - iDim3 = size(real5D, dim=3) - iDim4 = size(real5D, dim=2) - iDim5 = size(real5D, dim=1) - - !$omp do schedule(runtime) private(j, k, l, m, realValue, integerValue) - do i = 1, iDim1 - realValue = real(indexToCellID(i), kind=RKIND) - integerValue = indexToCellID(i) - do j = 1, iDim2 - do k = 1, iDim3 - do l = 1, iDim4 - do m = 1, iDim5 - real5D(m, l, k, j, i) = real5D(m, l, k, j, i) - realValue - end do - real4D(l, k, j, i) = real4D(l, k, j, i) - realValue - end do - real3D(k, j, i) = real3D(k, j, i) - realValue - int3D(k, j, i) = int3D(k, j, i) - integerValue - end do - real2D(j, i) = real2D(j, i) - realValue - int2D(j, i) = int2D(j, i) - integerValue - end do - real1D(i) = real1D(i) - realValue - int1D(i) = int1D(i) - integerValue - end do - !$omp end do - ! Validate that all differences are zero. #ifdef HALO_EXCH_DEBUG call mpas_log_write(' -- Testing persistent cell fields') #endif - if ( sum(real5D) /= 0.0_RKIND ) then - threadErrs(threadNum) = 1 - end if - - if ( sum(real4D) /= 0.0_RKIND ) then - threadErrs(threadNum) = 1 - end if - - if ( sum(real3D) /= 0.0_RKIND ) then - threadErrs(threadNum) = 1 - end if + threadErrs(threadNum) = computeErrors(nCells, indexToCellID, real5D, real4D, real3D, real2D, real1D, & + int3d, int2d, int1d) - if ( sum(real2D) /= 0.0_RKIND ) then - threadErrs(threadNum) = 1 - end if - - if ( sum(real1D) /= 0.0_RKIND ) then - threadErrs(threadNum) = 1 - end if - - if ( sum(int3D) /= 0 ) then - threadErrs(threadNum) = 1 - end if - - if ( sum(int2D) /= 0 ) then - threadErrs(threadNum) = 1 - end if - - if ( sum(int1D) /= 0 ) then - threadErrs(threadNum) = 1 - end if #ifdef HALO_EXCH_DEBUG call mpas_log_write(' -- Test result: $i', intArgs=(/threadErrs(threadNum)/)) #endif @@ -1162,71 +1201,13 @@ subroutine test_core_halo_exch_validate_fields(domain, threadErrs, err)!{{{ call mpas_pool_get_array(haloExchTestPool, 'edgePersistInt2D', int2D) call mpas_pool_get_array(haloExchTestPool, 'edgePersistInt1D', int1D) - ! Subtract index from all peristent edge fields - iDim1 = size(real5D, dim=5) - iDim2 = size(real5D, dim=4) - iDim3 = size(real5D, dim=3) - iDim4 = size(real5D, dim=2) - iDim5 = size(real5D, dim=1) - - !$omp do schedule(runtime) private(j, k, l, m, realValue, integerValue) - do i = 1, iDim1 - realValue = real(indexToEdgeID(i), kind=RKIND) - integerValue = indexToEdgeID(i) - do j = 1, iDim2 - do k = 1, iDim3 - do l = 1, iDim4 - do m = 1, iDim5 - real5D(m, l, k, j, i) = real5D(m, l, k, j, i) - realValue - end do - real4D(l, k, j, i) = real4D(l, k, j, i) - realValue - end do - real3D(k, j, i) = real3D(k, j, i) - realValue - int3D(k, j, i) = int3D(k, j, i) - integerValue - end do - real2D(j, i) = real2D(j, i) - realValue - int2D(j, i) = int2D(j, i) - integerValue - end do - real1D(i) = real1D(i) - realValue - int1D(i) = int1D(i) - integerValue - end do - !$omp end do - ! Validate that all differences are zero. #ifdef HALO_EXCH_DEBUG call mpas_log_write(' -- Testing persistent Edge fields') #endif - if ( sum(real5D) /= 0.0_RKIND ) then - threadErrs(threadNum) = 1 - end if - - if ( sum(real4D) /= 0.0_RKIND ) then - threadErrs(threadNum) = 1 - end if + threadErrs(threadNum) = computeErrors(nEdges, indexToEdgeID, real5D, real4D, real3D, real2D, real1D, & + int3d, int2d, int1d) - if ( sum(real3D) /= 0.0_RKIND ) then - threadErrs(threadNum) = 1 - end if - - if ( sum(real2D) /= 0.0_RKIND ) then - threadErrs(threadNum) = 1 - end if - - if ( sum(real1D) /= 0.0_RKIND ) then - threadErrs(threadNum) = 1 - end if - - if ( sum(int3D) /= 0 ) then - threadErrs(threadNum) = 1 - end if - - if ( sum(int2D) /= 0 ) then - threadErrs(threadNum) = 1 - end if - - if ( sum(int1D) /= 0 ) then - threadErrs(threadNum) = 1 - end if #ifdef HALO_EXCH_DEBUG call mpas_log_write(' -- Test result: $i', intArgs=(/threadErrs(threadNum)/)) #endif @@ -1241,63 +1222,13 @@ subroutine test_core_halo_exch_validate_fields(domain, threadErrs, err)!{{{ call mpas_pool_get_array(haloExchTestPool, 'vertexPersistInt2D', int2D) call mpas_pool_get_array(haloExchTestPool, 'vertexPersistInt1D', int1D) - ! Subtract index from all peristent vertex fields - iDim1 = size(real5D, dim=5) - iDim2 = size(real5D, dim=4) - iDim3 = size(real5D, dim=3) - iDim4 = size(real5D, dim=2) - iDim5 = size(real5D, dim=1) - - !$omp do schedule(runtime) private(j, k, l, m, realValue, integerValue) - do i = 1, iDim1 - realValue = real(indexToVertexID(i), kind=RKIND) - integerValue = indexToVertexID(i) - do j = 1, iDim2 - do k = 1, iDim3 - do l = 1, iDim4 - do m = 1, iDim5 - real5D(m, l, k, j, i) = real5D(m, l, k, j, i) - realValue - end do - real4D(l, k, j, i) = real4D(l, k, j, i) - realValue - end do - real3D(k, j, i) = real3D(k, j, i) - realValue - int3D(k, j, i) = int3D(k, j, i) - integerValue - end do - real2D(j, i) = real2D(j, i) - realValue - int2D(j, i) = int2D(j, i) - integerValue - end do - real1D(i) = real1D(i) - realValue - int1D(i) = int1D(i) - integerValue - end do - !$omp end do - ! Validate that all differences are zero. #ifdef HALO_EXCH_DEBUG call mpas_log_write(' -- Testing persistent Vertex fields') #endif - if ( sum(real5D) /= 0.0_RKIND ) then - threadErrs(threadNum) = 1 - end if + threadErrs(threadNum) = computeErrors(nVertices, indexToVertexID, real5D, real4D, real3D, real2D, real1D, & + int3d, int2d, int1d) - if ( sum(real4D) /= 0.0_RKIND ) then - threadErrs(threadNum) = 1 - end if - - if ( sum(real3D) /= 0.0_RKIND ) then - threadErrs(threadNum) = 1 - end if - - if ( sum(real2D) /= 0.0_RKIND ) then - threadErrs(threadNum) = 1 - end if - - if ( sum(real1D) /= 0.0_RKIND ) then - threadErrs(threadNum) = 1 - end if - - if ( sum(int3D) /= 0 ) then - threadErrs(threadNum) = 1 - end if #ifdef HALO_EXCH_DEBUG call mpas_log_write(' -- Test result: $i', intArgs=(/threadErrs(threadNum)/)) #endif @@ -1312,71 +1243,13 @@ subroutine test_core_halo_exch_validate_fields(domain, threadErrs, err)!{{{ call mpas_pool_get_array(haloExchTestPool, 'cellScratchInt2D', int2D) call mpas_pool_get_array(haloExchTestPool, 'cellScratchInt1D', int1D) - ! Subtract index from all peristent cell fields - iDim1 = size(real5D, dim=5) - iDim2 = size(real5D, dim=4) - iDim3 = size(real5D, dim=3) - iDim4 = size(real5D, dim=2) - iDim5 = size(real5D, dim=1) - - !$omp do schedule(runtime) private(j, k, l, m, realValue, integerValue) - do i = 1, iDim1 - realValue = real(indexToCellID(i), kind=RKIND) - integerValue = indexToCellID(i) - do j = 1, iDim2 - do k = 1, iDim3 - do l = 1, iDim4 - do m = 1, iDim5 - real5D(m, l, k, j, i) = real5D(m, l, k, j, i) - realValue - end do - real4D(l, k, j, i) = real4D(l, k, j, i) - realValue - end do - real3D(k, j, i) = real3D(k, j, i) - realValue - int3D(k, j, i) = int3D(k, j, i) - integerValue - end do - real2D(j, i) = real2D(j, i) - realValue - int2D(j, i) = int2D(j, i) - integerValue - end do - real1D(i) = real1D(i) - realValue - int1D(i) = int1D(i) - integerValue - end do - !$omp end do - ! Validate that all differences are zero. #ifdef HALO_EXCH_DEBUG call mpas_log_write(' -- Testing scratch cell fields') #endif - if ( sum(real5D) /= 0.0_RKIND ) then - threadErrs(threadNum) = 1 - end if - - if ( sum(real4D) /= 0.0_RKIND ) then - threadErrs(threadNum) = 1 - end if + threadErrs(threadNum) = computeErrors(nCells, indexToCellID, real5D, real4D, real3D, real2D, real1D, & + int3d, int2d, int1d) - if ( sum(real3D) /= 0.0_RKIND ) then - threadErrs(threadNum) = 1 - end if - - if ( sum(real2D) /= 0.0_RKIND ) then - threadErrs(threadNum) = 1 - end if - - if ( sum(real1D) /= 0.0_RKIND ) then - threadErrs(threadNum) = 1 - end if - - if ( sum(int3D) /= 0 ) then - threadErrs(threadNum) = 1 - end if - - if ( sum(int2D) /= 0 ) then - threadErrs(threadNum) = 1 - end if - - if ( sum(int1D) /= 0 ) then - threadErrs(threadNum) = 1 - end if #ifdef HALO_EXCH_DEBUG call mpas_log_write(' -- Test result: $i', intArgs=(/threadErrs(threadNum)/)) #endif @@ -1391,73 +1264,15 @@ subroutine test_core_halo_exch_validate_fields(domain, threadErrs, err)!{{{ call mpas_pool_get_array(haloExchTestPool, 'edgeScratchInt2D', int2D) call mpas_pool_get_array(haloExchTestPool, 'edgeScratchInt1D', int1D) - ! Subtract index from all peristent edge fields - iDim1 = size(real5D, dim=5) - iDim2 = size(real5D, dim=4) - iDim3 = size(real5D, dim=3) - iDim4 = size(real5D, dim=2) - iDim5 = size(real5D, dim=1) - - !$omp do schedule(runtime) private(j, k, l, m) - do i = 1, iDim1 - realValue = real(indexToEdgeID(i), kind=RKIND) - integerValue = indexToEdgeID(i) - do j = 1, iDim2 - do k = 1, iDim3 - do l = 1, iDim4 - do m = 1, iDim5 - real5D(m, l, k, j, i) = real5D(m, l, k, j, i) - realValue - end do - real4D(l, k, j, i) = real4D(l, k, j, i) - realValue - end do - real3D(k, j, i) = real3D(k, j, i) - realValue - int3D(k, j, i) = int3D(k, j, i) - integerValue - end do - real2D(j, i) = real2D(j, i) - realValue - int2D(j, i) = int2D(j, i) - integerValue - end do - real1D(i) = real1D(i) - realValue - int1D(i) = int1D(i) - integerValue - end do - !$omp end do - ! Validate that all differences are zero. #ifdef HALO_EXCH_DEBUG call mpas_log_write(' -- Testing scratch edge fields') #endif - if ( sum(real5D) /= 0.0_RKIND ) then - threadErrs(threadNum) = 1 - end if - - if ( sum(real4D) /= 0.0_RKIND ) then - threadErrs(threadNum) = 1 - end if - - if ( sum(real3D) /= 0.0_RKIND ) then - threadErrs(threadNum) = 1 - end if - - if ( sum(real2D) /= 0.0_RKIND ) then - threadErrs(threadNum) = 1 - end if - - if ( sum(real1D) /= 0.0_RKIND ) then - threadErrs(threadNum) = 1 - end if - - if ( sum(int3D) /= 0 ) then - threadErrs(threadNum) = 1 - end if - - if ( sum(int2D) /= 0 ) then - threadErrs(threadNum) = 1 - end if + threadErrs(threadNum) = computeErrors(nEdges, indexToEdgeID, real5D, real4D, real3D, real2D, real1D, & + int3d, int2d, int1d) - if ( sum(int1D) /= 0 ) then - threadErrs(threadNum) = 1 - end if #ifdef HALO_EXCH_DEBUG - call mpas_log_write(' -- Test result: $i', intArgs=(/threadErrs(threadNum)/) + call mpas_log_write(' -- Test result: $i', intArgs=(/threadErrs(threadNum)/)) #endif ! Compare scratch vertex fields @@ -1470,77 +1285,19 @@ subroutine test_core_halo_exch_validate_fields(domain, threadErrs, err)!{{{ call mpas_pool_get_array(haloExchTestPool, 'vertexScratchInt2D', int2D) call mpas_pool_get_array(haloExchTestPool, 'vertexScratchInt1D', int1D) - ! Subtract index from all peristent vertex fields - iDim1 = size(real5D, dim=5) - iDim2 = size(real5D, dim=4) - iDim3 = size(real5D, dim=3) - iDim4 = size(real5D, dim=2) - iDim5 = size(real5D, dim=1) - - !$omp do schedule(runtime) private(j, k, l, m, realValue, integerValue) - do i = 1, iDim1 - realValue = real(indexToVertexID(i), kind=RKIND) - integerValue = indexToVertexID(i) - do j = 1, iDim2 - do k = 1, iDim3 - do l = 1, iDim4 - do m = 1, iDim4 - real5D(m, l, k, j, i) = real5D(m, l, k, j, i) - realValue - end do - real4D(l, k, j, i) = real4D(l, k, j, i) - realValue - end do - real3D(k, j, i) = real3D(k, j, i) - realValue - int3D(k, j, i) = int3D(k, j, i) - integerValue - end do - real2D(j, i) = real2D(j, i) - realValue - int2D(j, i) = int2D(j, i) - integerValue - end do - real1D(i) = real1D(i) - realValue - int1D(i) = int1D(i) - integerValue - end do - !$omp end do - ! Validate that all differences are zero. #ifdef HALO_EXCH_DEBUG call mpas_log_write(' -- Testing scratch vertex fields') #endif - if ( sum(real5D) /= 0.0_RKIND ) then - threadErrs(threadNum) = 1 - end if - - if ( sum(real4D) /= 0.0_RKIND ) then - threadErrs(threadNum) = 1 - end if - - if ( sum(real3D) /= 0.0_RKIND ) then - threadErrs(threadNum) = 1 - end if - - if ( sum(real2D) /= 0.0_RKIND ) then - threadErrs(threadNum) = 1 - end if - - if ( sum(real1D) /= 0.0_RKIND ) then - threadErrs(threadNum) = 1 - end if - - if ( sum(int3D) /= 0 ) then - threadErrs(threadNum) = 1 - end if - - if ( sum(int2D) /= 0 ) then - threadErrs(threadNum) = 1 - end if + threadErrs(threadNum) = computeErrors(nVertices, indexToVertexID, real5D, real4D, real3D, real2D, real1D, & + int3d, int2d, int1d) - if ( sum(int1D) /= 0 ) then - threadErrs(threadNum) = 1 - end if #ifdef HALO_EXCH_DEBUG call mpas_log_write(' -- Test result: $i', intArgs=(/threadErrs(threadNum)/)) #endif block => block % next - end do + end do call mpas_threading_barrier() diff --git a/src/core_test/mpas_test_core_interface.F b/src/core_test/mpas_test_core_interface.F index c0bce7d7fc..3988f7288e 100644 --- a/src/core_test/mpas_test_core_interface.F +++ b/src/core_test/mpas_test_core_interface.F @@ -89,13 +89,14 @@ end subroutine test_setup_domain!}}} !> *not* allocated until after this routine is called. ! !----------------------------------------------------------------------- - function test_setup_packages(configPool, packagePool, iocontext) result(ierr)!{{{ + function test_setup_packages(configPool, streamInfo, packagePool, iocontext) result(ierr)!{{{ use mpas_derived_types implicit none type (mpas_pool_type), intent(inout) :: configPool + type (MPAS_streamInfo_type), intent(inout) :: streamInfo type (mpas_pool_type), intent(inout) :: packagePool type (mpas_io_context_type), intent(inout) :: iocontext integer :: ierr @@ -268,7 +269,7 @@ end function test_setup_log!}}} !> are available. ! !----------------------------------------------------------------------- - function test_get_mesh_stream(configs, stream) result(ierr)!{{{ + function test_get_mesh_stream(configs, streamInfo, stream) result(ierr)!{{{ use mpas_derived_types use mpas_pool_routines @@ -276,6 +277,7 @@ function test_get_mesh_stream(configs, stream) result(ierr)!{{{ implicit none type (mpas_pool_type), intent(inout) :: configs + type (MPAS_streamInfo_type), intent(inout) :: streamInfo character(len=StrKIND), intent(out) :: stream integer :: ierr diff --git a/src/core_test/mpas_test_core_stream_inquiry.F b/src/core_test/mpas_test_core_stream_inquiry.F new file mode 100644 index 0000000000..796e46fbb2 --- /dev/null +++ b/src/core_test/mpas_test_core_stream_inquiry.F @@ -0,0 +1,225 @@ +! Copyright (c) 2023 The University Corporation for Atmospheric Research (UCAR). +! +! Unless noted otherwise source code is licensed under the BSD license. +! Additional copyright and license information can be found in the LICENSE file +! distributed with this code, or at https://mpas-dev.github.io/license.html . +! +module mpas_test_core_stream_inquiry + + use mpas_derived_types, only : dm_info, MPAS_streamInfo_type + use mpas_log, only : mpas_log_write + + private + + public :: mpas_test_stream_inquiry + + + contains + + + !----------------------------------------------------------------------- + ! routine mpas_test_stream_inquiry + ! + !> \brief Main driver for tests of the mpas_stream_inquiry module + !> \author Michael Duda + !> \date 17 November 2023 + !> \details + !> This routine invokes tests for individual routines in the + !> mpas_stream_inquiry module, and reports PASSED/FAILED for each of + !> those tests. + !> + !> Return value: The total number of test that failed on any MPI rank. + ! + !----------------------------------------------------------------------- + function mpas_test_stream_inquiry(dminfo) result(ierr_count) + + use mpas_kind_types, only : StrKIND + use mpas_dmpar, only : mpas_dmpar_max_int + use mpas_stream_inquiry, only : MPAS_stream_inquiry_new_streaminfo + + implicit none + + ! Arguments + type (dm_info), intent(inout) :: dminfo + + ! Return value + integer :: ierr_count + + ! Local variables + integer :: ierr, ierr_global + character(len=StrKIND) :: routine_name + type (MPAS_streamInfo_type), pointer :: streamInfo + + ierr_count = 0 + + call mpas_log_write('--- Begin stream_inquiry tests') + + ! + ! Create a new instance of the MPAS_streamInfo_type derived type + ! + nullify(streamInfo) + streamInfo => MPAS_stream_inquiry_new_streaminfo() + + ! + ! Initialize the instance with the streams.test file + ! A failure here on any task causes this routine to return early + ! + routine_name = 'streamInfo % init' + ierr = streamInfo % init(dminfo % comm, 'streams.test') + call mpas_dmpar_max_int(dminfo, ierr, ierr_global) + if (ierr_global == 0) then + call mpas_log_write(' '//trim(routine_name)//' - PASSED') + else + ierr_count = ierr_count + 1 + call mpas_log_write(' '//trim(routine_name)//' - FAILED') + deallocate(streamInfo) + return + end if + + ! + ! Test streamInfo % query routine + ! + routine_name = 'streamInfo % query' + ierr = test_streaminfo_query(streamInfo) + call mpas_dmpar_max_int(dminfo, ierr, ierr_global) + if (ierr_global == 0) then + call mpas_log_write(' '//trim(routine_name)//' - PASSED') + else + ierr_count = ierr_count + 1 + call mpas_log_write(' '//trim(routine_name)//' - FAILED') + end if + + ! + ! Finalize the MPAS_streamInfo_type instance + ! + routine_name = 'streamInfo % finalize' + ierr = streamInfo % finalize() + call mpas_dmpar_max_int(dminfo, ierr, ierr_global) + if (ierr_global == 0) then + call mpas_log_write(' '//trim(routine_name)//' - PASSED') + else + ierr_count = ierr_count + 1 + call mpas_log_write(' '//trim(routine_name)//' - FAILED') + end if + + deallocate(streamInfo) + + end function mpas_test_stream_inquiry + + + !----------------------------------------------------------------------- + ! routine test_streaminfo_query + ! + !> \brief Tests the streaminfo_query / streamInfo % query routine + !> \author Michael Duda + !> \date 17 November 2023 + !> \details + !> This routine tests the streaminfo_query routine. + !> + !> Return value: The total number of test that failed on the calling rank. + ! + !----------------------------------------------------------------------- + function test_streaminfo_query(streamInfo) result(ierr_count) + + use mpas_kind_types, only : StrKIND + + implicit none + + ! Arguments + type (MPAS_streamInfo_type), intent(inout) :: streamInfo + + ! Return value + integer :: ierr_count + + ! Local variables + logical :: success + character(len=StrKIND) :: attvalue + + ierr_count = 0 + + + ! + ! Query about the existence of an immutable stream that exists + ! + if (streamInfo % query('input')) then + call mpas_log_write(' query existence of an immutable stream that exists - PASSED') + else + call mpas_log_write(' query existence of an immutable stream that exists - FAILED') + ierr_count = ierr_count + 1 + end if + + ! + ! Query about the existence of a mutable stream that exists + ! + if (streamInfo % query('mutable_test')) then + call mpas_log_write(' query existence of a mutable stream that exists - PASSED') + else + call mpas_log_write(' query existence of a mutable stream that exists - FAILED') + ierr_count = ierr_count + 1 + end if + + ! + ! Query about the existence of a stream that does not exist + ! + if (.not. streamInfo % query('foobar')) then + call mpas_log_write(' query existence of a stream that does not exist - PASSED') + else + call mpas_log_write(' query existence of a stream that does not exist - FAILED') + ierr_count = ierr_count + 1 + end if + + ! + ! Query about the existence of an attribute that exists (immutable stream) + ! + if (streamInfo % query('input', attname='filename_template')) then + call mpas_log_write(' query existence of an attribute that exists (immutable stream) - PASSED') + else + call mpas_log_write(' query existence of an attribute that exists (immutable stream) - FAILED') + ierr_count = ierr_count + 1 + end if + + ! + ! Query about the existence of an attribute that exists (mutable stream) + ! + if (streamInfo % query('mutable_test', attname='type')) then + call mpas_log_write(' query existence of an attribute that exists (mutable stream) - PASSED') + else + call mpas_log_write(' query existence of an attribute that exists (mutable stream) - FAILED') + ierr_count = ierr_count + 1 + end if + + ! + ! Query about the existence of an attribute that does not exist + ! + if (.not. streamInfo % query('input', attname='input_start_time')) then + call mpas_log_write(' query existence of an attribute that does not exist - PASSED') + else + call mpas_log_write(' query existence of an attribute that does not exist - FAILED') + ierr_count = ierr_count + 1 + end if + + ! + ! Query the value of an attribute (immutable stream) + ! + success = streamInfo % query('input', attname='input_interval', attvalue=attvalue) + if (success .and. trim(attvalue) == 'initial_only') then + call mpas_log_write(' query value of an attribute (immutable stream) - PASSED') + else + call mpas_log_write(' query value of an attribute (immutable stream) - FAILED') + ierr_count = ierr_count + 1 + end if + + ! + ! Query the value of an attribute (mutable stream) + ! + success = streamInfo % query('mutable_test', attname='filename_template', attvalue=attvalue) + if (success .and. trim(attvalue) == 'mutable_test.nc') then + call mpas_log_write(' query value of an attribute (mutable stream) - PASSED') + else + call mpas_log_write(' query value of an attribute (mutable stream) - FAILED') + ierr_count = ierr_count + 1 + end if + + end function test_streaminfo_query + +end module mpas_test_core_stream_inquiry diff --git a/src/core_test/mpas_test_core_string_utils.F b/src/core_test/mpas_test_core_string_utils.F new file mode 100644 index 0000000000..6e6c85c7c8 --- /dev/null +++ b/src/core_test/mpas_test_core_string_utils.F @@ -0,0 +1,183 @@ +! Copyright (c) 2023, University Corporation for Atmospheric Research (UCAR) +! +! Unless noted otherwise source code is licensed under the BSD license. +! Additional copyright and license information can be found in the +! LICENSE file distributed with this code, or at +! http://mpas-dev.github.com/license.html . +! +module test_core_string_utils + + use mpas_derived_types + use mpas_log + + private + + public :: mpas_test_string_utils + + contains + + subroutine mpas_test_string_replace(err) + + use mpas_string_utils, only : mpas_string_replace + + implicit none + + ! Arguments + integer, intent(out) :: err + + ! Local variables + character(len=StrKIND) :: testString + character(len=StrKIND) :: outString + character :: targetCharacter, toReplace + + err = 0 + + ! Basic functionality + testString = 'Test_String' + targetCharacter = '-' + toReplace = '_' + outString = mpas_string_replace(testString, toReplace, targetCharacter) + if (trim(outString) /= 'Test-String') then + err = err + 1 + call mpas_log_write('FAILED TO REPLACE STRING #1 CORRECTLY', & + MPAS_LOG_ERR) + end if + + ! Whitespace replacement + testString = 'Test String' + targetCharacter = '-' + toReplace = ' ' + outString = mpas_string_replace(testString, toReplace, targetCharacter) + if (trim(outString) /= 'Test-String') then + err = err + 1 + call mpas_log_write('FAILED TO REPLACE STRING #2 CORRECTLY', & + MPAS_LOG_ERR) + end if + + ! Consecutive charcters + testString = 'Test__String' + toReplace = '_' + outString = mpas_string_replace(testString, toReplace, targetCharacter) + if (trim(outString) /= 'Test--String') then + err = err + 1 + call mpas_log_write('FAILED TO REPLACE STRING #3 CORRECTLY', & + MPAS_LOG_ERR) + end if + + ! No Replacement + testString = 'Test String' + toReplace = '-' + outString = mpas_string_replace(testString, toReplace, targetCharacter) + if (trim(outString) /= 'Test String') then + err = err + 1 + call mpas_log_write('FAILED TO REPLACE STRING #4 CORRECTLY', & + MPAS_LOG_ERR) + end if + + end subroutine mpas_test_string_replace + + subroutine mpas_test_split_string(err) + + use mpas_string_utils, only : mpas_split_string + + implicit none + + character(len=StrKIND) :: testString + character :: delimiter + character(len=StrKIND), pointer, dimension(:) :: splitStrings + integer, intent(out) :: err + integer :: i + + err = 0 + + ! Test a basic case + delimiter = ' ' + testString = 'This is a basic test' + call mpas_split_string(testString, delimiter, splitStrings) + + if (size(splitStrings) /= 5) then + err = err + 1 + call mpas_log_write('FAILED TO SPLIT STRING #1 CORRECTLY: WRONG'//& + ' SUBSTRING COUNT', MPAS_LOG_ERR) + return + end if + + if (trim(splitStrings(1)) /= 'This' .or. & + trim(splitStrings(2)) /= 'is' .or. & + trim(splitStrings(3)) /= 'a' .or. & + trim(splitStrings(4)) /= 'basic' .or. & + trim(splitStrings(5)) /= 'test') then + err = err + 1 + call mpas_log_write('FAILED TO SPLIT STRING #1 CORRECTLY', & + MPAS_LOG_ERR) + end if + + ! Test a string without delimiters + testString = 'This-is-a-test' + call mpas_split_string(testString, delimiter, splitStrings) + + if (size(splitStrings) /= 1) then + err = err + 1 + call mpas_log_write('FAILED TO SPLIT STRING #2 CORRECTLY: WRONG'//& + ' SUBSTRING COUNT', MPAS_LOG_ERR) + return + end if + + if (trim(splitStrings(1)) /= 'This-is-a-test') then + err = err + 1 + call mpas_log_write('FAILED TO SPLIT STRING #2 CORRECTLY', & + MPAS_LOG_ERR) + end if + + ! Test a string with consecutive delimiters + testString = 'This--is-a-test' + delimiter = '-' + call mpas_split_string(testString, delimiter, splitStrings) + + if (size(splitStrings) /= 5) then + err = err + 1 + call mpas_log_write('FAILED TO SPLIT STRING #3 CORRECTLY: WRONG'//& + ' SUBSTRING COUNT', MPAS_LOG_ERR) + return + end if + + if (trim(splitStrings(1)) /= 'This' .or. & + trim(splitStrings(2)) /= '' .or. & + trim(splitStrings(3)) /= 'is' .or. & + trim(splitStrings(4)) /= 'a' .or. & + trim(splitStrings(5)) /= 'test') then + err = err + 1 + call mpas_log_write('FAILED TO SPLIT STRING #3 CORRECTLY', & + MPAS_LOG_ERR) + end if + + end subroutine mpas_test_split_string + + subroutine mpas_test_string_utils(err) + + implicit none + + integer, intent(out) :: err + + err = 0 + + call mpas_log_write('String Utils Tests') + + call mpas_test_split_string(err) + if (err == 0) then + call mpas_log_write(' mpas_split_string: SUCCESS') + else + call mpas_log_write(' mpas_split_string: FAILURE', MPAS_LOG_ERR) + end if + + call mpas_test_string_replace(err) + if (err == 0) then + call mpas_log_write(' mpas_string_replace: SUCCESS') + else + call mpas_log_write(' mpas_string_replace: FAILURE', & + MPAS_LOG_ERR) + end if + + end subroutine mpas_test_string_utils + +end module test_core_string_utils diff --git a/src/driver/mpas_subdriver.F b/src/driver/mpas_subdriver.F index bfe79d0508..ba94dcaf52 100644 --- a/src/driver/mpas_subdriver.F +++ b/src/driver/mpas_subdriver.F @@ -39,20 +39,28 @@ module mpas_subdriver contains - subroutine mpas_init(corelist, domain_ptr, mpi_comm, namelistFileParam, streamsFileParam) + subroutine mpas_init(corelist, domain_ptr, external_comm, namelistFileParam, streamsFileParam) +#ifdef MPAS_USE_MPI_F08 + use mpi_f08, only : MPI_Comm +#endif use mpas_stream_manager, only : MPAS_stream_mgr_init, MPAS_build_stream_filename, MPAS_stream_mgr_validate_streams use iso_c_binding, only : c_char, c_loc, c_ptr, c_int use mpas_c_interfacing, only : mpas_f_to_c_string, mpas_c_to_f_string use mpas_timekeeping, only : mpas_get_clock_time, mpas_get_time use mpas_bootstrapping, only : mpas_bootstrap_framework_phase1, mpas_bootstrap_framework_phase2 use mpas_log + use mpas_stream_inquiry, only : MPAS_stream_inquiry_new_streaminfo implicit none type (core_type), intent(inout), pointer :: corelist type (domain_type), intent(inout), pointer :: domain_ptr - integer, intent(in), optional :: mpi_comm +#ifdef MPAS_USE_MPI_F08 + type (MPI_Comm), intent(in), optional :: external_comm +#else + integer, intent(in), optional :: external_comm +#endif character(len=*), intent(in), optional :: namelistFileParam character(len=*), intent(in), optional :: streamsFileParam @@ -191,7 +199,7 @@ end subroutine xml_stream_get_attributes ! ! Initialize infrastructure ! - call mpas_framework_init_phase1(domain_ptr % dminfo, mpi_comm=mpi_comm) + call mpas_framework_init_phase1(domain_ptr % dminfo, external_comm=external_comm) #ifdef CORE_ATMOSPHERE @@ -248,12 +256,26 @@ end subroutine xml_stream_get_attributes call mpas_framework_init_phase2(domain_ptr) + ! + ! Before defining packages, initialize the stream inquiry instance for the domain + ! + domain_ptr % streamInfo => MPAS_stream_inquiry_new_streaminfo() + if (.not. associated(domain_ptr % streamInfo)) then + call mpas_log_write('Failed to instantiate streamInfo object for core '//trim(domain_ptr % core % coreName), & + messageType=MPAS_LOG_CRIT) + end if + if (domain_ptr % streamInfo % init(domain_ptr % dminfo % comm, domain_ptr % streams_filename) /= 0) then + call mpas_log_write('Initialization of streamInfo object failed for core '//trim(domain_ptr % core % coreName), & + messageType=MPAS_LOG_CRIT) + end if + ierr = domain_ptr % core % define_packages(domain_ptr % packages) if ( ierr /= 0 ) then call mpas_log_write('Package definition failed for core '//trim(domain_ptr % core % coreName), messageType=MPAS_LOG_CRIT) end if - ierr = domain_ptr % core % setup_packages(domain_ptr % configs, domain_ptr % packages, domain_ptr % iocontext) + ierr = domain_ptr % core % setup_packages(domain_ptr % configs, domain_ptr % streamInfo, domain_ptr % packages, & + domain_ptr % iocontext) if ( ierr /= 0 ) then call mpas_log_write('Package setup failed for core '//trim(domain_ptr % core % coreName), messageType=MPAS_LOG_CRIT) end if @@ -282,14 +304,18 @@ end subroutine xml_stream_get_attributes ! Using information from the namelist, a graph.info file, and a file containing ! mesh fields, build halos and allocate blocks in the domain ! - ierr = domain_ptr % core % get_mesh_stream(domain_ptr % configs, mesh_stream) + ierr = domain_ptr % core % get_mesh_stream(domain_ptr % configs, domain_ptr % streamInfo, mesh_stream) if ( ierr /= 0 ) then call mpas_log_write('Failed to find mesh stream for core '//trim(domain_ptr % core % coreName), messageType=MPAS_LOG_CRIT) end if call mpas_f_to_c_string(domain_ptr % streams_filename, c_filename) call mpas_f_to_c_string(mesh_stream, c_mesh_stream) +#ifdef MPAS_USE_MPI_F08 + c_comm = domain_ptr % dminfo % comm % mpi_val +#else c_comm = domain_ptr % dminfo % comm +#endif call xml_stream_get_attributes(c_filename, c_mesh_stream, c_comm, & c_mesh_filename_temp, c_ref_time_temp, & c_filename_interval_temp, c_iotype, c_ierr) @@ -399,6 +425,7 @@ subroutine mpas_finalize(corelist, domain_ptr) use mpas_stream_manager, only : MPAS_stream_mgr_finalize use mpas_log, only : mpas_log_finalize, mpas_log_info + use mpas_derived_types, only : MPAS_streamInfo_type implicit none @@ -406,6 +433,7 @@ subroutine mpas_finalize(corelist, domain_ptr) type (domain_type), intent(inout), pointer :: domain_ptr integer :: iErr + type (MPAS_streamInfo_type), pointer :: streamInfo ! @@ -426,6 +454,13 @@ subroutine mpas_finalize(corelist, domain_ptr) ! call MPAS_stream_mgr_finalize(domain_ptr % streamManager) + streamInfo => domain_ptr % streamInfo + if (streamInfo % finalize() /= 0) then + call mpas_log_write('Finalization of streamInfo object failed for core '//trim(domain_ptr % core % coreName), & + messageType=MPAS_LOG_ERR) + end if + deallocate(domain_ptr % streamInfo) + ! Print out log stats and close log file ! (Do this after timer stats are printed and stream mgr finalized, ! but before framework is finalized because domain is destroyed there.) diff --git a/src/framework/Makefile b/src/framework/Makefile index 564dcfd5ac..2d8e7dc92b 100644 --- a/src/framework/Makefile +++ b/src/framework/Makefile @@ -34,7 +34,10 @@ OBJS = mpas_kind_types.o \ xml_stream_parser.o \ regex_matching.o \ mpas_log.o \ - mpas_halo.o + mpas_halo.o \ + mpas_string_utils.o \ + mpas_stream_inquiry.o \ + stream_inquiry.o all: framework $(DEPS) @@ -78,7 +81,7 @@ mpas_dmpar.o: mpas_sort.o mpas_kind_types.o mpas_derived_types.o mpas_hash.o mpa mpas_sort.o: mpas_kind_types.o mpas_log.o -mpas_timekeeping.o: mpas_kind_types.o mpas_derived_types.o mpas_dmpar.o mpas_threading.o mpas_log.o +mpas_timekeeping.o: mpas_string_utils.o mpas_kind_types.o mpas_derived_types.o mpas_dmpar.o mpas_threading.o mpas_log.o mpas_timer.o: mpas_kind_types.o mpas_dmpar.o mpas_threading.o mpas_log.o @@ -109,6 +112,8 @@ xml_stream_parser.o: xml_stream_parser.c mpas_halo.o: mpas_derived_types.o mpas_pool_routines.o mpas_log.o +mpas_stream_inquiry.o : mpas_derived_types.o mpas_log.o mpas_c_interfacing.o + clean: $(RM) *.o *.mod *.f90 libframework.a @# Certain systems with intel compilers generate *.i files diff --git a/src/framework/framework.cmake b/src/framework/framework.cmake deleted file mode 100644 index f74747fb4f..0000000000 --- a/src/framework/framework.cmake +++ /dev/null @@ -1,35 +0,0 @@ -# framework -list(APPEND COMMON_RAW_SOURCES - framework/mpas_kind_types.F - framework/mpas_framework.F - framework/mpas_timer.F - framework/mpas_timekeeping.F - framework/mpas_constants.F - framework/mpas_attlist.F - framework/mpas_hash.F - framework/mpas_sort.F - framework/mpas_block_decomp.F - framework/mpas_block_creator.F - framework/mpas_dmpar.F - framework/mpas_abort.F - framework/mpas_decomp.F - framework/mpas_threading.F - framework/mpas_io.F - framework/mpas_io_streams.F - framework/mpas_bootstrapping.F - framework/mpas_io_units.F - framework/mpas_stream_manager.F - framework/mpas_stream_list.F - framework/mpas_forcing.F - framework/mpas_c_interfacing.F - framework/random_id.c - framework/pool_hash.c - framework/mpas_derived_types.F - framework/mpas_domain_routines.F - framework/mpas_field_routines.F - framework/mpas_pool_routines.F - framework/xml_stream_parser.c - framework/regex_matching.c - framework/mpas_field_accessor.F - framework/mpas_log.F -) diff --git a/src/framework/mpas_abort.F b/src/framework/mpas_abort.F index 6dddc941e1..f2707944aa 100644 --- a/src/framework/mpas_abort.F +++ b/src/framework/mpas_abort.F @@ -29,11 +29,15 @@ subroutine mpas_dmpar_global_abort(mesg, deferredAbort)!{{{ use mpas_kind_types, only : StrKIND use mpas_io_units, only : mpas_new_unit use mpas_threading, only : mpas_threading_get_thread_num - + #ifdef _MPI #ifndef NOMPIMOD +#ifdef MPAS_USE_MPI_F08 + use mpi_f08 +#else use mpi #endif +#endif #endif implicit none diff --git a/src/framework/mpas_attlist.F b/src/framework/mpas_attlist.F index bbebda1470..2ec70e1bf8 100644 --- a/src/framework/mpas_attlist.F +++ b/src/framework/mpas_attlist.F @@ -30,6 +30,14 @@ module mpas_attlist module procedure mpas_add_att_text end interface mpas_add_att + interface mpas_modify_att + module procedure mpas_modify_att_int0d + module procedure mpas_modify_att_int1d + module procedure mpas_modify_att_real0d + module procedure mpas_modify_att_real1d + module procedure mpas_modify_att_text + end interface mpas_modify_att + interface mpas_get_att module procedure mpas_get_att_int0d module procedure mpas_get_att_int1d @@ -253,6 +261,216 @@ subroutine mpas_add_att_text(attList, attName, attValue, ierr)!{{{ end subroutine mpas_add_att_text!}}} +!*********************************************************************** +! +! routine mpas_modify_att_text +! +! > \brief MPAS modify text attribute routine +! > \author Matthew Dimond +! > \date 06/27/23 +! > \details +! > This routine modifies a text attribute in the attribute list, +! > and returns a 1 in ierr if the attribute is not found, or the attribute +! > has a type incompatible with attValue. +! +!---------------------------------------------------------------------- + subroutine mpas_modify_att_text(attList, attName, attValue, ierr)!{{{ + + implicit none + + type (att_list_type), pointer :: attList !< Input/Output: Attribute List + character (len=*), intent(in) :: attName !< Input: Att. name to modify + character (len=*), intent(in) :: attValue !< Input: Updated Att. value + integer, intent(out), optional :: ierr !< Output: Error flag + + type (att_list_type), pointer :: cursor + + if (present(ierr)) ierr = 1 + + ! Traverse list looking for attName + cursor => attlist + do while (associated(cursor)) + if (trim(cursor % attName) == trim(attName)) then + if (cursor % attType == MPAS_ATT_TEXT) then + if (present(ierr)) ierr = 0 + write(cursor % attValueText,'(a)') trim(attValue) + end if + return + end if + cursor => cursor % next + end do + + end subroutine mpas_modify_att_text!}}} + + +!*********************************************************************** +! +! routine mpas_modify_att_int0d +! +! > \brief MPAS modify 0D integer attribute routine +! > \author Matthew Dimond +! > \date 06/27/23 +! > \details +! > This routine modifies a 0d integer attribute in the attribute list, +! > and returns a 1 in ierr if the attribute is not found, or the attribute +! > has a type incompatible with attValue. +! +!---------------------------------------------------------------------- + subroutine mpas_modify_att_int0d(attList, attName, attValue, ierr)!{{{ + + implicit none + + type (att_list_type), pointer :: attList !< Input/Output: Attribute List + character (len=*), intent(in) :: attName !< Input: Att. name to modify + integer, intent(in) :: attValue !< Input: Updated Att. value + integer, intent(out), optional :: ierr !< Output: Error flag + + type (att_list_type), pointer :: cursor + + if (present(ierr)) ierr = 1 + + ! Traverse list looking for attName + cursor => attlist + do while (associated(cursor)) + if (trim(cursor % attName) == trim(attName)) then + if (cursor % attType == MPAS_ATT_INT) then + if (present(ierr)) ierr = 0 + cursor % attValueInt = attValue + end if + return + end if + cursor => cursor % next + end do + + end subroutine mpas_modify_att_int0d!}}} + +!*********************************************************************** +! +! routine mpas_modify_att_int1d +! +! > \brief MPAS modify 1D integer attribute routine +! > \author Matthew Dimond +! > \date 06/27/23 +! > \details +! > This routine modifies a 1d integer attribute in the attribute list, +! > and returns a 1 in ierr if the attribute is not found, or the attribute +! > has a type incompatible with attValue. +! +!---------------------------------------------------------------------- + subroutine mpas_modify_att_int1d(attList, attName, attValue, ierr)!{{{ + + implicit none + + type (att_list_type), pointer :: attList !< Input/Output: Attribute List + character (len=*), intent(in) :: attName !< Input: Att. name to modify + integer, dimension(:), intent(in) :: attValue !< Input: Updated Att. value + integer, intent(out), optional :: ierr !< Output: Error flag + + type (att_list_type), pointer :: cursor + + if (present(ierr)) ierr = 1 + + ! Traverse list looking for attName + cursor => attlist + do while (associated(cursor)) + if (trim(cursor % attName) == trim(attName)) then + if (cursor % attType == MPAS_ATT_INTA) then + if (size(cursor % attValueIntA) == size(attValue)) then + if (present(ierr)) ierr = 0 + cursor % attValueIntA(:) = attValue(:) + end if + end if + return + end if + cursor => cursor % next + end do + + end subroutine mpas_modify_att_int1d!}}} + +!*********************************************************************** +! +! routine mpas_modify_att_real0d +! +! > \brief MPAS modify 0D real attribute routine +! > \author Matthew Dimond +! > \date 06/27/23 +! > \details +! > This routine modifies a 0d real attribute in the attribute list, +! > and returns a 1 in ierr if the attribute is not found, or the attribute +! > has a type incompatible with attValue. +! +!---------------------------------------------------------------------- + subroutine mpas_modify_att_real0d(attList, attName, attValue, ierr)!{{{ + + implicit none + + type (att_list_type), pointer :: attList !< Input/Output: Attribute List + character (len=*), intent(in) :: attName !< Input: Att. name to modify + real (kind=RKIND), intent(in) :: attValue !< Input: Updated Att. value + integer, intent(out), optional :: ierr !< Output: Error flag + + type (att_list_type), pointer :: cursor + + if (present(ierr)) ierr = 1 + + ! Traverse list looking for attName + cursor => attlist + do while (associated(cursor)) + if (trim(cursor % attName) == trim(attName)) then + if (cursor % attType == MPAS_ATT_REAL) then + if (present(ierr)) ierr = 0 + cursor % attValueReal = attValue + end if + return + end if + cursor => cursor % next + end do + + end subroutine mpas_modify_att_real0d!}}} + +!*********************************************************************** +! +! routine mpas_modify_att_real1d +! +! > \brief MPAS modify 1D real attribute routine +! > \author Matthew Dimond +! > \date 06/27/23 +! > \details +! > This routine modifies a 1d real attribute in the attribute list, +! > and returns a 1 in ierr if the attribute is not found, or the attribute +! > has a type incompatible with attValue. +! +!---------------------------------------------------------------------- + subroutine mpas_modify_att_real1d(attList, attName, attValue, ierr)!{{{ + + implicit none + + type (att_list_type), pointer :: attList !< Input/Output: Attribute List + character (len=*), intent(in) :: attName !< Input: Att. name to modify + real (kind=RKIND), dimension(:), intent(in) :: attValue !< Input: Updated Att. value + integer, intent(out), optional :: ierr !< Output: Error flag + + type (att_list_type), pointer :: cursor + + if (present(ierr)) ierr = 1 + + ! Traverse list looking for attName + cursor => attlist + do while (associated(cursor)) + if (trim(cursor % attName) == trim(attName)) then + if (cursor % attType == MPAS_ATT_REALA) then + if (size(cursor % attValueRealA) == size(attValue)) then + if (present(ierr)) ierr = 0 + cursor % attValueRealA(:) = attValue(:) + end if + end if + return + end if + cursor => cursor % next + end do + + end subroutine mpas_modify_att_real1d!}}} + !*********************************************************************** ! ! routine mpas_get_att_int0d diff --git a/src/framework/mpas_core_types.inc b/src/framework/mpas_core_types.inc index 282c804ab1..15a9866ccd 100644 --- a/src/framework/mpas_core_types.inc +++ b/src/framework/mpas_core_types.inc @@ -21,11 +21,13 @@ end interface abstract interface - function mpas_setup_packages_function(configs, packages, iocontext) result(iErr) + function mpas_setup_packages_function(configs, streamInfo, packages, iocontext) result(iErr) import mpas_pool_type import mpas_io_context_type + import mpas_streaminfo_type type (mpas_pool_type), intent(inout) :: configs + type (mpas_streaminfo_type), intent(inout) :: streamInfo type (mpas_pool_type), intent(inout) :: packages type (mpas_io_context_type), intent(inout) :: iocontext integer :: iErr @@ -42,11 +44,13 @@ end interface abstract interface - function mpas_get_mesh_stream_function(configs, stream) result(iErr) + function mpas_get_mesh_stream_function(configs, streamInfo, stream) result(iErr) use mpas_kind_types import mpas_pool_type + import mpas_streaminfo_type type (mpas_pool_type), intent(inout) :: configs + type (mpas_streaminfo_type), intent(inout) :: streamInfo character (len=StrKIND), intent(out) :: stream integer :: iErr end function mpas_get_mesh_stream_function diff --git a/src/framework/mpas_derived_types.F b/src/framework/mpas_derived_types.F index e9972e771a..9995fd147e 100644 --- a/src/framework/mpas_derived_types.F +++ b/src/framework/mpas_derived_types.F @@ -25,6 +25,8 @@ !----------------------------------------------------------------------- module mpas_derived_types + use iso_c_binding, only : c_ptr, c_null_ptr + use mpas_kind_types #ifdef MPAS_PIO_SUPPORT @@ -36,6 +38,10 @@ module mpas_derived_types use smiolf, only : SMIOLf_context, SMIOLf_decomp, SMIOLf_file, SMIOL_offset_kind #endif +#ifdef MPAS_USE_MPI_F08 + use mpi_f08, only : MPI_Request, MPI_Comm, MPI_Info +#endif + use ESMF #include "mpas_attlist_types.inc" @@ -70,6 +76,8 @@ module mpas_derived_types #include "mpas_decomp_types.inc" +#include "mpas_stream_inquiry_types.inc" + #include "mpas_domain_types.inc" #include "mpas_core_types.inc" diff --git a/src/framework/mpas_dmpar.F b/src/framework/mpas_dmpar.F index 8e5340e420..033c818f47 100644 --- a/src/framework/mpas_dmpar.F +++ b/src/framework/mpas_dmpar.F @@ -31,8 +31,12 @@ module mpas_dmpar #ifdef _MPI #ifndef NOMPIMOD +#ifdef MPAS_USE_MPI_F08 + use mpi_f08 +#else use mpi #endif +#endif #endif implicit none @@ -42,16 +46,31 @@ module mpas_dmpar #ifdef NOMPIMOD include 'mpif.h' #endif +#ifdef MPAS_USE_MPI_F08 + type (MPI_Datatype), parameter :: MPI_INTEGERKIND = MPI_INTEGER + type (MPI_Datatype), parameter :: MPI_2INTEGERKIND = MPI_2INTEGER +#else integer, parameter :: MPI_INTEGERKIND = MPI_INTEGER integer, parameter :: MPI_2INTEGERKIND = MPI_2INTEGER +#endif #ifdef SINGLE_PRECISION +#ifdef MPAS_USE_MPI_F08 + type (MPI_Datatype), parameter :: MPI_REALKIND = MPI_REAL + type (MPI_Datatype), parameter :: MPI_2REALKIND = MPI_2REAL +#else integer, parameter :: MPI_REALKIND = MPI_REAL integer, parameter :: MPI_2REALKIND = MPI_2REAL +#endif +#else +#ifdef MPAS_USE_MPI_F08 + type (MPI_Datatype), parameter :: MPI_REALKIND = MPI_DOUBLE_PRECISION + type (MPI_Datatype), parameter :: MPI_2REALKIND = MPI_2DOUBLE_PRECISION #else integer, parameter :: MPI_REALKIND = MPI_DOUBLE_PRECISION integer, parameter :: MPI_2REALKIND = MPI_2DOUBLE_PRECISION #endif +#endif #endif integer, parameter, public :: IO_NODE = 0 @@ -76,6 +95,7 @@ module mpas_dmpar public :: mpas_dmpar_bcast_char public :: mpas_dmpar_bcast_chars public :: mpas_dmpar_sum_int + public :: mpas_dmpar_sum_int8 public :: mpas_dmpar_sum_real public :: mpas_dmpar_min_int public :: mpas_dmpar_min_real @@ -231,12 +251,16 @@ module mpas_dmpar !> It also setups of the domain information structure. ! !----------------------------------------------------------------------- - subroutine mpas_dmpar_init(dminfo, mpi_comm)!{{{ + subroutine mpas_dmpar_init(dminfo, external_comm)!{{{ implicit none type (dm_info), intent(inout) :: dminfo !< Input/Output: Domain information - integer, intent(in), optional :: mpi_comm !< Input - Optional: externally-supplied MPI communicator +#ifdef MPAS_USE_MPI_F08 + type (MPI_Comm), intent(in), optional :: external_comm !< Input - Optional: externally-supplied MPI communicator +#else + integer, intent(in), optional :: external_comm !< Input - Optional: externally-supplied MPI communicator +#endif #ifdef _MPI integer :: mpi_rank, mpi_size @@ -245,13 +269,13 @@ subroutine mpas_dmpar_init(dminfo, mpi_comm)!{{{ integer :: desiredThreadLevel, threadLevel #endif - if ( present(mpi_comm) ) then + if ( present(external_comm) ) then dminfo % initialized_mpi = .false. #ifdef MPAS_OPENMP desiredThreadLevel = MPI_THREAD_FUNNELED call MPI_Query_thread(threadLevel, mpi_ierr) #endif - call MPI_Comm_dup(mpi_comm, dminfo % comm, mpi_ierr) + call MPI_Comm_dup(external_comm, dminfo % comm, mpi_ierr) else dminfo % initialized_mpi = .true. #ifdef MPAS_OPENMP @@ -750,6 +774,39 @@ subroutine mpas_dmpar_sum_int(dminfo, i, isum)!{{{ end subroutine mpas_dmpar_sum_int!}}} +!----------------------------------------------------------------------- +! routine mpas_dmpar_sum_int8 +! +!> \brief MPAS dmpar sum 8 byte integer routine. +!> \author Matthew Dimond +!> \date 11/07/2023 +!> \details +!> This routine sums (Allreduce) int(8) values across all processors in a communicator. +! +!----------------------------------------------------------------------- + subroutine mpas_dmpar_sum_int8(dminfo, i, isum)!{{{ + + implicit none + + type (dm_info), intent(in) :: dminfo !< Input: Domain information + integer(kind=I8KIND), intent(in) :: i !< Input: Integer value input + integer(kind=I8KIND), intent(out) :: isum !< Output: Integer sum for output + + integer :: mpi_ierr + integer :: threadNum + + threadNum = mpas_threading_get_thread_num() + + if ( threadNum == 0 ) then +#ifdef _MPI + call MPI_Allreduce(i, isum, 1, MPI_INTEGER8, MPI_SUM, dminfo % comm, mpi_ierr) +#else + isum = i +#endif + end if + + end subroutine mpas_dmpar_sum_int8!}}} + !----------------------------------------------------------------------- ! routine mpas_dmpar_sum_real ! @@ -1506,7 +1563,12 @@ subroutine mpas_dmpar_get_exch_list(haloLayer, ownedListField, neededListField, type (field0dInteger), pointer :: offsetCursor, ownedLimitCursor integer :: nOwnedBlocks, nNeededBlocks integer :: nOwnedList, nNeededList - integer :: mpi_ierr, mpi_rreq, mpi_sreq + integer :: mpi_ierr +#ifdef MPAS_USE_MPI_F08 + type (MPI_Request) :: mpi_rreq, mpi_sreq +#else + integer :: mpi_rreq, mpi_sreq +#endif type (hashtable) :: neededHash integer :: nUniqueNeededList, threadNum @@ -10039,7 +10101,11 @@ subroutine mpas_dmpar_exch_group_print_buffers(exchangeGroup)!{{{ call mpas_log_write(' proc: $i', intArgs=(/commListPtr % procID/)) call mpas_log_write(' size check: $i $i', intArgs=(/commListPtr % nlist, size( commListPtr % rbuffer )/)) call mpas_log_write(' bufferOffset: $i', intArgs=(/commListPtr % bufferOffset/)) +#ifdef MPAS_USE_MPI_F08 + call mpas_log_write(' reqId: $i', intArgs=(/commListPtr % reqId % mpi_val/)) +#else call mpas_log_write(' reqId: $i', intArgs=(/commListPtr % reqId/)) +#endif call mpas_log_write(' ibuffer assc: $l', logicArgs=(/ associated( commListPtr % ibuffer ) /) ) call mpas_log_write(' rbuffer assc: $l', logicArgs=(/ associated( commListPtr % rbuffer ) /) ) call mpas_log_write(' next assc: $l', logicArgs=(/ associated( commListPtr % next ) /) ) @@ -10058,7 +10124,11 @@ subroutine mpas_dmpar_exch_group_print_buffers(exchangeGroup)!{{{ call mpas_log_write(' proc: $i', intArgs=(/ commListPtr % procID /) ) call mpas_log_write(' size check: $i $i', intArgs=(/ commListPtr % nlist, size( commListPtr % rbuffer ) /) ) call mpas_log_write(' bufferOffset: $i', intArgs=(/ commListPtr % bufferOffset /) ) +#ifdef MPAS_USE_MPI_F08 + call mpas_log_write(' reqId: $i', intArgs=(/ commListPtr % reqId % mpi_val /) ) +#else call mpas_log_write(' reqId: $i', intArgs=(/ commListPtr % reqId /) ) +#endif call mpas_log_write(' ibuffer assc: $l', logicArgs=(/ associated( commListPtr % ibuffer ) /) ) call mpas_log_write(' rbuffer assc: $l', logicArgs=(/ associated( commListPtr % rbuffer ) /) ) call mpas_log_write(' next assc: $l', logicArgs=(/ associated( commListPtr % next ) /) ) diff --git a/src/framework/mpas_dmpar_types.inc b/src/framework/mpas_dmpar_types.inc index 7138a64b55..8540475aa6 100644 --- a/src/framework/mpas_dmpar_types.inc +++ b/src/framework/mpas_dmpar_types.inc @@ -7,7 +7,14 @@ integer, parameter :: MPAS_DMPAR_BUFFER_EXISTS = 6 type dm_info - integer :: nprocs, my_proc_id, comm, info +#ifdef MPAS_USE_MPI_F08 + type (MPI_Comm) :: comm + type (MPI_Info) :: info +#else + integer :: comm + integer :: info +#endif + integer :: nprocs, my_proc_id logical :: initialized_mpi ! Add variables specific to block decomposition. {{{ @@ -47,7 +54,11 @@ integer :: bufferOffset real (kind=RKIND), dimension(:), pointer :: rbuffer => null() integer, dimension(:), pointer :: ibuffer => null() +#ifdef MPAS_USE_MPI_F08 + type (MPI_Request) :: reqID +#else integer :: reqID +#endif type (mpas_communication_list), pointer :: next => null() integer :: commListSize logical :: received diff --git a/src/framework/mpas_domain_types.inc b/src/framework/mpas_domain_types.inc index 20eae3a11a..7a9d400e73 100644 --- a/src/framework/mpas_domain_types.inc +++ b/src/framework/mpas_domain_types.inc @@ -9,6 +9,8 @@ type (mpas_decomp_list), pointer :: decompositions => null() type (mpas_io_context_type), pointer :: ioContext => null() + type (MPAS_streamInfo_type), pointer :: streamInfo => null() + ! Also store parallelization info here type (dm_info), pointer :: dminfo diff --git a/src/framework/mpas_framework.F b/src/framework/mpas_framework.F index d31576c712..68445d186c 100644 --- a/src/framework/mpas_framework.F +++ b/src/framework/mpas_framework.F @@ -42,15 +42,23 @@ module mpas_framework !> MPI, the log unit numbers. ! !----------------------------------------------------------------------- - subroutine mpas_framework_init_phase1(dminfo, mpi_comm)!{{{ + subroutine mpas_framework_init_phase1(dminfo, external_comm)!{{{ + +#ifdef MPAS_USE_MPI_F08 + use mpi_f08, only : MPI_Comm +#endif implicit none type (dm_info), pointer :: dminfo - integer, intent(in), optional :: mpi_comm +#ifdef MPAS_USE_MPI_F08 + type (MPI_Comm), intent(in), optional :: external_comm +#else + integer, intent(in), optional :: external_comm +#endif allocate(dminfo) - call mpas_dmpar_init(dminfo, mpi_comm) + call mpas_dmpar_init(dminfo, external_comm) end subroutine mpas_framework_init_phase1!}}} diff --git a/src/framework/mpas_halo.F b/src/framework/mpas_halo.F index 401ab2c40f..57f89db875 100644 --- a/src/framework/mpas_halo.F +++ b/src/framework/mpas_halo.F @@ -485,16 +485,28 @@ end subroutine mpas_halo_exch_group_add_field !----------------------------------------------------------------------- subroutine mpas_halo_exch_group_full_halo_exch(domain, groupName, iErr) +#ifdef MPAS_USE_MPI_F08 + use mpi_f08 +#else use mpi +#endif use mpas_derived_types, only : domain_type, mpas_halo_group, MPAS_HALO_REAL, MPAS_LOG_CRIT use mpas_pool_routines, only : mpas_pool_get_array use mpas_log, only : mpas_log_write ! Parameters +#ifdef MPAS_USE_MPI_F08 +#ifdef SINGLE_PRECISION + type (MPI_Datatype), parameter :: MPI_REALKIND = MPI_REAL +#else + type (MPI_Datatype), parameter :: MPI_REALKIND = MPI_DOUBLE_PRECISION +#endif +#else #ifdef SINGLE_PRECISION integer, parameter :: MPI_REALKIND = MPI_REAL #else integer, parameter :: MPI_REALKIND = MPI_DOUBLE_PRECISION +#endif #endif ! Arguments @@ -508,7 +520,12 @@ subroutine mpas_halo_exch_group_full_halo_exch(domain, groupName, iErr) integer :: i1, i2, j, iNeighbor, iReq integer :: iHalo, iEndp integer :: nHalos, nSendEndpts, nRecvEndpts - integer :: rank, comm + integer :: rank +#ifdef MPAS_USE_MPI_F08 + type (MPI_Comm) :: comm +#else + integer :: comm +#endif integer :: mpi_ierr type (mpas_halo_group), pointer :: group integer, dimension(:), pointer :: compactHaloInfo @@ -550,7 +567,11 @@ subroutine mpas_halo_exch_group_full_halo_exch(domain, groupName, iErr) ! the group; all fields should be using the same communicator, so this should not ! be problematic ! +#ifdef MPAS_USE_MPI_F08 + comm % mpi_val = group % fields(1) % compactHaloInfo(7) +#else comm = group % fields(1) % compactHaloInfo(7) +#endif rank = group % fields(1) % compactHaloInfo(8) @@ -992,7 +1013,11 @@ subroutine mpas_halo_compact_halo_info(domain, sendList, recvList, dimSizes, hal ! 7-8: Add MPI info ! idx = 7 +#ifdef MPAS_USE_MPI_F08 + compactHaloInfo(idx) = domain % dminfo % comm % mpi_val +#else compactHaloInfo(idx) = domain % dminfo % comm +#endif idx = idx + 1 compactHaloInfo(idx) = domain % dminfo % my_proc_id idx = idx + 1 diff --git a/src/framework/mpas_halo_types.inc b/src/framework/mpas_halo_types.inc index 46841c6883..5efafd0399 100644 --- a/src/framework/mpas_halo_types.inc +++ b/src/framework/mpas_halo_types.inc @@ -47,7 +47,11 @@ integer :: nGroupSendNeighbors = MPAS_HALO_INVALID ! Number of unique neighbors that we send to integer :: groupSendBufSize = MPAS_HALO_INVALID ! Total number of elements to be sent in a group exchange real (kind=RKIND), dimension(:), pointer :: sendBuf => null() ! Segmented buffer used for outgoing messages - integer, dimension(:), pointer :: sendRequests => null() ! Used internally - MPI request IDs +#ifdef MPAS_USE_MPI_F08 + type (MPI_Request), dimension(:), pointer :: sendRequests => null() ! Used internally - MPI request IDs +#else + integer, dimension(:), pointer :: sendRequests => null() ! Used internally - MPI request IDs +#endif integer, dimension(:,:), pointer :: groupPackOffsets => null() ! Offsets into sendBuf for each neighbor and each field ! dimensioned (nGroupSendNeighbors, nFields) integer, dimension(:), pointer :: groupSendNeighbors => null() ! List of neighbors we send to @@ -60,7 +64,11 @@ integer :: nGroupRecvNeighbors = MPAS_HALO_INVALID ! Number of unique neighbors that we recv from integer :: groupRecvBufSize = MPAS_HALO_INVALID ! Total number of elements to be recvd in a group exchange real (kind=RKIND), dimension(:), pointer :: recvBuf => null() ! Segmented buffer used for incoming messages - integer, dimension(:), pointer :: recvRequests => null() ! Used internally - MPI request IDs +#ifdef MPAS_USE_MPI_F08 + type (MPI_Request), dimension(:), pointer :: recvRequests => null() ! Used internally - MPI request IDs +#else + integer, dimension(:), pointer :: recvRequests => null() ! Used internally - MPI request IDs +#endif integer, dimension(:,:), pointer :: groupUnpackOffsets => null() ! Offsets into recvBuf for each neighbor and each field ! dimensioned (nGroupRecvNeighbors, nFields) integer, dimension(:), pointer :: groupRecvNeighbors => null() ! List of neighbors we recv from diff --git a/src/framework/mpas_io.F b/src/framework/mpas_io.F index f699eae7fc..a9ddee472c 100644 --- a/src/framework/mpas_io.F +++ b/src/framework/mpas_io.F @@ -80,6 +80,13 @@ module mpas_io #endif +#endif + +#ifdef MPAS_PIO_SUPPORT + integer, private :: io_global_err = PIO_noerr +#endif +#ifdef MPAS_SMIOL_SUPPORT + integer, private :: io_global_err = SMIOL_SUCCESS #endif interface MPAS_io_get_var @@ -186,7 +193,11 @@ subroutine MPAS_io_init(ioContext, io_task_count, io_task_stride, io_system, ier #ifdef MPAS_PIO_SUPPORT allocate(ioContext % pio_iosystem) call PIO_init(ioContext % dminfo % my_proc_id, & ! comp_rank +#ifdef MPAS_USE_MPI_F08 + ioContext % dminfo % comm % mpi_val, & ! comp_comm +#else ioContext % dminfo % comm, & ! comp_comm +#endif io_task_count, & ! num_iotasks 0, & ! num_aggregator io_task_stride, & ! stride @@ -196,7 +207,11 @@ subroutine MPAS_io_init(ioContext, io_task_count, io_task_stride, io_system, ier #ifdef MPAS_SMIOL_SUPPORT allocate(ioContext % smiol_context) +#ifdef MPAS_USE_MPI_F08 + local_ierr = SMIOLf_init(ioContext % dminfo % comm % mpi_val, & +#else local_ierr = SMIOLf_init(ioContext % dminfo % comm, & +#endif io_task_count, & io_task_stride, & iocontext % smiol_context) @@ -425,7 +440,8 @@ type (MPAS_IO_Handle_type) function MPAS_io_open(filename, mode, ioformat, ioCon endif #ifdef MPAS_PIO_SUPPORT if (pio_ierr /= PIO_noerr) then - if (present(ierr)) ierr = MPAS_IO_ERR_PIO + io_global_err = pio_ierr + if (present(ierr)) ierr = MPAS_IO_ERR_BACKEND return end if #endif @@ -437,6 +453,10 @@ type (MPAS_IO_Handle_type) function MPAS_io_open(filename, mode, ioformat, ioCon else call mpas_log_write(trim(SMIOLf_error_string(local_ierr)), messageType=MPAS_LOG_ERR) end if + + io_global_err = local_ierr + if (present(ierr)) ierr = MPAS_IO_ERR_BACKEND + return end if #endif MPAS_io_open % external_file_desc = .false. @@ -448,7 +468,8 @@ type (MPAS_IO_Handle_type) function MPAS_io_open(filename, mode, ioformat, ioCon pio_ierr = PIO_inquire(MPAS_io_open % pio_file, unlimitedDimID=MPAS_io_open % pio_unlimited_dimid) !call mpas_log_write('Found unlimited dim $i', intArgs=(/MPAS_io_open % pio_unlimited_dimid/) ) if (pio_ierr /= PIO_noerr) then - if (present(ierr)) ierr = MPAS_IO_ERR_PIO + io_global_err = pio_ierr + if (present(ierr)) ierr = MPAS_IO_ERR_BACKEND return end if #endif @@ -461,7 +482,8 @@ type (MPAS_IO_Handle_type) function MPAS_io_open(filename, mode, ioformat, ioCon if ( MPAS_io_open % pio_unlimited_dimid >= 0 ) then pio_ierr = PIO_inq_dimlen(MPAS_io_open % pio_file, MPAS_io_open % pio_unlimited_dimid, MPAS_io_open % preexisting_records) if (pio_ierr /= PIO_noerr) then - if (present(ierr)) ierr = MPAS_IO_ERR_PIO + io_global_err = pio_ierr + if (present(ierr)) ierr = MPAS_IO_ERR_BACKEND return end if else @@ -585,7 +607,8 @@ subroutine MPAS_io_inq_dim(handle, dimname, dimsize, ierr) pio_ierr = PIO_inq_dimlen(handle % pio_file, new_dimlist_node % dimhandle % dimid, new_dimlist_node % dimhandle % dimsize) if (pio_ierr /= PIO_noerr) then - if (present(ierr)) ierr = MPAS_IO_ERR_PIO + io_global_err = pio_ierr + if (present(ierr)) ierr = MPAS_IO_ERR_BACKEND deallocate(new_dimlist_node % dimhandle) deallocate(new_dimlist_node) dimsize = -1 @@ -692,7 +715,7 @@ subroutine MPAS_io_def_dim(handle, dimname, dimsize, ierr) ! if (handle % preexisting_file) then call MPAS_io_inq_dim(handle, dimname, inq_dimsize, ierr=pio_ierr) - if (pio_ierr /= MPAS_IO_ERR_PIO) then + if (pio_ierr /= MPAS_IO_ERR_BACKEND) then ! Verify that the dimsize matches... if (dimsize /= inq_dimsize .and. dimsize /= MPAS_IO_UNLIMITED_DIM) then @@ -739,11 +762,16 @@ subroutine MPAS_io_def_dim(handle, dimname, dimsize, ierr) else call mpas_log_write(trim(SMIOLf_error_string(local_ierr)), messageType=MPAS_LOG_ERR) end if + + io_global_err = local_ierr + if (present(ierr)) ierr = MPAS_IO_ERR_BACKEND + return end if #endif #ifdef MPAS_PIO_SUPPORT if (pio_ierr /= PIO_noerr) then - if (present(ierr)) ierr = MPAS_IO_ERR_PIO + io_global_err = pio_ierr + if (present(ierr)) ierr = MPAS_IO_ERR_BACKEND deallocate(new_dimlist_node % dimhandle) deallocate(new_dimlist_node) return @@ -836,7 +864,8 @@ subroutine MPAS_io_inq_var(handle, fieldname, fieldtype, ndims, dimnames, dimsiz pio_ierr = PIO_inq_varid(handle % pio_file, trim(fieldname), new_fieldlist_node % fieldhandle % fieldid) pio_ierr = PIO_inq_varid(handle % pio_file, trim(fieldname), new_fieldlist_node % fieldhandle % field_desc) if (pio_ierr /= PIO_noerr) then - if (present(ierr)) ierr = MPAS_IO_ERR_PIO + io_global_err = pio_ierr + if (present(ierr)) ierr = MPAS_IO_ERR_BACKEND deallocate(new_fieldlist_node % fieldhandle) deallocate(new_fieldlist_node) call mpas_log_write('Variable ' // trim(fieldname) // ' not in input file.', MPAS_LOG_WARN) @@ -847,7 +876,8 @@ subroutine MPAS_io_inq_var(handle, fieldname, fieldtype, ndims, dimnames, dimsiz ! Get field type pio_ierr = PIO_inq_vartype(handle % pio_file, new_fieldlist_node % fieldhandle % fieldid, new_fieldlist_node % fieldhandle % field_type) if (pio_ierr /= PIO_noerr) then - if (present(ierr)) ierr = MPAS_IO_ERR_PIO + io_global_err = pio_ierr + if (present(ierr)) ierr = MPAS_IO_ERR_BACKEND deallocate(new_fieldlist_node % fieldhandle) deallocate(new_fieldlist_node) return @@ -873,7 +903,8 @@ subroutine MPAS_io_inq_var(handle, fieldname, fieldtype, ndims, dimnames, dimsiz #ifdef MPAS_SMIOL_SUPPORT local_ierr = SMIOLf_inquire_var(handle % smiol_file, trim(fieldname), vartype=smiol_type) if (local_ierr /= SMIOL_SUCCESS) then - if (present(ierr)) ierr = MPAS_IO_ERR_PIO + io_global_err = local_ierr + if (present(ierr)) ierr = MPAS_IO_ERR_BACKEND deallocate(new_fieldlist_node % fieldhandle) deallocate(new_fieldlist_node) call mpas_log_write('Variable ' // trim(fieldname) // ' not in input file.', MPAS_LOG_WARN) @@ -900,7 +931,8 @@ subroutine MPAS_io_inq_var(handle, fieldname, fieldtype, ndims, dimnames, dimsiz #ifdef MPAS_PIO_SUPPORT pio_ierr = PIO_inq_varndims(handle % pio_file, new_fieldlist_node % fieldhandle % fieldid, new_fieldlist_node % fieldhandle % ndims) if (pio_ierr /= PIO_noerr) then - if (present(ierr)) ierr = MPAS_IO_ERR_PIO + io_global_err = pio_ierr + if (present(ierr)) ierr = MPAS_IO_ERR_BACKEND deallocate(new_fieldlist_node % fieldhandle) deallocate(new_fieldlist_node) return @@ -918,7 +950,8 @@ subroutine MPAS_io_inq_var(handle, fieldname, fieldtype, ndims, dimnames, dimsiz call mpas_log_write(trim(SMIOLf_error_string(local_ierr)), messageType=MPAS_LOG_ERR) end if - if (present(ierr)) ierr = MPAS_IO_ERR_PIO + io_global_err = local_ierr + if (present(ierr)) ierr = MPAS_IO_ERR_BACKEND deallocate(new_fieldlist_node % fieldhandle) deallocate(new_fieldlist_node) @@ -935,7 +968,8 @@ subroutine MPAS_io_inq_var(handle, fieldname, fieldtype, ndims, dimnames, dimsiz if (new_fieldlist_node % fieldhandle % ndims > 0) then pio_ierr = PIO_inq_vardimid(handle % pio_file, new_fieldlist_node % fieldhandle % fieldid, dimids) if (pio_ierr /= PIO_noerr) then - if (present(ierr)) ierr = MPAS_IO_ERR_PIO + io_global_err = pio_ierr + if (present(ierr)) ierr = MPAS_IO_ERR_BACKEND deallocate(new_fieldlist_node % fieldhandle) deallocate(new_fieldlist_node) deallocate(dimids) @@ -958,7 +992,8 @@ subroutine MPAS_io_inq_var(handle, fieldname, fieldtype, ndims, dimnames, dimsiz pio_ierr = PIO_inq_dimlen(handle % pio_file, dimids(i), new_fieldlist_node % fieldhandle % dims(i) % dimsize) if (pio_ierr /= PIO_noerr) then - if (present(ierr)) ierr = MPAS_IO_ERR_PIO + io_global_err = pio_ierr + if (present(ierr)) ierr = MPAS_IO_ERR_BACKEND deallocate(new_fieldlist_node % fieldhandle) deallocate(new_fieldlist_node) deallocate(dimids) @@ -968,7 +1003,8 @@ subroutine MPAS_io_inq_var(handle, fieldname, fieldtype, ndims, dimnames, dimsiz pio_ierr = PIO_inq_dimname(handle % pio_file, dimids(i), new_fieldlist_node % fieldhandle % dims(i) % dimname) if (pio_ierr /= PIO_noerr) then - if (present(ierr)) ierr = MPAS_IO_ERR_PIO + io_global_err = pio_ierr + if (present(ierr)) ierr = MPAS_IO_ERR_BACKEND deallocate(new_fieldlist_node % fieldhandle) deallocate(new_fieldlist_node) deallocate(dimids) @@ -990,6 +1026,10 @@ subroutine MPAS_io_inq_var(handle, fieldname, fieldtype, ndims, dimnames, dimsiz else call mpas_log_write(trim(SMIOLf_error_string(local_ierr)), messageType=MPAS_LOG_ERR) end if + + io_global_err = local_ierr + if (present(ierr)) ierr = MPAS_IO_ERR_BACKEND + return end if do i=1,new_fieldlist_node % fieldhandle % ndims new_fieldlist_node % fieldhandle % dims(i) % dimname = smiol_dimnames(i) @@ -1005,6 +1045,10 @@ subroutine MPAS_io_inq_var(handle, fieldname, fieldtype, ndims, dimnames, dimsiz else call mpas_log_write(trim(SMIOLf_error_string(local_ierr)), messageType=MPAS_LOG_ERR) end if + + io_global_err = local_ierr + if (present(ierr)) ierr = MPAS_IO_ERR_BACKEND + return end if new_fieldlist_node % fieldhandle % dims(i) % dimsize = smiol_dimlen if (new_fieldlist_node % fieldhandle % dims(i) % is_unlimited_dim) then @@ -1173,7 +1217,7 @@ subroutine MPAS_io_def_var(handle, fieldname, fieldtype, dimnames, precision, ie ! if (handle % preexisting_file) then call MPAS_io_inq_var(handle, fieldname, inq_fieldtype, inq_ndims, inq_dimnames, ierr=pio_ierr) - if (pio_ierr /= MPAS_IO_ERR_PIO) then + if (pio_ierr /= MPAS_IO_ERR_BACKEND) then ! Verify that the type and dimensions match... if (fieldtype == MPAS_IO_DOUBLE) then @@ -1310,7 +1354,8 @@ subroutine MPAS_io_def_var(handle, fieldname, fieldtype, dimnames, precision, ie pio_ierr = PIO_def_var(handle % pio_file, trim(fieldname), pio_type, dimids, new_fieldlist_node % fieldhandle % field_desc) end if if (pio_ierr /= PIO_noerr) then - if (present(ierr)) ierr = MPAS_IO_ERR_PIO + io_global_err = pio_ierr + if (present(ierr)) ierr = MPAS_IO_ERR_BACKEND return end if #endif @@ -1323,6 +1368,10 @@ subroutine MPAS_io_def_var(handle, fieldname, fieldtype, dimnames, precision, ie else call mpas_log_write(trim(SMIOLf_error_string(local_ierr)), messageType=MPAS_LOG_ERR) end if + + io_global_err = local_ierr + if (present(ierr)) ierr = MPAS_IO_ERR_BACKEND + return end if #endif @@ -1330,7 +1379,8 @@ subroutine MPAS_io_def_var(handle, fieldname, fieldtype, dimnames, precision, ie #ifdef MPAS_PIO_SUPPORT pio_ierr = PIO_inq_varid(handle % pio_file, trim(fieldname), new_fieldlist_node % fieldhandle % fieldid) if (pio_ierr /= PIO_noerr) then - if (present(ierr)) ierr = MPAS_IO_ERR_PIO + io_global_err = pio_ierr + if (present(ierr)) ierr = MPAS_IO_ERR_BACKEND return end if #endif @@ -1673,6 +1723,10 @@ subroutine MPAS_io_set_var_indices(handle, fieldname, indices, ierr) else call mpas_log_write(trim(SMIOLf_error_string(local_ierr)), messageType=MPAS_LOG_ERR) end if + + io_global_err = local_ierr + if (present(ierr)) ierr = MPAS_IO_ERR_BACKEND + return end if #endif @@ -1820,6 +1874,10 @@ subroutine MPAS_io_get_var_generic(handle, fieldname, intVal, intArray1d, intArr else call mpas_log_write(trim(SMIOLf_error_string(local_ierr)), messageType=MPAS_LOG_ERR) end if + + io_global_err = local_ierr + if (present(ierr)) ierr = MPAS_IO_ERR_BACKEND + return end if #endif @@ -2682,7 +2740,8 @@ subroutine MPAS_io_get_var_generic(handle, fieldname, intVal, intArray1d, intArr ! call mpas_log_write('Checking for error') #ifdef MPAS_PIO_SUPPORT if (pio_ierr /= PIO_noerr) then - if (present(ierr)) ierr = MPAS_IO_ERR_PIO + io_global_err = pio_ierr + if (present(ierr)) ierr = MPAS_IO_ERR_BACKEND return end if #endif @@ -2695,6 +2754,10 @@ subroutine MPAS_io_get_var_generic(handle, fieldname, intVal, intArray1d, intArr else call mpas_log_write(trim(SMIOLf_error_string(local_ierr)), messageType=MPAS_LOG_ERR) end if + + io_global_err = local_ierr + if (present(ierr)) ierr = MPAS_IO_ERR_BACKEND + return end if #endif @@ -3055,7 +3118,8 @@ subroutine MPAS_io_put_var_generic(handle, fieldname, intVal, intArray1d, intArr ! pre-existing files. if (pio_ierr /= PIO_noerr .and. & .not. (handle % external_file_desc .or. handle % preexisting_file)) then - if (present(ierr)) ierr = MPAS_IO_ERR_PIO + io_global_err = pio_ierr + if (present(ierr)) ierr = MPAS_IO_ERR_BACKEND return end if #endif @@ -3097,6 +3161,10 @@ subroutine MPAS_io_put_var_generic(handle, fieldname, intVal, intArray1d, intArr else call mpas_log_write(trim(SMIOLf_error_string(local_ierr)), messageType=MPAS_LOG_ERR) end if + + io_global_err = local_ierr + if (present(ierr)) ierr = MPAS_IO_ERR_BACKEND + return end if #endif @@ -3950,7 +4018,8 @@ subroutine MPAS_io_put_var_generic(handle, fieldname, intVal, intArray1d, intArr end if #ifdef MPAS_PIO_SUPPORT if (pio_ierr /= PIO_noerr) then - if (present(ierr)) ierr = MPAS_IO_ERR_PIO + io_global_err = pio_ierr + if (present(ierr)) ierr = MPAS_IO_ERR_BACKEND return end if #endif @@ -3962,6 +4031,10 @@ subroutine MPAS_io_put_var_generic(handle, fieldname, intVal, intArray1d, intArr else call mpas_log_write(trim(SMIOLf_error_string(local_ierr)), messageType=MPAS_LOG_ERR) end if + + io_global_err = local_ierr + if (present(ierr)) ierr = MPAS_IO_ERR_BACKEND + return end if #endif @@ -4279,7 +4352,8 @@ subroutine MPAS_io_get_att_int0d(handle, attName, attValue, fieldname, ierr) #ifdef MPAS_PIO_SUPPORT pio_ierr = PIO_inq_att(handle % pio_file, varid, attName, xtype, len) if (pio_ierr /= PIO_noerr) then - if (present(ierr)) ierr = MPAS_IO_ERR_PIO + io_global_err = pio_ierr + if (present(ierr)) ierr = MPAS_IO_ERR_BACKEND return end if if (xtype /= PIO_int) then @@ -4289,7 +4363,8 @@ subroutine MPAS_io_get_att_int0d(handle, attName, attValue, fieldname, ierr) pio_ierr = PIO_get_att(handle % pio_file, varid, attName, attValue) if (pio_ierr /= PIO_noerr) then - if (present(ierr)) ierr = MPAS_IO_ERR_PIO + io_global_err = pio_ierr + if (present(ierr)) ierr = MPAS_IO_ERR_BACKEND return end if #endif @@ -4305,7 +4380,8 @@ subroutine MPAS_io_get_att_int0d(handle, attName, attValue, fieldname, ierr) if (present(ierr)) ierr = MPAS_IO_ERR_WRONG_ATT_TYPE return else - if (present(ierr)) ierr = MPAS_IO_ERR_PIO + io_global_err = local_ierr + if (present(ierr)) ierr = MPAS_IO_ERR_BACKEND return end if end if @@ -4444,7 +4520,8 @@ subroutine MPAS_io_get_att_int1d(handle, attName, attValue, fieldname, ierr) #ifdef MPAS_PIO_SUPPORT pio_ierr = PIO_inq_att(handle % pio_file, varid, attName, xtype, len) if (pio_ierr /= PIO_noerr) then - if (present(ierr)) ierr = MPAS_IO_ERR_PIO + io_global_err = pio_ierr + if (present(ierr)) ierr = MPAS_IO_ERR_BACKEND return end if @@ -4455,14 +4532,16 @@ subroutine MPAS_io_get_att_int1d(handle, attName, attValue, fieldname, ierr) pio_ierr = PIO_inq_attlen(handle % pio_file, varid, attName, attlen) if (pio_ierr /= PIO_noerr) then - if (present(ierr)) ierr = MPAS_IO_ERR_PIO + io_global_err = pio_ierr + if (present(ierr)) ierr = MPAS_IO_ERR_BACKEND return end if allocate(attValue(attlen)) pio_ierr = PIO_get_att(handle % pio_file, varid, attName, attValue) if (pio_ierr /= PIO_noerr) then - if (present(ierr)) ierr = MPAS_IO_ERR_PIO + io_global_err = pio_ierr + if (present(ierr)) ierr = MPAS_IO_ERR_BACKEND return end if #endif @@ -4607,7 +4686,8 @@ subroutine MPAS_io_get_att_real0d(handle, attName, attValue, fieldname, precisio ! Query attribute value pio_ierr = PIO_inq_att(handle % pio_file, varid, attName, xtype, len) if (pio_ierr /= PIO_noerr) then - if (present(ierr)) ierr = MPAS_IO_ERR_PIO + io_global_err = pio_ierr + if (present(ierr)) ierr = MPAS_IO_ERR_BACKEND return end if @@ -4643,7 +4723,8 @@ subroutine MPAS_io_get_att_real0d(handle, attName, attValue, fieldname, precisio end if if (pio_ierr /= PIO_noerr) then - if (present(ierr)) ierr = MPAS_IO_ERR_PIO + io_global_err = pio_ierr + if (present(ierr)) ierr = MPAS_IO_ERR_BACKEND return end if #endif @@ -4705,7 +4786,9 @@ subroutine MPAS_io_get_att_real0d(handle, attName, attValue, fieldname, precisio if (local_ierr == SMIOL_WRONG_ARG_TYPE) then if (present(ierr)) ierr = MPAS_IO_ERR_WRONG_ATT_TYPE else - if (present(ierr)) ierr = MPAS_IO_ERR_PIO + io_global_err = local_ierr + if (present(ierr)) ierr = MPAS_IO_ERR_BACKEND + return end if return end if @@ -4855,13 +4938,15 @@ subroutine MPAS_io_get_att_real1d(handle, attName, attValue, fieldname, precisio #ifdef MPAS_PIO_SUPPORT pio_ierr = PIO_inq_att(handle % pio_file, varid, attName, xtype, len) if (pio_ierr /= PIO_noerr) then - if (present(ierr)) ierr = MPAS_IO_ERR_PIO + io_global_err = pio_ierr + if (present(ierr)) ierr = MPAS_IO_ERR_BACKEND return end if pio_ierr = PIO_inq_attlen(handle % pio_file, varid, attName, attlen) if (pio_ierr /= PIO_noerr) then - if (present(ierr)) ierr = MPAS_IO_ERR_PIO + io_global_err = pio_ierr + if (present(ierr)) ierr = MPAS_IO_ERR_BACKEND return end if @@ -4902,7 +4987,8 @@ subroutine MPAS_io_get_att_real1d(handle, attName, attValue, fieldname, precisio end if if (pio_ierr /= PIO_noerr) then - if (present(ierr)) ierr = MPAS_IO_ERR_PIO + io_global_err = pio_ierr + if (present(ierr)) ierr = MPAS_IO_ERR_BACKEND return end if #endif @@ -5038,7 +5124,8 @@ subroutine MPAS_io_get_att_text(handle, attName, attValue, fieldname, ierr) #ifdef MPAS_PIO_SUPPORT pio_ierr = PIO_inq_att(handle % pio_file, varid, attName, xtype, len) if (pio_ierr /= PIO_noerr) then - if (present(ierr)) ierr = MPAS_IO_ERR_PIO + io_global_err = pio_ierr + if (present(ierr)) ierr = MPAS_IO_ERR_BACKEND return end if if (xtype /= PIO_char) then @@ -5048,7 +5135,8 @@ subroutine MPAS_io_get_att_text(handle, attName, attValue, fieldname, ierr) pio_ierr = PIO_get_att(handle % pio_file, varid, attName, attValue) if (pio_ierr /= PIO_noerr) then - if (present(ierr)) ierr = MPAS_IO_ERR_PIO + io_global_err = pio_ierr + if (present(ierr)) ierr = MPAS_IO_ERR_BACKEND return end if #endif @@ -5064,7 +5152,8 @@ subroutine MPAS_io_get_att_text(handle, attName, attValue, fieldname, ierr) if (present(ierr)) ierr = MPAS_IO_ERR_WRONG_ATT_TYPE return else - if (present(ierr)) ierr = MPAS_IO_ERR_PIO + io_global_err = local_ierr + if (present(ierr)) ierr = MPAS_IO_ERR_BACKEND return end if end if @@ -5251,7 +5340,8 @@ subroutine MPAS_io_put_att_int0d(handle, attName, attValue, fieldname, syncVal, #ifdef MPAS_PIO_SUPPORT pio_ierr = PIO_put_att(handle % pio_file, varid, attName, attValueLocal) if (pio_ierr /= PIO_noerr) then - if (present(ierr)) ierr = MPAS_IO_ERR_PIO + io_global_err = pio_ierr + if (present(ierr)) ierr = MPAS_IO_ERR_BACKEND return end if #endif @@ -5269,6 +5359,10 @@ subroutine MPAS_io_put_att_int0d(handle, attName, attValue, fieldname, syncVal, else call mpas_log_write(trim(SMIOLf_error_string(local_ierr)), messageType=MPAS_LOG_ERR) end if + + io_global_err = local_ierr + if (present(ierr)) ierr = MPAS_IO_ERR_BACKEND + return end if #endif @@ -5431,7 +5525,8 @@ subroutine MPAS_io_put_att_int1d(handle, attName, attValue, fieldname, syncVal, #ifdef MPAS_PIO_SUPPORT pio_ierr = PIO_put_att(handle % pio_file, varid, attName, attValueLocal) if (pio_ierr /= PIO_noerr) then - if (present(ierr)) ierr = MPAS_IO_ERR_PIO + io_global_err = pio_ierr + if (present(ierr)) ierr = MPAS_IO_ERR_BACKEND return end if #endif @@ -5634,7 +5729,8 @@ subroutine MPAS_io_put_att_real0d(handle, attName, attValue, fieldname, syncVal, #ifdef MPAS_PIO_SUPPORT if (pio_ierr /= PIO_noerr) then - if (present(ierr)) ierr = MPAS_IO_ERR_PIO + io_global_err = pio_ierr + if (present(ierr)) ierr = MPAS_IO_ERR_BACKEND return end if #endif @@ -5646,6 +5742,10 @@ subroutine MPAS_io_put_att_real0d(handle, attName, attValue, fieldname, syncVal, else call mpas_log_write(trim(SMIOLf_error_string(local_ierr)), messageType=MPAS_LOG_ERR) end if + + io_global_err = local_ierr + if (present(ierr)) ierr = MPAS_IO_ERR_BACKEND + return end if #endif @@ -5837,7 +5937,8 @@ subroutine MPAS_io_put_att_real1d(handle, attName, attValue, fieldname, syncVal, end if #ifdef MPAS_PIO_SUPPORT if (pio_ierr /= PIO_noerr) then - if (present(ierr)) ierr = MPAS_IO_ERR_PIO + io_global_err = pio_ierr + if (present(ierr)) ierr = MPAS_IO_ERR_BACKEND return end if #endif @@ -6002,7 +6103,8 @@ subroutine MPAS_io_put_att_text(handle, attName, attValue, fieldname, syncVal, i pio_ierr = PIO_put_att(handle % pio_file, varid, attName, trim(attValueLocal)) if (pio_ierr /= PIO_noerr) then - if (present(ierr)) ierr = MPAS_IO_ERR_PIO + io_global_err = pio_ierr + if (present(ierr)) ierr = MPAS_IO_ERR_BACKEND ! ! If we are working with a pre-existing file and the text attribute is larger than in the file, we need @@ -6013,16 +6115,19 @@ subroutine MPAS_io_put_att_text(handle, attName, attValue, fieldname, syncVal, i if (handle % preexisting_file .and. .not. handle % data_mode) then pio_ierr = PIO_redef(handle % pio_file) if (pio_ierr /= PIO_noerr) then + io_global_err = pio_ierr return end if pio_ierr = PIO_put_att(handle % pio_file, varid, attName, trim(attValueLocal)) if (pio_ierr /= PIO_noerr) then + io_global_err = pio_ierr return end if pio_ierr = PIO_enddef(handle % pio_file) if (pio_ierr /= PIO_noerr) then + io_global_err = pio_ierr return end if @@ -6047,6 +6152,10 @@ subroutine MPAS_io_put_att_text(handle, attName, attValue, fieldname, syncVal, i else call mpas_log_write(trim(SMIOLf_error_string(local_ierr)), messageType=MPAS_LOG_ERR) end if + + io_global_err = local_ierr + if (present(ierr)) ierr = MPAS_IO_ERR_BACKEND + return end if #endif @@ -6117,6 +6226,10 @@ subroutine MPAS_io_sync(handle, ierr) else call mpas_log_write(trim(SMIOLf_error_string(local_ierr)), messageType=MPAS_LOG_ERR) end if + + io_global_err = local_ierr + if (present(ierr)) ierr = MPAS_IO_ERR_BACKEND + return end if #endif @@ -6206,6 +6319,10 @@ subroutine MPAS_io_close(handle, ierr) else call mpas_log_write(trim(SMIOLf_error_string(local_ierr)), messageType=MPAS_LOG_ERR) end if + + io_global_err = local_ierr + if (present(ierr)) ierr = MPAS_IO_ERR_BACKEND + return end if #endif @@ -6254,7 +6371,8 @@ subroutine MPAS_io_finalize(ioContext, finalize_iosystem, ierr) #ifdef MPAS_PIO_SUPPORT call PIO_finalize(ioContext % pio_iosystem, pio_ierr) if (pio_ierr /= PIO_noerr) then - if (present(ierr)) ierr = MPAS_IO_ERR_PIO + io_global_err = pio_ierr + if (present(ierr)) ierr = MPAS_IO_ERR_BACKEND return end if deallocate(ioContext % pio_iosystem) @@ -6263,6 +6381,9 @@ subroutine MPAS_io_finalize(ioContext, finalize_iosystem, ierr) local_ierr = SMIOLf_finalize(ioContext % smiol_context) if (local_ierr /= SMIOL_SUCCESS) then call mpas_log_write('SMIOLf_free_decomp failed with code $i', intArgs=[local_ierr], messageType=MPAS_LOG_ERR) + io_global_err = local_ierr + if (present(ierr)) ierr = MPAS_IO_ERR_BACKEND + return end if #endif end if @@ -6282,13 +6403,19 @@ type (dm_info) function MPAS_io_handle_dminfo(handle) end function MPAS_io_handle_dminfo - subroutine MPAS_io_err_mesg(ierr, fatal) + subroutine MPAS_io_err_mesg(ioContext, ierr, fatal) implicit none + type (mpas_io_context_type), intent(inout) :: ioContext integer, intent(in) :: ierr logical, intent(in) :: fatal +#ifdef MPAS_PIO_SUPPORT + integer :: ierr_local + character(len=StrKIND) :: pio_string +#endif + select case (ierr) case (MPAS_IO_NOERR) ! ... do nothing ... @@ -6300,8 +6427,20 @@ subroutine MPAS_io_err_mesg(ierr, fatal) call mpas_log_write('MPAS IO Error: Filename too long', MPAS_LOG_ERR) case (MPAS_IO_ERR_UNINIT_HANDLE) call mpas_log_write('MPAS IO Error: Uninitialized I/O handle', MPAS_LOG_ERR) - case (MPAS_IO_ERR_PIO) - call mpas_log_write('MPAS IO Error: Bad return value from PIO', MPAS_LOG_ERR) + case (MPAS_IO_ERR_BACKEND) +#ifdef MPAS_PIO_SUPPORT + ierr_local = PIO_strerror(io_global_err, pio_string) + call mpas_log_write('MPAS IO Error: PIO error $i: '//trim(pio_string), & + messageType=MPAS_LOG_ERR, intArgs=[io_global_err]) +#endif +#ifdef MPAS_SMIOL_SUPPORT + call mpas_log_write('MPAS IO Error: SMIOL error $i: '//trim(SMIOLf_error_string(io_global_err)), & + messageType=MPAS_LOG_ERR, intArgs=[io_global_err]) + if (io_global_err == SMIOL_LIBRARY_ERROR) then + call mpas_log_write('Library error message: '// & + trim(SMIOLf_lib_error_string(ioContext % smiol_context)), messageType=MPAS_LOG_ERR) + end if +#endif case (MPAS_IO_ERR_DATA_MODE) call mpas_log_write('MPAS IO Error: Cannot define in data mode', MPAS_LOG_ERR) case (MPAS_IO_ERR_NOWRITE) diff --git a/src/framework/mpas_io_streams.F b/src/framework/mpas_io_streams.F index 82665d243e..b445d5881a 100644 --- a/src/framework/mpas_io_streams.F +++ b/src/framework/mpas_io_streams.F @@ -118,7 +118,7 @@ subroutine MPAS_createStream(stream, ioContext, fileName, ioFormat, ioDirection, end if ! General error - call MPAS_io_err_mesg(io_err, .false.) + call MPAS_io_err_mesg(ioContext, io_err, .false.) if (io_err /= MPAS_IO_NOERR) then if (present(ierr)) ierr = MPAS_IO_ERR return @@ -1704,7 +1704,7 @@ subroutine MPAS_streamAddField_generic(stream, fieldName, fieldType, dimNames, d !call mpas_log_write('... defining dimension '// trim(dimNames(idim))//" $i", intArgs=(/ dimSizes(idim)/)) write(dimNamesLocal(idim),'(a)') dimNames(idim) call MPAS_io_def_dim(stream % fileHandle, trim(dimNames(idim)), dimSizes(idim), io_err) - call MPAS_io_err_mesg(io_err, .false.) + call MPAS_io_err_mesg(stream % fileHandle % ioContext, io_err, .false.) if (io_err /= MPAS_IO_NOERR) then if (present(ierr)) ierr = MPAS_IO_ERR deallocate(new_field_list_node) @@ -1729,7 +1729,7 @@ subroutine MPAS_streamAddField_generic(stream, fieldName, fieldType, dimNames, d if (ndims > 0) then !call mpas_log_write('... defining dimension '// trim(dimNames(idim))//" $i", intArgs=(/ globalDimSize/)) call MPAS_io_def_dim(stream % fileHandle, trim(dimNames(idim)), globalDimSize, io_err) - call MPAS_io_err_mesg(io_err, .false.) + call MPAS_io_err_mesg(stream % fileHandle % ioContext, io_err, .false.) if (io_err /= MPAS_IO_NOERR) then if (present(ierr)) ierr = MPAS_IO_ERR deallocate(new_field_list_node) @@ -1743,7 +1743,7 @@ subroutine MPAS_streamAddField_generic(stream, fieldName, fieldType, dimNames, d if (hasTimeDimension) then !call mpas_log_write('... defining Time dimension ') call MPAS_io_def_dim(stream % fileHandle, 'Time', MPAS_IO_UNLIMITED_DIM, io_err) - call MPAS_io_err_mesg(io_err, .false.) + call MPAS_io_err_mesg(stream % fileHandle % ioContext, io_err, .false.) if (io_err /= MPAS_IO_NOERR) then if (present(ierr)) ierr = MPAS_IO_ERR deallocate(new_field_list_node) @@ -1759,7 +1759,7 @@ subroutine MPAS_streamAddField_generic(stream, fieldName, fieldType, dimNames, d !call mpas_log_write('... defining var to low-level interface with ndims $i', intArgs=(/ndims/)) call MPAS_io_def_var(stream % fileHandle, trim(fieldName), fieldType, dimNamesLocal(1:ndims), precision=precision, ierr=io_err) - call MPAS_io_err_mesg(io_err, .false.) + call MPAS_io_err_mesg(stream % fileHandle % ioContext, io_err, .false.) if (io_err /= MPAS_IO_NOERR) then if (present(ierr)) ierr = MPAS_IO_ERR deallocate(new_field_list_node) @@ -1772,7 +1772,7 @@ subroutine MPAS_streamAddField_generic(stream, fieldName, fieldType, dimNames, d call MPAS_io_inq_var(stream % fileHandle, trim(fieldName), dimnames=dimNamesInq, dimsizes=dimSizesInq, ierr=io_err) ! If the field does not exist in the input file, we should handle this situation gracefully at higher levels ! without printing disconcerting error messages - !call MPAS_io_err_mesg(io_err, .false.) + !call MPAS_io_err_mesg(stream % fileHandle % ioContext, io_err, .false.) if (io_err /= MPAS_IO_NOERR) then if (present(ierr)) ierr = MPAS_IO_ERR deallocate(new_field_list_node) @@ -1830,7 +1830,7 @@ subroutine MPAS_streamAddField_generic(stream, fieldName, fieldType, dimNames, d ! if (ndims > 0 .and. isDecomposed) then call MPAS_io_set_var_indices(stream % fileHandle, trim(fieldName), indices, io_err) - call MPAS_io_err_mesg(io_err, .false.) + call MPAS_io_err_mesg(stream % fileHandle % ioContext, io_err, .false.) if (io_err /= MPAS_IO_NOERR) then if (present(ierr)) ierr = MPAS_IO_ERR deallocate(new_field_list_node) @@ -2479,7 +2479,7 @@ subroutine MPAS_readStream(stream, frame, ierr) ! Set time frame to real ! call MPAS_io_set_frame(stream % fileHandle, frame, io_err) - call MPAS_io_err_mesg(io_err, .false.) + call MPAS_io_err_mesg(stream % fileHandle % ioContext, io_err, .false.) if (io_err /= MPAS_IO_NOERR) then if (present(ierr)) ierr = MPAS_IO_ERR return @@ -2500,7 +2500,7 @@ subroutine MPAS_readStream(stream, frame, ierr) !call mpas_log_write('MGD calling MPAS_io_get_var now...') call MPAS_io_get_var(stream % fileHandle, field_cursor % int0dField % fieldName, int0d_temp, io_err) - call MPAS_io_err_mesg(io_err, .false.) + call MPAS_io_err_mesg(stream % fileHandle % ioContext, io_err, .false.) if (io_err /= MPAS_IO_NOERR) then if (present(ierr)) ierr = MPAS_IO_ERR return @@ -2532,7 +2532,7 @@ subroutine MPAS_readStream(stream, frame, ierr) else call MPAS_io_get_var(stream % fileHandle, field_cursor % int1dField % fieldName, int1d_temp, io_err) end if - call MPAS_io_err_mesg(io_err, .false.) + call MPAS_io_err_mesg(stream % fileHandle % ioContext, io_err, .false.) if (io_err /= MPAS_IO_NOERR) then if (present(ierr)) ierr = MPAS_IO_ERR if (.not. field_cursor % int1dField % isVarArray) then @@ -2608,7 +2608,7 @@ subroutine MPAS_readStream(stream, frame, ierr) else call MPAS_io_get_var(stream % fileHandle, field_cursor % int2dField % fieldName, int2d_temp, io_err) end if - call MPAS_io_err_mesg(io_err, .false.) + call MPAS_io_err_mesg(stream % fileHandle % ioContext, io_err, .false.) if (io_err /= MPAS_IO_NOERR) then if (present(ierr)) ierr = MPAS_IO_ERR if (field_cursor % int2dField % isVarArray) then @@ -2690,7 +2690,7 @@ subroutine MPAS_readStream(stream, frame, ierr) else call MPAS_io_get_var(stream % fileHandle, field_cursor % int3dField % fieldName, int3d_temp, io_err) end if - call MPAS_io_err_mesg(io_err, .false.) + call MPAS_io_err_mesg(stream % fileHandle % ioContext, io_err, .false.) if (io_err /= MPAS_IO_NOERR) then if (present(ierr)) ierr = MPAS_IO_ERR if (field_cursor % int3dField % isVarArray) then @@ -2760,7 +2760,7 @@ subroutine MPAS_readStream(stream, frame, ierr) !call mpas_log_write('MGD calling MPAS_io_get_var now...') call MPAS_io_get_var(stream % fileHandle, field_cursor % real0dField % fieldName, real0d_temp, io_err) - call MPAS_io_err_mesg(io_err, .false.) + call MPAS_io_err_mesg(stream % fileHandle % ioContext, io_err, .false.) if (io_err /= MPAS_IO_NOERR) then if (present(ierr)) ierr = MPAS_IO_ERR return @@ -2792,7 +2792,7 @@ subroutine MPAS_readStream(stream, frame, ierr) else call MPAS_io_get_var(stream % fileHandle, field_cursor % real1dField % fieldName, real1d_temp, io_err) end if - call MPAS_io_err_mesg(io_err, .false.) + call MPAS_io_err_mesg(stream % fileHandle % ioContext, io_err, .false.) if (io_err /= MPAS_IO_NOERR) then if (present(ierr)) ierr = MPAS_IO_ERR if (.not. field_cursor % real1dField % isVarArray) then @@ -2869,7 +2869,7 @@ subroutine MPAS_readStream(stream, frame, ierr) else call MPAS_io_get_var(stream % fileHandle, field_cursor % real2dField % fieldName, real2d_temp, io_err) end if - call MPAS_io_err_mesg(io_err, .false.) + call MPAS_io_err_mesg(stream % fileHandle % ioContext, io_err, .false.) if (io_err /= MPAS_IO_NOERR) then if (present(ierr)) ierr = MPAS_IO_ERR if (field_cursor % real2dField % isVarArray) then @@ -2954,7 +2954,7 @@ subroutine MPAS_readStream(stream, frame, ierr) else call MPAS_io_get_var(stream % fileHandle, field_cursor % real3dField % fieldName, real3d_temp, io_err) end if - call MPAS_io_err_mesg(io_err, .false.) + call MPAS_io_err_mesg(stream % fileHandle % ioContext, io_err, .false.) if (io_err /= MPAS_IO_NOERR) then if (present(ierr)) ierr = MPAS_IO_ERR if (field_cursor % real3dField % isVarArray) then @@ -3041,7 +3041,7 @@ subroutine MPAS_readStream(stream, frame, ierr) else call MPAS_io_get_var(stream % fileHandle, field_cursor % real4dField % fieldName, real4d_temp, io_err) end if - call MPAS_io_err_mesg(io_err, .false.) + call MPAS_io_err_mesg(stream % fileHandle % ioContext, io_err, .false.) if (io_err /= MPAS_IO_NOERR) then if (present(ierr)) ierr = MPAS_IO_ERR if (field_cursor % real4dField % isVarArray) then @@ -3131,7 +3131,7 @@ subroutine MPAS_readStream(stream, frame, ierr) else call MPAS_io_get_var(stream % fileHandle, field_cursor % real5dField % fieldName, real5d_temp, io_err) end if - call MPAS_io_err_mesg(io_err, .false.) + call MPAS_io_err_mesg(stream % fileHandle % ioContext, io_err, .false.) if (io_err /= MPAS_IO_NOERR) then if (present(ierr)) ierr = MPAS_IO_ERR if (field_cursor % real5dField % isVarArray) then @@ -3202,7 +3202,7 @@ subroutine MPAS_readStream(stream, frame, ierr) !call mpas_log_write('MGD calling MPAS_io_get_var now...') call MPAS_io_get_var(stream % fileHandle, field_cursor % char0dField % fieldName, field_cursor % char0dField % scalar, io_err) - call MPAS_io_err_mesg(io_err, .false.) + call MPAS_io_err_mesg(stream % fileHandle % ioContext, io_err, .false.) if (io_err /= MPAS_IO_NOERR) then if (present(ierr)) ierr = MPAS_IO_ERR return @@ -3225,7 +3225,7 @@ subroutine MPAS_readStream(stream, frame, ierr) !call mpas_log_write('MGD calling MPAS_io_get_var now...') allocate(char1d_temp(field_cursor % char1dField % dimSizes(1))) call MPAS_io_get_var(stream % fileHandle, field_cursor % char1dField % fieldName, char1d_temp, io_err) - call MPAS_io_err_mesg(io_err, .false.) + call MPAS_io_err_mesg(stream % fileHandle % ioContext, io_err, .false.) if (io_err /= MPAS_IO_NOERR) then if (present(ierr)) ierr = MPAS_IO_ERR deallocate(char1d_temp) @@ -3302,7 +3302,7 @@ subroutine MPAS_writeStream(stream, frame, ierr) ! Set time frame to write ! call MPAS_io_set_frame(stream % fileHandle, frame, io_err) - call MPAS_io_err_mesg(io_err, .false.) + call MPAS_io_err_mesg(stream % fileHandle % ioContext, io_err, .false.) if (io_err /= MPAS_IO_NOERR) then if (present(ierr)) ierr = MPAS_IO_ERR return @@ -3344,7 +3344,7 @@ subroutine MPAS_writeStream(stream, frame, ierr) !call mpas_log_write('MGD calling MPAS_io_put_var now...') call MPAS_io_put_var(stream % fileHandle, field_cursor % int0dField % fieldName, int0d_temp, io_err) - call MPAS_io_err_mesg(io_err, .false.) + call MPAS_io_err_mesg(stream % fileHandle % ioContext, io_err, .false.) if (io_err /= MPAS_IO_NOERR .and. present(ierr)) ierr = MPAS_IO_ERR else if (field_cursor % field_type == FIELD_1D_INT) then @@ -3401,7 +3401,7 @@ subroutine MPAS_writeStream(stream, frame, ierr) else call MPAS_io_put_var(stream % fileHandle, field_cursor % int1dField % fieldName, int1d_temp, io_err) end if - call MPAS_io_err_mesg(io_err, .false.) + call MPAS_io_err_mesg(stream % fileHandle % ioContext, io_err, .false.) if (io_err /= MPAS_IO_NOERR .and. present(ierr)) ierr = MPAS_IO_ERR end do @@ -3464,7 +3464,7 @@ subroutine MPAS_writeStream(stream, frame, ierr) else call MPAS_io_put_var(stream % fileHandle, field_cursor % int2dField % fieldName, int2d_temp, io_err) end if - call MPAS_io_err_mesg(io_err, .false.) + call MPAS_io_err_mesg(stream % fileHandle % ioContext, io_err, .false.) if (io_err /= MPAS_IO_NOERR .and. present(ierr)) ierr = MPAS_IO_ERR end do @@ -3531,7 +3531,7 @@ subroutine MPAS_writeStream(stream, frame, ierr) else call MPAS_io_put_var(stream % fileHandle, field_cursor % int3dField % fieldName, int3d_temp, io_err) end if - call MPAS_io_err_mesg(io_err, .false.) + call MPAS_io_err_mesg(stream % fileHandle % ioContext, io_err, .false.) if (io_err /= MPAS_IO_NOERR .and. present(ierr)) ierr = MPAS_IO_ERR end do @@ -3552,7 +3552,7 @@ subroutine MPAS_writeStream(stream, frame, ierr) !call mpas_log_write('MGD calling MPAS_io_put_var now...') call MPAS_io_put_var(stream % fileHandle, field_cursor % real0dField % fieldName, real0d_temp, io_err) - call MPAS_io_err_mesg(io_err, .false.) + call MPAS_io_err_mesg(stream % fileHandle % ioContext, io_err, .false.) if (io_err /= MPAS_IO_NOERR .and. present(ierr)) ierr = MPAS_IO_ERR else if (field_cursor % field_type == FIELD_1D_REAL) then @@ -3609,7 +3609,7 @@ subroutine MPAS_writeStream(stream, frame, ierr) else call MPAS_io_put_var(stream % fileHandle, field_cursor % real1dField % fieldName, real1d_temp, io_err) end if - call MPAS_io_err_mesg(io_err, .false.) + call MPAS_io_err_mesg(stream % fileHandle % ioContext, io_err, .false.) if (io_err /= MPAS_IO_NOERR .and. present(ierr)) ierr = MPAS_IO_ERR end do @@ -3672,7 +3672,7 @@ subroutine MPAS_writeStream(stream, frame, ierr) else call MPAS_io_put_var(stream % fileHandle, field_cursor % real2dField % fieldName, real2d_temp, io_err) end if - call MPAS_io_err_mesg(io_err, .false.) + call MPAS_io_err_mesg(stream % fileHandle % ioContext, io_err, .false.) if (io_err /= MPAS_IO_NOERR .and. present(ierr)) ierr = MPAS_IO_ERR end do @@ -3739,7 +3739,7 @@ subroutine MPAS_writeStream(stream, frame, ierr) else call MPAS_io_put_var(stream % fileHandle, field_cursor % real3dField % fieldName, real3d_temp, io_err) end if - call MPAS_io_err_mesg(io_err, .false.) + call MPAS_io_err_mesg(stream % fileHandle % ioContext, io_err, .false.) if (io_err /= MPAS_IO_NOERR .and. present(ierr)) ierr = MPAS_IO_ERR end do @@ -3808,7 +3808,7 @@ subroutine MPAS_writeStream(stream, frame, ierr) else call MPAS_io_put_var(stream % fileHandle, field_cursor % real4dField % fieldName, real4d_temp, io_err) end if - call MPAS_io_err_mesg(io_err, .false.) + call MPAS_io_err_mesg(stream % fileHandle % ioContext, io_err, .false.) if (io_err /= MPAS_IO_NOERR .and. present(ierr)) ierr = MPAS_IO_ERR end do @@ -3879,7 +3879,7 @@ subroutine MPAS_writeStream(stream, frame, ierr) else call MPAS_io_put_var(stream % fileHandle, field_cursor % real5dField % fieldName, real5d_temp, io_err) end if - call MPAS_io_err_mesg(io_err, .false.) + call MPAS_io_err_mesg(stream % fileHandle % ioContext, io_err, .false.) if (io_err /= MPAS_IO_NOERR .and. present(ierr)) ierr = MPAS_IO_ERR end do @@ -3898,7 +3898,7 @@ subroutine MPAS_writeStream(stream, frame, ierr) !call mpas_log_write('Copying field from first block') !call mpas_log_write('MGD calling MPAS_io_put_var now...') call MPAS_io_put_var(stream % fileHandle, field_cursor % char0dField % fieldName, field_cursor % char0dField % scalar, io_err) - call MPAS_io_err_mesg(io_err, .false.) + call MPAS_io_err_mesg(stream % fileHandle % ioContext, io_err, .false.) if (io_err /= MPAS_IO_NOERR .and. present(ierr)) ierr = MPAS_IO_ERR else if (field_cursor % field_type == FIELD_1D_CHAR) then @@ -3910,7 +3910,7 @@ subroutine MPAS_writeStream(stream, frame, ierr) !call mpas_log_write('Copying field from first block') !call mpas_log_write('MGD calling MPAS_io_put_var now...') call MPAS_io_put_var(stream % fileHandle, field_cursor % char1dField % fieldName, field_cursor % char1dField % array, io_err) - call MPAS_io_err_mesg(io_err, .false.) + call MPAS_io_err_mesg(stream % fileHandle % ioContext, io_err, .false.) if (io_err /= MPAS_IO_NOERR .and. present(ierr)) ierr = MPAS_IO_ERR @@ -3949,7 +3949,7 @@ subroutine MPAS_readStreamAtt_0dInteger(stream, attName, attValue, ierr) end if call MPAS_io_get_att(stream % fileHandle, attName, attValue, ierr=io_err) - call MPAS_io_err_mesg(io_err, .false.) + call MPAS_io_err_mesg(stream % fileHandle % ioContext, io_err, .false.) if (io_err /= MPAS_IO_NOERR .and. present(ierr)) ierr = MPAS_IO_ERR end subroutine MPAS_readStreamAtt_0dInteger @@ -3977,7 +3977,7 @@ subroutine MPAS_readStreamAtt_1dInteger(stream, attName, attValue, ierr) end if call MPAS_io_get_att(stream % fileHandle, attName, attValue, ierr=io_err) - call MPAS_io_err_mesg(io_err, .false.) + call MPAS_io_err_mesg(stream % fileHandle % ioContext, io_err, .false.) if (io_err /= MPAS_IO_NOERR .and. present(ierr)) ierr = MPAS_IO_ERR end subroutine MPAS_readStreamAtt_1dInteger @@ -4013,7 +4013,7 @@ subroutine MPAS_readStreamAtt_0dReal(stream, attName, attValue, precision, ierr) end if call MPAS_io_get_att(stream % fileHandle, attName, attValue, precision=local_precision, ierr=io_err) - call MPAS_io_err_mesg(io_err, .false.) + call MPAS_io_err_mesg(stream % fileHandle % ioContext, io_err, .false.) if (io_err /= MPAS_IO_NOERR .and. present(ierr)) ierr = MPAS_IO_ERR end subroutine MPAS_readStreamAtt_0dReal @@ -4049,7 +4049,7 @@ subroutine MPAS_readStreamAtt_1dReal(stream, attName, attValue, precision, ierr) end if call MPAS_io_get_att(stream % fileHandle, attName, attValue, precision=local_precision, ierr=io_err) - call MPAS_io_err_mesg(io_err, .false.) + call MPAS_io_err_mesg(stream % fileHandle % ioContext, io_err, .false.) if (io_err /= MPAS_IO_NOERR .and. present(ierr)) ierr = MPAS_IO_ERR end subroutine MPAS_readStreamAtt_1dReal @@ -4077,7 +4077,7 @@ subroutine MPAS_readStreamAtt_text(stream, attName, attValue, ierr) end if call MPAS_io_get_att(stream % fileHandle, attName, attValue, ierr=io_err) - call MPAS_io_err_mesg(io_err, .false.) + call MPAS_io_err_mesg(stream % fileHandle % ioContext, io_err, .false.) if (io_err /= MPAS_IO_NOERR .and. present(ierr)) ierr = MPAS_IO_ERR end subroutine MPAS_readStreamAtt_text @@ -4106,7 +4106,7 @@ subroutine MPAS_writeStreamAtt_0dInteger(stream, attName, attValue, syncVal, ier end if call MPAS_io_put_att(stream % fileHandle, attName, attValue, syncVal=syncVal, ierr=io_err) - call MPAS_io_err_mesg(io_err, .false.) + call MPAS_io_err_mesg(stream % fileHandle % ioContext, io_err, .false.) if (io_err /= MPAS_IO_NOERR .and. present(ierr)) ierr = MPAS_IO_ERR end subroutine MPAS_writeStreamAtt_0dInteger @@ -4135,7 +4135,7 @@ subroutine MPAS_writeStreamAtt_1dInteger(stream, attName, attValue, syncVal, ier end if call MPAS_io_put_att(stream % fileHandle, attName, attValue, syncVal=syncVal, ierr=io_err) - call MPAS_io_err_mesg(io_err, .false.) + call MPAS_io_err_mesg(stream % fileHandle % ioContext, io_err, .false.) if (io_err /= MPAS_IO_NOERR .and. present(ierr)) ierr = MPAS_IO_ERR end subroutine MPAS_writeStreamAtt_1dInteger @@ -4172,7 +4172,7 @@ subroutine MPAS_writeStreamAtt_0dReal(stream, attName, attValue, syncVal, precis end if call MPAS_io_put_att(stream % fileHandle, attName, attValue, syncVal=syncVal, precision=local_precision, ierr=io_err) - call MPAS_io_err_mesg(io_err, .false.) + call MPAS_io_err_mesg(stream % fileHandle % ioContext, io_err, .false.) if (io_err /= MPAS_IO_NOERR .and. present(ierr)) ierr = MPAS_IO_ERR end subroutine MPAS_writeStreamAtt_0dReal @@ -4209,7 +4209,7 @@ subroutine MPAS_writeStreamAtt_1dReal(stream, attName, attValue, syncVal, precis end if call MPAS_io_put_att(stream % fileHandle, attName, attValue, syncVal=syncVal, precision=local_precision, ierr=io_err) - call MPAS_io_err_mesg(io_err, .false.) + call MPAS_io_err_mesg(stream % fileHandle % ioContext, io_err, .false.) if (io_err /= MPAS_IO_NOERR .and. present(ierr)) ierr = MPAS_IO_ERR end subroutine MPAS_writeStreamAtt_1dReal @@ -4238,7 +4238,7 @@ subroutine MPAS_writeStreamAtt_text(stream, attName, attValue, syncVal, ierr) end if call MPAS_io_put_att(stream % fileHandle, attName, attValue, syncVal=syncVal, ierr=io_err) - call MPAS_io_err_mesg(io_err, .false.) + call MPAS_io_err_mesg(stream % fileHandle % ioContext, io_err, .false.) if (io_err /= MPAS_IO_NOERR .and. present(ierr)) ierr = MPAS_IO_ERR end subroutine MPAS_writeStreamAtt_text @@ -4265,7 +4265,7 @@ subroutine MPAS_closeStream(stream, ierr) end if call MPAS_io_close(stream % fileHandle, io_err) - call MPAS_io_err_mesg(io_err, .false.) + call MPAS_io_err_mesg(stream % fileHandle % ioContext, io_err, .false.) if (io_err /= MPAS_IO_NOERR .and. present(ierr)) ierr = MPAS_IO_ERR !call mpas_log_write('Deallocating global attribute list') diff --git a/src/framework/mpas_io_types.inc b/src/framework/mpas_io_types.inc index e648b234ef..522e6e1ad5 100644 --- a/src/framework/mpas_io_types.inc +++ b/src/framework/mpas_io_types.inc @@ -49,7 +49,7 @@ MPAS_IO_ERR_INVALID_FORMAT = -2, & MPAS_IO_ERR_LONG_FILENAME = -3, & MPAS_IO_ERR_UNINIT_HANDLE = -4, & - MPAS_IO_ERR_PIO = -5, & + MPAS_IO_ERR_BACKEND = -5, & MPAS_IO_ERR_DATA_MODE = -6, & MPAS_IO_ERR_NOWRITE = -7, & MPAS_IO_ERR_REDEF_DIM = -8, & diff --git a/src/framework/mpas_log.F b/src/framework/mpas_log.F index 08404ca4c0..8462545fba 100644 --- a/src/framework/mpas_log.F +++ b/src/framework/mpas_log.F @@ -808,8 +808,12 @@ subroutine log_abort() #ifdef _MPI #ifndef NOMPIMOD +#ifdef MPAS_USE_MPI_F08 + use mpi_f08 +#else use mpi #endif +#endif #endif implicit none diff --git a/src/framework/mpas_stream_inquiry.F b/src/framework/mpas_stream_inquiry.F new file mode 100644 index 0000000000..4a81ead1ad --- /dev/null +++ b/src/framework/mpas_stream_inquiry.F @@ -0,0 +1,275 @@ +! Copyright (c) 2023 The University Corporation for Atmospheric Research (UCAR). +! +! Unless noted otherwise source code is licensed under the BSD license. +! Additional copyright and license information can be found in the LICENSE file +! distributed with this code, or at https://mpas-dev.github.io/license.html . +! +!----------------------------------------------------------------------- +! mpas_stream_inquiry +! +!> \brief Enables inquiries of the contents of the streams. file +!> \author Michael Duda +!> \date 15 November 2023 +!> \details +!> This module provides a method for instantiating a new MPAS_streamInfo_type +!> type, as well as routines that may be invoked from that instance to query +!> the contents of a streams XML file. +!> +!> Example usage to determine the value of the "input_interval" attribute +!> for the "foo" stream: +!> +!> type (MPAS_streamInfo_type), pointer :: streamInfo +!> character(len=StrKIND) :: attvalue +!> integer :: ierr +!> +!> streamInfo => MPAS_stream_inquiry_new_streaminfo() +!> +!> ierr = streamInfo % init(dminfo % comm, 'streams.test') +!> +!> if (streamInfo % query('foo', attname='input_interval', attvalue=attvalue)) then +!> call mpas_log_write('input_interval = '//trim(attvalue)) +!> end if +!> +!> ierr = streamInfo % finalize() +!> +!> deallocate(streamInfo) +!> +! +!----------------------------------------------------------------------- +module mpas_stream_inquiry + + public :: MPAS_stream_inquiry_new_streaminfo + + +contains + + + !----------------------------------------------------------------------- + ! routine MPAS_stream_inquiry_new_streaminfo + ! + !> \brief Returns a pointer to a new MPAS_streamInfo_type instance + !> \author Michael Duda + !> \date 15 November 2023 + !> \details + !> This routine returns a pointer to a newly allocated instance of an + !> MPAS_streamInfo_type. The new instance has valid methods init(), query(), + !> and finalize() that may be called. + !> + !> After all queries via the MPAS_streamInfo_type instance have been + !> completed, the instance finalize() method should be called before the + !> instance is deallocated. + ! + !----------------------------------------------------------------------- + function MPAS_stream_inquiry_new_streaminfo() result(new_streaminfo) + + use mpas_derived_types, only : MPAS_streamInfo_type + + implicit none + + ! Return value + type (MPAS_streamInfo_type), pointer :: new_streaminfo + + allocate(new_streaminfo) + new_streaminfo % init => streaminfo_init + new_streaminfo % finalize => streaminfo_finalize + new_streaminfo % query => streaminfo_query + + end function MPAS_stream_inquiry_new_streaminfo + + + !----------------------------------------------------------------------- + ! routine streaminfo_init + ! + !> \brief Initializes an MPAS_streamInfo_type instance from a streams XML file + !> \author Michael Duda + !> \date 15 November 2023 + !> \details + !> This routine should be called as a method within an MPAS_streamInfo_type + !> instance, e.g., streaminfo % init(...). Given the name of an MPAS streams + !> XML file, this method initializes the instance so that later queries may + !> be made with the query() method. + ! + !----------------------------------------------------------------------- + function streaminfo_init(this, comm, stream_filename) result(ierr) + + use mpas_derived_types, only : MPAS_streamInfo_type + use mpas_log, only : mpas_log_write + use mpas_c_interfacing, only : mpas_f_to_c_string + use iso_c_binding, only : c_char, c_associated +#ifdef MPAS_USE_MPI_F08 + use mpi_f08, only : MPI_Comm +#endif + + implicit none + + ! Arguments + class (MPAS_streamInfo_type) :: this +#ifdef MPAS_USE_MPI_F08 + type (MPI_Comm), intent(in) :: comm +#else + integer, intent(in) :: comm +#endif + character(len=*), intent(in) :: stream_filename + + ! Return value + integer :: ierr + + ! Local variables + character(kind=c_char), dimension(len(stream_filename)+1) :: c_stream_filename + + interface + function parse_streams_file(comm, filename) bind(C, name='parse_streams_file') result(xmltree) + use iso_c_binding, only : c_char, c_ptr + integer, intent(in), value :: comm + character(kind=c_char), dimension(*), intent(in) :: filename + type(c_ptr) :: xmltree + end function parse_streams_file + end interface + + + ierr = 0 + + call mpas_f_to_c_string(stream_filename, c_stream_filename) + call mpas_log_write('Initializing MPAS_streamInfo from file '//trim(stream_filename)) +#ifdef MPAS_USE_MPI_F08 + this % xmltree = parse_streams_file(comm % mpi_val, c_stream_filename) +#else + this % xmltree = parse_streams_file(comm, c_stream_filename) +#endif + + if (.not. c_associated(this % xmltree)) then + ierr = 1 + end if + end function streaminfo_init + + + !----------------------------------------------------------------------- + ! routine streaminfo_finalize + ! + !> \brief Finalizes an instance of the MPAS_streamInfo_type type + !> \author Michael Duda + !> \date 15 November 2023 + !> \details + !> This routine finalizes an instance of the MPAS_streamInfo_type type + !> after all queries about the contents of the streams XML file associated + !> with the instance have been completed. This routine should be called as + !> a method within an MPAS_streamInfo_type type, e.g., + !> streaminfo % finalize(). + ! + !----------------------------------------------------------------------- + function streaminfo_finalize(this) result(ierr) + + use mpas_derived_types, only : MPAS_streamInfo_type + use iso_c_binding, only : c_null_ptr, c_associated + + implicit none + + ! Arguments + class (MPAS_streamInfo_type) :: this + + ! Return value + integer :: ierr + + interface + subroutine free_streams_file(xmltree) bind(C, name='free_streams_file') + use iso_c_binding, only : c_ptr + type(c_ptr), value :: xmltree + end subroutine free_streams_file + end interface + + + ierr = 0 + + if (c_associated(this % xmltree)) then + call free_streams_file(this % xmltree) + this % xmltree = c_null_ptr + end if + + end function streaminfo_finalize + + + !----------------------------------------------------------------------- + ! routine streaminfo_query + ! + !> \brief Makes inquiries about the contents of a streams XML file + !> \author Michael Duda + !> \date 15 November 2023 + !> \details + !> For an instance of the MPAS_streamInfo_type type that has previously + !> been allocated and initialized from an MPAS streams XML file, this + !> routine allows for inquiries about the contents of the associated + !> streams file. This routine should be called as a method within an + !> instance of the MPAS_streamInfo_type type, e.g., as + !> streaminfo % query(...). + !> + !> If only the required streamname attribute is given, this routine returns + !> .TRUE. if that stream exists, and .FALSE. otherwise. If the optional + !> attname attribute is given, and if that attribute exists for the + !> specified stream, .TRUE. is returned and .FALSE is returned otherwise; + !> further, if the optional attvalue argument is given, the value of the + !> attribute will assigned to the attvalue argument if the attribute + !> exists. + ! + !----------------------------------------------------------------------- + function streaminfo_query(this, streamname, attname, attvalue) result(success) + + use mpas_derived_types, only : MPAS_streamInfo_type + use mpas_c_interfacing, only : mpas_f_to_c_string, mpas_c_to_f_string + use iso_c_binding, only : c_char, c_ptr, c_null_ptr, c_loc, c_associated, c_f_pointer + + implicit none + + ! Arguments + class (MPAS_streamInfo_type) :: this + character(len=*), intent(in) :: streamname + character(len=*), intent(in), optional :: attname + character(len=*), intent(out), optional :: attvalue + + ! Return value + logical :: success + + ! Local variables + character(kind=c_char), dimension(len(streamname)+1) :: c_streamname + character(kind=c_char), dimension(:), pointer :: c_attname, c_attvalue + type (c_ptr) :: c_attname_ptr, c_attvalue_ptr + + interface + function query_streams_file(xmltree, streamname, attname, attvalue) bind(C, name='query_streams_file') result(found) + use iso_c_binding, only : c_ptr, c_int, c_char + type (c_ptr), value :: xmltree + character(kind=c_char), dimension(*), intent(in) :: streamname + type (c_ptr), value :: attname + type (c_ptr) :: attvalue + integer(kind=c_int) :: found + end function query_streams_file + end interface + + + success = .true. + call mpas_f_to_c_string(streamname, c_streamname) + + if (present(attname)) then + allocate(c_attname(len(attname))) + call mpas_f_to_c_string(attname, c_attname) + c_attname_ptr = c_loc(c_attname) + else + c_attname_ptr = c_null_ptr + end if + c_attvalue_ptr = c_null_ptr + if (query_streams_file(this % xmltree, c_streamname, c_attname_ptr, c_attvalue_ptr) /= 1) then + success = .false. + end if + if (present(attname)) then + deallocate(c_attname) + end if + if (success .and. present(attname) .and. present(attvalue)) then + if (c_associated(c_attvalue_ptr)) then + call c_f_pointer(c_attvalue_ptr, c_attvalue, shape=[len(attvalue)]) + call mpas_c_to_f_string(c_attvalue, attvalue) + else + end if + end if + + end function streaminfo_query + +end module mpas_stream_inquiry diff --git a/src/framework/mpas_stream_inquiry_types.inc b/src/framework/mpas_stream_inquiry_types.inc new file mode 100644 index 0000000000..061c8bb431 --- /dev/null +++ b/src/framework/mpas_stream_inquiry_types.inc @@ -0,0 +1,39 @@ + type MPAS_streamInfo_type + type (c_ptr) :: xmltree = c_null_ptr + + procedure (streaminfo_init_function), pass, pointer :: init => null() + procedure (streaminfo_finalize_function), pass, pointer :: finalize => null() + procedure (streaminfo_query_function), pass, pointer :: query => null() + end type MPAS_streamInfo_type + + abstract interface + function streaminfo_init_function(this, comm, stream_filename) result(ierr) +#ifdef MPAS_USE_MPI_F08 + use mpi_f08, only : MPI_Comm +#endif + import MPAS_streamInfo_type + class (MPAS_streamInfo_type) :: this +#ifdef MPAS_USE_MPI_F08 + type (MPI_Comm), intent(in) :: comm +#else + integer, intent(in) :: comm +#endif + character(len=*), intent(in) :: stream_filename + integer :: ierr + end function streaminfo_init_function + + function streaminfo_finalize_function(this) result(ierr) + import MPAS_streamInfo_type + class (MPAS_streamInfo_type) :: this + integer :: ierr + end function streaminfo_finalize_function + + function streaminfo_query_function(this, streamname, attname, attvalue) result(success) + import MPAS_streamInfo_type + class (MPAS_streamInfo_type) :: this + character(len=*), intent(in) :: streamname + character(len=*), intent(in), optional :: attname + character(len=*), intent(out), optional :: attvalue + logical :: success + end function streaminfo_query_function + end interface diff --git a/src/framework/mpas_stream_manager.F b/src/framework/mpas_stream_manager.F index 0276d34653..d00fcaa800 100644 --- a/src/framework/mpas_stream_manager.F +++ b/src/framework/mpas_stream_manager.F @@ -3363,7 +3363,7 @@ subroutine write_stream(manager, stream, blockID, timeLevel, mgLevel, forceWrite ! if ( .not. stream % blockWrite ) then STREAM_DEBUG_WRITE(' -- Prewrite reindex for stream ' // trim(stream % name)) - call prewrite_reindex(manager % allFields, stream % field_pool) + call prewrite_reindex(manager % allFields, manager % allPackages, stream % field_pool, stream % field_pkg_pool) end if ! @@ -3973,12 +3973,13 @@ subroutine read_stream(manager, stream, timeLevel, mgLevel, forceReadNow, when, ! ! Exchange halos for all decomposed fields in this stream ! - call exch_all_halos(manager % allFields, stream % field_pool, stream % timeLevel, local_ierr) + call exch_all_halos(manager % allFields, manager % allPackages, stream % field_pool, stream % field_pkg_pool, & + stream % timeLevel, local_ierr) ! ! For any connectivity arrays in this stream, convert global indices to local indices ! - call postread_reindex(manager % allFields, stream % field_pool) + call postread_reindex(manager % allFields, manager % allPackages, stream % field_pool, stream % field_pkg_pool) end if end subroutine read_stream !}}} @@ -4646,12 +4647,14 @@ end function parse_package_list !> This routine performs a halo exchange of each decomposed field within a stream. ! !----------------------------------------------------------------------- - subroutine exch_all_halos(allFields, streamFields, timeLevel, ierr) !{{{ + subroutine exch_all_halos(allFields, allPackages, streamFields, fieldPkgPool, timeLevel, ierr) !{{{ implicit none type (mpas_pool_type), pointer :: allFields + type (mpas_pool_type), pointer :: allPackages type (mpas_pool_type), pointer :: streamFields + type (mpas_pool_type), pointer :: fieldPkgPool integer, intent(in) :: timeLevel integer, intent(out) :: ierr @@ -4667,6 +4670,10 @@ subroutine exch_all_halos(allFields, streamFields, timeLevel, ierr) !{{{ type (field2DInteger), pointer :: int2DField type (field3DInteger), pointer :: int3DField + character (len=StrKIND), pointer :: packages + logical :: active_field + integer :: err_level + ierr = MPAS_STREAM_MGR_NOERR @@ -4677,6 +4684,26 @@ subroutine exch_all_halos(allFields, streamFields, timeLevel, ierr) !{{{ ! Note: in a stream's field_pool, the names of fields are stored as configs if ( fieldItr % memberType == MPAS_POOL_CONFIG ) then + ! + ! Check whether the field is active in this stream + ! + err_level = mpas_pool_get_error_level() + call mpas_pool_set_error_level(MPAS_POOL_SILENT) + + nullify(packages) + call mpas_pool_get_config(fieldPkgPool, trim(fieldItr % memberName)//':packages', packages) + if (associated(packages)) then + active_field = parse_package_list(allPackages, trim(packages)) + else + active_field = .true. + end if + call mpas_pool_set_error_level(err_level) + + if (.not. active_field) then + STREAM_DEBUG_WRITE('-- '//trim(fieldItr % memberName)//' not active in stream and halo will not be exchanged') + cycle + end if + call mpas_pool_get_field_info(allFields, fieldItr % memberName, fieldInfo) if ( fieldInfo % nDims == 1) then @@ -4837,7 +4864,7 @@ end function is_decomposed_dim !}}} !> the top of this module where this routine is made public. ! !----------------------------------------------------------------------- - subroutine prewrite_reindex(allFields, streamFields) !{{{ + subroutine prewrite_reindex(allFields, allPackages, streamFields, fieldPkgPool) !{{{ implicit none @@ -4846,7 +4873,9 @@ subroutine prewrite_reindex(allFields, streamFields) !{{{ integer, parameter :: UNUSED_VERTEX = 0 type (mpas_pool_type), pointer :: allFields + type (mpas_pool_type), pointer :: allPackages type (mpas_pool_type), pointer :: streamFields + type (mpas_pool_type), pointer :: fieldPkgPool type (mpas_pool_iterator_type) :: fieldItr type (mpas_pool_field_info_type) :: fieldInfo @@ -4869,6 +4898,11 @@ subroutine prewrite_reindex(allFields, streamFields) !{{{ integer :: i, j, threadNum + character (len=StrKIND), pointer :: packages + logical :: active_field + integer :: err_level + + threadNum = mpas_threading_get_thread_num() if ( threadNum == 0 ) then @@ -4898,6 +4932,27 @@ subroutine prewrite_reindex(allFields, streamFields) !{{{ ! Note: in a stream's field_pool, the names of fields are stored as configs if ( fieldItr % memberType == MPAS_POOL_CONFIG ) then + + ! + ! Check whether the field is active in this stream + ! + err_level = mpas_pool_get_error_level() + call mpas_pool_set_error_level(MPAS_POOL_SILENT) + + nullify(packages) + call mpas_pool_get_config(fieldPkgPool, trim(fieldItr % memberName)//':packages', packages) + if (associated(packages)) then + active_field = parse_package_list(allPackages, trim(packages)) + else + active_field = .true. + end if + call mpas_pool_set_error_level(err_level) + + if (.not. active_field) then + STREAM_DEBUG_WRITE('-- '//trim(fieldItr % memberName)//' not active in stream and will not be reindexed') + cycle + end if + call mpas_pool_get_field_info(allFields, fieldItr % memberName, fieldInfo) if (trim(fieldItr % memberName) == 'cellsOnCell') then @@ -4959,6 +5014,7 @@ subroutine prewrite_reindex(allFields, streamFields) !{{{ call mpas_pool_get_dimension(indexToCellID % block % dimensions, 'vertexDegree', vertexDegree) if (associated(cellsOnCell)) then + STREAM_DEBUG_WRITE(' -- reindexing cellsOnCell from local to global indices') cellsOnCell_ptr % array => cellsOnCell % array allocate(cellsOnCell % array(maxEdges, nCells+1)) @@ -4979,6 +5035,7 @@ subroutine prewrite_reindex(allFields, streamFields) !{{{ end if if (associated(edgesOnCell)) then + STREAM_DEBUG_WRITE(' -- reindexing edgesOnCell from local to global indices') edgesOnCell_ptr % array => edgesOnCell % array allocate(edgesOnCell % array(maxEdges, nCells+1)) @@ -4999,6 +5056,7 @@ subroutine prewrite_reindex(allFields, streamFields) !{{{ end if if (associated(verticesOnCell)) then + STREAM_DEBUG_WRITE(' -- reindexing verticesOnCell from local to global indices') verticesOnCell_ptr % array => verticesOnCell % array allocate(verticesOnCell % array(maxEdges, nCells+1)) @@ -5019,6 +5077,7 @@ subroutine prewrite_reindex(allFields, streamFields) !{{{ end if if (associated(cellsOnEdge)) then + STREAM_DEBUG_WRITE(' -- reindexing cellsOnEdge from local to global indices') cellsOnEdge_ptr % array => cellsOnEdge % array allocate(cellsOnEdge % array(2, nEdges+1)) @@ -5036,6 +5095,7 @@ subroutine prewrite_reindex(allFields, streamFields) !{{{ end if if (associated(verticesOnEdge)) then + STREAM_DEBUG_WRITE(' -- reindexing verticesOnEdge from local to global indices') verticesOnEdge_ptr % array => verticesOnEdge % array allocate(verticesOnEdge % array(2, nEdges+1)) @@ -5053,6 +5113,7 @@ subroutine prewrite_reindex(allFields, streamFields) !{{{ end if if (associated(edgesOnEdge)) then + STREAM_DEBUG_WRITE(' -- reindexing edgesOnEdge from local to global indices') edgesOnEdge_ptr % array => edgesOnEdge % array allocate(edgesOnEdge % array(maxEdges2, nEdges+1)) @@ -5073,6 +5134,7 @@ subroutine prewrite_reindex(allFields, streamFields) !{{{ end if if (associated(cellsOnVertex)) then + STREAM_DEBUG_WRITE(' -- reindexing cellsOnVertex from local to global indices') cellsOnVertex_ptr % array => cellsOnVertex % array allocate(cellsOnVertex % array(vertexDegree, nVertices+1)) @@ -5091,6 +5153,7 @@ subroutine prewrite_reindex(allFields, streamFields) !{{{ end if if (associated(edgesOnVertex)) then + STREAM_DEBUG_WRITE(' -- reindexing edgesOnVertex from local to global indices') edgesOnVertex_ptr % array => edgesOnVertex % array allocate(edgesOnVertex % array(vertexDegree, nVertices+1)) @@ -5211,6 +5274,7 @@ subroutine postwrite_reindex(allFields, streamFields) !{{{ do while (associated(indexToCellID)) if (associated(cellsOnCell)) then + STREAM_DEBUG_WRITE(' -- restoring cellsOnCell to local indices') deallocate(cellsOnCell % array) cellsOnCell % array => cellsOnCell_ptr % array nullify(cellsOnCell_ptr % array) @@ -5219,6 +5283,7 @@ subroutine postwrite_reindex(allFields, streamFields) !{{{ end if if (associated(edgesOnCell)) then + STREAM_DEBUG_WRITE(' -- restoring edgesOnCell to local indices') deallocate(edgesOnCell % array) edgesOnCell % array => edgesOnCell_ptr % array nullify(edgesOnCell_ptr % array) @@ -5227,6 +5292,7 @@ subroutine postwrite_reindex(allFields, streamFields) !{{{ end if if (associated(verticesOnCell)) then + STREAM_DEBUG_WRITE(' -- restoring verticesOnCell to local indices') deallocate(verticesOnCell % array) verticesOnCell % array => verticesOnCell_ptr % array nullify(verticesOnCell_ptr % array) @@ -5235,6 +5301,7 @@ subroutine postwrite_reindex(allFields, streamFields) !{{{ end if if (associated(cellsOnEdge)) then + STREAM_DEBUG_WRITE(' -- restoring cellsOnEdge to local indices') deallocate(cellsOnEdge % array) cellsOnEdge % array => cellsOnEdge_ptr % array nullify(cellsOnEdge_ptr % array) @@ -5243,6 +5310,7 @@ subroutine postwrite_reindex(allFields, streamFields) !{{{ end if if (associated(verticesOnEdge)) then + STREAM_DEBUG_WRITE(' -- restoring verticesOnEdge to local indices') deallocate(verticesOnEdge % array) verticesOnEdge % array => verticesOnEdge_ptr % array nullify(verticesOnEdge_ptr % array) @@ -5251,6 +5319,7 @@ subroutine postwrite_reindex(allFields, streamFields) !{{{ end if if (associated(edgesOnEdge)) then + STREAM_DEBUG_WRITE(' -- restoring edgesOnEdge to local indices') deallocate(edgesOnEdge % array) edgesOnEdge % array => edgesOnEdge_ptr % array nullify(edgesOnEdge_ptr % array) @@ -5259,6 +5328,7 @@ subroutine postwrite_reindex(allFields, streamFields) !{{{ end if if (associated(cellsOnVertex)) then + STREAM_DEBUG_WRITE(' -- restoring cellsOnVertex to local indices') deallocate(cellsOnVertex % array) cellsOnVertex % array => cellsOnVertex_ptr % array nullify(cellsOnVertex_ptr % array) @@ -5267,6 +5337,7 @@ subroutine postwrite_reindex(allFields, streamFields) !{{{ end if if (associated(edgesOnVertex)) then + STREAM_DEBUG_WRITE(' -- restoring edgesOnVertex to local indices') deallocate(edgesOnVertex % array) edgesOnVertex % array => edgesOnVertex_ptr % array nullify(edgesOnVertex_ptr % array) @@ -5312,12 +5383,14 @@ end subroutine postwrite_reindex !}}} !> This routine should be called immediately after a read of a stream. ! !----------------------------------------------------------------------- - subroutine postread_reindex(allFields, streamFields) !{{{ + subroutine postread_reindex(allFields, allPackages, streamFields, fieldPkgPool) !{{{ implicit none type (mpas_pool_type), pointer :: allFields + type (mpas_pool_type), pointer :: allPackages type (mpas_pool_type), pointer :: streamFields + type (mpas_pool_type), pointer :: fieldPkgPool type (mpas_pool_iterator_type) :: fieldItr type (mpas_pool_field_info_type) :: fieldInfo @@ -5332,6 +5405,10 @@ subroutine postread_reindex(allFields, streamFields) !{{{ logical :: skip_field integer :: i, j, k + character (len=StrKIND), pointer :: packages + logical :: active_field + integer :: err_level + call mpas_pool_get_field(allFields, 'indexToCellID', indexToCellID) call mpas_pool_get_field(allFields, 'indexToEdgeID', indexToEdgeID) @@ -5344,12 +5421,32 @@ subroutine postread_reindex(allFields, streamFields) !{{{ ! Note: in a stream's field_pool, the names of fields are stored as configs if ( fieldItr % memberType == MPAS_POOL_CONFIG ) then + ! + ! Check whether the field is active in this stream + ! + err_level = mpas_pool_get_error_level() + call mpas_pool_set_error_level(MPAS_POOL_SILENT) + + nullify(packages) + call mpas_pool_get_config(fieldPkgPool, trim(fieldItr % memberName)//':packages', packages) + if (associated(packages)) then + active_field = parse_package_list(allPackages, trim(packages)) + else + active_field = .true. + end if + call mpas_pool_set_error_level(err_level) + + if (.not. active_field) then + STREAM_DEBUG_WRITE('-- '//trim(fieldItr % memberName)//' not active in stream and will not be reindexed') + cycle + end if + call mpas_pool_get_field_info(allFields, fieldItr % memberName, fieldInfo) skip_field = .false. if (trim(fieldItr % memberName) == 'cellsOnCell') then - STREAM_DEBUG_WRITE('-- Reindexing cellsOnCell') + STREAM_DEBUG_WRITE(' -- Reindexing cellsOnCell') ! Get pointer to the field to be reindexed call mpas_pool_get_field(allFields, 'cellsOnCell', int2DField) @@ -5365,7 +5462,7 @@ subroutine postread_reindex(allFields, streamFields) !{{{ else if (trim(fieldItr % memberName) == 'edgesOnCell') then - STREAM_DEBUG_WRITE('-- Reindexing edgesOnCell') + STREAM_DEBUG_WRITE(' -- Reindexing edgesOnCell') ! Get pointer to the field to be reindexed call mpas_pool_get_field(allFields, 'edgesOnCell', int2DField) @@ -5381,7 +5478,7 @@ subroutine postread_reindex(allFields, streamFields) !{{{ else if (trim(fieldItr % memberName) == 'verticesOnCell') then - STREAM_DEBUG_WRITE('-- Reindexing verticesOnCell') + STREAM_DEBUG_WRITE(' -- Reindexing verticesOnCell') ! Get pointer to the field to be reindexed call mpas_pool_get_field(allFields, 'verticesOnCell', int2DField) @@ -5397,7 +5494,7 @@ subroutine postread_reindex(allFields, streamFields) !{{{ else if (trim(fieldItr % memberName) == 'cellsOnEdge') then - STREAM_DEBUG_WRITE('-- Reindexing cellsOnEdge') + STREAM_DEBUG_WRITE(' -- Reindexing cellsOnEdge') ! Get pointer to the field to be reindexed call mpas_pool_get_field(allFields, 'cellsOnEdge', int2DField) @@ -5413,7 +5510,7 @@ subroutine postread_reindex(allFields, streamFields) !{{{ else if (trim(fieldItr % memberName) == 'verticesOnEdge') then - STREAM_DEBUG_WRITE('-- Reindexing verticesOnEdge') + STREAM_DEBUG_WRITE(' -- Reindexing verticesOnEdge') ! Get pointer to the field to be reindexed call mpas_pool_get_field(allFields, 'verticesOnEdge', int2DField) @@ -5429,7 +5526,7 @@ subroutine postread_reindex(allFields, streamFields) !{{{ else if (trim(fieldItr % memberName) == 'edgesOnEdge') then - STREAM_DEBUG_WRITE('-- Reindexing edgesOnEdge') + STREAM_DEBUG_WRITE(' -- Reindexing edgesOnEdge') ! Get pointer to the field to be reindexed call mpas_pool_get_field(allFields, 'edgesOnEdge', int2DField) @@ -5445,7 +5542,7 @@ subroutine postread_reindex(allFields, streamFields) !{{{ else if (trim(fieldItr % memberName) == 'cellsOnVertex') then - STREAM_DEBUG_WRITE('-- Reindexing cellsOnVertex') + STREAM_DEBUG_WRITE(' -- Reindexing cellsOnVertex') ! Get pointer to the field to be reindexed call mpas_pool_get_field(allFields, 'cellsOnVertex', int2DField) @@ -5461,7 +5558,7 @@ subroutine postread_reindex(allFields, streamFields) !{{{ else if (trim(fieldItr % memberName) == 'edgesOnVertex') then - STREAM_DEBUG_WRITE('-- Reindexing edgesOnVertex') + STREAM_DEBUG_WRITE(' -- Reindexing edgesOnVertex') ! Get pointer to the field to be reindexed call mpas_pool_get_field(allFields, 'edgesOnVertex', int2DField) diff --git a/src/framework/mpas_string_utils.F b/src/framework/mpas_string_utils.F new file mode 100644 index 0000000000..775b621af2 --- /dev/null +++ b/src/framework/mpas_string_utils.F @@ -0,0 +1,106 @@ +! Copyright (c) 2023 The University Corporation for Atmospheric Research (UCAR). +! +! Unless noted otherwise source code is licensed under the BSD license. +! Additional copyright and license information can be found in the LICENSE file +! distributed with this code, or at https://mpas-dev.github.io/license.html . +! +!----------------------------------------------------------------------- +! mpas_string_utils +! +!> \brief Collection of functions used for string manipulation +!> \author Matthew Dimond +!> \date 25 July 2023 +!> \details +!> This module provides functions and subroutines used for string +!> manipulations and utilities. +! +!----------------------------------------------------------------------- +module mpas_string_utils + + contains + + !----------------------------------------------------------------------- + ! routine mpas_split_string + ! + !> \brief This routine splits a string on a specified delimiting character + !> \author Michael Duda, Doug Jacobsen + !> \date 07/23/2014 + !> \details This routine splits the given "string" on the delimiter + !> character, and returns an array of pointers to the substrings + !> between the delimiting characters. Strings are trimmed before + !> splitting such that all trailing whitespace is ignored. + ! + !----------------------------------------------------------------------- + subroutine mpas_split_string(string, delimiter, subStrings) + + implicit none + + ! Arguments + character(len=*), intent(in) :: string + character, intent(in) :: delimiter + character(len=*), pointer, dimension(:) :: subStrings + + ! Local variables + character(len=len_trim(string)) :: trimString + integer :: i, start, index + + trimString = trim(string) + index = 1 + + do i = 1, len(trimString) + if (trimString(i:i) == delimiter) then + index = index + 1 + end if + end do + + allocate(subStrings(1:index)) + + start = 1 + index = 1 + do i = 1, len(trimString) + if (trimString(i:i) == delimiter) then + subStrings(index) = trimString(start:i-1) + index = index + 1 + start = i + 1 + end if + end do + subStrings(index) = trimString(start:len(trimString)) + + end subroutine mpas_split_string + + !----------------------------------------------------------------------- + ! routine mpas_string_replace + ! + !> \brief Returns string with charToReplace replaced with targetChar + !> \author Matthew Dimond + !> \date 07/26/2023 + !> \details This function replaces all characters matching charToReplace in + !> "string" with the char "targetChar" after trimming "string" + ! + !----------------------------------------------------------------------- + function mpas_string_replace(string, charToReplace, targetChar) result(stringOut) + + implicit none + + ! Arguments + character(len=*), intent(in) :: string + character, intent(in) :: targetChar, charToReplace + + ! Local variables + integer :: i + + ! Result + character(len=len_trim(string)) :: stringOut + + stringOut = trim(string) + + do i = 1, len_trim(string) + if (string(i:i) == charToReplace) then + stringOut(i:i) = targetChar + end if + end do + + end function mpas_string_replace + +end module mpas_string_utils + diff --git a/src/framework/mpas_timekeeping.F b/src/framework/mpas_timekeeping.F index 14a001039f..93fdb86336 100644 --- a/src/framework/mpas_timekeeping.F +++ b/src/framework/mpas_timekeeping.F @@ -12,6 +12,7 @@ module mpas_timekeeping use mpas_dmpar use mpas_threading use mpas_log + use mpas_string_utils, only : mpas_split_string use ESMF @@ -2108,40 +2109,6 @@ end function abs_ti ! ! end function mod - - subroutine mpas_split_string(string, delimiter, subStrings) - - implicit none - - character(len=*), intent(in) :: string - character, intent(in) :: delimiter - character(len=*), pointer, dimension(:) :: subStrings - - integer :: i, start, index - - index = 1 - do i = 1, len(string) - if(string(i:i) == delimiter) then - index = index + 1 - end if - end do - - allocate(subStrings(1:index)) - - start = 1 - index = 1 - do i = 1, len(string) - if(string(i:i) == delimiter) then - subStrings(index) = string(start:i-1) - index = index + 1 - start = i + 1 - end if - end do - subStrings(index) = string(start:len(string)) - - end subroutine mpas_split_string - - subroutine mpas_get_month_day(YYYY, DoY, month, day) implicit none diff --git a/src/framework/stream_inquiry.c b/src/framework/stream_inquiry.c new file mode 100644 index 0000000000..5689b2dedd --- /dev/null +++ b/src/framework/stream_inquiry.c @@ -0,0 +1,224 @@ +/* + * Copyright (c) 2023, The University Corporation for Atmospheric Research (UCAR). + * + * Unless noted otherwise source code is licensed under the BSD license. + * Additional copyright and license information can be found in the LICENSE file + * distributed with this code, or at http://mpas-dev.github.com/license.html + */ + +#include +#include +#include +#include +#include +#include "ezxml.h" + +#ifdef _MPI +#include "mpi.h" +#endif + +#define MSGSIZE 256 + + +/* + * Interface routines for writing log messages; defined in mpas_log.F + * messageType_c may be any of "MPAS_LOG_OUT", "MPAS_LOG_WARN", "MPAS_LOG_ERR", or "MPAS_LOG_CRIT" + */ +void mpas_log_write_c(const char *message_c, const char *messageType_c); + + +/********************************************************************************* + * + * Function: read_and_broadcast + * + * Reads the contents of a file into a buffer in distributed-memory parallel code. + * + * The buffer buf is allocated with size bufsize, which will be exactly the + * number of bytes in the file fname. Only the master task will actually read the + * file, and the contents are broadcast to all other tasks. The mpi_comm argument + * is a Fortran MPI communicator used to determine which task is the master task. + * + * A return code of 0 indicates the file was successfully read and broadcast to + * all MPI tasks that belong to the communicator. + * + *********************************************************************************/ +int read_and_broadcast(const char *fname, int mpi_comm, char **buf, size_t *bufsize) +{ + int iofd; + int rank; + struct stat s; + char msgbuf[MSGSIZE]; + +#ifdef _MPI + MPI_Comm comm; + + comm = MPI_Comm_f2c((MPI_Fint)mpi_comm); + if (MPI_Comm_rank(comm, &rank) != MPI_SUCCESS) { + snprintf(msgbuf, MSGSIZE, "Error getting MPI rank in read_and_broadcast"); + mpas_log_write_c(msgbuf, "MPAS_LOG_ERR"); + return 1; + } +#else + rank = 0; +#endif + + if (rank == 0) { + iofd = open(fname, O_RDONLY); + if (iofd <= 0) { + snprintf(msgbuf, MSGSIZE, "Could not open file %s in read_and_broadcast", fname); + mpas_log_write_c(msgbuf, "MPAS_LOG_ERR"); + return 1; + } + + fstat(iofd, &s); + *bufsize = (size_t)s.st_size; +#ifdef _MPI + if (MPI_Bcast((void *)bufsize, (int)sizeof(size_t), MPI_BYTE, 0, comm) != MPI_SUCCESS) { + snprintf(msgbuf, MSGSIZE, "Error from MPI_Bcast in read_and_broadcast"); + mpas_log_write_c(msgbuf, "MPAS_LOG_ERR"); + return 1; + } +#endif + + *buf = (char *)malloc(*bufsize); + + if (read(iofd, (void *)(*buf), *bufsize) < 0) { + snprintf(msgbuf, MSGSIZE, "Error reading from %s in read_and_broadcast", fname); + mpas_log_write_c(msgbuf, "MPAS_LOG_ERR"); + free(*buf); + *buf = NULL; + return 1; + } + +#ifdef _MPI + if (MPI_Bcast((void *)(*buf), (int)(*bufsize), MPI_CHAR, 0, comm) != MPI_SUCCESS) { + snprintf(msgbuf, MSGSIZE, "Error from MPI_Bcast in read_and_broadcast"); + mpas_log_write_c(msgbuf, "MPAS_LOG_ERR"); + free(*buf); + *buf = NULL; + return 1; + } +#endif + } + else { +#ifdef _MPI + if (MPI_Bcast((void *)bufsize, (int)sizeof(size_t), MPI_BYTE, 0, comm) != MPI_SUCCESS) { + snprintf(msgbuf, MSGSIZE, "Error from MPI_Bcast in read_and_broadcast"); + mpas_log_write_c(msgbuf, "MPAS_LOG_ERR"); + return 1; + } +#endif + *buf = (char *)malloc(*bufsize); + +#ifdef _MPI + if (MPI_Bcast((void *)(*buf), (int)(*bufsize), MPI_CHAR, 0, comm) != MPI_SUCCESS) { + snprintf(msgbuf, MSGSIZE, "Error from MPI_Bcast in read_and_broadcast"); + mpas_log_write_c(msgbuf, "MPAS_LOG_ERR"); + free(*buf); + *buf = NULL; + return 1; + } +#endif + } + + return 0; +} + +/******************************************************************************** + * + * parse_streams_file + * + * Parses an MPAS streams file into an XML tree + * + * Given the name of an MPAS streams XML file as well as an MPI communicator, + * this routine reads and broadcasts the file contents to all MPI tasks in the + * communicator, then parses the file into an ezxml_t struct. + * + * Upon success, a valid pointer to a root ezxml_t struct is returned; + * otherwise, a NULL ezxml_t is returned. + * + ********************************************************************************/ +ezxml_t parse_streams_file(int mpi_comm, const char *filename) +{ + char *xml_buf; + size_t bufsize; + + if (read_and_broadcast(filename, mpi_comm, &xml_buf, &bufsize) != 0) { + return NULL; + } + + return ezxml_parse_str(xml_buf, bufsize); +} + +/******************************************************************************** + * + * free_streams_file + * + * Frees memory associated with an ezxml_t struct. + * + ********************************************************************************/ +void free_streams_file(ezxml_t xmltree) +{ + ezxml_free(xmltree); +} + + +/******************************************************************************** + * + * query_streams_file + * + * Returns information about the contents of a previously read streams XML file + * + * Given an ezxml_t holding the contents of a streams XML file -- typically from + * a previous call to parse_streams_file -- returns a 1 if the specified stream + * (and, optionally, attribute) exists in the file. If the stream and optionally + * specified attribute are found, and if the attvalue argument is not a NULL + * pointer, the value of the attribute is also returned. + * + * Both immutable and mutable streams can be queried. + * + * If the specified stream does not exist, a value of 0 is returned. If the + * stream is found, but the specified attribute is not defined for the stream, a + * value of 0 is returned. + * + ********************************************************************************/ +int query_streams_file(ezxml_t xmltree, const char *streamname, const char *attname, const char **attvalue) +{ + ezxml_t stream_xml; + const char *streamID; + const char *attval_local; + + for (stream_xml = ezxml_child(xmltree, "immutable_stream"); stream_xml; stream_xml = ezxml_next(stream_xml)) { + streamID = ezxml_attr(stream_xml, "name"); + + if (strcmp(streamID, streamname) == 0) { + if (attname != NULL) { + attval_local = ezxml_attr(stream_xml, attname); + if (attval_local != NULL) { + *attvalue = attval_local; + } else { + return 0; + } + } + return 1; + } + } + + for (stream_xml = ezxml_child(xmltree, "stream"); stream_xml; stream_xml = ezxml_next(stream_xml)) { + streamID = ezxml_attr(stream_xml, "name"); + + if (strcmp(streamID, streamname) == 0) { + if (attname != NULL) { + attval_local = ezxml_attr(stream_xml, attname); + if (attval_local != NULL) { + *attvalue = attval_local; + } else { + return 0; + } + } + return 1; + } + } + + return 0; +} diff --git a/src/operators/operators.cmake b/src/operators/operators.cmake deleted file mode 100644 index d65c7c661e..0000000000 --- a/src/operators/operators.cmake +++ /dev/null @@ -1,13 +0,0 @@ -# operators -list(APPEND COMMON_RAW_SOURCES - operators/mpas_vector_operations.F - operators/mpas_matrix_operations.F - operators/mpas_tensor_operations.F - operators/mpas_rbf_interpolation.F - operators/mpas_vector_reconstruction.F - operators/mpas_spline_interpolation.F - operators/mpas_tracer_advection_helpers.F - operators/mpas_tracer_advection_mono.F - operators/mpas_tracer_advection_std.F - operators/mpas_geometry_utils.F -) diff --git a/src/tools/CMakeLists.txt b/src/tools/CMakeLists.txt deleted file mode 100644 index 513ae48cf1..0000000000 --- a/src/tools/CMakeLists.txt +++ /dev/null @@ -1,30 +0,0 @@ - -if (DEFINED ENV{MPAS_TOOL_DIR}) - message(STATUS "*** Using MPAS tools from $ENV{MPAS_TOOL_DIR} ***") - add_custom_target(namelist_gen) - add_custom_command( - TARGET namelist_gen PRE_BUILD - COMMAND ${CMAKE_COMMAND} -E copy $ENV{MPAS_TOOL_DIR}/input_gen/namelist_gen ${CMAKE_CURRENT_BINARY_DIR}/namelist_gen) - add_custom_target(streams_gen) - add_custom_command( - TARGET streams_gen PRE_BUILD - COMMAND ${CMAKE_COMMAND} -E copy $ENV{MPAS_TOOL_DIR}/input_gen/streams_gen ${CMAKE_CURRENT_BINARY_DIR}/streams_gen) - add_custom_target(parse) - add_custom_command( - TARGET parse PRE_BUILD - COMMAND ${CMAKE_COMMAND} -E copy $ENV{MPAS_TOOL_DIR}/input_gen/parse ${CMAKE_CURRENT_BINARY_DIR}/parse) -else() - message(STATUS "*** Building MPAS tools from source ***") - # Make build tools, need to be compiled with serial compiler. - set(CMAKE_C_COMPILER ${SCC}) - - add_executable(streams_gen input_gen/streams_gen.c input_gen/test_functions.c ../external/ezxml/ezxml.c) - add_executable(namelist_gen input_gen/namelist_gen.c input_gen/test_functions.c ../external/ezxml/ezxml.c) - add_executable(parse registry/parse.c registry/dictionary.c registry/gen_inc.c registry/fortprintf.c registry/utility.c ../external/ezxml/ezxml.c) - - foreach(EXEITEM streams_gen namelist_gen parse) - target_compile_definitions(${EXEITEM} PRIVATE ${CPPDEFS}) - target_compile_options(${EXEITEM} PRIVATE "-Uvector") - target_include_directories(${EXEITEM} PRIVATE ${INCLUDES}) - endforeach() -endif() diff --git a/src/tools/registry/fortprintf.c b/src/tools/registry/fortprintf.c index 0635146602..1c71fa6744 100644 --- a/src/tools/registry/fortprintf.c +++ b/src/tools/registry/fortprintf.c @@ -25,7 +25,7 @@ int nbuf = 0; int fortprintf(FILE * fd, char * str, ...)/*{{{*/ { - int i, nl, sp, sp_inquotes, inquotes, q; + int i, nl, sp, sp_inquotes, indoublequotes, inquotes; int lastchar; int errorcode; va_list ap; @@ -52,32 +52,36 @@ int fortprintf(FILE * fd, char * str, ...)/*{{{*/ nbuf = nbuf + i; inquotes = 0; - q = -1; + indoublequotes = 0; do { nl = sp = -1; - /* Scan through the max line length - 1 (since we may have to add an & character) or the end of the buffer, whichever comes first */ for (i=0; i= 0) { snprintf(printbuf, sp+2, "%s", fbuffer); i = sp+1; - if (sp_inquotes && (sp > q)) printbuf[i++] = '\''; printbuf[i++] = '&'; printbuf[i++] = '\n'; + + /* If we are in a character context, add an ampersand at the start + of the next line */ + if (sp_inquotes) { + printbuf[i++] = '&'; + } + printbuf[i++] = '\0'; fprintf(fd, "%s", printbuf); sp++; i = 0; - if (sp_inquotes && (sp > q)) { - inquotes = (inquotes + 1) % 2; - fbuffer[i++] = '/'; - fbuffer[i++] = '/'; - fbuffer[i++] = '\''; - } - /* Shift unprinted contents of fortran buffer to the beginning */ for ( ; sp= bufferSize) return 1; + result[resultIndex++] = '\''; + } + if (resultIndex >= bufferSize) return 1; + result[resultIndex++] = stringIn[i]; + } + + return 0; +} + +void add_attribute_if_not_ignored(FILE *fd, char *index, char *att_name, char *pointer_name_arr, char *att_value){ + char *format_string; + + // Allocate buffers for escaping apostrophes, + size_t value_buffer_size = 2 * strlen(att_value) + 1; + size_t name_buffer_size = 2 * strlen(att_name) + 1; + char *escaped_value = (char*)malloc(value_buffer_size); + char *escaped_name = (char*)malloc(name_buffer_size); + + // Confirm that memory was allocated correctly + if (escaped_value == NULL) { + fprintf(stderr, + "ERROR: Failed to allocate memory while escaping quotes for att_value %s of att %s\n", + att_value, + att_name); + free(escaped_value); + free(escaped_name); + return; + } else if (escaped_name == NULL) { + fprintf(stderr, + "ERROR: Failed to allocate memory while escaping quotes for att_name of att %s\n", + att_name); + free(escaped_value); + free(escaped_name); + return; + } + + + // Return early if we want to ignore the attribute + if (find_string_in_array(att_name, ATTRS_TO_IGNORE, NUM_IGNORED_ATTRS) >= 0){ + free(escaped_value); + free(escaped_name); + return; + } + + // check if the attribute is numeric + if (find_string_in_array(att_name, NUMERIC_ATTRS, NUM_NUMERIC_ATTRS) >= 0){ + format_string = " call mpas_add_att(%s %% attLists(%s) %% attList, '%s', %s)\n"; + } + // If it isn't numeric, make sure to wrap att_value in quotes + else { + format_string = " call mpas_add_att(%s %% attLists(%s) %% attList, '%s', '%s')\n"; + } + + // Escape the quotes + if ( escape_quotes(att_value, escaped_value, value_buffer_size) == 1){ + fprintf(stderr, + "ERROR: Buffer too small to escape quotes for att_value %s of att %s\n", + att_value, + att_name); + free(escaped_value); + free(escaped_name); + return; + } + + if ( escape_quotes(modify_attr(att_name, ATTRS_TO_MODIFY, NUM_MODIFIED_ATTRS), + escaped_name, + name_buffer_size) == 1) { + fprintf(stderr, + "ERROR: Buffer too small to escape quotes for att_name of att %s\n", + att_name); + free(escaped_value); + free(escaped_name); + return; + } + // Write the add_att code + fortprintf(fd, + format_string, + pointer_name_arr, + index, + escaped_name, + escaped_value); + + free(escaped_value); + free(escaped_name); +} int set_pointer_name(int type, int ndims, char *pointer_name, int time_levs){/*{{{*/ @@ -156,16 +301,18 @@ int add_package_to_list(const char * package, const char * package_list){/*{{{*/ token = strsep(&string, ";"); if(strcmp(package, token) == 0){ + free(tofree); return 0; } while( (token = strsep(&string, ";")) != NULL){ if(strcmp(package, token) == 0){ - + free(tofree); return 0; } } + free(tofree); return 1; }/*}}}*/ @@ -228,12 +375,14 @@ int build_struct_package_lists(ezxml_t currentPosition, char * out_packages){/*{ if(out_packages[0] == '\0'){ sprintf(out_packages, "%s", token); } else if(add_package_to_list(token, out_packages)){ - sprintf(out_packages, "%s;%s", out_packages, token); + strcat(out_packages, ";"); + strcat(out_packages, token); } while( (token = strsep(&string, ";")) != NULL){ if(add_package_to_list(token, out_packages)){ - sprintf(out_packages, "%s;%s", out_packages, token); + strcat(out_packages, ";"); + strcat(out_packages, token); } } @@ -252,12 +401,14 @@ int build_struct_package_lists(ezxml_t currentPosition, char * out_packages){/*{ if(out_packages[0] == '\0'){ sprintf(out_packages, "%s", token); } else if(add_package_to_list(token, out_packages)){ - sprintf(out_packages, "%s;%s", out_packages, token); + strcat(out_packages, ";"); + strcat(out_packages, token); } while( (token = strsep(&string, ";")) != NULL){ if(add_package_to_list(token, out_packages)){ - sprintf(out_packages, "%s;%s", out_packages, token); + strcat(out_packages, ";"); + strcat(out_packages, token); } } @@ -278,12 +429,14 @@ int build_struct_package_lists(ezxml_t currentPosition, char * out_packages){/*{ if(out_packages[0] == '\0'){ sprintf(out_packages, "%s", token); } else if(add_package_to_list(token, out_packages)){ - sprintf(out_packages, "%s;%s", out_packages, token); + strcat(out_packages, ";"); + strcat(out_packages, token); } while( (token = strsep(&string, ";")) != NULL){ if(add_package_to_list(token, out_packages)){ - sprintf(out_packages, "%s;%s", out_packages, token); + strcat(out_packages, ";"); + strcat(out_packages, token); } } @@ -648,7 +801,6 @@ int parse_namelist_records_from_registry(ezxml_t registry)/*{{{*/ if(in_subpool){ fortprintf(fd, "\n"); - fortprintf(fd, " allocate(recordPool)\n"); fortprintf(fd, " call mpas_pool_create_pool(recordPool)\n"); fortprintf(fd, " call mpas_pool_add_subpool(configPool, '%s', recordPool)\n", nmlrecname); fortprintf(fd, "\n"); @@ -1016,7 +1168,7 @@ int parse_var_array(FILE *fd, ezxml_t registry, ezxml_t superStruct, ezxml_t var const char *structname, *structlevs, *structpackages; const char *substructname; const char *vararrname, *vararrtype, *vararrdims, *vararrpersistence, *vararrdefaultval, *vararrpackages, *vararrmissingval; - const char *varname, *varpersistence, *vartype, *vardims, *varunits, *vardesc, *vararrgroup, *varstreams, *vardefaultval, *varpackages; + const char *varname, *varpersistence, *vartype, *vardims, *vararrgroup, *varstreams, *vardefaultval, *varpackages; const char *varname2, *vararrgroup2, *vararrname_in_code; const char *varname_in_code; const char *streamname, *streamname2; @@ -1156,6 +1308,7 @@ int parse_var_array(FILE *fd, ezxml_t registry, ezxml_t superStruct, ezxml_t var while( (token = strsep(&string, ";")) != NULL){ fortprintf(fd, " .or. %sActive", token); } + free(tofree); fortprintf(fd, ") then\n"); snprintf(sub_spacing, 1024, " "); @@ -1221,6 +1374,7 @@ int parse_var_array(FILE *fd, ezxml_t registry, ezxml_t superStruct, ezxml_t var while( (token = strsep(&string, ";")) != NULL){ fortprintf(fd, " .or. %sActive", token); } + free(tofree); fortprintf(fd, ") then\n"); snprintf(sub_spacing, 1024, " "); @@ -1364,10 +1518,9 @@ int parse_var_array(FILE *fd, ezxml_t registry, ezxml_t superStruct, ezxml_t var fortprintf(fd, " end do\n"); for(var_xml = ezxml_child(var_arr_xml, "var"); var_xml; var_xml = var_xml->next){ + char **attr; varname = ezxml_attr(var_xml, "name"); varname_in_code = ezxml_attr(var_xml, "name_in_code"); - vardesc = ezxml_attr(var_xml, "description"); - varunits = ezxml_attr(var_xml, "units"); if(!varname_in_code){ varname_in_code = ezxml_attr(var_xml, "name"); @@ -1377,40 +1530,18 @@ int parse_var_array(FILE *fd, ezxml_t registry, ezxml_t superStruct, ezxml_t var fortprintf(fd, " call mpas_pool_get_dimension(newSubPool, 'index_%s', const_index)\n", varname_in_code); fortprintf(fd, " end if\n"); fortprintf(fd, " if (const_index > 0) then\n", spacing); - if ( vardesc != NULL ) { - string = strdup(vardesc); - tofree = string; - - token = strsep(&string, "'"); - sprintf(temp_str, "%s", token); - - while ( ( token = strsep(&string, "'") ) != NULL ) { - sprintf(temp_str, "%s''%s", temp_str, token); - } - - free(tofree); - - fortprintf(fd, " call mpas_add_att(%s %% attLists(const_index) %% attList, 'long_name', '%s')\n", pointer_name_arr, temp_str); - } - - if ( varunits != NULL ) { - string = strdup(varunits); - tofree = string; - token = strsep(&string, "'"); - sprintf(temp_str, "%s", token); - - while ( ( token = strsep(&string, "'") ) != NULL ) { - sprintf(temp_str, "%s''%s", temp_str, token); + for (attr = var_xml->attr; attr && *attr; attr+=2) { + // If the attr is "missing_value", ignore it and later on take + // the value from the var array. + if (strcmp(attr[0], "missing_value") == 0) { + printf("WARNING: Ignoring missing_value attribute for var %s defined in var_array %s\n", varname, vararrname); + } else { + add_attribute_if_not_ignored(fd, "const_index", attr[0], pointer_name_arr, attr[1]); } - - free(tofree); - - fortprintf(fd, " call mpas_add_att(%s %% attLists(const_index) %% attList, 'units', '%s')\n", pointer_name_arr, temp_str); } - if ( vararrmissingval ) { - fortprintf(fd, " call mpas_add_att(%s %% attLists(const_index) %% attList, '_FillValue', %s)\n", pointer_name_arr, missing_value); + add_attribute_if_not_ignored(fd, "const_index", "missing_value", pointer_name_arr, missing_value); } fortprintf(fd, " %s %% missingValue = %s\n", pointer_name_arr, missing_value); fortprintf(fd, " %s %% constituentNames(const_index) = '%s'\n", pointer_name_arr, varname); @@ -1435,6 +1566,7 @@ int parse_var_array(FILE *fd, ezxml_t registry, ezxml_t superStruct, ezxml_t var while( (token = strsep(&string, ";")) != NULL){ fortprintf(fd, " .or. %sActive", token); } + free(tofree); fortprintf(fd, ") then\n"); } @@ -1467,7 +1599,7 @@ int parse_var(FILE *fd, ezxml_t registry, ezxml_t superStruct, ezxml_t currentVa const char *structtimelevs, *vartimelevs; const char *structname, *structlevs, *structpackages; const char *substructname; - const char *varname, *varpersistence, *vartype, *vardims, *varunits, *vardesc, *vararrgroup, *varstreams, *vardefaultval, *varpackages, *varmissingval; + const char *varname, *varpersistence, *vartype, *vardims, *vararrgroup, *varstreams, *vardefaultval, *varpackages, *varmissingval; const char *varname2, *vararrgroup2; const char *varname_in_code; const char *streamname, *streamname2; @@ -1502,8 +1634,6 @@ int parse_var(FILE *fd, ezxml_t registry, ezxml_t superStruct, ezxml_t currentVa vardefaultval = ezxml_attr(var_xml, "default_value"); vartimelevs = ezxml_attr(var_xml, "time_levs"); varname_in_code = ezxml_attr(var_xml, "name_in_code"); - varunits = ezxml_attr(var_xml, "units"); - vardesc = ezxml_attr(var_xml, "description"); varmissingval = ezxml_attr(var_xml, "missing_value"); if(!varname_in_code){ @@ -1548,6 +1678,7 @@ int parse_var(FILE *fd, ezxml_t registry, ezxml_t superStruct, ezxml_t currentVa } for(time_lev = 1; time_lev <= time_levs; time_lev++){ + char **attr; if (time_levs > 1) { snprintf(pointer_name_arr, 1024, "%s(%d)", pointer_name, time_lev); } else { @@ -1603,41 +1734,14 @@ int parse_var(FILE *fd, ezxml_t registry, ezxml_t superStruct, ezxml_t currentVa } fortprintf(fd, " allocate(%s %% attLists(1))\n", pointer_name_arr); fortprintf(fd, " allocate(%s %% attLists(1) %% attList)\n", pointer_name_arr); - - if ( varunits != NULL ) { - string = strdup(varunits); - tofree = string; - token = strsep(&string, "'"); - - sprintf(temp_str, "%s", token); - - while ( ( token = strsep(&string, "'") ) != NULL ) { - sprintf(temp_str, "%s''%s", temp_str, token); - } - - free(tofree); - - fortprintf(fd, " call mpas_add_att(%s %% attLists(1) %% attList, 'units', '%s')\n", pointer_name_arr, temp_str); - } - - if ( vardesc != NULL ) { - string = strdup(vardesc); - tofree = string; - token = strsep(&string, "'"); - - sprintf(temp_str, "%s", token); - - while ( ( token = strsep(&string, "'") ) != NULL ) { - sprintf(temp_str, "%s''%s", temp_str, token); + for (attr = var_xml->attr; attr && *attr; attr+=2) { + // If the attr is "missing_value", use the specified fill value + // for real, integer, or char values. + if (strcmp(attr[0], "missing_value") == 0) { + add_attribute_if_not_ignored(fd, "1", attr[0], pointer_name_arr, missing_value); + } else { + add_attribute_if_not_ignored(fd, "1", attr[0], pointer_name_arr, attr[1]); } - - free(tofree); - - fortprintf(fd, " call mpas_add_att(%s %% attLists(1) %% attList, 'long_name', '%s')\n", pointer_name_arr, temp_str); - } - - if ( varmissingval != NULL ) { - fortprintf(fd, " call mpas_add_att(%s %% attLists(1) %% attList, '_FillValue', %s)\n", pointer_name_arr, missing_value); } fortprintf(fd, " %s %% missingValue = %s\n", pointer_name_arr, missing_value); @@ -1659,6 +1763,7 @@ int parse_var(FILE *fd, ezxml_t registry, ezxml_t superStruct, ezxml_t currentVa while( (token = strsep(&string, ";")) != NULL){ fortprintf(fd, " .or. %sActive", token); } + free(tofree); fortprintf(fd, ") then\n"); } @@ -1780,7 +1885,6 @@ int parse_struct(FILE *fd, ezxml_t registry, ezxml_t superStruct, int subpool, c fortprintf(fd, "\n"); // Setup new pool to be added into structPool - fortprintf(fd, " allocate(newSubPool)\n"); fortprintf(fd, " call mpas_pool_create_pool(newSubPool)\n"); fortprintf(fd, " call mpas_pool_add_subpool(structPool, '%s', newSubPool)\n", structnameincode); fortprintf(fd, " call mpas_pool_add_subpool(block %% allStructs, '%s', newSubPool)\n", structname); diff --git a/src/tools/registry/gen_inc.h b/src/tools/registry/gen_inc.h index 96db3de8b3..3833456d66 100644 --- a/src/tools/registry/gen_inc.h +++ b/src/tools/registry/gen_inc.h @@ -9,6 +9,8 @@ #include "ezxml.h" +void add_attribute_if_not_ignored(FILE *fd, char *index, char *att_name, char *pointer_name_arr, char *temp_str); +int find_string_in_array(char *input_string, const char *array[], size_t rows); void write_model_variables(ezxml_t registry); int write_field_pointer_arrays(FILE* fd); int set_pointer_name(int type, int ndims, char *pointer_name, int time_levs);